diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs deleted file mode 100644 --- a/Distribution/Client/BuildReports/Anonymous.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Reporting --- Copyright : (c) David Waern 2008 --- License : BSD-like --- --- Maintainer : david.waern@gmail.com --- Stability : experimental --- Portability : portable --- --- Anonymous build report data structure, printing and parsing --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Anonymous ( - BuildReport(..), - InstallOutcome(..), - Outcome(..), - - -- * Constructing and writing reports - newBuildReport, - - -- * parsing and pretty printing - parseBuildReport, - parseBuildReportList, - showBuildReport, --- showList, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Client.BuildReports.Types -import Distribution.Client.Utils (cabalInstallVersion) -import Distribution.Compiler (CompilerId (..)) -import Distribution.FieldGrammar -import Distribution.Fields (readFields, showFields) -import Distribution.Fields.ParseResult (ParseResult, parseFatalFailure, runParseResult) -import Distribution.Package (PackageIdentifier (..), mkPackageName) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.Parsec (PError (..), zeroPos) -import Distribution.System (Arch, OS) - -import qualified Distribution.Client.BuildReports.Lens as L -import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..)) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 - - -------------------------------------------------------------------------------- --- New -------------------------------------------------------------------------------- - -newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment - -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport -newBuildReport os' arch' comp pkgid flags deps result = - BuildReport { - package = pkgid, - os = os', - arch = arch', - compiler = comp, - client = cabalInstallID, - flagAssignment = flags, - dependencies = deps, - installOutcome = convertInstallOutcome, --- cabalVersion = undefined - docsOutcome = convertDocsOutcome, - testsOutcome = convertTestsOutcome - } - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildResult _ _ _) -> InstallOk - convertDocsOutcome = case result of - Left _ -> NotTried - Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried - Right (BR.BuildResult BR.DocsFailed _ _) -> Failed - Right (BR.BuildResult BR.DocsOk _ _) -> Ok - convertTestsOutcome = case result of - Left (BR.TestsFailed _) -> Failed - Left _ -> NotTried - Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried - Right (BR.BuildResult _ BR.TestsOk _) -> Ok - -cabalInstallID :: PackageIdentifier -cabalInstallID = - PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion - -------------------------------------------------------------------------------- --- FieldGrammar -------------------------------------------------------------------------------- - -fieldDescrs - :: ( Applicative (g BuildReport), FieldGrammar c g - , c (Identity Arch) - , c (Identity CompilerId) - , c (Identity FlagAssignment) - , c (Identity InstallOutcome) - , c (Identity OS) - , c (Identity Outcome) - , c (Identity PackageIdentifier) - , c (List VCat (Identity PackageIdentifier) PackageIdentifier) - ) - => g BuildReport BuildReport -fieldDescrs = BuildReport - <$> uniqueField "package" L.package - <*> uniqueField "os" L.os - <*> uniqueField "arch" L.arch - <*> uniqueField "compiler" L.compiler - <*> uniqueField "client" L.client - <*> monoidalField "flags" L.flagAssignment - <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies - <*> uniqueField "install-outcome" L.installOutcome - <*> uniqueField "docs-outcome" L.docsOutcome - <*> uniqueField "tests-outcome" L.testsOutcome - --- ----------------------------------------------------------------------------- --- Parsing - -parseBuildReport :: BS.ByteString -> Either String BuildReport -parseBuildReport s = case snd $ runParseResult $ parseFields s of - Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ] - Right report -> Right report - -parseFields :: BS.ByteString -> ParseResult BuildReport -parseFields input = do - fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input - case partitionFields fields of - (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs - _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport" - -parseBuildReportList :: BS.ByteString -> [BuildReport] -parseBuildReportList str = - [ report | Right report <- map parseBuildReport (split str) ] - - where - split :: BS.ByteString -> [BS.ByteString] - split = filter (not . BS.null) . unfoldr chunk . BS8.lines - chunk [] = Nothing - chunk ls = case break BS.null ls of - (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs) - --- ----------------------------------------------------------------------------- --- Pretty-printing - -showBuildReport :: BuildReport -> String -showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs diff --git a/Distribution/Client/BuildReports/Lens.hs b/Distribution/Client/BuildReports/Lens.hs deleted file mode 100644 --- a/Distribution/Client/BuildReports/Lens.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Distribution.Client.BuildReports.Lens ( - BuildReport, - module Distribution.Client.BuildReports.Lens, -) where - -import Distribution.Client.Compat.Prelude -import Distribution.Compat.Lens -import Prelude () - -import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome) -import Distribution.Compiler (CompilerId) -import Distribution.System (Arch, OS) -import Distribution.Types.Flag (FlagAssignment) -import Distribution.Types.PackageId (PackageIdentifier) - -import qualified Distribution.Client.BuildReports.Types as T - -package :: Lens' BuildReport PackageIdentifier -package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) - -os :: Lens' BuildReport OS -os f s = fmap (\x -> s { T.os = x }) (f (T.os s)) - -arch :: Lens' BuildReport Arch -arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s)) - -compiler :: Lens' BuildReport CompilerId -compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s)) - -client :: Lens' BuildReport PackageIdentifier -client f s = fmap (\x -> s { T.client = x }) (f (T.client s)) - -flagAssignment :: Lens' BuildReport FlagAssignment -flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s)) - -dependencies :: Lens' BuildReport [PackageIdentifier] -dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s)) - -installOutcome :: Lens' BuildReport InstallOutcome -installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s)) - -docsOutcome :: Lens' BuildReport Outcome -docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s)) - -testsOutcome :: Lens' BuildReport Outcome -testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s)) diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs deleted file mode 100644 --- a/Distribution/Client/BuildReports/Storage.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Reporting --- Copyright : (c) David Waern 2008 --- License : BSD-like --- --- Maintainer : david.waern@gmail.com --- Stability : experimental --- Portability : portable --- --- Anonymous build report data structure, printing and parsing --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Storage ( - - -- * Storing and retrieving build reports - storeAnonymous, - storeLocal, --- retrieve, - - -- * 'InstallPlan' support - fromInstallPlan, - fromPlanningFailure, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport - -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan - ( InstallPlan ) - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.SourcePackage - -import Distribution.Package - ( PackageId, packageId ) -import Distribution.PackageDescription - ( FlagAssignment ) -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , initialPathTemplateEnv, substPathTemplate ) -import Distribution.System - ( Platform(Platform) ) -import Distribution.Compiler - ( CompilerId(..), CompilerInfo(..) ) -import Distribution.Simple.Utils - ( equating ) - -import Data.List.NonEmpty - ( groupBy ) -import qualified Data.List as L -import System.FilePath - ( (), takeDirectory ) -import System.Directory - ( createDirectoryIfMissing ) - -storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO () -storeAnonymous reports = sequence_ - [ appendFile file (concatMap format reports') - | (repo, reports') <- separate reports - , let file = repoLocalDir repo "build-reports.log" ] - --TODO: make this concurrency safe, either lock the report file or make sure - -- the writes for each report are atomic (under 4k and flush at boundaries) - - where - format r = '\n' : showBuildReport r ++ "\n" - separate :: [(BuildReport, Maybe Repo)] - -> [(Repo, [BuildReport])] - separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) - . map (concatMap toList) - . L.groupBy (equating (repoName' . head)) - . sortBy (comparing (repoName' . head)) - . groupBy (equating repoName') - . onlyRemote - - repoName' (_,_,rrepo) = remoteRepoName rrepo - - onlyRemote :: [(BuildReport, Maybe Repo)] - -> [(BuildReport, Repo, RemoteRepo)] - onlyRemote rs = - [ (report, repo, remoteRepo) - | (report, Just repo) <- rs - , Just remoteRepo <- [maybeRepoRemote repo] - ] - -storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)] - -> Platform -> IO () -storeLocal cinfo templates reports platform = sequence_ - [ do createDirectoryIfMissing True (takeDirectory file) - appendFile file output - --TODO: make this concurrency safe, either lock the report file or make - -- sure the writes for each report are atomic - | (file, reports') <- groupByFileName - [ (reportFileName template report, report) - | template <- templates - , (report, _repo) <- reports ] - , let output = concatMap format reports' - ] - where - format r = '\n' : showBuildReport r ++ "\n" - - reportFileName template report = - fromPathTemplate (substPathTemplate env template) - where env = initialPathTemplateEnv - (BuildReport.package report) - -- TODO: In principle, we can support $pkgkey, but only - -- if the configure step succeeds. So add a Maybe field - -- to the build report, and either use that or make up - -- a fake identifier if it's not available. - (error "storeLocal: package key not available") - cinfo - platform - - groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) - . L.groupBy (equating fst) - . sortBy (comparing fst) - --- ------------------------------------------------------------ --- * InstallPlan support --- ------------------------------------------------------------ - -fromInstallPlan :: Platform -> CompilerId - -> InstallPlan - -> BuildOutcomes - -> [(BuildReport, Maybe Repo)] -fromInstallPlan platform comp plan buildOutcomes = - mapMaybe (\pkg -> fromPlanPackage - platform comp pkg - (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) - . InstallPlan.toList - $ plan - -fromPlanPackage :: Platform -> CompilerId - -> InstallPlan.PlanPackage - -> Maybe BuildOutcome - -> Maybe (BuildReport, Maybe Repo) -fromPlanPackage (Platform arch os) comp - (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps)) - (Just buildResult) = - Just ( newBuildReport os arch comp - (packageId srcPkg) flags - (map packageId (CD.nonSetupDeps deps)) - buildResult - , extractRepo srcPkg) - where - extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ }) - = Just repo - extractRepo _ = Nothing - -fromPlanPackage _ _ _ _ = Nothing - - -fromPlanningFailure :: Platform -> CompilerId - -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] -fromPlanningFailure (Platform arch os) comp pkgids flags = - [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing) - | pkgid <- pkgids ] diff --git a/Distribution/Client/BuildReports/Types.hs b/Distribution/Client/BuildReports/Types.hs deleted file mode 100644 --- a/Distribution/Client/BuildReports/Types.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildReports.Types --- Copyright : (c) Duncan Coutts 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Types related to build reporting --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Types ( - ReportLevel(..), - BuildReport (..), - InstallOutcome(..), - Outcome(..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Distribution.Compiler (CompilerId (..)) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.System (Arch, OS) -import Distribution.Types.PackageId (PackageIdentifier) - -------------------------------------------------------------------------------- --- ReportLevel -------------------------------------------------------------------------------- - -data ReportLevel = NoReports | AnonymousReports | DetailedReports - deriving (Eq, Ord, Enum, Bounded, Show, Generic) - -instance Binary ReportLevel -instance Structured ReportLevel - -instance Pretty ReportLevel where - pretty NoReports = Disp.text "none" - pretty AnonymousReports = Disp.text "anonymous" - pretty DetailedReports = Disp.text "detailed" - -instance Parsec ReportLevel where - parsec = do - name <- P.munch1 isAlpha - case lowercase name of - "none" -> return NoReports - "anonymous" -> return AnonymousReports - "detailed" -> return DetailedReports - _ -> P.unexpected $ "ReportLevel: " ++ name - -lowercase :: String -> String -lowercase = map toLower - -------------------------------------------------------------------------------- --- BuildReport -------------------------------------------------------------------------------- - -data BuildReport = BuildReport { - -- | The package this build report is about - package :: PackageIdentifier, - - -- | The OS and Arch the package was built on - os :: OS, - arch :: Arch, - - -- | The Haskell compiler (and hopefully version) used - compiler :: CompilerId, - - -- | The uploading client, ie cabal-install-x.y.z - client :: PackageIdentifier, - - -- | Which configurations flags we used - flagAssignment :: FlagAssignment, - - -- | Which dependent packages we were using exactly - dependencies :: [PackageIdentifier], - - -- | Did installing work ok? - installOutcome :: InstallOutcome, - - -- Which version of the Cabal library was used to compile the Setup.hs --- cabalVersion :: Version, - - -- Which build tools we were using (with versions) --- tools :: [PackageIdentifier], - - -- | Configure outcome, did configure work ok? - docsOutcome :: Outcome, - - -- | Configure outcome, did configure work ok? - testsOutcome :: Outcome - } - deriving (Eq, Show, Generic) - - - -------------------------------------------------------------------------------- --- InstallOutcome -------------------------------------------------------------------------------- - -data InstallOutcome - = PlanningFailed - | DependencyFailed PackageIdentifier - | DownloadFailed - | UnpackFailed - | SetupFailed - | ConfigureFailed - | BuildFailed - | TestsFailed - | InstallFailed - | InstallOk - deriving (Eq, Show, Generic) - -instance Pretty InstallOutcome where - pretty PlanningFailed = Disp.text "PlanningFailed" - pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid - pretty DownloadFailed = Disp.text "DownloadFailed" - pretty UnpackFailed = Disp.text "UnpackFailed" - pretty SetupFailed = Disp.text "SetupFailed" - pretty ConfigureFailed = Disp.text "ConfigureFailed" - pretty BuildFailed = Disp.text "BuildFailed" - pretty TestsFailed = Disp.text "TestsFailed" - pretty InstallFailed = Disp.text "InstallFailed" - pretty InstallOk = Disp.text "InstallOk" - -instance Parsec InstallOutcome where - parsec = do - name <- P.munch1 isAlpha - case name of - "PlanningFailed" -> return PlanningFailed - "DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec - "DownloadFailed" -> return DownloadFailed - "UnpackFailed" -> return UnpackFailed - "SetupFailed" -> return SetupFailed - "ConfigureFailed" -> return ConfigureFailed - "BuildFailed" -> return BuildFailed - "TestsFailed" -> return TestsFailed - "InstallFailed" -> return InstallFailed - "InstallOk" -> return InstallOk - _ -> P.unexpected $ "InstallOutcome: " ++ name - -------------------------------------------------------------------------------- --- Outcome -------------------------------------------------------------------------------- - -data Outcome = NotTried | Failed | Ok - deriving (Eq, Show, Enum, Bounded, Generic) - -instance Pretty Outcome where - pretty NotTried = Disp.text "NotTried" - pretty Failed = Disp.text "Failed" - pretty Ok = Disp.text "Ok" - -instance Parsec Outcome where - parsec = do - name <- P.munch1 isAlpha - case name of - "NotTried" -> return NotTried - "Failed" -> return Failed - "Ok" -> return Ok - _ -> P.unexpected $ "Outcome: " ++ name diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs deleted file mode 100644 --- a/Distribution/Client/BuildReports/Upload.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE CPP, PatternGuards #-} --- This is a quick hack for uploading build reports to Hackage. - -module Distribution.Client.BuildReports.Upload - ( BuildLog - , BuildReportId - , uploadReports - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -{- -import Network.Browser - ( BrowserAction, request, setAllowRedirects ) -import Network.HTTP - ( Header(..), HeaderName(..) - , Request(..), RequestMethod(..), Response(..) ) -import Network.TCP (HandleStream) --} -import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo) - -import System.FilePath.Posix - ( () ) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport -import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport) -import Distribution.Simple.Utils (die') -import Distribution.Client.HttpUtils -import Distribution.Client.Setup - ( RepoContext(..) ) - -type BuildReportId = URI -type BuildLog = String - -uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO () -uploadReports verbosity repoCtxt auth uri reports = do - for_ reports $ \(report, mbBuildLog) -> do - buildId <- postBuildReport verbosity repoCtxt auth uri report - case mbBuildLog of - Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog - Nothing -> return () - -postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId -postBuildReport verbosity repoCtxt auth uri buildReport = do - let fullURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" } - transport <- repoContextGetTransport repoCtxt - res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth) - case res of - (303, redir) -> return $ undefined redir --TODO parse redir - _ -> die' verbosity "unrecognized response" -- give response - -{- - setAllowRedirects False - (_, response) <- request Request { - rqURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" }, - rqMethod = POST, - rqHeaders = [Header HdrContentType ("text/plain"), - Header HdrContentLength (show (length body)), - Header HdrAccept ("text/plain")], - rqBody = body - } - case rspCode response of - (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location -#if defined(VERSION_network_uri) - return $ relativeTo rel uri -#elif defined(VERSION_network) -#if MIN_VERSION_network(2,4,0) - return $ relativeTo rel uri -#else - relativeTo rel uri -#endif -#endif - | Header HdrLocation location <- rspHeaders response ] - -> return $ buildId - _ -> error "Unrecognised response from server." - where body = BuildReport.show buildReport --} - - --- TODO force this to be a PUT? - -putBuildLog :: Verbosity -> RepoContext -> (String, String) - -> BuildReportId -> BuildLog - -> IO () -putBuildLog verbosity repoCtxt auth reportId buildLog = do - let fullURI = reportId {uriPath = uriPath reportId "log"} - transport <- repoContextGetTransport repoCtxt - res <- postHttp transport verbosity fullURI buildLog (Just auth) - case res of - (200, _) -> return () - _ -> die' verbosity "unrecognized response" -- give response diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs deleted file mode 100644 --- a/Distribution/Client/Check.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Check --- Copyright : (c) Lennart Kolmodin 2008 --- License : BSD-like --- --- Maintainer : kolmodin@haskell.org --- Stability : provisional --- Portability : portable --- --- Check a package for common mistakes --- ------------------------------------------------------------------------------ -module Distribution.Client.Check ( - check - ) where - - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Utils.Parsec (renderParseError) -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.PackageDescription.Check -import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.PackageDescription.Parsec - (parseGenericPackageDescription, runParseResult) -import Distribution.Parsec (PWarning (..), showPError, showPWarning) -import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) -import System.IO (hPutStr, stderr) - -import qualified Data.ByteString as BS -import qualified System.Directory as Dir - -readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription) -readGenericPackageDescriptionCheck verbosity fpath = do - exists <- Dir.doesFileExist fpath - unless exists $ - die' verbosity $ - "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." - bs <- BS.readFile fpath - let (warnings, result) = runParseResult (parseGenericPackageDescription bs) - case result of - Left (_, errors) -> do - traverse_ (warn verbosity . showPError fpath) errors - hPutStr stderr $ renderParseError fpath bs errors warnings - die' verbosity "parse error" - Right x -> return (warnings, x) - --- | Note: must be called with the CWD set to the directory containing --- the '.cabal' file. -check :: Verbosity -> IO Bool -check verbosity = do - pdfile <- defaultPackageDesc verbosity - (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile - -- convert parse warnings into PackageChecks - -- Note: we /could/ pick different levels, based on warning type. - let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ] - -- flatten the generic package description into a regular package - -- description - -- TODO: this may give more warnings than it should give; - -- consider two branches of a condition, one saying - -- ghc-options: -Wall - -- and the other - -- ghc-options: -Werror - -- joined into - -- ghc-options: -Wall -Werror - -- checkPackages will yield a warning on the last line, but it - -- would not on each individual branch. - -- Hovever, this is the same way hackage does it, so we will yield - -- the exact same errors as it will. - let pkg_desc = flattenPackageDescription ppd - ioChecks <- checkPackageFiles verbosity pkg_desc "." - let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' - buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] - buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] - distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] - ++ [ x | x@PackageDistSuspiciousWarn {} <- packageChecks ] - distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] - - unless (null buildImpossible) $ do - warn verbosity "The package will not build sanely due to these errors:" - printCheckMessages buildImpossible - - unless (null buildWarning) $ do - warn verbosity "The following warnings are likely to affect your build negatively:" - printCheckMessages buildWarning - - unless (null distSuspicious) $ do - warn verbosity "These warnings may cause trouble when distributing the package:" - printCheckMessages distSuspicious - - unless (null distInexusable) $ do - warn verbosity "The following errors will cause portability problems on other environments:" - printCheckMessages distInexusable - - let isDistError (PackageDistSuspicious {}) = False - isDistError (PackageDistSuspiciousWarn {}) = False - isDistError _ = True - isCheckError (PackageDistSuspiciousWarn {}) = False - isCheckError _ = True - errors = filter isDistError packageChecks - - unless (null errors) $ - warn verbosity "Hackage would reject this package." - - when (null packageChecks) $ - notice verbosity "No errors or warnings could be found in the package." - - return (not . any isCheckError $ packageChecks) - - where - printCheckMessages = traverse_ (warn verbosity . explanation) diff --git a/Distribution/Client/CmdBench.hs b/Distribution/Client/CmdBench.hs deleted file mode 100644 --- a/Distribution/Client/CmdBench.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: bench --- -module Distribution.Client.CmdBench ( - -- * The @bench@ CLI and action - benchCommand, - benchAction, - - -- * Internals exposed for testing - componentNotBenchmarkProblem, - isSubComponentProblem, - noBenchmarksProblem, - selectPackageTargets, - selectComponentTarget - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, renderTargetProblem, - renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( wrapText, die' ) - -benchCommand :: CommandUI (NixStyleFlags ()) -benchCommand = CommandUI { - commandName = "v2-bench", - commandSynopsis = "Run benchmarks", - commandUsage = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Runs the specified benchmarks, first ensuring they are up to " - ++ "date.\n\n" - - ++ "Any benchmark in any package in the project can be specified. " - ++ "A package can be specified in which case all the benchmarks in the " - ++ "package are run. The default is to run all the benchmarks in the " - ++ "package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-bench\n" - ++ " Run all the benchmarks in the package in the current directory\n" - ++ " " ++ pname ++ " v2-bench pkgname\n" - ++ " Run all the benchmarks in the package named pkgname\n" - ++ " " ++ pname ++ " v2-bench cname\n" - ++ " Run the benchmark named cname\n" - ++ " " ++ pname ++ " v2-bench cname -O2\n" - ++ " Run the benchmark built with '-O2' (including local libs used)\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - - --- | The @build@ command does a lot. It brings the install plan up to date, --- selects that part of the plan needed by the given or implicit targets and --- then executes the plan. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ - "The bench command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'bench'." - - -- Interpret the targets on the command line as bench targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBench - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - --- | This defines what a 'TargetSelector' means for the @bench@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @bench@ command we select all buildable benchmarks, --- or fail if there are no benchmarks or no buildable benchmarks. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either BenchTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there are any buildable benchmark targets then we select those - | not (null targetsBenchBuildable) - = Right targetsBenchBuildable - - -- If there are benchmarks but none are buildable then we report those - | not (null targetsBench) - = Left (TargetProblemNoneEnabled targetSelector targetsBench) - - -- If there are no benchmarks but some other targets then we report that - | not (null targets) - = Left (noBenchmarksProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targetsBenchBuildable = selectBuildableTargets - . filterTargetsKind BenchKind - $ targets - - targetsBench = forgetTargetsDetail - . filterTargetsKind BenchKind - $ targets - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @bench@ command we just need to check it is a benchmark, in addition --- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either BenchTargetProblem k -selectComponentTarget subtarget@WholeComponent t - | CBenchName _ <- availableTargetComponentName t - = selectComponentTargetBasic subtarget t - | otherwise - = Left (componentNotBenchmarkProblem - (availableTargetPackageId t) - (availableTargetComponentName t)) - -selectComponentTarget subtarget t - = Left (isSubComponentProblem - (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. --- -data BenchProblem = - -- | The 'TargetSelector' matches targets but no benchmarks - TargetProblemNoBenchmarks TargetSelector - - -- | The 'TargetSelector' refers to a component that is not a benchmark - | TargetProblemComponentNotBenchmark PackageId ComponentName - - -- | Asking to benchmark an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget - deriving (Eq, Show) - - -type BenchTargetProblem = TargetProblem BenchProblem - -noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem -noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks - -componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem -componentNotBenchmarkProblem pkgid name = CustomTargetProblem $ - TargetProblemComponentNotBenchmark pkgid name - -isSubComponentProblem - :: PackageId - -> ComponentName - -> SubComponentTarget - -> TargetProblem BenchProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent - -reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderBenchTargetProblem - -renderBenchTargetProblem :: BenchTargetProblem -> String -renderBenchTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= BenchKind - -> "The bench command is for running benchmarks, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "benchmark" targetSelector -renderBenchTargetProblem problem = - renderTargetProblem "benchmark" renderBenchProblem problem - -renderBenchProblem :: BenchProblem -> String -renderBenchProblem (TargetProblemNoBenchmarks targetSelector) = - "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any benchmarks." - -renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) = - "The bench command is for running benchmarks, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." - where - targetSelector = TargetComponent pkgid cname WholeComponent - -renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The bench command can only run benchmarks as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - where - targetSelector = TargetComponent pkgid cname subtarget diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs deleted file mode 100644 --- a/Distribution/Client/CmdBuild.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --- | cabal-install CLI command: build --- -module Distribution.Client.CmdBuild ( - -- * The @build@ CLI and action - buildCommand, - buildAction, - - -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.TargetProblem - ( TargetProblem (..), TargetProblem' ) -import Distribution.Client.CmdErrorMessages - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), yesNoOpt ) -import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives, option, optionName ) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( wrapText, die' ) - -import qualified Data.Map as Map - - -buildCommand :: CommandUI (NixStyleFlags BuildFlags) -buildCommand = CommandUI { - commandName = "v2-build", - commandSynopsis = "Compile targets within the project.", - commandUsage = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Build one or more targets from within the project. The available " - ++ "targets are the packages in the project as well as individual " - ++ "components within those packages, including libraries, executables, " - ++ "test-suites or benchmarks. Targets can be specified by name or " - ++ "location. If no target is specified then the default is to build " - ++ "the package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-build\n" - ++ " Build the package in the current directory " - ++ "or all packages in the project\n" - ++ " " ++ pname ++ " v2-build pkgname\n" - ++ " Build the package named pkgname in the project\n" - ++ " " ++ pname ++ " v2-build ./pkgfoo\n" - ++ " Build the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " v2-build cname\n" - ++ " Build the component named cname in the project\n" - ++ " " ++ pname ++ " v2-build cname --enable-profiling\n" - ++ " Build the component in profiling mode " - ++ "(including dependencies as needed)\n" - - , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags - , commandOptions = filter (\o -> optionName o /= "ignore-project") - . nixStyleOptions (\showOrParseArgs -> - [ option [] ["only-configure"] - "Instead of performing a full build just run the configure step" - buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v }) - (yesNoOpt showOrParseArgs) - ]) - } - -data BuildFlags = BuildFlags - { buildOnlyConfigure :: Flag Bool - } - -defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags - { buildOnlyConfigure = toFlag False - } - --- | The @build@ command does a lot. It brings the install plan up to date, --- selects that part of the plan needed by the given or implicit targets and --- then executes the plan. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO () -buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do - -- TODO: This flags defaults business is ugly - let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags - <> buildOnlyConfigure buildFlags) - targetAction - | onlyConfigure = TargetActionConfigure - | otherwise = TargetActionBuild - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportBuildTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - targetAction - targets - elaboratedPlan - elaboratedPlan'' <- - if buildSettingOnlyDeps (buildSettings baseCtx) - then either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies (Map.keysSet targets) - elaboratedPlan' - else return elaboratedPlan' - - return (elaboratedPlan'', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - --- | This defines what a 'TargetSelector' means for the @bench@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @build@ command select all components except non-buildable --- and disabled tests\/benchmarks, fail if there are no such --- components --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] -selectPackageTargets targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targets' = forgetTargetsDetail targets - targetsBuildable = selectBuildableTargetsWith - (buildable targetSelector) - targets - - -- When there's a target filter like "pkg:tests" then we do select tests, - -- but if it's just a target like "pkg" then we don't build tests unless - -- they are requested by default (i.e. by using --enable-tests) - buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False - buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False - buildable _ _ = True - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @build@ command we just need the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k -selectComponentTarget = selectComponentTargetBasic - -reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a -reportBuildTargetProblems verbosity problems = - reportTargetProblems verbosity "build" problems - -reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a -reportCannotPruneDependencies verbosity = - die' verbosity . renderCannotPruneDependencies diff --git a/Distribution/Client/CmdClean.hs b/Distribution/Client/CmdClean.hs deleted file mode 100644 --- a/Distribution/Client/CmdClean.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.CmdClean (cleanCommand, cleanAction) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), defaultDistDirLayout ) -import Distribution.Client.ProjectConfig - ( findProjectRoot ) -import Distribution.Client.Setup - ( GlobalFlags ) -import Distribution.ReadE ( succeedReadE ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe - , optionDistPref, optionVerbosity, falseArg - ) -import Distribution.Simple.Command - ( CommandUI(..), option, reqArg ) -import Distribution.Simple.Utils - ( info, die', wrapText, handleDoesNotExist ) -import Distribution.Verbosity - ( normal ) - -import System.Directory - ( removeDirectoryRecursive, removeFile - , doesDirectoryExist, getDirectoryContents ) -import System.FilePath - ( () ) - -data CleanFlags = CleanFlags - { cleanSaveConfig :: Flag Bool - , cleanVerbosity :: Flag Verbosity - , cleanDistDir :: Flag FilePath - , cleanProjectFile :: Flag FilePath - } deriving (Eq) - -defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags - { cleanSaveConfig = toFlag False - , cleanVerbosity = toFlag normal - , cleanDistDir = NoFlag - , cleanProjectFile = mempty - } - -cleanCommand :: CommandUI CleanFlags -cleanCommand = CommandUI - { commandName = "v2-clean" - , commandSynopsis = "Clean the package store and remove temporary files." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " new-clean [FLAGS]\n" - , commandDescription = Just $ \_ -> wrapText $ - "Removes all temporary files created during the building process " - ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " - ++ "local caches (by default).\n\n" - , commandNotes = Nothing - , commandDefaultFlags = defaultCleanFlags - , commandOptions = \showOrParseArgs -> - [ optionVerbosity - cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - , optionDistPref - cleanDistDir (\dd flags -> flags { cleanDistDir = dd }) - showOrParseArgs - , option [] ["project-file"] - ("Set the name of the cabal.project file" - ++ " to search for in parent directories") - cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf}) - (reqArg "FILE" (succeedReadE Flag) flagToList) - , option ['s'] ["save-config"] - "Save configuration, only remove build artifacts" - cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc }) - falseArg - ] - } - -cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () -cleanAction CleanFlags{..} extraArgs _ = do - let verbosity = fromFlagOrDefault normal cleanVerbosity - saveConfig = fromFlagOrDefault False cleanSaveConfig - mdistDirectory = flagToMaybe cleanDistDir - mprojectFile = flagToMaybe cleanProjectFile - - unless (null extraArgs) $ - die' verbosity $ "'clean' doesn't take any extra arguments: " - ++ unwords extraArgs - - projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile - - let distLayout = defaultDistDirLayout projectRoot mdistDirectory - - if saveConfig - then do - let buildRoot = distBuildRootDirectory distLayout - - buildRootExists <- doesDirectoryExist buildRoot - - when buildRootExists $ do - info verbosity ("Deleting build root (" ++ buildRoot ++ ")") - handleDoesNotExist () $ removeDirectoryRecursive buildRoot - else do - let distRoot = distDirectory distLayout - - info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") - handleDoesNotExist () $ removeDirectoryRecursive distRoot - - removeEnvFiles (distProjectRootDirectory distLayout) - -removeEnvFiles :: FilePath -> IO () -removeEnvFiles dir = - (traverse_ (removeFile . (dir )) . filter ((".ghc.environment" ==) . take 16)) - =<< getDirectoryContents dir diff --git a/Distribution/Client/CmdConfigure.hs b/Distribution/Client/CmdConfigure.hs deleted file mode 100644 --- a/Distribution/Client/CmdConfigure.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --- | cabal-install CLI command: configure --- -module Distribution.Client.CmdConfigure ( - configureCommand, - configureAction, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import System.Directory -import System.FilePath -import qualified Data.Map as Map - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectConfig - ( writeProjectLocalExtraConfig ) - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Verbosity - ( normal ) - -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives, optionName ) -import Distribution.Simple.Utils - ( wrapText, notice ) - -import Distribution.Client.DistDirLayout - ( DistDirLayout(..) ) - -configureCommand :: CommandUI (NixStyleFlags ()) -configureCommand = CommandUI { - commandName = "v2-configure", - commandSynopsis = "Add extra project configuration", - commandUsage = usageAlternatives "v2-configure" [ "[FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Adjust how the project is built by setting additional package flags " - ++ "and other flags.\n\n" - - ++ "The configuration options are written to the 'cabal.project.local' " - ++ "file (or '$project_file.local', if '--project-file' is specified) " - ++ "which extends the configuration from the 'cabal.project' file " - ++ "(if any). This combination is used as the project configuration for " - ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it " - ++ "can be extended/overridden on a per-command basis.\n\n" - - ++ "The v2-configure command also checks that the project configuration " - ++ "will work. In particular it checks that there is a consistent set of " - ++ "dependencies for the project as a whole.\n\n" - - ++ "The 'cabal.project.local' file persists across 'v2-clean' but is " - ++ "overwritten on the next use of the 'v2-configure' command. The " - ++ "intention is that the 'cabal.project' file should be kept in source " - ++ "control but the 'cabal.project.local' should not.\n\n" - - ++ "It is never necessary to use the 'v2-configure' command. It is " - ++ "merely a convenience in cases where you do not want to specify flags " - ++ "to 'v2-build' (and other commands) every time and yet do not want " - ++ "to alter the 'cabal.project' persistently.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n" - ++ " Adjust the project configuration to use the given compiler\n" - ++ " program and check the resulting configuration works.\n" - ++ " " ++ pname ++ " v2-configure\n" - ++ " Reset the local configuration to empty and check the overall\n" - ++ " project configuration works.\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = filter (\o -> optionName o /= "ignore-project") - . nixStyleOptions (const []) - } - --- | To a first approximation, the @configure@ just runs the first phase of --- the @build@ command where we bring the install plan up to date (thus --- checking that it's possible). --- --- The only difference is that @configure@ also allows the user to specify --- some extra config flags which we save in the file @cabal.project.local@. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -configureAction flags@NixStyleFlags {..} _extraArgs globalFlags = do - --TODO: deal with _extraArgs, since flags with wrong syntax end up there - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - -- Write out the @cabal.project.local@ so it gets picked up by the - -- planning phase. If old config exists, then print the contents - -- before overwriting - - let localFile = distProjectFile (distDirLayout baseCtx) "local" - -- | Chooses cabal.project.local~, or if it already exists - -- cabal.project.local~0, cabal.project.local~1 etc. - firstFreeBackup = firstFreeBackup' (0 :: Int) - firstFreeBackup' i = do - let backup = localFile <> "~" <> (if i <= 0 then "" else show (i - 1)) - exists <- doesFileExist backup - if exists - then firstFreeBackup' (i + 1) - else return backup - - -- If cabal.project.local already exists, back up to cabal.project.local~[n] - exists <- doesFileExist localFile - when exists $ do - backup <- firstFreeBackup - notice verbosity $ - quote (takeFileName localFile) <> " already exists, backing it up to " - <> quote (takeFileName backup) <> "." - copyFile localFile backup - writeProjectLocalExtraConfig (distDirLayout baseCtx) - cliConfig - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> - - -- TODO: Select the same subset of targets as 'CmdBuild' would - -- pick (ignoring, for example, executables in libraries - -- we depend on). But we don't want it to fail, so actually we - -- have to do it slightly differently from build. - return (elaboratedPlan, Map.empty) - - let baseCtx' = baseCtx { - buildSettings = (buildSettings baseCtx) { - buildSettingDryRun = True - } - } - - -- TODO: Hmm, but we don't have any targets. Currently this prints - -- what we would build if we were to build everything. Could pick - -- implicit target like "." - -- - -- TODO: should we say what's in the project (+deps) as a whole? - printPlan verbosity baseCtx' buildCtx - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - quote s = "'" <> s <> "'" - diff --git a/Distribution/Client/CmdErrorMessages.hs b/Distribution/Client/CmdErrorMessages.hs deleted file mode 100644 --- a/Distribution/Client/CmdErrorMessages.hs +++ /dev/null @@ -1,441 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - - --- | Utilities to help format error messages for the various CLI commands. --- -module Distribution.Client.CmdErrorMessages ( - module Distribution.Client.CmdErrorMessages, - module Distribution.Client.TargetSelector, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectPlanning - ( AvailableTarget(..), AvailableTargetStatus(..), - CannotPruneDependencies(..), TargetRequested(..) ) -import Distribution.Client.TargetSelector - ( SubComponentTarget(..) ) -import Distribution.Client.TargetProblem - ( TargetProblem(..), TargetProblem' ) -import Distribution.Client.TargetSelector - ( ComponentKind(..), ComponentKindFilter, TargetSelector(..), - componentKind, showTargetSelector ) - -import Distribution.Package - ( PackageId, packageId, PackageName, packageName ) -import Distribution.Simple.Utils - ( die' ) -import Distribution.Types.ComponentName - ( ComponentName(..), showComponentName ) -import Distribution.Types.LibraryName - ( LibraryName(..) ) -import Distribution.Solver.Types.OptionalStanza - ( OptionalStanza(..) ) - -import qualified Data.List.NonEmpty as NE - - ------------------------ --- Singular or plural --- - --- | A tag used in rendering messages to distinguish singular or plural. --- -data Plural = Singular | Plural - --- | Used to render a singular or plural version of something --- --- > plural (listPlural theThings) "it is" "they are" --- -plural :: Plural -> a -> a -> a -plural Singular si _pl = si -plural Plural _si pl = pl - --- | Singular for singleton lists and plural otherwise. --- -listPlural :: [a] -> Plural -listPlural [_] = Singular -listPlural _ = Plural - - --------------------- --- Rendering lists --- - --- | Render a list of things in the style @foo, bar and baz@ -renderListCommaAnd :: [String] -> String -renderListCommaAnd [] = "" -renderListCommaAnd [x] = x -renderListCommaAnd [x,x'] = x ++ " and " ++ x' -renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs - --- | Render a list of things in the style @blah blah; this that; and the other@ -renderListSemiAnd :: [String] -> String -renderListSemiAnd [] = "" -renderListSemiAnd [x] = x -renderListSemiAnd [x,x'] = x ++ "; and " ++ x' -renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs - --- | When rendering lists of things it often reads better to group related --- things, e.g. grouping components by package name --- --- > renderListSemiAnd --- > [ "the package " ++ prettyShow pkgname ++ " components " --- > ++ renderListCommaAnd showComponentName components --- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] --- -sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] -sortGroupOn key = map (\(x:|xs) -> (key x, x:xs)) - . NE.groupBy ((==) `on` key) - . sortBy (compare `on` key) - - ----------------------------------------------------- --- Renderering for a few project and package types --- - -renderTargetSelector :: TargetSelector -> String -renderTargetSelector (TargetPackage _ pkgids Nothing) = - "the " ++ plural (listPlural pkgids) "package" "packages" ++ " " - ++ renderListCommaAnd (map prettyShow pkgids) - -renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = - "the " ++ renderComponentKind Plural kfilter - ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " - ++ renderListCommaAnd (map prettyShow pkgids) - -renderTargetSelector (TargetPackageNamed pkgname Nothing) = - "the package " ++ prettyShow pkgname - -renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) = - "the " ++ renderComponentKind Plural kfilter - ++ " in the package " ++ prettyShow pkgname - -renderTargetSelector (TargetAllPackages Nothing) = - "all the packages in the project" - -renderTargetSelector (TargetAllPackages (Just kfilter)) = - "all the " ++ renderComponentKind Plural kfilter - ++ " in the project" - -renderTargetSelector (TargetComponent pkgid cname subtarget) = - renderSubComponentTarget subtarget ++ "the " - ++ renderComponentName (packageName pkgid) cname - -renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) = - renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname - ++ " in the package " ++ prettyShow pkgname - -renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) = - renderSubComponentTarget subtarget ++ "the " - ++ renderComponentName pkgname cname - -renderSubComponentTarget :: SubComponentTarget -> String -renderSubComponentTarget WholeComponent = "" -renderSubComponentTarget (FileTarget filename) = - "the file " ++ filename ++ "in " -renderSubComponentTarget (ModuleTarget modname) = - "the module" ++ prettyShow modname ++ "in " - - -renderOptionalStanza :: Plural -> OptionalStanza -> String -renderOptionalStanza Singular TestStanzas = "test suite" -renderOptionalStanza Plural TestStanzas = "test suites" -renderOptionalStanza Singular BenchStanzas = "benchmark" -renderOptionalStanza Plural BenchStanzas = "benchmarks" - --- | The optional stanza type (test suite or benchmark), if it is one. -optionalStanza :: ComponentName -> Maybe OptionalStanza -optionalStanza (CTestName _) = Just TestStanzas -optionalStanza (CBenchName _) = Just BenchStanzas -optionalStanza _ = Nothing - --- | Does the 'TargetSelector' potentially refer to one package or many? --- -targetSelectorPluralPkgs :: TargetSelector -> Plural -targetSelectorPluralPkgs (TargetAllPackages _) = Plural -targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids -targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular -targetSelectorPluralPkgs TargetComponent{} = Singular -targetSelectorPluralPkgs TargetComponentUnknown{} = Singular - --- | Does the 'TargetSelector' refer to packages or to components? -targetSelectorRefersToPkgs :: TargetSelector -> Bool -targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs TargetComponent{} = False -targetSelectorRefersToPkgs TargetComponentUnknown{} = False - -targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter -targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter -targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter -targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter -targetSelectorFilter TargetComponent{} = Nothing -targetSelectorFilter TargetComponentUnknown{} = Nothing - -renderComponentName :: PackageName -> ComponentName -> String -renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname -renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name -renderComponentName _ (CFLibName name) = "foreign library " ++ prettyShow name -renderComponentName _ (CExeName name) = "executable " ++ prettyShow name -renderComponentName _ (CTestName name) = "test suite " ++ prettyShow name -renderComponentName _ (CBenchName name) = "benchmark " ++ prettyShow name - -renderComponentKind :: Plural -> ComponentKind -> String -renderComponentKind Singular ckind = case ckind of - LibKind -> "library" -- internal/sub libs? - FLibKind -> "foreign library" - ExeKind -> "executable" - TestKind -> "test suite" - BenchKind -> "benchmark" -renderComponentKind Plural ckind = case ckind of - LibKind -> "libraries" -- internal/sub libs? - FLibKind -> "foreign libraries" - ExeKind -> "executables" - TestKind -> "test suites" - BenchKind -> "benchmarks" - - -------------------------------------------------------- --- Renderering error messages for TargetProblem --- - --- | Default implementation of 'reportTargetProblems' simply renders one problem per line. -reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a -reportTargetProblems verbosity verb = - die' verbosity . unlines . map (renderTargetProblem verb absurd) - --- | Default implementation of 'renderTargetProblem'. -renderTargetProblem - :: String -- ^ verb - -> (a -> String) -- ^ how to render custom problems - -> TargetProblem a - -> String -renderTargetProblem _verb f (CustomTargetProblem x) = f x -renderTargetProblem verb _ (TargetProblemNoneEnabled targetSelector targets) = - renderTargetProblemNoneEnabled verb targetSelector targets -renderTargetProblem verb _ (TargetProblemNoTargets targetSelector) = - renderTargetProblemNoTargets verb targetSelector - -renderTargetProblem verb _ (TargetNotInProject pkgname) = - "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " - ++ "in this project (either directly or indirectly). If you want to add it " - ++ "to the project then edit the cabal.project file." - -renderTargetProblem verb _ (TargetAvailableInIndex pkgname) = - "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " - ++ "in this project (either directly or indirectly), but it is in the current " - ++ "package index. If you want to add it to the project then edit the " - ++ "cabal.project file." - -renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " - ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal " - ++ "does not currently support building test suites or benchmarks of " - ++ "non-local dependencies. To run test suites or benchmarks from " - ++ "dependencies you can unpack the package locally and adjust the " - ++ "cabal.project file to include that package directory." - -renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is " - ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid) - ++ ".cabal' file (at least for the current configuration). If you believe it " - ++ "should be buildable then check the .cabal file to see if the buildable " - ++ "property is conditional on flags. Alternatively you may simply have to " - ++ "edit the .cabal file to declare it as buildable and fix any resulting " - ++ "build problems." - -renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because " - ++ "building " ++ compkinds ++ " has been explicitly disabled in the " - ++ "configuration. You can adjust this configuration in the " - ++ "cabal.project{.local} file either for all packages in the project or on " - ++ "a per-package basis. Note that if you do not explicitly disable " - ++ compkinds ++ " then the solver will merely try to make a plan with " - ++ "them available, so you may wish to explicitly enable them which will " - ++ "require the solver to find a plan with them available or to fail with an " - ++ "explanation." - where - compkinds = renderComponentKind Plural (componentKind cname) - -renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " - ++ "solver did not find a plan that included the " ++ compkinds - ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with " - ++ compkinds ++ " explicitly enabled in the configuration in the " - ++ "cabal.project{.local} file. This will ask the solver to find a plan with " - ++ "the " ++ compkinds ++ " available. It will either fail with an " - ++ "explanation or find a different plan that uses different versions of some " - ++ "other packages. Use the '--dry-run' flag to see package versions and " - ++ "check that you are happy with the choices." - where - compkinds = renderComponentKind Plural (componentKind cname) - -renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) = - "Cannot " ++ verb ++ " the " - ++ (case ecname of - Left ucname -> "component " ++ prettyShow ucname - Right cname -> renderComponentName pkgname cname) - ++ " from the package " ++ prettyShow pkgname - ++ ", because the package does not contain a " - ++ (case ecname of - Left _ -> "component" - Right cname -> renderComponentKind Singular (componentKind cname)) - ++ " with that name." - -renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) = - "Internal error when trying to " ++ verb ++ " the package " - ++ prettyShow pkgid ++ ". The package is not in the set of available targets " - ++ "for the project plan, which would suggest an inconsistency " - ++ "between readTargetSelectors and resolveTargets." - -renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) = - "Internal error when trying to " ++ verb ++ " the " - ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid - ++ ". The package,component pair is not in the set of available targets " - ++ "for the project plan, which would suggest an inconsistency " - ++ "between readTargetSelectors and resolveTargets." - - ------------------------------------------------------------- --- Renderering error messages for TargetProblemNoneEnabled --- - --- | Several commands have a @TargetProblemNoneEnabled@ problem constructor. --- This renders an error message for those cases. --- -renderTargetProblemNoneEnabled :: String - -> TargetSelector - -> [AvailableTarget ()] - -> String -renderTargetProblemNoneEnabled verb targetSelector targets = - "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector - ++ " because none of the components are available to build: " - ++ renderListSemiAnd - [ case (status, mstanza) of - (TargetDisabledByUser, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are " - ++ " not available because building " - ++ renderOptionalStanza Plural stanza - ++ " has been disabled in the configuration" - (TargetDisabledBySolver, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are " - ++ "not available because the solver did not find a plan that " - ++ "included the " ++ renderOptionalStanza Plural stanza - ++ ". Force the solver to enable this for all packages by adding the " - ++ "line 'tests: True' to the 'cabal.project.local' file." - (TargetNotBuildable, _) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are all " - ++ "marked as 'buildable: False'" - (TargetNotLocal, _) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ " cannot be built because cabal does not currently support " - ++ "building test suites or benchmarks of non-local dependencies" - (TargetBuildable () TargetNotRequestedByDefault, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ " will not be built because " ++ renderOptionalStanza Plural stanza - ++ " are not built by default in the current configuration (but you " - ++ "can still build them specifically)" --TODO: say how - _ -> error $ "renderBuildTargetProblem: unexpected status " - ++ show (status, mstanza) - | ((status, mstanza), targets') <- sortGroupOn groupingKey targets - ] - where - groupingKey t = - ( availableTargetStatus t - , case availableTargetStatus t of - TargetNotBuildable -> Nothing - TargetNotLocal -> Nothing - _ -> optionalStanza (availableTargetComponentName t) - ) - ------------------------------------------------------------- --- Renderering error messages for TargetProblemNoneEnabled --- - --- | Several commands have a @TargetProblemNoTargets@ problem constructor. --- This renders an error message for those cases. --- -renderTargetProblemNoTargets :: String -> TargetSelector -> String -renderTargetProblemNoTargets verb targetSelector = - "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector - ++ " because " ++ reason targetSelector ++ ". " - ++ "Check the .cabal " - ++ plural (targetSelectorPluralPkgs targetSelector) - "file for the package and make sure that it properly declares " - "files for the packages and make sure that they properly declare " - ++ "the components that you expect." - where - reason (TargetPackage _ _ Nothing) = - "it does not contain any components at all" - reason (TargetPackage _ _ (Just kfilter)) = - "it does not contain any " ++ renderComponentKind Plural kfilter - reason (TargetPackageNamed _ Nothing) = - "it does not contain any components at all" - reason (TargetPackageNamed _ (Just kfilter)) = - "it does not contain any " ++ renderComponentKind Plural kfilter - reason (TargetAllPackages Nothing) = - "none of them contain any components at all" - reason (TargetAllPackages (Just kfilter)) = - "none of the packages contain any " - ++ renderComponentKind Plural kfilter - reason ts@TargetComponent{} = - error $ "renderTargetProblemNoTargets: " ++ show ts - reason ts@TargetComponentUnknown{} = - error $ "renderTargetProblemNoTargets: " ++ show ts - ------------------------------------------------------------ --- Renderering error messages for CannotPruneDependencies --- - -renderCannotPruneDependencies :: CannotPruneDependencies -> String -renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = - "Cannot select only the dependencies (as requested by the " - ++ "'--only-dependencies' flag), " - ++ (case pkgids of - [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " - _ -> "the packages " - ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ") - ++ "required by a dependency of one of the other targets." - where - -- throw away the details and just list the deps that are needed - pkgids :: [PackageId] - pkgids = nub . map packageId . concatMap snd $ brokenPackages - -{- - ++ "Syntax:\n" - ++ " - build [package]\n" - ++ " - build [package:]component\n" - ++ " - build [package:][component:]module\n" - ++ " - build [package:][component:]file\n" - ++ " where\n" - ++ " package is a package name, package dir or .cabal file\n\n" - ++ "Examples:\n" - ++ " - build foo -- package name\n" - ++ " - build tests -- component name\n" - ++ " (name of library, executable, test-suite or benchmark)\n" - ++ " - build Data.Foo -- module name\n" - ++ " - build Data/Foo.hsc -- file name\n\n" - ++ "An ambigious target can be qualified by package, component\n" - ++ "and/or component kind (lib|exe|test|bench|flib)\n" - ++ " - build foo:tests -- component qualified by package\n" - ++ " - build tests:Data.Foo -- module qualified by component\n" - ++ " - build lib:foo -- component qualified by kind" --} diff --git a/Distribution/Client/CmdExec.hs b/Distribution/Client/CmdExec.hs deleted file mode 100644 --- a/Distribution/Client/CmdExec.hs +++ /dev/null @@ -1,251 +0,0 @@ -------------------------------------------------------------------------------- --- | --- Module : Distribution.Client.Exec --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Implementation of the 'v2-exec' command for running an arbitrary executable --- in an environment suited to the part of the store built for a project. -------------------------------------------------------------------------------- - -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.CmdExec - ( execAction - , execCommand - ) where - -import Distribution.Client.DistDirLayout - ( DistDirLayout(..) - ) -import Distribution.Client.InstallPlan - ( GenericPlanPackage(..) - , toGraph - ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( ConfigFlags(configVerbosity) - , GlobalFlags - ) -import Distribution.Client.ProjectOrchestration - ( ProjectBuildContext(..) - , runProjectPreBuildPhase - , CurrentCommand(..) - , establishProjectBaseContext - , distDirLayout - , commandLineFlagsToProjectConfig - , ProjectBaseContext(..) - ) -import Distribution.Client.ProjectPlanOutput - ( updatePostBuildProjectStatus - , createPackageEnvironment - , argsEquivalentOfGhcEnvironmentFile - , PostBuildProjectStatus - ) -import qualified Distribution.Client.ProjectPlanning as Planning -import Distribution.Client.ProjectPlanning - ( ElaboratedInstallPlan - , ElaboratedSharedConfig(..) - ) -import Distribution.Simple.Command - ( CommandUI(..), optionName - ) -import Distribution.Simple.Program.Db - ( modifyProgramSearchPath - , requireProgram - , configuredPrograms - ) -import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry(..) - ) -import Distribution.Simple.Program.Run - ( programInvocation - , runProgramInvocation - ) -import Distribution.Simple.Program.Types - ( programOverrideEnv - , programDefaultArgs - , programPath - , simpleProgram - , ConfiguredProgram - ) -import Distribution.Simple.GHC - ( getImplInfo - , GhcImplInfo(supportsPkgEnvFiles) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault - ) -import Distribution.Simple.Utils - ( die' - , info - , createDirectoryIfMissingVerbose - , withTempDirectory - , wrapText - ) -import Distribution.Verbosity - ( normal - ) - -import Prelude () -import Distribution.Client.Compat.Prelude - -import qualified Data.Set as S -import qualified Data.Map as M - -execCommand :: CommandUI (NixStyleFlags ()) -execCommand = CommandUI - { commandName = "v2-exec" - , commandSynopsis = "Give a command access to the store." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" - , commandDescription = Just $ \pname -> wrapText $ - "During development it is often useful to run build tasks and perform" - ++ " one-off program executions to experiment with the behavior of build" - ++ " tools. It is convenient to run these tools in the same way " ++ pname - ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to" - ++ " do so.\n" - ++ "\n" - ++ "Compiler tools will be configured to see the same subset of the store" - ++ " that builds would see. The PATH is modified to make all executables in" - ++ " the dependency tree available (provided they have been built already)." - ++ " Commands are also rewritten in the way cabal itself would. For" - ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration" - ++ " to choose an appropriate version of ghc and to include any" - ++ " ghc-specific flags requested." - , commandNotes = Nothing - , commandOptions = filter (\o -> optionName o /= "ignore-project") - . nixStyleOptions (const []) - , commandDefaultFlags = defaultNixStyleFlags () - } - -execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -execAction flags@NixStyleFlags {..} extraArgs globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - -- To set up the environment, we'd like to select the libraries in our - -- dependency tree that we've already built. So first we set up an install - -- plan, but we walk the dependency tree without first executing the plan. - buildCtx <- runProjectPreBuildPhase - verbosity - baseCtx - (\plan -> return (plan, M.empty)) - - -- We use the build status below to decide what libraries to include in the - -- compiler environment, but we don't want to actually build anything. So we - -- pass mempty to indicate that nothing happened and we just want the current - -- status. - buildStatus <- updatePostBuildProjectStatus - verbosity - (distDirLayout baseCtx) - (elaboratedPlanOriginal buildCtx) - (pkgsBuildStatus buildCtx) - mempty - - -- Some dependencies may have executables. Let's put those on the PATH. - extraPaths <- pathAdditions verbosity baseCtx buildCtx - let programDb = modifyProgramSearchPath - (map ProgramSearchPathDir extraPaths ++) - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx - - -- Now that we have the packages, set up the environment. We accomplish this - -- by creating an environment file that selects the databases and packages we - -- computed in the previous step, and setting an environment variable to - -- point at the file. - -- In case ghc is too old to support environment files, - -- we pass the same info as arguments - let compiler = pkgConfigCompiler $ elaboratedShared buildCtx - envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) - case extraArgs of - [] -> die' verbosity "Please specify an executable to run" - exe:args -> do - (program, _) <- requireProgram verbosity (simpleProgram exe) programDb - let argOverrides = - argsEquivalentOfGhcEnvironmentFile - compiler - (distDirLayout baseCtx) - (elaboratedPlanOriginal buildCtx) - buildStatus - programIsConfiguredCompiler = matchCompilerPath - (elaboratedShared buildCtx) - program - argOverrides' = - if envFilesSupported - || not programIsConfiguredCompiler - then [] - else argOverrides - - (if envFilesSupported - then withTempEnvFile verbosity baseCtx buildCtx buildStatus - else \f -> f []) $ \envOverrides -> do - let program' = withOverrides - envOverrides - argOverrides' - program - invocation = programInvocation program' args - runProgramInvocation verbosity invocation - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - withOverrides env args program = program - { programOverrideEnv = programOverrideEnv program ++ env - , programDefaultArgs = programDefaultArgs program ++ args} - -matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool -matchCompilerPath elaboratedShared program = - programPath program - `elem` - (programPath <$> configuredCompilers) - where - configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared - --- | Execute an action with a temporary .ghc.environment file reflecting the --- current environment. The action takes an environment containing the env --- variable which points ghc to the file. -withTempEnvFile :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> PostBuildProjectStatus - -> ([(String, Maybe String)] -> IO a) - -> IO a -withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do - createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) - withTempDirectory - verbosity - (distTempDirectory (distDirLayout baseCtx)) - "environment." - (\tmpDir -> do - envOverrides <- createPackageEnvironment - verbosity - tmpDir - (elaboratedPlanToExecute buildCtx) - (elaboratedShared buildCtx) - buildStatus - action envOverrides) - -pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] -pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do - info verbosity . unlines $ "Including the following directories in PATH:" - : paths - return paths - where - paths = S.toList - $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute - -binDirectories - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> Set FilePath -binDirectories layout config = fromElaboratedInstallPlan where - fromElaboratedInstallPlan = fromGraph . toGraph - fromGraph = foldMap fromPlan - fromSrcPkg = S.fromList . Planning.binDirectories layout config - - fromPlan (PreExisting _) = mempty - fromPlan (Configured pkg) = fromSrcPkg pkg - fromPlan (Installed pkg) = fromSrcPkg pkg - diff --git a/Distribution/Client/CmdFreeze.hs b/Distribution/Client/CmdFreeze.hs deleted file mode 100644 --- a/Distribution/Client/CmdFreeze.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} - --- | cabal-install CLI command: freeze --- -module Distribution.Client.CmdFreeze ( - freezeCommand, - freezeAction, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..) - , writeProjectLocalFreezeConfig ) -import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos) -import Distribution.Client.Targets - ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) -import Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(..) ) -import Distribution.Client.DistDirLayout - ( DistDirLayout(distProjectFile) ) -import qualified Distribution.Client.InstallPlan as InstallPlan - - -import Distribution.Package - ( PackageName, packageName, packageVersion ) -import Distribution.Version - ( VersionRange, thisVersion - , unionVersionRanges, simplifyVersionRange ) -import Distribution.PackageDescription - ( FlagAssignment, nullFlagAssignment ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Flag (Flag (..)) -import Distribution.Simple.Utils - ( die', notice, wrapText ) -import Distribution.Verbosity - ( normal ) - -import qualified Data.Map as Map - -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) - -freezeCommand :: CommandUI (NixStyleFlags ()) -freezeCommand = CommandUI { - commandName = "v2-freeze", - commandSynopsis = "Freeze dependencies.", - commandUsage = usageAlternatives "v2-freeze" [ "[FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "The project configuration is frozen so that it will be reproducible " - ++ "in future.\n\n" - - ++ "The precise dependency configuration for the project is written to " - ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " - ++ "'--project-file' is specified). This file extends the configuration " - ++ "from the 'cabal.project' file and thus is used as the project " - ++ "configuration for all other commands (such as 'v2-build', " - ++ "'v2-repl' etc).\n\n" - - ++ "The freeze file can be kept in source control. To make small " - ++ "adjustments it may be edited manually, or to make bigger changes " - ++ "you may wish to delete the file and re-freeze. For more control, " - ++ "one approach is to try variations using 'v2-build --dry-run' with " - ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " - ++ "a satisfactory solution to freeze it using the 'v2-freeze' command " - ++ "with the same set of flags.", - - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-freeze\n" - ++ " Freeze the configuration of the current project\n\n" - ++ " " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n" - ++ " Check what a solution with the given constraints would look like\n" - ++ " " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n" - ++ " Freeze a solution using the given constraints\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - --- | To a first approximation, the @freeze@ command runs the first phase of --- the @build@ command where we bring the install plan up to date, and then --- based on the install plan we write out a @cabal.project.freeze@ config file. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do - - unless (null extraArgs) $ - die' verbosity $ "'freeze' doesn't take any extra arguments: " - ++ unwords extraArgs - - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages - } <- establishProjectBaseContext verbosity cliConfig OtherCommand - - (_, elaboratedPlan, _, totalIndexState, activeRepos) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - - let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos - writeProjectLocalFreezeConfig distDirLayout freezeConfig - notice verbosity $ - "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" - - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - - - --- | Given the install plan, produce a config value with constraints that --- freezes the versions of packages used in the plan. --- -projectFreezeConfig - :: ElaboratedInstallPlan - -> TotalIndexState - -> ActiveRepos - -> ProjectConfig -projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty - { projectConfigShared = mempty - { projectConfigConstraints = - concat (Map.elems (projectFreezeConstraints elaboratedPlan)) - , projectConfigIndexState = Flag totalIndexState - , projectConfigActiveRepos = Flag activeRepos - } - } - where - activeRepos :: ActiveRepos - activeRepos = filterSkippedActiveRepos activeRepos0 - --- | Given the install plan, produce solver constraints that will ensure the --- solver picks the same solution again in future in different environments. --- -projectFreezeConstraints :: ElaboratedInstallPlan - -> Map PackageName [(UserConstraint, ConstraintSource)] -projectFreezeConstraints plan = - -- - -- TODO: [required eventually] this is currently an underapproximation - -- since the constraints language is not expressive enough to specify the - -- precise solution. See https://github.com/haskell/cabal/issues/3502. - -- - -- For the moment we deal with multiple versions in the solution by using - -- constraints that allow either version. Also, we do not include any - -- /version/ constraints for packages that are local to the project (e.g. - -- if the solution has two instances of Cabal, one from the local project - -- and one pulled in as a setup deps then we exclude all constraints on - -- Cabal, not just the constraint for the local instance since any - -- constraint would apply to both instances). We do however keep flag - -- constraints of local packages. - -- - deleteLocalPackagesVersionConstraints - (Map.unionWith (++) versionConstraints flagConstraints) - where - versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] - versionConstraints = - Map.mapWithKey - (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v), - ConstraintSourceFreeze)]) - versionRanges - - versionRanges :: Map PackageName VersionRange - versionRanges = - Map.map simplifyVersionRange $ - Map.fromListWith unionVersionRanges $ - [ (packageName pkg, thisVersion (packageVersion pkg)) - | InstallPlan.PreExisting pkg <- InstallPlan.toList plan - ] - ++ [ (packageName pkg, thisVersion (packageVersion pkg)) - | InstallPlan.Configured pkg <- InstallPlan.toList plan - ] - - flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] - flagConstraints = - Map.mapWithKey - (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f), - ConstraintSourceFreeze)]) - flagAssignments - - flagAssignments :: Map PackageName FlagAssignment - flagAssignments = - Map.fromList - [ (pkgname, flags) - | InstallPlan.Configured elab <- InstallPlan.toList plan - , let flags = elabFlagAssignment elab - pkgname = packageName elab - , not (nullFlagAssignment flags) ] - - -- As described above, remove the version constraints on local packages, - -- but leave any flag constraints. - deleteLocalPackagesVersionConstraints - :: Map PackageName [(UserConstraint, ConstraintSource)] - -> Map PackageName [(UserConstraint, ConstraintSource)] - deleteLocalPackagesVersionConstraints = - Map.mergeWithKey - (\_pkgname () constraints -> - case filter (not . isVersionConstraint . fst) constraints of - [] -> Nothing - constraints' -> Just constraints') - (const Map.empty) id - localPackages - - isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True - isVersionConstraint _ = False - - localPackages :: Map PackageName () - localPackages = - Map.fromList - [ (packageName elab, ()) - | InstallPlan.Configured elab <- InstallPlan.toList plan - , elabLocalToProject elab - ] - diff --git a/Distribution/Client/CmdHaddock.hs b/Distribution/Client/CmdHaddock.hs deleted file mode 100644 --- a/Distribution/Client/CmdHaddock.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: haddock --- -module Distribution.Client.CmdHaddock ( - -- * The @haddock@ CLI and action - haddockCommand, - haddockAction, - - -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages -import Distribution.Client.TargetProblem - ( TargetProblem (..), TargetProblem' ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Setup - ( HaddockFlags(..), fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( wrapText, die' ) - -haddockCommand :: CommandUI (NixStyleFlags ()) -haddockCommand = CommandUI { - commandName = "v2-haddock", - commandSynopsis = "Build Haddock documentation", - commandUsage = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ], - commandDescription = Just $ \_ -> wrapText $ - "Build Haddock documentation for the specified packages within the " - ++ "project.\n\n" - - ++ "Any package in the project can be specified. If no package is " - ++ "specified, the default is to build the documentation for the package " - ++ "in the current directory. The default behaviour is to build " - ++ "documentation for the exposed modules of the library component (if " - ++ "any). This can be changed with the '--internal', '--executables', " - ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" - - ++ "Currently, documentation for dependencies is NOT built. This " - ++ "behavior may change in future.\n\n" - - ++ "Additional configuration flags can be specified on the command line " - ++ "and these extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-haddock pkgname" - ++ " Build documentation for the package named pkgname\n" - , commandOptions = nixStyleOptions (const []) - , commandDefaultFlags = defaultNixStyleFlags () - } - --TODO: [nice to have] support haddock on specific components, not just - -- whole packages and the silly --executables etc modifiers. - --- | The @haddock@ command is TODO. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -haddockAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do - baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity - "The haddock command does not support '--only-dependencies'." - - -- When we interpret the targets on the command line, interpret them as - -- haddock targets - targets <- either (reportBuildDocumentationTargetProblems verbosity) return - $ resolveTargets - (selectPackageTargets haddockFlags) - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionHaddock - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - --- | This defines what a 'TargetSelector' means for the @haddock@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @haddock@ command we select all buildable libraries. Additionally, --- depending on the @--executables@ flag we also select all the buildable exes. --- We do similarly for test-suites, benchmarks and foreign libs. --- -selectPackageTargets :: HaddockFlags -> TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] -selectPackageTargets haddockFlags targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targets' = forgetTargetsDetail (map disableNotRequested targets) - targetsBuildable = selectBuildableTargets (map disableNotRequested targets) - - -- When there's a target filter like "pkg:exes" then we do select exes, - -- but if it's just a target like "pkg" then we don't build docs for exes - -- unless they are requested by default (i.e. by using --executables) - disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _) - | not (isRequested targetSelector (componentKind cname)) - = t { availableTargetStatus = TargetDisabledByUser } - disableNotRequested t = t - - isRequested (TargetPackage _ _ (Just _)) _ = True - isRequested (TargetAllPackages (Just _)) _ = True - isRequested _ LibKind = True --- isRequested _ SubLibKind = True --TODO: what about sublibs? - - -- TODO/HACK, we encode some defaults here as v2-haddock's logic; - -- make sure this matches the defaults applied in - -- "Distribution.Client.ProjectPlanning"; this may need more work - -- to be done properly - -- - -- See also https://github.com/haskell/cabal/pull/4886 - isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags) - isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags) - isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags) - isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags) - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @haddock@ command we just need the basic checks on being buildable --- etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k -selectComponentTarget = selectComponentTargetBasic - -reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a -reportBuildDocumentationTargetProblems verbosity problems = - reportTargetProblems verbosity "build documentation for" problems diff --git a/Distribution/Client/CmdInstall.hs b/Distribution/Client/CmdInstall.hs deleted file mode 100644 --- a/Distribution/Client/CmdInstall.hs +++ /dev/null @@ -1,960 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - --- | cabal-install CLI command: build --- -module Distribution.Client.CmdInstall ( - -- * The @build@ CLI and action - installCommand, - installAction, - - -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget, - -- * Internals exposed for CmdRepl + CmdRun - establishDummyDistDirLayout, - establishDummyProjectBaseContext - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Compat.Directory - ( doesPathExist ) - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages -import Distribution.Client.CmdSdist -import Distribution.Client.TargetProblem - ( TargetProblem', TargetProblem (..) ) - -import Distribution.Client.CmdInstall.ClientInstallFlags -import Distribution.Client.CmdInstall.ClientInstallTargetSelector - -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) -import Distribution.Client.Types - ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage - , SourcePackageDb(..) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Package - ( Package(..), PackageName, mkPackageName, unPackageName ) -import Distribution.Types.PackageId - ( PackageIdentifier(..) ) -import Distribution.Client.ProjectConfig - ( ProjectPackageLocation(..) - , fetchAndReadSourcePackages - ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.ProjectFlags (ProjectFlags (..)) -import Distribution.Client.ProjectConfig.Types - ( ProjectConfig(..), ProjectConfigShared(..) - , ProjectConfigBuildOnly(..), PackageConfig(..) - , getMapLast, getMapMappend, projectConfigLogsDir - , projectConfigStoreDir, projectConfigBuildOnly - , projectConfigConfigFile ) -import Distribution.Simple.Program.Db - ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb - , modifyProgramSearchPath, ProgramDb ) -import Distribution.Simple.BuildPaths - ( exeExtension ) -import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry(..) ) -import Distribution.Client.Config - ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) ) -import qualified Distribution.Simple.PackageIndex as PI -import Distribution.Solver.Types.PackageIndex - ( lookupPackageName, searchByName ) -import Distribution.Types.InstalledPackageInfo - ( InstalledPackageInfo(..) ) -import Distribution.Types.Version - ( Version, nullVersion ) -import Distribution.Types.VersionRange - ( thisVersion ) -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) -import Distribution.Client.IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.ProjectConfig - ( projectConfigWithBuilderRepoContext - , resolveBuildTimeSettings, withProjectOrGlobalConfig ) -import Distribution.Client.ProjectPlanning - ( storePackageInstallDirs' ) -import Distribution.Client.ProjectPlanning.Types - ( ElaboratedInstallPlan ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), mkCabalDirLayout - , cabalStoreDirLayout - , CabalDirLayout(..), StoreDirLayout(..) ) -import Distribution.Client.RebuildMonad - ( runRebuild ) -import Distribution.Client.InstallSymlink - ( symlinkBinary, trySymlink ) -import Distribution.Client.Types.OverwritePolicy - ( OverwritePolicy (..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe, flagElim ) -import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Simple.Configure - ( configCompilerEx ) -import Distribution.Simple.Compiler - ( Compiler(..), CompilerId(..), CompilerFlavor(..) - , PackageDBStack ) -import Distribution.Simple.GHC - ( ghcPlatformAndVersionString, getGhcAppDir - , GhcImplInfo(..), getImplInfo - , GhcEnvironmentFileEntry(..) - , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) -import Distribution.System - ( Platform , buildOS, OS (Windows) ) -import Distribution.Types.UnitId - ( UnitId ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) -import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Simple.Utils - ( wrapText, die', notice, warn - , withTempDirectory, createDirectoryIfMissingVerbose - , ordNub ) -import Distribution.Utils.Generic - ( safeHead, writeFileAtomic ) - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Ord - ( Down(..) ) -import qualified Data.Map as Map -import Distribution.Utils.NubList - ( fromNubList ) -import Network.URI (URI) -import System.Directory - ( doesFileExist, createDirectoryIfMissing - , getTemporaryDirectory, makeAbsolute, doesDirectoryExist - , removeFile, removeDirectory, copyFile ) -import System.FilePath - ( (), (<.>), takeDirectory, takeBaseName ) - -installCommand :: CommandUI (NixStyleFlags ClientInstallFlags) -installCommand = CommandUI - { commandName = "v2-install" - , commandSynopsis = "Install packages." - , commandUsage = usageAlternatives - "v2-install" [ "[TARGETS] [FLAGS]" ] - , commandDescription = Just $ \_ -> wrapText $ - "Installs one or more packages. This is done by installing them " - ++ "in the store and symlinking/copying the executables in the directory " - ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). " - ++ "If you want the installed executables to be available globally, " - ++ "make sure that the PATH environment variable contains that directory. " - ++ "\n\n" - ++ "If TARGET is a library, it will be added to the global environment. " - ++ "When doing this, cabal will try to build a plan that includes all " - ++ "the previously installed libraries. This is currently not implemented." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-install\n" - ++ " Install the package in the current directory\n" - ++ " " ++ pname ++ " v2-install pkgname\n" - ++ " Install the package named pkgname" - ++ " (fetching it from hackage if necessary)\n" - ++ " " ++ pname ++ " v2-install ./pkgfoo\n" - ++ " Install the package in the ./pkgfoo directory\n" - - , commandOptions = nixStyleOptions clientInstallOptions - , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags - } - --- | The @install@ command actually serves four different needs. It installs: --- * exes: --- For example a program from hackage. The behavior is similar to the old --- install command, except that now conflicts between separate runs of the --- command are impossible thanks to the store. --- Exes are installed in the store like a normal dependency, then they are --- symlinked/copied in the directory specified by --installdir. --- To do this we need a dummy projectBaseContext containing the targets as --- estra packages and using a temporary dist directory. --- * libraries --- Libraries install through a similar process, but using GHC environment --- files instead of symlinks. This means that 'v2-install'ing libraries --- only works on GHC >= 8.0. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO () -installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do - -- Ensure there were no invalid configuration options specified. - verifyPreconditionsOrDie verbosity configFlags' - - -- We cannot use establishDummyProjectBaseContext to get these flags, since - -- it requires one of them as an argument. Normal establishProjectBaseContext - -- does not, and this is why this is done only for the install command - clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags' - - let - installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) - targetFilter = if installLibs then Just LibKind else Just ExeKind - targetStrings' = if null targetStrings then ["."] else targetStrings - - withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig) - withProject = do - let reducedVerbosity = lessVerbose verbosity - - -- First, we need to learn about what's available to be installed. - localBaseCtx <- - establishProjectBaseContext reducedVerbosity cliConfig InstallCommand - let localDistDirLayout = distDirLayout localBaseCtx - pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity - (buildSettings localBaseCtx) (getSourcePackages verbosity) - - let - (targetStrings'', packageIds) = - partitionEithers . - flip fmap targetStrings' $ - \str -> case simpleParsec str of - Just (pkgId :: PackageId) - | pkgVersion pkgId /= nullVersion -> Right pkgId - _ -> Left str - packageSpecifiers = - flip fmap packageIds $ \case - PackageIdentifier{..} - | pkgVersion == nullVersion -> NamedPackage pkgName [] - | otherwise -> NamedPackage pkgName - [PackagePropertyVersion - (thisVersion pkgVersion)] - packageTargets = - flip TargetPackageNamed targetFilter . pkgName <$> packageIds - - if null targetStrings' - then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx) - else do - targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages localBaseCtx) - Nothing targetStrings'' - - (specs, selectors) <- - getSpecsAndTargetSelectors - verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter - - return ( specs ++ packageSpecifiers - , [] - , selectors ++ packageTargets - , projectConfig localBaseCtx ) - - withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig) - withoutProject globalConfig = do - tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings' - - cabalDir <- getCabalDir - let - projectConfig = globalConfig <> cliConfig - - ProjectConfigBuildOnly { - projectConfigLogsDir - } = projectConfigBuildOnly projectConfig - - ProjectConfigShared { - projectConfigStoreDir - } = projectConfigShared projectConfig - - mlogsDir = flagToMaybe projectConfigLogsDir - mstoreDir = flagToMaybe projectConfigStoreDir - cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext - verbosity buildSettings - (getSourcePackages verbosity) - - for_ (concatMap woPackageNames tss) $ \name -> do - when (null (lookupPackageName packageIndex name)) $ do - let xs = searchByName packageIndex (unPackageName name) - let emptyIf True _ = [] - emptyIf False zs = zs - die' verbosity $ concat $ - [ "Unknown package \"", unPackageName name, "\". " - ] ++ emptyIf (null xs) - [ "Did you mean any of the following?\n" - , unlines (("- " ++) . unPackageName . fst <$> xs) - ] - - let - (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss - packageTargets = map woPackageTargets tss - - return (packageSpecifiers, uris, packageTargets, projectConfig) - - (specs, uris, targetSelectors, config) <- - withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject - - let - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly { - projectConfigLogsDir - }, - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg, - projectConfigStoreDir - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra - } - } = config - - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg - - -- ProgramDb with directly user specified paths - preProgDb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) - $ defaultProgramDb - - -- progDb is a program database with compiler tools configured properly - (compiler@Compiler { compilerId = - compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <- - configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity - - let - GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler - - envFile <- getEnvFile clientInstallFlags platform compilerVersion - existingEnvEntries <- - getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile - packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir - installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb - - let - (envSpecs, nonGlobalEnvEntries) = - getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs - - -- Second, we need to use a fake project to let Cabal build the - -- installables correctly. For that, we need a place to put a - -- temporary dist directory. - globalTmp <- getTemporaryDirectory - - withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do - distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir - - uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages - verbosity - distDirLayout - (projectConfigShared config) - (projectConfigBuildOnly config) - [ ProjectPackageRemoteTarball uri | uri <- uris ] - - baseCtx <- establishDummyProjectBaseContext - verbosity - config - distDirLayout - (envSpecs ++ specs ++ uriSpecs) - InstallCommand - - buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - - -- Now that we built everything we can do the installation part. - -- First, figure out if / what parts we want to install: - let - dryRun = buildSettingDryRun $ buildSettings baseCtx - - -- Then, install! - when (not dryRun) $ - if installLibs - then installLibraries verbosity - buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries - else installExes verbosity - baseCtx buildCtx platform compiler configFlags clientInstallFlags - where - configFlags' = disableTestsBenchsByDefault configFlags - verbosity = fromFlagOrDefault normal (configVerbosity configFlags') - ignoreProject = flagIgnoreProject projectFlags - cliConfig = commandLineFlagsToProjectConfig - globalFlags - flags { configFlags = configFlags' } - clientInstallFlags' - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - --- | Verify that invalid config options were not passed to the install command. --- --- If an invalid configuration is found the command will @die'@. -verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO () -verifyPreconditionsOrDie verbosity configFlags = do - -- We never try to build tests/benchmarks for remote packages. - -- So we set them as disabled by default and error if they are explicitly - -- enabled. - when (configTests configFlags == Flag True) $ - die' verbosity $ "--enable-tests was specified, but tests can't " - ++ "be enabled in a remote package" - when (configBenchmarks configFlags == Flag True) $ - die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " - ++ "be enabled in a remote package" - -getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags -getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do - let configFileFlag = globalConfigFile globalFlags - savedConfig <- loadConfig verbosity configFileFlag - pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags - - -getSpecsAndTargetSelectors - :: Verbosity - -> Verbosity - -> SourcePackageDb - -> [TargetSelector] - -> DistDirLayout - -> ProjectBaseContext - -> Maybe ComponentKindFilter - -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) -getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter = - withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do - -- Split into known targets and hackage packages. - (targets, hackageNames) <- - partitionToKnownTargetsAndHackagePackages - verbosity pkgDb elaboratedPlan targetSelectors - - let - planMap = InstallPlan.toMap elaboratedPlan - targetIds = Map.keys targets - - sdistize (SpecificSourcePackage spkg) = - SpecificSourcePackage spkg' - where - sdistPath = distSdistFile localDistDirLayout (packageId spkg) - spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath } - sdistize named = named - - local = sdistize <$> localPackages localBaseCtx - - gatherTargets :: UnitId -> TargetSelector - gatherTargets targetId = TargetPackageNamed pkgName targetFilter - where - targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap - PackageIdentifier{..} = packageId targetUnit - - targets' = fmap gatherTargets targetIds - - hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] - hackagePkgs = flip NamedPackage [] <$> hackageNames - - hackageTargets :: [TargetSelector] - hackageTargets = - flip TargetPackageNamed targetFilter <$> hackageNames - - createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) - - unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of - SpecificSourcePackage pkg -> packageToSdist verbosity - (distProjectRootDirectory localDistDirLayout) TarGzArchive - (distSdistFile localDistDirLayout (packageId pkg)) pkg - NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName - - if null targets - then return (hackagePkgs, hackageTargets) - else return (local ++ hackagePkgs, targets' ++ hackageTargets) - --- | Partitions the target selectors into known local targets and hackage packages. -partitionToKnownTargetsAndHackagePackages - :: Verbosity - -> SourcePackageDb - -> ElaboratedInstallPlan - -> [TargetSelector] - -> IO (Map UnitId [(ComponentTarget,[TargetSelector])], [PackageName]) -partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do - let mTargets = resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - (Just pkgDb) - targetSelectors - case mTargets of - Right targets -> - -- Everything is a local dependency. - return (targets, []) - Left errs -> do - -- Not everything is local. - let - (errs', hackageNames) = partitionEithers . flip fmap errs $ \case - TargetAvailableInIndex name -> Right name - err -> Left err - - -- report incorrect case for known package. - for_ errs' $ \case - TargetNotInProject hn -> - case searchByName (packageIndex pkgDb) (unPackageName hn) of - [] -> return () - xs -> die' verbosity . concat $ - [ "Unknown package \"", unPackageName hn, "\". " - , "Did you mean any of the following?\n" - , unlines (("- " ++) . unPackageName . fst <$> xs) - ] - _ -> return () - - when (not . null $ errs') $ reportBuildTargetProblems verbosity errs' - - let - targetSelectors' = flip filter targetSelectors $ \case - TargetComponentUnknown name _ _ - | name `elem` hackageNames -> False - TargetPackageNamed name _ - | name `elem` hackageNames -> False - _ -> True - - -- This can't fail, because all of the errors are - -- removed (or we've given up). - targets <- - either (reportBuildTargetProblems verbosity) return $ - resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors' - - return (targets, hackageNames) - - - -constructProjectBuildContext - :: Verbosity - -> ProjectBaseContext - -- ^ The synthetic base context to use to produce the full build context. - -> [TargetSelector] - -> IO ProjectBuildContext -constructProjectBuildContext verbosity baseCtx targetSelectors = do - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - -- Interpret the targets on the command line as build targets - targets <- either (reportBuildTargetProblems verbosity) return $ - resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let prunedToTargetsElaboratedPlan = - pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan - prunedElaboratedPlan <- - if buildSettingOnlyDeps (buildSettings baseCtx) - then either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies (Map.keysSet targets) - prunedToTargetsElaboratedPlan - else return prunedToTargetsElaboratedPlan - - return (prunedElaboratedPlan, targets) - - --- | Install any built exe by symlinking/copying it --- we don't use BuildOutcomes because we also need the component names -installExes - :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> Platform - -> Compiler - -> ConfigFlags - -> ClientInstallFlags - -> IO () -installExes verbosity baseCtx buildCtx platform compiler - configFlags clientInstallFlags = do - installPath <- defaultInstallPath - let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx - - prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags)) - suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags)) - - mkUnitBinDir :: UnitId -> FilePath - mkUnitBinDir = - InstallDirs.bindir . - storePackageInstallDirs' storeDirLayout (compilerId compiler) - - mkExeName :: UnqualComponentName -> FilePath - mkExeName exe = unUnqualComponentName exe <.> exeExtension platform - - mkFinalExeName :: UnqualComponentName -> FilePath - mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform - installdirUnknown = - "installdir is not defined. Set it in your cabal config file " - ++ "or use --installdir=. Using default installdir: " ++ show installPath - - installdir <- fromFlagOrDefault - (warn verbosity installdirUnknown >> pure installPath) $ - pure <$> cinstInstalldir clientInstallFlags - createDirectoryIfMissingVerbose verbosity False installdir - warnIfNoExes verbosity buildCtx - - installMethod <- flagElim defaultMethod return $ - cinstInstallMethod clientInstallFlags - - let - doInstall = installUnitExes - verbosity - overwritePolicy - mkUnitBinDir mkExeName mkFinalExeName - installdir installMethod - in traverse_ doInstall $ Map.toList $ targetsMap buildCtx - where - overwritePolicy = fromFlagOrDefault NeverOverwrite $ - cinstOverwritePolicy clientInstallFlags - isWindows = buildOS == Windows - - -- This is in IO as we will make environment checks, - -- to decide which method is best - defaultMethod :: IO InstallMethod - defaultMethod - -- Try symlinking in temporary directory, if it works default to - -- symlinking even on windows - | isWindows = do - symlinks <- trySymlink verbosity - return $ if symlinks then InstallMethodSymlink else InstallMethodCopy - | otherwise = return InstallMethodSymlink - --- | Install any built library by adding it to the default ghc environment -installLibraries - :: Verbosity - -> ProjectBuildContext - -> Compiler - -> PackageDBStack - -> ProgramDb - -> FilePath -- ^ Environment file - -> [GhcEnvironmentFileEntry] - -> IO () -installLibraries verbosity buildCtx compiler - packageDbs programDb envFile envEntries = do - -- Why do we get it again? If we updated a globalPackage then we need - -- the new version. - installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb - if supportsPkgEnvFiles $ getImplInfo compiler - then do - let - getLatest :: PackageName -> [InstalledPackageInfo] - getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) - . PI.lookupPackageName installedIndex - globalLatest = concat (getLatest <$> globalPackages) - - baseEntries = - GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs - globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest - pkgEntries = ordNub $ - globalEntries - ++ envEntries - ++ entriesForLibraryComponents (targetsMap buildCtx) - contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) - createDirectoryIfMissing True (takeDirectory envFile) - writeFileAtomic envFile (BS.pack contents') - else - warn verbosity $ - "The current compiler doesn't support safely installing libraries, " - ++ "so only executables will be available. (Library installation is " - ++ "supported on GHC 8.0+ only)" - -warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () -warnIfNoExes verbosity buildCtx = - when noExes $ - warn verbosity $ - "\n" <> - "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> - "@ WARNING: Installation might not be completed as desired! @\n" <> - "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> - "Without flags, the command \"cabal install\" doesn't expose" <> - " libraries in a usable manner. You might have wanted to run" <> - " \"cabal install --lib " <> - unwords (showTargetSelector <$> selectors) <> "\". " - where - targets = concat $ Map.elems $ targetsMap buildCtx - components = fst <$> targets - selectors = concatMap snd targets - noExes = null $ catMaybes $ exeMaybe <$> components - - exeMaybe (ComponentTarget (CExeName exe) _) = Just exe - exeMaybe _ = Nothing - -globalPackages :: [PackageName] -globalPackages = mkPackageName <$> - [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath" - , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary" - , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq" - , "ghc-boot-th", "pretty", "template-haskell", "directory", "text" - , "bin-package-db" - ] - --- | Return the package specifiers and non-global environment file entries. -getEnvSpecsAndNonGlobalEntries - :: PI.InstalledPackageIndex - -> [GhcEnvironmentFileEntry] - -> Bool - -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) -getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs = - if installLibs - then (envSpecs, envEntries') - else ([], envEntries') - where - (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries - -environmentFileToSpecifiers - :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] - -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) -environmentFileToSpecifiers ipi = foldMap $ \case - (GhcEnvFilePackageId unitId) - | Just InstalledPackageInfo - { sourcePackageId = PackageIdentifier{..}, installedUnitId } - <- PI.lookupUnitId ipi unitId - , let pkgSpec = NamedPackage pkgName - [PackagePropertyVersion (thisVersion pkgVersion)] - -> if pkgName `elem` globalPackages - then ([pkgSpec], []) - else ([pkgSpec], [GhcEnvFilePackageId installedUnitId]) - _ -> ([], []) - - --- | Disables tests and benchmarks if they weren't explicitly enabled. -disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags -disableTestsBenchsByDefault configFlags = - configFlags { configTests = Flag False <> configTests configFlags - , configBenchmarks = Flag False <> configBenchmarks configFlags } - --- | Symlink/copy every exe from a package from the store to a given location -installUnitExes - :: Verbosity - -> OverwritePolicy -- ^ Whether to overwrite existing files - -> (UnitId -> FilePath) -- ^ A function to get an UnitId's - -- ^ store directory - -> (UnqualComponentName -> FilePath) -- ^ A function to get an - -- ^ exe's filename - -> (UnqualComponentName -> FilePath) -- ^ A function to get an - -- ^ exe's final possibly - -- ^ different to the name in the store. - -> FilePath - -> InstallMethod - -> ( UnitId - , [(ComponentTarget, [TargetSelector])] ) - -> IO () -installUnitExes verbosity overwritePolicy - mkSourceBinDir mkExeName mkFinalExeName - installdir installMethod - (unit, components) = - traverse_ installAndWarn exes - where - exes = catMaybes $ (exeMaybe . fst) <$> components - exeMaybe (ComponentTarget (CExeName exe) _) = Just exe - exeMaybe _ = Nothing - installAndWarn exe = do - success <- installBuiltExe - verbosity overwritePolicy - (mkSourceBinDir unit) (mkExeName exe) - (mkFinalExeName exe) - installdir installMethod - let errorMessage = case overwritePolicy of - NeverOverwrite -> - "Path '" <> (installdir prettyShow exe) <> "' already exists. " - <> "Use --overwrite-policy=always to overwrite." - -- This shouldn't even be possible, but we keep it in case - -- symlinking/copying logic changes - AlwaysOverwrite -> - case installMethod of - InstallMethodSymlink -> "Symlinking" - InstallMethodCopy -> - "Copying" <> " '" <> prettyShow exe <> "' failed." - unless success $ die' verbosity errorMessage - --- | Install a specific exe. -installBuiltExe - :: Verbosity -> OverwritePolicy - -> FilePath -- ^ The directory where the built exe is located - -> FilePath -- ^ The exe's filename - -> FilePath -- ^ The exe's filename in the public install directory - -> FilePath -- ^ the directory where it should be installed - -> InstallMethod - -> IO Bool -- ^ Whether the installation was successful -installBuiltExe verbosity overwritePolicy - sourceDir exeName finalExeName - installdir InstallMethodSymlink = do - notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'" - symlinkBinary - overwritePolicy - installdir - sourceDir - finalExeName - exeName - where - destination = installdir finalExeName -installBuiltExe verbosity overwritePolicy - sourceDir exeName finalExeName - installdir InstallMethodCopy = do - notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'" - exists <- doesPathExist destination - case (exists, overwritePolicy) of - (True , NeverOverwrite ) -> pure False - (True , AlwaysOverwrite) -> remove >> copy - (False, _ ) -> copy - where - source = sourceDir exeName - destination = installdir finalExeName - remove = do - isDir <- doesDirectoryExist destination - if isDir - then removeDirectory destination - else removeFile destination - copy = copyFile source destination >> pure True - --- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. -entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] -entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] - where - hasLib :: (ComponentTarget, [TargetSelector]) -> Bool - hasLib (ComponentTarget (CLibName _) _, _) = True - hasLib _ = False - - go :: UnitId - -> [(ComponentTarget, [TargetSelector])] - -> [GhcEnvironmentFileEntry] - go unitId targets - | any hasLib targets = [GhcEnvFilePackageId unitId] - | otherwise = [] - - --- | Gets the file path to the request environment file. -getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath -getEnvFile clientInstallFlags platform compilerVersion = do - appDir <- getGhcAppDir - case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of - Just spec - -- Is spec a bare word without any "pathy" content, then it refers to - -- a named global environment. - | takeBaseName spec == spec -> - return (getGlobalEnv appDir platform compilerVersion spec) - | otherwise -> do - spec' <- makeAbsolute spec - isDir <- doesDirectoryExist spec' - if isDir - -- If spec is a directory, then make an ambient environment inside - -- that directory. - then return (getLocalEnv spec' platform compilerVersion) - -- Otherwise, treat it like a literal file path. - else return spec' - Nothing -> - return (getGlobalEnv appDir platform compilerVersion "default") - --- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the --- environment being operated on. -getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry] -getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do - envFileExists <- doesFileExist envFile - filterEnvEntries <$> if - (compilerFlavor == GHC || compilerFlavor == GHCJS) - && supportsPkgEnvFiles && envFileExists - then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) -> - warn verbosity ("The environment file " ++ envFile ++ - " is unparsable. Libraries cannot be installed.") >> return [] - else return [] - where - -- Why? We know what the first part will be, we only care about the packages. - filterEnvEntries = filter $ \case - GhcEnvFilePackageId _ -> True - _ -> False - --- | Constructs the path to the global GHC environment file. --- --- TODO(m-renaud): Create PkgEnvName newtype wrapper. -getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath -getGlobalEnv appDir platform compilerVersion name = - appDir ghcPlatformAndVersionString platform compilerVersion - "environments" name - --- | Constructs the path to a local GHC environment file. -getLocalEnv :: FilePath -> Platform -> Version -> FilePath -getLocalEnv dir platform compilerVersion = - dir - ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion - -getPackageDbStack - :: CompilerId - -> Flag FilePath - -> Flag FilePath - -> IO PackageDBStack -getPackageDbStack compilerId storeDirFlag logsDirFlag = do - cabalDir <- getCabalDir - mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag - let - mlogsDir = flagToMaybe logsDirFlag - cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId - --- | This defines what a 'TargetSelector' means for the @bench@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @build@ command select all components except non-buildable --- and disabled tests\/benchmarks, fail if there are no such --- components --- -selectPackageTargets - :: TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] -selectPackageTargets targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targets' = forgetTargetsDetail targets - targetsBuildable = selectBuildableTargetsWith - (buildable targetSelector) - targets - - -- When there's a target filter like "pkg:tests" then we do select tests, - -- but if it's just a target like "pkg" then we don't build tests unless - -- they are requested by default (i.e. by using --enable-tests) - buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False - buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False - buildable _ _ = True - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @build@ command we just need the basic checks on being buildable etc. --- -selectComponentTarget - :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k -selectComponentTarget = selectComponentTargetBasic - -reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a -reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems - -reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a -reportCannotPruneDependencies verbosity = - die' verbosity . renderCannotPruneDependencies diff --git a/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/Distribution/Client/CmdInstall/ClientInstallFlags.hs deleted file mode 100644 --- a/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -module Distribution.Client.CmdInstall.ClientInstallFlags -( InstallMethod(..) -, ClientInstallFlags(..) -, defaultClientInstallFlags -, clientInstallOptions -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.ReadE - ( succeedReadE, parsecToReadE ) -import Distribution.Simple.Command - ( ShowOrParseArgs(..), OptionField(..), option, reqArg ) -import Distribution.Simple.Setup - ( Flag(..), trueArg, flagToList, toFlag ) - -import Distribution.Client.Types.InstallMethod - ( InstallMethod (..) ) -import Distribution.Client.Types.OverwritePolicy - ( OverwritePolicy(..) ) - -import qualified Distribution.Compat.CharParsing as P - -data ClientInstallFlags = ClientInstallFlags - { cinstInstallLibs :: Flag Bool - , cinstEnvironmentPath :: Flag FilePath - , cinstOverwritePolicy :: Flag OverwritePolicy - , cinstInstallMethod :: Flag InstallMethod - , cinstInstalldir :: Flag FilePath - } deriving (Eq, Show, Generic) - -instance Monoid ClientInstallFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ClientInstallFlags where - (<>) = gmappend - -instance Binary ClientInstallFlags -instance Structured ClientInstallFlags - -defaultClientInstallFlags :: ClientInstallFlags -defaultClientInstallFlags = ClientInstallFlags - { cinstInstallLibs = toFlag False - , cinstEnvironmentPath = mempty - , cinstOverwritePolicy = mempty - , cinstInstallMethod = mempty - , cinstInstalldir = mempty - } - -clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags] -clientInstallOptions _ = - [ option [] ["lib"] - "Install libraries rather than executables from the target package." - cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v }) - trueArg - , option [] ["package-env", "env"] - "Set the environment file that may be modified." - cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf }) - (reqArg "ENV" (succeedReadE Flag) flagToList) - , option [] ["overwrite-policy"] - "How to handle already existing symlinks." - cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) - $ reqArg "always|never" - (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) - (map prettyShow . flagToList) - , option [] ["install-method"] - "How to install the executables." - cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v }) - $ reqArg - "default|copy|symlink" - (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod)) - (map prettyShow . flagToList) - , option [] ["installdir"] - "Where to install (by symlinking or copying) the executables in." - cinstInstalldir (\v flags -> flags { cinstInstalldir = v }) - $ reqArg "DIR" (succeedReadE Flag) flagToList - ] - -parsecInstallMethod :: CabalParsing m => m InstallMethod -parsecInstallMethod = do - name <- P.munch1 isAlpha - case name of - "copy" -> pure InstallMethodCopy - "symlink" -> pure InstallMethodSymlink - _ -> P.unexpected $ "InstallMethod: " ++ name diff --git a/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs deleted file mode 100644 --- a/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Distribution.Client.CmdInstall.ClientInstallTargetSelector ( - WithoutProjectTargetSelector (..), - parseWithoutProjectTargetSelector, - woPackageNames, - woPackageTargets, - woPackageSpecifiers, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Network.URI (URI, parseURI) - -import Distribution.Client.TargetSelector -import Distribution.Client.Types -import Distribution.Compat.CharParsing (char, optional) -import Distribution.Package -import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName)) -import Distribution.Simple.Utils (die') -import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) -import Distribution.Version - -data WithoutProjectTargetSelector - = WoPackageId PackageId - | WoPackageComponent PackageId ComponentName - | WoURI URI - deriving (Show) - -parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector -parseWithoutProjectTargetSelector verbosity input = - case explicitEitherParsec parser input of - Right ts -> return ts - Left err -> case parseURI input of - Just uri -> return (WoURI uri) - Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err - where - parser :: CabalParsing m => m WithoutProjectTargetSelector - parser = do - pid <- parsec - cn <- optional (char ':' *> parsec) - return $ case cn of - Nothing -> WoPackageId pid - Just cn' -> WoPackageComponent pid (CExeName cn') - -woPackageNames :: WithoutProjectTargetSelector -> [PackageName] -woPackageNames (WoPackageId pid) = [pkgName pid] -woPackageNames (WoPackageComponent pid _) = [pkgName pid] -woPackageNames (WoURI _) = [] - -woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector -woPackageTargets (WoPackageId pid) = - TargetPackageNamed (pkgName pid) Nothing -woPackageTargets (WoPackageComponent pid cn) = - TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent -woPackageTargets (WoURI _) = - TargetAllPackages (Just ExeKind) - -woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg) -woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid) -woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid) -woPackageSpecifiers (WoURI uri) = Left uri - -pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg -pidPackageSpecifiers pid - | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) [] - | otherwise = NamedPackage (pkgName pid) - [ PackagePropertyVersion (thisVersion (pkgVersion pid)) - ] diff --git a/Distribution/Client/CmdLegacy.hs b/Distribution/Client/CmdLegacy.hs deleted file mode 100644 --- a/Distribution/Client/CmdLegacy.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.Sandbox - ( loadConfigOrSandboxConfig, findSavedDistPref ) -import qualified Distribution.Client.Setup as Client -import Distribution.Client.SetupWrapper - ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions ) -import qualified Distribution.Simple.Setup as Setup -import Distribution.Simple.Command -import Distribution.Simple.Utils - ( wrapText ) -import Distribution.Verbosity - ( normal ) - -import Control.Exception - ( try ) -import qualified Data.Text as T - --- Tweaked versions of code from Main. -regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action) -regularCmd ui action = - CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand - -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ()) -wrapperCmd ui verbosity' distPref = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand - -wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ()) -wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) - - load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) - let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - - let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command } - - setupWrapper verbosity' setupScriptOptions Nothing - command' (const flags) (const extraArgs) - --- - -class HasVerbosity a where - verbosity :: a -> Verbosity - -instance HasVerbosity (Setup.Flag Verbosity) where - verbosity = Setup.fromFlagOrDefault normal - -instance (HasVerbosity a) => HasVerbosity (a, b) where - verbosity (a, _) = verbosity a - -instance (HasVerbosity a) => HasVerbosity (a, b, c) where - verbosity (a , _, _) = verbosity a - -instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where - verbosity (a, _, _, _) = verbosity a - -instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where - verbosity (a, _, _, _, _) = verbosity a - -instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where - verbosity (a, _, _, _, _, _) = verbosity a - -instance HasVerbosity Setup.BuildFlags where - verbosity = verbosity . Setup.buildVerbosity - -instance HasVerbosity Setup.ConfigFlags where - verbosity = verbosity . Setup.configVerbosity - -instance HasVerbosity Setup.ReplFlags where - verbosity = verbosity . Setup.replVerbosity - -instance HasVerbosity Client.FreezeFlags where - verbosity = verbosity . Client.freezeVerbosity - -instance HasVerbosity Setup.HaddockFlags where - verbosity = verbosity . Setup.haddockVerbosity - -instance HasVerbosity Client.ExecFlags where - verbosity = verbosity . Client.execVerbosity - -instance HasVerbosity Client.UpdateFlags where - verbosity = verbosity . Client.updateVerbosity - -instance HasVerbosity Setup.CleanFlags where - verbosity = verbosity . Setup.cleanVerbosity - -instance HasVerbosity Setup.DoctestFlags where - verbosity = verbosity . Setup.doctestVerbosity - --- - -legacyNote :: String -> String -legacyNote cmd = wrapText $ - "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ - - "It is a legacy feature and will be removed in a future release of cabal-install." ++ - " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++ - " commands.\n\n" ++ - - "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" - -toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] -toLegacyCmd mkSpec = [toLegacy mkSpec] - where - toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' - where - legUi = origUi - { commandName = "v1-" ++ commandName - , commandNotes = Just $ \pname -> case commandNotes of - Just notes -> notes pname ++ "\n" ++ legacyNote commandName - Nothing -> legacyNote commandName - } - -legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] -legacyCmd ui action = toLegacyCmd (regularCmd ui action) - -legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())] -legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref) - -newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] -newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi] - where - cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand - - newMsg = T.unpack . T.replace "v2-" "new-" . T.pack - newUi = origUi - { commandName = newMsg commandName - , commandUsage = newMsg . commandUsage - , commandDescription = (newMsg .) <$> commandDescription - , commandNotes = (newMsg .) <$> commandNotes - } - - defaultMsg = T.unpack . T.replace "v2-" "" . T.pack - defaultUi = origUi - { commandName = defaultMsg commandName - , commandUsage = defaultMsg . commandUsage - , commandDescription = (defaultMsg .) <$> commandDescription - , commandNotes = (defaultMsg .) <$> commandNotes - } diff --git a/Distribution/Client/CmdListBin.hs b/Distribution/Client/CmdListBin.hs deleted file mode 100644 --- a/Distribution/Client/CmdListBin.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -module Distribution.Client.CmdListBin ( - listbinCommand, - listbinAction, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.CmdErrorMessages - (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets, - renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs) -import Distribution.Client.DistDirLayout (DistDirLayout (..), ProjectRoot (..)) -import Distribution.Client.NixStyleOptions - (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions) -import Distribution.Client.ProjectConfig - (ProjectConfig, projectConfigConfigFile, projectConfigShared, withProjectOrGlobalConfig) -import Distribution.Client.ProjectFlags (ProjectFlags (..)) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.Setup (GlobalFlags (..)) -import Distribution.Client.TargetProblem (TargetProblem (..)) -import Distribution.Simple.BuildPaths (dllExtension, exeExtension) -import Distribution.Simple.Command (CommandUI (..)) -import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault) -import Distribution.Simple.Utils (die', ordNub, wrapText) -import Distribution.System (Platform) -import Distribution.Types.ComponentName (showComponentName) -import Distribution.Types.UnitId (UnitId) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Verbosity (silent, verboseStderr) -import System.Directory (getCurrentDirectory) -import System.FilePath ((<.>), ()) - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Distribution.Client.InstallPlan as IP -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Solver.Types.ComponentDeps as CD - -------------------------------------------------------------------------------- --- Command -------------------------------------------------------------------------------- - -listbinCommand :: CommandUI (NixStyleFlags ()) -listbinCommand = CommandUI - { commandName = "list-bin" - , commandSynopsis = "list path to a single executable." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n" - , commandDescription = Just $ \_ -> wrapText - "List path to a build product." - , commandNotes = Nothing - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - -------------------------------------------------------------------------------- --- Action -------------------------------------------------------------------------------- - -listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -listbinAction flags@NixStyleFlags{..} args globalFlags = do - -- fail early if multiple target selectors specified - target <- case args of - [] -> die' verbosity "One target is required, none provided" - [x] -> return x - _ -> die' verbosity "One target is required, given multiple" - - -- configure - (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject - let localPkgs = localPackages baseCtx - - -- elaborate target selectors - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing [target] - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - -- - -- Note that we discard the target and return the whole 'TargetsMap', - -- so this check will be repeated (and must succeed) after - -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. - _ <- singleComponentOrElse - (reportTargetProblems - verbosity - [multipleTargetsProblem targets]) - targets - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) - - (selectedUnitId, _selectedComponent) <- - -- Slight duplication with 'runProjectPreBuildPhase'. - singleComponentOrElse - (die' verbosity $ "No or multiple targets given, but the run " - ++ "phase has been reached. This is a bug.") - $ targetsMap buildCtx - - printPlan verbosity baseCtx buildCtx - - binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of - Nothing -> die' verbosity "No or multiple targets given..." - Just gpp -> return $ IP.foldPlanPackage - (const []) -- IPI don't have executables - (elaboratedPackage distDirLayout (elaboratedShared buildCtx)) - gpp - - case binfiles of - [exe] -> putStrLn exe - _ -> die' verbosity "No or multiple targets given" - where - defaultVerbosity = verboseStderr silent - verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) - ignoreProject = flagIgnoreProject projectFlags - prjConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) - - withProject :: IO (ProjectBaseContext, DistDirLayout) - withProject = do - baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand - return (baseCtx, distDirLayout baseCtx) - - withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) - withoutProject config = do - cwd <- getCurrentDirectory - baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand - return (baseCtx, distDirLayout baseCtx) - - -- this is copied from - elaboratedPackage - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> [FilePath] - elaboratedPackage distDirLayout elaboratedSharedConfig elab = case elabPkgOrComp elab of - ElabPackage pkg -> - [ bin - | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg) - (pkgExeDependencies pkg) - , bin <- bin_file c - ] - ElabComponent comp -> bin_file (compSolverName comp) - where - dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab) - - bin_file c = case c of - CD.ComponentExe s -> [bin_file' s] - CD.ComponentTest s -> [bin_file' s] - CD.ComponentBench s -> [bin_file' s] - CD.ComponentFLib s -> [flib_file' s] - _ -> [] - - plat :: Platform - plat = pkgConfigPlatform elaboratedSharedConfig - - -- here and in PlanOutput, - -- use binDirectoryFor? - bin_file' s = - if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat - else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat - - flib_file' s = - if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat - else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat - -------------------------------------------------------------------------------- --- Target Problem: the very similar to CmdRun -------------------------------------------------------------------------------- - -singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) -singleComponentOrElse action targetsMap = - case Set.toList . distinctTargetComponents $ targetsMap - of [(unitId, CExeName component)] -> return (unitId, component) - [(unitId, CTestName component)] -> return (unitId, component) - [(unitId, CBenchName component)] -> return (unitId, component) - [(unitId, CFLibName component)] -> return (unitId, component) - _ -> action - --- | This defines what a 'TargetSelector' means for the @list-bin@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @list-bin@ command we select the exe or flib if there is only one --- and it's buildable. Fail if there are no or multiple buildable exe components. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either ListBinTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there is exactly one buildable executable then we select that - | [target] <- targetsExesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExesBuildable') - - -- If there are executables but none are buildable then we report those - | not (null targetsExes) - = Left (TargetProblemNoneEnabled targetSelector targetsExes) - - -- If there are no executables but some other targets then we report that - | not (null targets) - = Left (noComponentsProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - -- Targets that can be executed - targetsExecutableLike = - concatMap (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] - (targetsExesBuildable, - targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike - - targetsExes = forgetTargetsDetail targetsExecutableLike - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @run@ command we just need to check it is a executable-like --- (an executable, a test, or a benchmark), in addition --- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either ListBinTargetProblem k -selectComponentTarget subtarget@WholeComponent t - = case availableTargetComponentName t - of CExeName _ -> component - CTestName _ -> component - CBenchName _ -> component - CFLibName _ -> component - _ -> Left (componentNotRightKindProblem pkgid cname) - where pkgid = availableTargetPackageId t - cname = availableTargetComponentName t - component = selectComponentTargetBasic subtarget t - -selectComponentTarget subtarget t - = Left (isSubComponentProblem (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @run@ command. --- -data ListBinProblem = - -- | The 'TargetSelector' matches targets but no executables - TargetProblemNoRightComps TargetSelector - - -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap - - -- | The 'TargetSelector' refers to a component that is not an executable - | TargetProblemComponentNotRightKind PackageId ComponentName - - -- | Asking to run an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget - deriving (Eq, Show) - -type ListBinTargetProblem = TargetProblem ListBinProblem - -noComponentsProblem :: TargetSelector -> ListBinTargetProblem -noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps - -matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem -matchesMultipleProblem selector targets = CustomTargetProblem $ - TargetProblemMatchesMultiple selector targets - -multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem -multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets - -componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem -componentNotRightKindProblem pkgid name = CustomTargetProblem $ - TargetProblemComponentNotRightKind pkgid name - -isSubComponentProblem - :: PackageId - -> ComponentName - -> SubComponentTarget - -> TargetProblem ListBinProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent - -reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderListBinTargetProblem - -renderListBinTargetProblem :: ListBinTargetProblem -> String -renderListBinTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= ExeKind - -> "The list-bin command is for finding binaries, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "list-bin" targetSelector -renderListBinTargetProblem problem = - renderTargetProblem "list-bin" renderListBinProblem problem - -renderListBinProblem :: ListBinProblem -> String -renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) = - "The list-bin command is for finding a single binary at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which includes " - ++ renderListCommaAnd ( ("the "++) <$> - showComponentName <$> - availableTargetComponentName <$> - foldMap - (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] ) - ++ "." - -renderListBinProblem (TargetProblemMultipleTargets selectorMap) = - "The list-bin command is for finding a single binary at once. The targets " - ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" - | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] - ++ " refer to different executables." - -renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) = - "The list-bin command is for finding binaries, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." - where - targetSelector = TargetComponent pkgid cname WholeComponent - -renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The list-bin command can only find a binary as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - where - targetSelector = TargetComponent pkgid cname subtarget - -renderListBinProblem (TargetProblemNoRightComps targetSelector) = - "Cannot list-bin the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any executables or foreign libraries." diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs deleted file mode 100644 --- a/Distribution/Client/CmdRepl.hs +++ /dev/null @@ -1,582 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: repl --- -module Distribution.Client.CmdRepl ( - -- * The @repl@ CLI and action - replCommand, - replAction, - - -- * Internals exposed for testing - matchesMultipleProblem, - selectPackageTargets, - selectComponentTarget - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Compat.Lens -import qualified Distribution.Types.Lens as L - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, - renderTargetProblem, - targetSelectorRefersToPkgs, - renderComponentKind, renderListCommaAnd, renderListSemiAnd, - componentKind, sortGroupOn, Plural(..) ) -import Distribution.Client.TargetProblem - ( TargetProblem(..) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.ProjectBuilding - ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), withProjectOrGlobalConfig - , projectConfigConfigFile ) -import Distribution.Client.ProjectFlags - ( flagIgnoreProject ) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning - ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) -import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import qualified Distribution.Client.Setup as Client -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, replOptions - , Flag(..), toFlag, falseArg ) -import Distribution.Simple.Command - ( CommandUI(..), liftOptionL, usageAlternatives, option - , ShowOrParseArgs, OptionField, reqArg ) -import Distribution.Compiler - ( CompilerFlavor(GHC) ) -import Distribution.Simple.Compiler - ( compilerCompatVersion ) -import Distribution.Package - ( Package(..), packageName, UnitId, installedUnitId ) -import Distribution.PackageDescription.PrettyPrint -import Distribution.Parsec - ( parsecCommaList ) -import Distribution.ReadE - ( ReadE, parsecToReadE ) -import qualified Distribution.SPDX.License as SPDX -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.Types.BuildInfo - ( BuildInfo(..), emptyBuildInfo ) -import Distribution.Types.ComponentName - ( componentNameString ) -import Distribution.Types.CondTree - ( CondTree(..), traverseCondTreeC ) -import Distribution.Types.Dependency - ( Dependency(..), mainLibSet ) -import Distribution.Types.GenericPackageDescription - ( emptyGenericPackageDescription ) -import Distribution.Types.PackageDescription - ( PackageDescription(..), emptyPackageDescription ) -import Distribution.Types.PackageName.Magic - ( fakePackageId ) -import Distribution.Types.Library - ( Library(..), emptyLibrary ) -import Distribution.Types.Version - ( mkVersion ) -import Distribution.Types.VersionRange - ( anyVersion ) -import Distribution.Utils.Generic - ( safeHead ) -import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Simple.Utils - ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist ) -import Language.Haskell.Extension - ( Language(..) ) -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..) ) - -import Data.List - ( (\\) ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import System.Directory - ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive ) -import System.FilePath - ( () ) - -type ReplFlags = [String] - -data EnvFlags = EnvFlags - { envPackages :: [Dependency] - , envIncludeTransitive :: Flag Bool - } - -defaultEnvFlags :: EnvFlags -defaultEnvFlags = EnvFlags - { envPackages = [] - , envIncludeTransitive = toFlag True - } - -envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] -envOptions _ = - [ option ['b'] ["build-depends"] - "Include additional packages in the environment presented to GHCi." - envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) - (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) - , option [] ["no-transitive-deps"] - "Don't automatically include transitive dependencies of requested packages." - envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) - falseArg - ] - where - dependenciesReadE :: ReadE [Dependency] - dependenciesReadE = - parsecToReadE - ("couldn't parse dependencies: " ++) - (parsecCommaList parsec) - -replCommand :: CommandUI (NixStyleFlags (ReplFlags, EnvFlags)) -replCommand = Client.installCommand { - commandName = "v2-repl", - commandSynopsis = "Open an interactive session for the given component.", - commandUsage = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Open an interactive session for a component within the project. The " - ++ "available targets are the same as for the 'v2-build' command: " - ++ "individual components within packages in the project, including " - ++ "libraries, executables, test-suites or benchmarks. Packages can " - ++ "also be specified in which case the library component in the " - ++ "package will be used, or the (first listed) executable in the " - ++ "package if there is no library.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples, open an interactive session:\n" - ++ " " ++ pname ++ " v2-repl\n" - ++ " for the default component in the package in the current directory\n" - ++ " " ++ pname ++ " v2-repl pkgname\n" - ++ " for the default component in the package named 'pkgname'\n" - ++ " " ++ pname ++ " v2-repl ./pkgfoo\n" - ++ " for the default component in the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " v2-repl cname\n" - ++ " for the component named 'cname'\n" - ++ " " ++ pname ++ " v2-repl pkgname:cname\n" - ++ " for the component 'cname' in the package 'pkgname'\n\n" - ++ " " ++ pname ++ " v2-repl --build-depends lens\n" - ++ " add the latest version of the library 'lens' to the default component " - ++ "(or no componentif there is no project present)\n" - ++ " " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" - ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " - ++ "to the default component (or no component if there is no project present)\n", - - commandDefaultFlags = defaultNixStyleFlags ([], defaultEnvFlags), - commandOptions = nixStyleOptions $ \showOrParseArgs -> - map (liftOptionL _1) (replOptions showOrParseArgs) ++ - map (liftOptionL _2) (envOptions showOrParseArgs) - } - --- | The @repl@ command is very much like @build@. It brings the install plan --- up to date, selects that part of the plan needed by the given or implicit --- repl target and then executes the plan. --- --- Compared to @build@ the difference is that only one target is allowed --- (given or implicit) and the target type is repl rather than build. The --- general plan execution infrastructure handles both build and repl targets. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO () -replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do - let - with = withProject cliConfig verbosity targetStrings - without config = withoutProject (config <> cliConfig) verbosity targetStrings - - (baseCtx, targetSelectors, finalizer, replType) <- - withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ "The repl command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'repl'." - - (originalComponent, baseCtx') <- if null (envPackages envFlags) - then return (Nothing, baseCtx) - else - -- Unfortunately, the best way to do this is to let the normal solver - -- help us resolve the targets, but that isn't ideal for performance, - -- especially in the no-project case. - withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do - -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets elaboratedPlan targetSelectors - - let - (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets - originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId - oci = OriginalComponentInfo unitId originalDeps - pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId - baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx - - return (Just oci, baseCtx') - - -- Now, we run the solver again with the added packages. While the graph - -- won't actually reflect the addition of transitive dependencies, - -- they're going to be available already and will be offered to the REPL - -- and that's good enough. - -- - -- In addition, to avoid a *third* trip through the solver, we are - -- replicating the second half of 'runProjectPreBuildPhase' by hand - -- here. - (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $ - \elaboratedPlan elaboratedShared' -> do - let ProjectBaseContext{..} = baseCtx' - - -- Recalculate with updated project. - targets <- validatedTargets elaboratedPlan targetSelectors - - let - elaboratedPlan' = pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags) - - pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared' - elaboratedPlan' - - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' - debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') - - let - buildCtx = ProjectBuildContext - { elaboratedPlanOriginal = elaboratedPlan - , elaboratedPlanToExecute = elaboratedPlan'' - , elaboratedShared = elaboratedShared' - , pkgsBuildStatus - , targetsMap = targets - } - - ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared' - - -- First version of GHC where GHCi supported the flag we need. - -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html - minGhciScriptVersion = mkVersion [7, 6] - - replFlags' = case originalComponent of - Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci - Nothing -> [] - replFlags'' = case replType of - GlobalRepl scriptPath - | Just version <- compilerCompatVersion GHC compiler - , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags' - _ -> replFlags' - - return (buildCtx, replFlags'') - - let buildCtx' = buildCtx - { elaboratedShared = (elaboratedShared buildCtx) - { pkgConfigReplOptions = replFlags ++ replFlags'' } - } - printPlan verbosity baseCtx' buildCtx' - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx' - runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes - finalizer - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - ignoreProject = flagIgnoreProject projectFlags - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - - validatedTargets elaboratedPlan targetSelectors = do - -- Interpret the targets on the command line as repl targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - when (Set.size (distinctTargetComponents targets) > 1) $ - reportTargetProblems verbosity - [multipleTargetsProblem targets] - - return targets - -data OriginalComponentInfo = OriginalComponentInfo - { ociUnitId :: UnitId - , ociOriginalDeps :: [UnitId] - } - deriving (Show) - --- | Tracks what type of GHCi instance we're creating. -data ReplType = ProjectRepl - | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi - -- script responsible for changing to the - -- correct directory. Only works on GHC geq - -- 7.6, though. 🙁 - deriving (Show, Eq) - -withProject :: ProjectConfig -> Verbosity -> [String] - -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) -withProject cliConfig verbosity targetStrings = do - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings - - return (baseCtx, targetSelectors, return (), ProjectRepl) - -withoutProject :: ProjectConfig -> Verbosity -> [String] - -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) -withoutProject config verbosity extraArgs = do - unless (null extraArgs) $ - die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs - - globalTmp <- getTemporaryDirectory - tempDir <- createTempDirectory globalTmp "cabal-repl." - - -- We need to create a dummy package that lives in our dummy project. - let - sourcePackage = SourcePackage - { srcpkgPackageId = pkgId - , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage tempDir - , srcpkgDescrOverride = Nothing - } - genericPackageDescription = emptyGenericPackageDescription - & L.packageDescription .~ packageDescription - & L.condLibrary .~ Just (CondNode library [baseDep] []) - packageDescription = emptyPackageDescription - { package = pkgId - , specVersion = CabalSpecV2_2 - , licenseRaw = Left SPDX.NONE - } - library = emptyLibrary { libBuildInfo = buildInfo } - buildInfo = emptyBuildInfo - { targetBuildDepends = [baseDep] - , defaultLanguage = Just Haskell2010 - } - baseDep = Dependency "base" anyVersion mainLibSet - pkgId = fakePackageId - - writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription - - let ghciScriptPath = tempDir "setcwd.ghci" - cwd <- getCurrentDirectory - writeFile ghciScriptPath (":cd " ++ cwd) - - distDirLayout <- establishDummyDistDirLayout verbosity config tempDir - baseCtx <- - establishDummyProjectBaseContext - verbosity - config - distDirLayout - [SpecificSourcePackage sourcePackage] - OtherCommand - - let - targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] - finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir) - - return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath) - -addDepsToProjectTarget :: [Dependency] - -> PackageId - -> ProjectBaseContext - -> ProjectBaseContext -addDepsToProjectTarget deps pkgId ctx = - (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx - where - addDeps :: PackageSpecifier UnresolvedSourcePackage - -> PackageSpecifier UnresolvedSourcePackage - addDeps (SpecificSourcePackage pkg) - | packageId pkg /= pkgId = SpecificSourcePackage pkg - | SourcePackage{..} <- pkg = - SpecificSourcePackage $ pkg { srcpkgDescription = - srcpkgDescription & (\f -> L.allCondTrees $ traverseCondTreeC f) - %~ (deps ++) - } - addDeps spec = spec - -generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags -generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags - where - exeDeps :: [UnitId] - exeDeps = - foldMap - (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies) - (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId]) - - deps, deps', trans, trans' :: [UnitId] - flags :: ReplFlags - deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId - deps' = deps \\ ociOriginalDeps - trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' - trans' = trans \\ ociOriginalDeps - flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) - $ if includeTransitive then trans' else deps' - --- | This defines what a 'TargetSelector' means for the @repl@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For repl we select: --- --- * the library if there is only one and it's buildable; or --- --- * the exe if there is only one and it's buildable; or --- --- * any other buildable component. --- --- Fail if there are no buildable lib\/exe components, or if there are --- multiple libs or exes. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either ReplTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there is exactly one buildable library then we select that - | [target] <- targetsLibsBuildable - = Right [target] - - -- but fail if there are multiple buildable libraries. - | not (null targetsLibsBuildable) - = Left (matchesMultipleProblem targetSelector targetsLibsBuildable') - - -- If there is exactly one buildable executable then we select that - | [target] <- targetsExesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExesBuildable') - - -- If there is exactly one other target then we select that - | [target] <- targetsBuildable - = Right [target] - - -- but fail if there are multiple such targets - | not (null targetsBuildable) - = Left (matchesMultipleProblem targetSelector targetsBuildable') - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targets' = forgetTargetsDetail targets - (targetsLibsBuildable, - targetsLibsBuildable') = selectBuildableTargets' - . filterTargetsKind LibKind - $ targets - (targetsExesBuildable, - targetsExesBuildable') = selectBuildableTargets' - . filterTargetsKind ExeKind - $ targets - (targetsBuildable, - targetsBuildable') = selectBuildableTargetsWith' - (isRequested targetSelector) targets - - -- When there's a target filter like "pkg:tests" then we do select tests, - -- but if it's just a target like "pkg" then we don't build tests unless - -- they are requested by default (i.e. by using --enable-tests) - isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False - isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False - isRequested _ _ = True - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @repl@ command we just need the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either ReplTargetProblem k -selectComponentTarget = selectComponentTargetBasic - - -data ReplProblem - = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap - deriving (Eq, Show) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. --- -type ReplTargetProblem = TargetProblem ReplProblem - -matchesMultipleProblem - :: TargetSelector - -> [AvailableTarget ()] - -> ReplTargetProblem -matchesMultipleProblem targetSelector targetsExesBuildable = - CustomTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable - -multipleTargetsProblem - :: TargetsMap - -> ReplTargetProblem -multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets - -reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderReplTargetProblem - -renderReplTargetProblem :: TargetProblem ReplProblem -> String -renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem - -renderReplProblem :: ReplProblem -> String -renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) = - "Cannot open a repl for multiple components at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which " - ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") - ++ renderListSemiAnd - [ "the " ++ renderComponentKind Plural ckind ++ " " ++ - renderListCommaAnd - [ maybe (prettyShow pkgname) prettyShow (componentNameString cname) - | t <- ts - , let cname = availableTargetComponentName t - pkgname = packageName (availableTargetPackageId t) - ] - | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets - ] - ++ ".\n\n" ++ explanationSingleComponentLimitation - where - availableTargetComponentKind = componentKind - . availableTargetComponentName - -renderReplProblem (TargetProblemMultipleTargets selectorMap) = - "Cannot open a repl for multiple components at once. The targets " - ++ renderListCommaAnd - [ "'" ++ showTargetSelector ts ++ "'" - | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] - ++ " refer to different components." - ++ ".\n\n" ++ explanationSingleComponentLimitation - -explanationSingleComponentLimitation :: String -explanationSingleComponentLimitation = - "The reason for this limitation is that current versions of ghci do not " - ++ "support loading multiple components as source. Load just one component " - ++ "and when you make changes to a dependent component then quit and reload." diff --git a/Distribution/Client/CmdRun.hs b/Distribution/Client/CmdRun.hs deleted file mode 100644 --- a/Distribution/Client/CmdRun.hs +++ /dev/null @@ -1,632 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: run --- -module Distribution.Client.CmdRun ( - -- * The @run@ CLI and action - runCommand, - runAction, - handleShebang, validScript, - - -- * Internals exposed for testing - matchesMultipleProblem, - noExesProblem, - selectPackageTargets, - selectComponentTarget - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (toList) - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, - renderTargetProblem, - renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter, renderListCommaAnd ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) -import Distribution.Client.GlobalFlags - ( defaultGlobalFlags ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Types.ComponentName - ( showComponentName ) -import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( wrapText, warn, die', ordNub, info - , createTempDirectory, handleDoesNotExist ) -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..) - , withProjectOrGlobalConfig ) -import Distribution.Client.ProjectFlags - ( flagIgnoreProject ) -import Distribution.Client.ProjectPlanning - ( ElaboratedConfiguredPackage(..) - , ElaboratedInstallPlan, binDirectoryFor ) -import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan ) -import Distribution.Client.TargetSelector - ( TargetSelectorProblem(..), TargetString(..) ) -import Distribution.Client.InstallPlan - ( toList, foldPlanPackage ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) -import Distribution.Simple.Program.Run - ( runProgramInvocation, ProgramInvocation(..), - emptyProgramInvocation ) -import Distribution.Types.UnitId - ( UnitId ) - -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..) ) -import Distribution.FieldGrammar - ( takeFields, parseFieldGrammar ) -import Distribution.PackageDescription.FieldGrammar - ( executableFieldGrammar ) -import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) -import Distribution.Parsec - ( Position(..) ) -import Distribution.Fields - ( ParseResult, parseString, parseFatalFailure, readFields ) -import qualified Distribution.SPDX.License as SPDX -import Distribution.Solver.Types.SourcePackage as SP - ( SourcePackage(..) ) -import Distribution.Types.BuildInfo - ( BuildInfo(..) ) -import Distribution.Types.CondTree - ( CondTree(..) ) -import Distribution.Types.Executable - ( Executable(..) ) -import Distribution.Types.GenericPackageDescription as GPD - ( GenericPackageDescription(..), emptyGenericPackageDescription ) -import Distribution.Types.PackageDescription - ( PackageDescription(..), emptyPackageDescription ) -import Distribution.Types.PackageName.Magic - ( fakePackageId ) -import Language.Haskell.Extension - ( Language(..) ) - -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Text.Parsec as P -import System.Directory - ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist ) -import System.FilePath - ( (), isValid, isPathSeparator, takeExtension ) - - -runCommand :: CommandUI (NixStyleFlags ()) -runCommand = CommandUI - { commandName = "v2-run" - , commandSynopsis = "Run an executable." - , commandUsage = usageAlternatives "v2-run" - [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ] - , commandDescription = Just $ \pname -> wrapText $ - "Runs the specified executable-like component (an executable, a test, " - ++ "or a benchmark), first ensuring it is up to date.\n\n" - - ++ "Any executable-like component in any package in the project can be " - ++ "specified. A package can be specified if contains just one " - ++ "executable-like. The default is to use the package in the current " - ++ "directory if it contains just one executable-like.\n\n" - - ++ "Extra arguments can be passed to the program, but use '--' to " - ++ "separate arguments for the program from arguments for " ++ pname - ++ ". The executable is run in an environment where it can find its " - ++ "data files inplace in the build tree.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-run\n" - ++ " Run the executable-like in the package in the current directory\n" - ++ " " ++ pname ++ " v2-run foo-tool\n" - ++ " Run the named executable-like (in any package in the project)\n" - ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" - ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" - ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" - ++ " Build with '-O2' and run the program, passing it extra arguments.\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - --- | The @run@ command runs a specified executable-like component, building it --- first if necessary. The component can be either an executable, a test, --- or a benchmark. This is particularly useful for passing arguments to --- exes/tests/benchs by simply appending them after a @--@. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -runAction flags@NixStyleFlags {..} targetStrings globalFlags = do - globalTmp <- getTemporaryDirectory - tmpDir <- createTempDirectory globalTmp "cabal-repl." - - let - with = - establishProjectBaseContext verbosity cliConfig OtherCommand - without config = do - distDirLayout <- establishDummyDistDirLayout verbosity (config <> cliConfig) tmpDir - establishDummyProjectBaseContext verbosity (config <> cliConfig) distDirLayout [] OtherCommand - - baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without - - let - scriptOrError script err = do - exists <- doesFileExist script - let pol | takeExtension script == ".lhs" = LiterateHaskell - | otherwise = PlainHaskell - if exists - then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tmpDir - else reportTargetSelectorProblems verbosity err - - (baseCtx', targetSelectors) <- - readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) - >>= \case - Left err@(TargetSelectorNoTargetsInProject:_) - | (script:_) <- targetStrings -> scriptOrError script err - Left err@(TargetSelectorNoSuch t _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err -> reportTargetSelectorProblems verbosity err - Right sels -> return (baseCtx, sels) - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx')) $ - die' verbosity $ - "The run command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'run'." - - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - -- - -- Note that we discard the target and return the whole 'TargetsMap', - -- so this check will be repeated (and must succeed) after - -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. - _ <- singleExeOrElse - (reportTargetProblems - verbosity - [multipleTargetsProblem targets]) - targets - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) - - (selectedUnitId, selectedComponent) <- - -- Slight duplication with 'runProjectPreBuildPhase'. - singleExeOrElse - (die' verbosity $ "No or multiple targets given, but the run " - ++ "phase has been reached. This is a bug.") - $ targetsMap buildCtx - - printPlan verbosity baseCtx' buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx - runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes - - - let elaboratedPlan = elaboratedPlanToExecute buildCtx - matchingElaboratedConfiguredPackages = - matchingPackagesByUnitId - selectedUnitId - elaboratedPlan - - let exeName = unUnqualComponentName selectedComponent - - -- In the common case, we expect @matchingElaboratedConfiguredPackages@ - -- to consist of a single element that provides a single way of building - -- an appropriately-named executable. In that case we take that - -- package and continue. - -- - -- However, multiple packages/components could provide that - -- executable, or it's possible we don't find the executable anywhere - -- in the build plan. I suppose in principle it's also possible that - -- a single package provides an executable in two different ways, - -- though that's probably a bug if. Anyway it's a good lint to report - -- an error in all of these cases, even if some seem like they - -- shouldn't happen. - pkg <- case matchingElaboratedConfiguredPackages of - [] -> die' verbosity $ "Unknown executable " - ++ exeName - ++ " in package " - ++ prettyShow selectedUnitId - [elabPkg] -> do - info verbosity $ "Selecting " - ++ prettyShow selectedUnitId - ++ " to supply " ++ exeName - return elabPkg - elabPkgs -> die' verbosity - $ "Multiple matching executables found matching " - ++ exeName - ++ ":\n" - ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - let exePath = binDirectoryFor (distDirLayout baseCtx) - (elaboratedShared buildCtx) - pkg - exeName - exeName - let args = drop 1 targetStrings - runProgramInvocation - verbosity - emptyProgramInvocation { - progInvokePath = exePath, - progInvokeArgs = args, - progInvokeEnv = dataDirsEnvironmentForPlan - (distDirLayout baseCtx) - elaboratedPlan - } - - handleDoesNotExist () (removeDirectoryRecursive tmpDir) - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - ignoreProject = flagIgnoreProject projectFlags - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - --- | Used by the main CLI parser as heuristic to decide whether @cabal@ was --- invoked as a script interpreter, i.e. via --- --- > #! /usr/bin/env cabal --- --- or --- --- > #! /usr/bin/cabal --- --- As the first argument passed to `cabal` will be a filepath to the --- script to be interpreted. --- --- See also 'handleShebang' -validScript :: String -> IO Bool -validScript script - | isValid script && any isPathSeparator script = doesFileExist script - | otherwise = return False - --- | Handle @cabal@ invoked as script interpreter, see also 'validScript' --- --- First argument is the 'FilePath' to the script to be executed; second --- argument is a list of arguments to be passed to the script. -handleShebang :: FilePath -> [String] -> IO () -handleShebang script args = - runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags - -parseScriptBlock :: BS.ByteString -> ParseResult Executable -parseScriptBlock str = - case readFields str of - Right fs -> do - let (fields, _) = takeFields fs - parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - -readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable -readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" - -readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString) -readScriptBlockFromScript verbosity pol str = do - str' <- case extractScriptBlock pol str of - Left e -> die' verbosity $ "Failed extracting script block: " ++ e - Right x -> return x - when (BS.all isSpace str') $ warn verbosity "Empty script block" - (\x -> (x, noShebang)) <$> readScriptBlock verbosity str' - where - noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str - --- | Extract the first encountered script metadata block started end --- terminated by the tokens --- --- * @{- cabal:@ --- --- * @-}@ --- --- appearing alone on lines (while tolerating trailing whitespace). --- These tokens are not part of the 'Right' result. --- --- In case of missing or unterminated blocks a 'Left'-error is --- returned. -extractScriptBlock :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString -extractScriptBlock _pol str = goPre (BS.lines str) - where - isStartMarker = (== startMarker) . stripTrailSpace - isEndMarker = (== endMarker) . stripTrailSpace - - stripTrailSpace = fst . BS.spanEnd isSpace - - -- before start marker - goPre ls = case dropWhile (not . isStartMarker) ls of - [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" - (_:ls') -> goBody [] ls' - - goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" - goBody acc (l:ls) - | isEndMarker l = Right $! BS.unlines $ reverse acc - | otherwise = goBody (l:acc) ls - - startMarker, endMarker :: BS.ByteString - startMarker = fromString "{- cabal:" - endMarker = fromString "-}" - -data PlainOrLiterate - = PlainHaskell - | LiterateHaskell - -handleScriptCase - :: Verbosity - -> PlainOrLiterate - -> ProjectBaseContext - -> FilePath - -> BS.ByteString - -> IO (ProjectBaseContext, [TargetSelector]) -handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do - (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents - - -- We need to create a dummy package that lives in our dummy project. - let - mainName = case pol of - PlainHaskell -> "Main.hs" - LiterateHaskell -> "Main.lhs" - - sourcePackage = SourcePackage - { srcpkgPackageId = pkgId - , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage tmpDir - , srcpkgDescrOverride = Nothing - } - genericPackageDescription = emptyGenericPackageDescription - { GPD.packageDescription = packageDescription - , condExecutables = [("script", CondNode executable' targetBuildDepends [])] - } - executable' = executable - { modulePath = mainName - , buildInfo = binfo - { defaultLanguage = - case defaultLanguage of - just@(Just _) -> just - Nothing -> Just Haskell2010 - } - } - binfo@BuildInfo{..} = buildInfo executable - packageDescription = emptyPackageDescription - { package = pkgId - , specVersion = CabalSpecV2_2 - , licenseRaw = Left SPDX.NONE - } - pkgId = fakePackageId - - writeGenericPackageDescription (tmpDir "fake-package.cabal") genericPackageDescription - BS.writeFile (tmpDir mainName) contents' - - let - baseCtx' = baseCtx - { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] } - targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] - - return (baseCtx', targetSelectors) - -singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) -singleExeOrElse action targetsMap = - case Set.toList . distinctTargetComponents $ targetsMap - of [(unitId, CExeName component)] -> return (unitId, component) - [(unitId, CTestName component)] -> return (unitId, component) - [(unitId, CBenchName component)] -> return (unitId, component) - _ -> action - --- | Filter the 'ElaboratedInstallPlan' keeping only the --- 'ElaboratedConfiguredPackage's that match the specified --- 'UnitId'. -matchingPackagesByUnitId :: UnitId - -> ElaboratedInstallPlan - -> [ElaboratedConfiguredPackage] -matchingPackagesByUnitId uid = - catMaybes - . fmap (foldPlanPackage - (const Nothing) - (\x -> if elabUnitId x == uid - then Just x - else Nothing)) - . toList - --- | This defines what a 'TargetSelector' means for the @run@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @run@ command we select the exe if there is only one and it's --- buildable. Fail if there are no or multiple buildable exe components. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either RunTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there is exactly one buildable executable then we select that - | [target] <- targetsExesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExesBuildable') - - -- If there are executables but none are buildable then we report those - | not (null targetsExes) - = Left (TargetProblemNoneEnabled targetSelector targetsExes) - - -- If there are no executables but some other targets then we report that - | not (null targets) - = Left (noExesProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - -- Targets that can be executed - targetsExecutableLike = - concatMap (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] - (targetsExesBuildable, - targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike - - targetsExes = forgetTargetsDetail targetsExecutableLike - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @run@ command we just need to check it is a executable-like --- (an executable, a test, or a benchmark), in addition --- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either RunTargetProblem k -selectComponentTarget subtarget@WholeComponent t - = case availableTargetComponentName t - of CExeName _ -> component - CTestName _ -> component - CBenchName _ -> component - _ -> Left (componentNotExeProblem pkgid cname) - where pkgid = availableTargetPackageId t - cname = availableTargetComponentName t - component = selectComponentTargetBasic subtarget t - -selectComponentTarget subtarget t - = Left (isSubComponentProblem (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @run@ command. --- -data RunProblem = - -- | The 'TargetSelector' matches targets but no executables - TargetProblemNoExes TargetSelector - - -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap - - -- | The 'TargetSelector' refers to a component that is not an executable - | TargetProblemComponentNotExe PackageId ComponentName - - -- | Asking to run an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget - deriving (Eq, Show) - -type RunTargetProblem = TargetProblem RunProblem - -noExesProblem :: TargetSelector -> RunTargetProblem -noExesProblem = CustomTargetProblem . TargetProblemNoExes - -matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem -matchesMultipleProblem selector targets = CustomTargetProblem $ - TargetProblemMatchesMultiple selector targets - -multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem -multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets - -componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem -componentNotExeProblem pkgid name = CustomTargetProblem $ - TargetProblemComponentNotExe pkgid name - -isSubComponentProblem - :: PackageId - -> ComponentName - -> SubComponentTarget - -> TargetProblem RunProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent - -reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a -reportTargetProblems verbosity = - die' verbosity . unlines . map renderRunTargetProblem - -renderRunTargetProblem :: RunTargetProblem -> String -renderRunTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= ExeKind - -> "The run command is for running executables, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "run" targetSelector -renderRunTargetProblem problem = - renderTargetProblem "run" renderRunProblem problem - -renderRunProblem :: RunProblem -> String -renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) = - "The run command is for running a single executable at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which includes " - ++ renderListCommaAnd ( ("the "++) <$> - showComponentName <$> - availableTargetComponentName <$> - foldMap - (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] ) - ++ "." - -renderRunProblem (TargetProblemMultipleTargets selectorMap) = - "The run command is for running a single executable at once. The targets " - ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" - | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] - ++ " refer to different executables." - -renderRunProblem (TargetProblemComponentNotExe pkgid cname) = - "The run command is for running executables, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." - where - targetSelector = TargetComponent pkgid cname WholeComponent - -renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The run command can only run an executable as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - where - targetSelector = TargetComponent pkgid cname subtarget - -renderRunProblem (TargetProblemNoExes targetSelector) = - "Cannot run the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any executables." diff --git a/Distribution/Client/CmdSdist.hs b/Distribution/Client/CmdSdist.hs deleted file mode 100644 --- a/Distribution/Client/CmdSdist.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -module Distribution.Client.CmdSdist - ( sdistCommand, sdistAction, packageToSdist - , OutputFormat(..)) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.CmdErrorMessages - ( Plural(..), renderComponentKind ) -import Distribution.Client.ProjectOrchestration - ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), defaultNixStyleFlags ) -import Distribution.Client.TargetSelector - ( TargetSelector(..), ComponentKind - , readTargetSelectors, reportTargetSelectorProblems ) -import Distribution.Client.Setup - ( GlobalFlags(..) ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.Client.Types - ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), ProjectRoot (..) ) -import Distribution.Client.ProjectConfig - ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared ) -import Distribution.Client.ProjectFlags - ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions ) - -import Distribution.Compat.Lens - ( _1, _2 ) -import Distribution.Package - ( Package(packageId) ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.ReadE - ( succeedReadE ) -import Distribution.Simple.Command - ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs ) -import Distribution.Simple.PreProcess - ( knownSuffixHandlers ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe - , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref - ) -import Distribution.Simple.SrcDist - ( listPackageSources ) -import Distribution.Client.SrcDist - ( packageDirToSdist ) -import Distribution.Simple.Utils - ( die', notice, withOutputMarker, wrapText ) -import Distribution.Types.ComponentName - ( ComponentName, showComponentName ) -import Distribution.Types.PackageName - ( PackageName, unPackageName ) -import Distribution.Verbosity - ( normal ) - -import qualified Data.ByteString.Lazy.Char8 as BSL -import System.Directory - ( getCurrentDirectory - , createDirectoryIfMissing, makeAbsolute - ) -import System.FilePath - ( (), (<.>), makeRelative, normalise ) - -------------------------------------------------------------------------------- --- Command -------------------------------------------------------------------------------- - -sdistCommand :: CommandUI (ProjectFlags, SdistFlags) -sdistCommand = CommandUI - { commandName = "v2-sdist" - , commandSynopsis = "Generate a source distribution file (.tar.gz)." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n" - , commandDescription = Just $ \_ -> wrapText - "Generates tarballs of project packages suitable for upload to Hackage." - , commandNotes = Nothing - , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags) - , commandOptions = \showOrParseArgs -> - map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) ++ - map (liftOptionL _2) (sdistOptions showOrParseArgs) - } - -------------------------------------------------------------------------------- --- Flags -------------------------------------------------------------------------------- - -data SdistFlags = SdistFlags - { sdistVerbosity :: Flag Verbosity - , sdistDistDir :: Flag FilePath - , sdistListSources :: Flag Bool - , sdistNulSeparated :: Flag Bool - , sdistOutputPath :: Flag FilePath - } - -defaultSdistFlags :: SdistFlags -defaultSdistFlags = SdistFlags - { sdistVerbosity = toFlag normal - , sdistDistDir = mempty - , sdistListSources = toFlag False - , sdistNulSeparated = toFlag False - , sdistOutputPath = mempty - } - -sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags] -sdistOptions showOrParseArgs = - [ optionVerbosity - sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) - , optionDistPref - sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) - showOrParseArgs - , option ['l'] ["list-only"] - "Just list the sources, do not make a tarball" - sdistListSources (\v flags -> flags { sdistListSources = v }) - trueArg - , option [] ["null-sep"] - "Separate the source files with NUL bytes rather than newlines." - sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) - trueArg - , option ['o'] ["output-directory", "outputdir"] - "Choose the output directory of this command. '-' sends all output to stdout" - sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) - (reqArg "PATH" (succeedReadE Flag) flagToList) - ] - -------------------------------------------------------------------------------- --- Action -------------------------------------------------------------------------------- - -sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO () -sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do - (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject - - let localPkgs = localPackages baseCtx - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing targetStrings - - -- elaborate path, create target directory - mOutputPath' <- case mOutputPath of - Just "-" -> return (Just "-") - Just path -> do - abspath <- makeAbsolute path - createDirectoryIfMissing True abspath - return (Just abspath) - Nothing -> do - createDirectoryIfMissing True (distSdistDirectory distDirLayout) - return Nothing - - let format :: OutputFormat - format = - if | listSources, nulSeparated -> SourceList '\0' - | listSources -> SourceList '\n' - | otherwise -> TarGzArchive - - ext = case format of - SourceList _ -> "list" - TarGzArchive -> "tar.gz" - - outputPath pkg = case mOutputPath' of - Just path - | path == "-" -> "-" - | otherwise -> path prettyShow (packageId pkg) <.> ext - Nothing - | listSources -> "-" - | otherwise -> distSdistFile distDirLayout (packageId pkg) - - - case reifyTargetSelectors localPkgs targetSelectors of - Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs - Right pkgs - | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> - die' verbosity "Can't write multiple tarballs to standard output!" - | otherwise -> - traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs - where - verbosity = fromFlagOrDefault normal sdistVerbosity - listSources = fromFlagOrDefault False sdistListSources - nulSeparated = fromFlagOrDefault False sdistNulSeparated - mOutputPath = flagToMaybe sdistOutputPath - ignoreProject = flagIgnoreProject - - prjConfig :: ProjectConfig - prjConfig = commandLineFlagsToProjectConfig - globalFlags - (defaultNixStyleFlags ()) - { configFlags = (configFlags $ defaultNixStyleFlags ()) - { configVerbosity = sdistVerbosity - , configDistPref = sdistDistDir - } - } - mempty - - globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) - - withProject :: IO (ProjectBaseContext, DistDirLayout) - withProject = do - baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand - return (baseCtx, distDirLayout baseCtx) - - withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) - withoutProject config = do - cwd <- getCurrentDirectory - baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand - return (baseCtx, distDirLayout baseCtx) - -data OutputFormat = SourceList Char - | TarGzArchive - deriving (Show, Eq) - -packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () -packageToSdist verbosity projectRootDir format outputFile pkg = do - let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg)) - dir0 <- case srcpkgSource pkg of - LocalUnpackedPackage path -> pure (Right path) - RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz) - RemoteSourceRepoPackage {} -> death - LocalTarballPackage tgz -> pure (Left tgz) - RemoteTarballPackage _ (Just tgz) -> pure (Left tgz) - RemoteTarballPackage {} -> death - RepoTarballPackage {} -> death - - let -- Write String to stdout or file, using the default TextEncoding. - write str - | outputFile == "-" = putStr (withOutputMarker verbosity str) - | otherwise = do - writeFile outputFile str - notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" - -- Write raw ByteString to stdout or file as it is, without encoding. - writeLBS lbs - | outputFile == "-" = BSL.putStr lbs - | otherwise = do - BSL.writeFile outputFile lbs - notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" - - case dir0 of - Left tgz -> do - case format of - TarGzArchive -> do - writeLBS =<< BSL.readFile tgz - _ -> die' verbosity ("cannot convert tarball package to " ++ show format) - - Right dir -> case format of - SourceList nulSep -> do - files' <- listPackageSources verbosity dir (flattenPackageDescription $ srcpkgDescription pkg) knownSuffixHandlers - let files = nub $ sort $ map normalise files' - let prefix = makeRelative projectRootDir dir - write $ concat [prefix i ++ [nulSep] | i <- files] - - TarGzArchive -> do - packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS - --- - -reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] -reifyTargetSelectors pkgs sels = - case partitionEithers (foldMap go sels) of - ([], sels') -> Right sels' - (errs, _) -> Left errs - where - flatten (SpecificSourcePackage pkg@SourcePackage{}) = pkg - flatten _ = error "The impossible happened: how do we not know about a local package?" - pkgs' = fmap flatten pkgs - - getPkg pid = case find ((== pid) . packageId) pkgs' of - Just pkg -> Right pkg - Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." - - go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] - go (TargetPackage _ pids Nothing) = fmap getPkg pids - go (TargetAllPackages Nothing) = Right <$> pkgs' - - go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] - go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] - - go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] - go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] - - go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] - -data TargetProblem = AllComponentsOnly ComponentKind - | NonlocalPackageNotAllowed PackageName - | ComponentsNotAllowed ComponentName - -renderTargetProblem :: TargetProblem -> String -renderTargetProblem (AllComponentsOnly kind) = - "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package " - ++ "for distribution. Only entire packages may be packaged for distribution." -renderTargetProblem (ComponentsNotAllowed cname) = - "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. " - ++ "Only entire packages may be packaged for distribution." -renderTargetProblem (NonlocalPackageNotAllowed pname) = - "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not " - ++ "local to this project." diff --git a/Distribution/Client/CmdTest.hs b/Distribution/Client/CmdTest.hs deleted file mode 100644 --- a/Distribution/Client/CmdTest.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | cabal-install CLI command: test --- -module Distribution.Client.CmdTest ( - -- * The @test@ CLI and action - testCommand, - testAction, - - -- * Internals exposed for testing - isSubComponentProblem, - notTestProblem, - noTestsProblem, - selectPackageTargets, - selectComponentTarget - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural, - renderTargetProblem, - renderTargetProblemNoTargets, targetSelectorPluralPkgs ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) -import Distribution.Simple.Setup - ( TestFlags(..), fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Simple.Flag - ( Flag(..) ) -import Distribution.Verbosity - ( normal ) -import Distribution.Simple.Utils - ( notice, wrapText, die' ) - -import qualified System.Exit (exitSuccess) - - -testCommand :: CommandUI (NixStyleFlags ()) -testCommand = CommandUI - { commandName = "v2-test" - , commandSynopsis = "Run test-suites" - , commandUsage = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ] - , commandDescription = Just $ \_ -> wrapText $ - "Runs the specified test-suites, first ensuring they are up to " - ++ "date.\n\n" - - ++ "Any test-suite in any package in the project can be specified. " - ++ "A package can be specified in which case all the test-suites in the " - ++ "package are run. The default is to run all the test-suites in the " - ++ "package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.\n\n" - - ++ "To pass command-line arguments to a test suite, see the " - ++ "v2-run command." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-test\n" - ++ " Run all the test-suites in the package in the current directory\n" - ++ " " ++ pname ++ " v2-test pkgname\n" - ++ " Run all the test-suites in the package named pkgname\n" - ++ " " ++ pname ++ " v2-test cname\n" - ++ " Run the test-suite named cname\n" - ++ " " ++ pname ++ " v2-test cname --enable-coverage\n" - ++ " Run the test-suite built with code coverage (including local libs used)\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - - - --- | The @test@ command is very much like @build@. It brings the install plan --- up to date, selects that part of the plan needed by the given or implicit --- test target(s) and then executes the plan. --- --- Compared to @build@ the difference is that there's also test targets --- which are ephemeral. --- --- For more details on how this works, see the module --- "Distribution.Client.ProjectOrchestration" --- -testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -testAction flags@NixStyleFlags {..} targetStrings globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ - "The test command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'test'." - - -- Interpret the targets on the command line as test targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionTest - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - where - failWhenNoTestSuites = testFailWhenNoTestSuites testFlags - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags - --- | This defines what a 'TargetSelector' means for the @test@ command. --- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, --- or otherwise classifies the problem. --- --- For the @test@ command we select all buildable test-suites, --- or fail if there are no test-suites or no buildable test-suites. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either TestTargetProblem [k] -selectPackageTargets targetSelector targets - - -- If there are any buildable test-suite targets then we select those - | not (null targetsTestsBuildable) - = Right targetsTestsBuildable - - -- If there are test-suites but none are buildable then we report those - | not (null targetsTests) - = Left (TargetProblemNoneEnabled targetSelector targetsTests) - - -- If there are no test-suite but some other targets then we report that - | not (null targets) - = Left (noTestsProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) - where - targetsTestsBuildable = selectBuildableTargets - . filterTargetsKind TestKind - $ targets - - targetsTests = forgetTargetsDetail - . filterTargetsKind TestKind - $ targets - - --- | For a 'TargetComponent' 'TargetSelector', check if the component can be --- selected. --- --- For the @test@ command we just need to check it is a test-suite, in addition --- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TestTargetProblem k -selectComponentTarget subtarget@WholeComponent t - | CTestName _ <- availableTargetComponentName t - = either Left return $ - selectComponentTargetBasic subtarget t - | otherwise - = Left (notTestProblem - (availableTargetPackageId t) - (availableTargetComponentName t)) - -selectComponentTarget subtarget t - = Left (isSubComponentProblem - (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) - --- | The various error conditions that can occur when matching a --- 'TargetSelector' against 'AvailableTarget's for the @test@ command. --- -data TestProblem = - -- | The 'TargetSelector' matches targets but no test-suites - TargetProblemNoTests TargetSelector - - -- | The 'TargetSelector' refers to a component that is not a test-suite - | TargetProblemComponentNotTest PackageId ComponentName - - -- | Asking to test an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget - deriving (Eq, Show) - - -type TestTargetProblem = TargetProblem TestProblem - - -noTestsProblem :: TargetSelector -> TargetProblem TestProblem -noTestsProblem = CustomTargetProblem . TargetProblemNoTests - -notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem -notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name - -isSubComponentProblem - :: PackageId - -> ComponentName - -> SubComponentTarget - -> TargetProblem TestProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent - -reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a -reportTargetProblems verbosity failWhenNoTestSuites problems = - case (failWhenNoTestSuites, problems) of - (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) -> - die' verbosity problemsMessage - (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do - notice verbosity (renderAllowedNoTestsProblem selector) - System.Exit.exitSuccess - (_, _) -> die' verbosity problemsMessage - where - problemsMessage = unlines . map renderTestTargetProblem $ problems - --- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't --- @die@ when the target problem is 'TargetProblemNoTests'. --- Instead, we display a notice saying that no tests have run and --- indicate how this behaviour was enabled. -renderAllowedNoTestsProblem :: TargetSelector -> String -renderAllowedNoTestsProblem selector = - "No tests to run for " ++ renderTargetSelector selector - -renderTestTargetProblem :: TestTargetProblem -> String -renderTestTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= TestKind - -> "The test command is for running test suites, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - ++ "\n" ++ show targetSelector - - _ -> renderTargetProblemNoTargets "test" targetSelector -renderTestTargetProblem problem = - renderTargetProblem "test" renderTestProblem problem - - -renderTestProblem :: TestProblem -> String -renderTestProblem (TargetProblemNoTests targetSelector) = - "Cannot run tests for the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any test suites." - -renderTestProblem (TargetProblemComponentNotTest pkgid cname) = - "The test command is for running test suites, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." - where - targetSelector = TargetComponent pkgid cname WholeComponent - -renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The test command can only run test suites as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - where - targetSelector = TargetComponent pkgid cname subtarget diff --git a/Distribution/Client/CmdUpdate.hs b/Distribution/Client/CmdUpdate.hs deleted file mode 100644 --- a/Distribution/Client/CmdUpdate.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - --- | cabal-install CLI command: update --- -module Distribution.Client.CmdUpdate ( - updateCommand, - updateAction, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Compat.Directory - ( setModificationTime ) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectConfig - ( ProjectConfig(..) - , ProjectConfigShared(projectConfigConfigFile) - , projectConfigWithSolverRepoContext - , withProjectOrGlobalConfig ) -import Distribution.Client.ProjectFlags - ( ProjectFlags (..) ) -import Distribution.Client.Types - ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName ) -import Distribution.Client.HttpUtils - ( DownloadResult(..) ) -import Distribution.Client.FetchUtils - ( downloadIndex ) -import Distribution.Client.JobControl - ( newParallelJobControl, spawnJob, collectJob ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) - , UpdateFlags, defaultUpdateFlags - , RepoContext(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Utils - ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) -import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Client.IndexUtils.Timestamp -import Distribution.Client.IndexUtils.IndexState -import Distribution.Client.IndexUtils - ( updateRepoIndexCache, Index(..), writeIndexTimestamp - , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile ) - -import qualified Data.Maybe as Unsafe (fromJust) -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import qualified Data.ByteString.Lazy as BS -import Distribution.Client.GZipUtils (maybeDecompress) -import System.FilePath ((<.>), dropExtension) -import Data.Time (getCurrentTime) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) - -import qualified Hackage.Security.Client as Sec - -updateCommand :: CommandUI (NixStyleFlags ()) -updateCommand = CommandUI - { commandName = "v2-update" - , commandSynopsis = "Updates list of known packages." - , commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ] - , commandDescription = Just $ \_ -> wrapText $ - "For all known remote repositories, download the package list." - - , commandNotes = Just $ \pname -> - "REPO has the format [,] where index-state follows\n" - ++ "the same format and syntax that is supported by the --index-state flag.\n\n" - ++ "Examples:\n" - ++ " " ++ pname ++ " v2-update\n" - ++ " Download the package list for all known remote repositories.\n\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org\n" - ++ " Download hackage.haskell.org at a specific index state.\n\n" - ++ " " ++ pname ++ " new update hackage.haskell.org head.hackage\n" - ++ " Download hackage.haskell.org and head.hackage\n" - ++ " head.hackage must be a known repo-id. E.g. from\n" - ++ " your cabal.project(.local) file.\n" - - , commandOptions = nixStyleOptions $ const [] - , commandDefaultFlags = defaultNixStyleFlags () - } - -data UpdateRequest = UpdateRequest - { _updateRequestRepoName :: RepoName - , _updateRequestRepoState :: RepoIndexState - } deriving (Show) - -instance Pretty UpdateRequest where - pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s - -instance Parsec UpdateRequest where - parsec = do - name <- parsec - state <- P.char ',' *> parsec <|> pure IndexStateHead - return (UpdateRequest name state) - -updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do - let ignoreProject = flagIgnoreProject projectFlags - - projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag - (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) - (\globalConfig -> return $ globalConfig <> cliConfig) - - projectConfigWithSolverRepoContext verbosity - (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) - $ \repoCtxt -> do - - let repos :: [Repo] - repos = repoContextRepos repoCtxt - - parseArg :: String -> IO UpdateRequest - parseArg s = case simpleParsec s of - Just r -> return r - Nothing -> die' verbosity $ - "'v2-update' unable to parse repo: \"" ++ s ++ "\"" - - updateRepoRequests <- traverse parseArg extraArgs - - unless (null updateRepoRequests) $ do - let remoteRepoNames = map repoName repos - unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests - , not (r `elem` remoteRepoNames)] - unless (null unknownRepos) $ - die' verbosity $ "'v2-update' repo(s): \"" - ++ intercalate "\", \"" (map unRepoName unknownRepos) - ++ "\" can not be found in known remote repo(s): " - ++ intercalate ", " (map unRepoName remoteRepoNames) - - let reposToUpdate :: [(Repo, RepoIndexState)] - reposToUpdate = case updateRepoRequests of - -- If we are not given any specific repository, update all - -- repositories to HEAD. - [] -> map (,IndexStateHead) repos - updateRequests -> let repoMap = [(repoName r, r) | r <- repos] - lookup' k = Unsafe.fromJust (lookup k repoMap) - in [ (lookup' name, state) - | (UpdateRequest name state) <- updateRequests ] - - case reposToUpdate of - [] -> - notice verbosity "No remote repositories configured" - [(remoteRepo, _)] -> - notice verbosity $ "Downloading the latest package list from " - ++ unRepoName (repoName remoteRepo) - _ -> notice verbosity . unlines - $ "Downloading the latest package lists from: " - : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate - - unless (null reposToUpdate) $ do - jobCtrl <- newParallelJobControl (length reposToUpdate) - traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) - reposToUpdate - traverse_ (\_ -> collectJob jobCtrl) reposToUpdate - - where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - -updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState) - -> IO () -updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do - transport <- repoContextGetTransport repoCtxt - case repo of - RepoLocalNoIndex{} -> do - let index = RepoIndex repoCtxt repo - updatePackageIndexCacheFile verbosity index - - RepoRemote{..} -> do - downloadResult <- downloadIndex transport verbosity - repoRemote repoLocalDir - case downloadResult of - FileAlreadyInCache -> - setModificationTime (indexBaseName repo <.> "tar") - =<< getCurrentTime - FileDownloaded indexPath -> do - writeFileAtomic (dropExtension indexPath) . maybeDecompress - =<< BS.readFile indexPath - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) - RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do - let index = RepoIndex repoCtxt repo - -- NB: This may be a nullTimestamp if we've never updated before - current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo - -- NB: always update the timestamp, even if we didn't actually - -- download anything - writeIndexTimestamp index indexState - ce <- if repoContextIgnoreExpiry repoCtxt - then Just `fmap` getCurrentTime - else return Nothing - updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce - - let rname = remoteRepoName (repoRemote repo) - - -- Update cabal's internal index as well so that it's not out of sync - -- (If all access to the cache goes through hackage-security this can go) - case updated of - Sec.NoUpdates -> do - now <- getCurrentTime - setModificationTime (indexBaseName repo <.> "tar") now - noticeNoWrap verbosity $ - "Package list of " ++ prettyShow rname ++ - " is up to date at index-state " ++ prettyShow (IndexStateTime current_ts) - - Sec.HasUpdates -> do - updateRepoIndexCache verbosity index - new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo - noticeNoWrap verbosity $ - "Updated package list of " ++ prettyShow rname ++ - " to the index-state " ++ prettyShow (IndexStateTime new_ts) - - -- TODO: This will print multiple times if there are multiple - -- repositories: main problem is we don't have a way of updating - -- a specific repo. Once we implement that, update this. - when (current_ts /= nullTimestamp) $ - noticeNoWrap verbosity $ - "To revert to previous state run:\n" ++ - " cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n" diff --git a/Distribution/Client/Compat/Directory.hs b/Distribution/Client/Compat/Directory.hs deleted file mode 100644 --- a/Distribution/Client/Compat/Directory.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Client.Compat.Directory ( - setModificationTime, - createFileLink, - pathIsSymbolicLink, - getSymbolicLinkTarget, - ) where - -#if MIN_VERSION_directory(1,2,3) -import System.Directory (setModificationTime) -#else -import Data.Time.Clock (UTCTime) -#endif - -#if MIN_VERSION_directory(1,3,1) -import System.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink) -#elif defined(MIN_VERSION_unix) -import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink) -#endif - -------------------------------------------------------------------------------- --- setModificationTime -------------------------------------------------------------------------------- - -#if !MIN_VERSION_directory(1,2,3) - -setModificationTime :: FilePath -> UTCTime -> IO () -setModificationTime _fp _t = return () - -#endif - -------------------------------------------------------------------------------- --- Symlink -------------------------------------------------------------------------------- - -#if MIN_VERSION_directory(1,3,1) -#elif defined(MIN_VERSION_unix) -createFileLink :: FilePath -> FilePath -> IO () -createFileLink = createSymbolicLink - -pathIsSymbolicLink :: FilePath -> IO Bool -pathIsSymbolicLink fp = do - status <- getSymbolicLinkStatus fp - return (isSymbolicLink status) - -getSymbolicLinkTarget :: FilePath -> IO FilePath -getSymbolicLinkTarget = readSymbolicLink - -#else -createFileLink :: FilePath -> FilePath -> IO () -createFileLink _ _ = fail "Symlinking feature not available" - -pathIsSymbolicLink :: FilePath -> IO Bool -pathIsSymbolicLink _ = fail "Symlinking feature not available" - -getSymbolicLinkTarget :: FilePath -> IO FilePath -getSymbolicLinkTarget _ = fail "Symlinking feature not available" -#endif diff --git a/Distribution/Client/Compat/ExecutablePath.hs b/Distribution/Client/Compat/ExecutablePath.hs deleted file mode 100644 --- a/Distribution/Client/Compat/ExecutablePath.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE CPP #-} - --- Copied verbatim from base-4.6.0.0. We can't simply import --- System.Environment.getExecutablePath because we need compatibility with older --- GHCs. - -module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where - -import Prelude - --- The imports are purposely kept completely disjoint to prevent edits --- to one OS implementation from breaking another. - -#if defined(darwin_HOST_OS) -import Data.Word -import Foreign.C -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -import System.Posix.Internals -#elif defined(linux_HOST_OS) -import Foreign.C -import Foreign.Marshal.Array -import System.Posix.Internals -#elif defined(mingw32_HOST_OS) -import Data.Word -import Foreign.C -import Foreign.Marshal.Array -import Foreign.Ptr -import System.Posix.Internals -#else -import Foreign.C -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -import System.Posix.Internals -#endif - --- The exported function is defined outside any if-guard to make sure --- every OS implements it with the same type. - --- | Returns the absolute pathname of the current executable. --- --- Note that for scripts and interactive sessions, this is the path to --- the interpreter (e.g. ghci.) --- --- /Since: 4.6.0.0/ -getExecutablePath :: IO FilePath - --------------------------------------------------------------------------------- --- Mac OS X - -#if defined(darwin_HOST_OS) - -type UInt32 = Word32 - -foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath" - c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt - --- | Returns the path of the main executable. The path may be a --- symbolic link and not the real file. --- --- See dyld(3) -_NSGetExecutablePath :: IO FilePath -_NSGetExecutablePath = - allocaBytes 1024 $ \ buf -> -- PATH_MAX is 1024 on OS X - alloca $ \ bufsize -> do - poke bufsize 1024 - status <- c__NSGetExecutablePath buf bufsize - if status == 0 - then peekFilePath buf - else do reqBufsize <- fromIntegral `fmap` peek bufsize - allocaBytes reqBufsize $ \ newBuf -> do - status2 <- c__NSGetExecutablePath newBuf bufsize - if status2 == 0 - then peekFilePath newBuf - else error "_NSGetExecutablePath: buffer too small" - -foreign import ccall unsafe "stdlib.h realpath" - c_realpath :: CString -> CString -> IO CString - --- | Resolves all symbolic links, extra \/ characters, and references --- to \/.\/ and \/..\/. Returns an absolute pathname. --- --- See realpath(3) -realpath :: FilePath -> IO FilePath -realpath path = - withFilePath path $ \ fileName -> - allocaBytes 1024 $ \ resolvedName -> do - _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName - peekFilePath resolvedName - -getExecutablePath = _NSGetExecutablePath >>= realpath - --------------------------------------------------------------------------------- --- Linux - -#elif defined(linux_HOST_OS) - -foreign import ccall unsafe "readlink" - c_readlink :: CString -> CString -> CSize -> IO CInt - --- | Reads the @FilePath@ pointed to by the symbolic link and returns --- it. --- --- See readlink(2) -readSymbolicLink :: FilePath -> IO FilePath -readSymbolicLink file = - allocaArray0 4096 $ \buf -> do - withFilePath file $ \s -> do - len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ - c_readlink s buf 4096 - peekFilePathLen (buf,fromIntegral len) - -getExecutablePath = readSymbolicLink $ "/proc/self/exe" - --------------------------------------------------------------------------------- --- Windows - -#elif defined(mingw32_HOST_OS) - -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif - -foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 - -getExecutablePath = go 2048 -- plenty, PATH_MAX is 512 under Win32 - where - go size = allocaArray (fromIntegral size) $ \ buf -> do - ret <- c_GetModuleFileName nullPtr buf size - case ret of - 0 -> error "getExecutablePath: GetModuleFileNameW returned an error" - _ | ret < size -> peekFilePath buf - | otherwise -> go (size * 2) - --------------------------------------------------------------------------------- --- Fallback to argv[0] - -#else - -foreign import ccall unsafe "getFullProgArgv" - c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () - -getExecutablePath = - alloca $ \ p_argc -> - alloca $ \ p_argv -> do - c_getFullProgArgv p_argc p_argv - argc <- peek p_argc - if argc > 0 - -- If argc > 0 then argv[0] is guaranteed by the standard - -- to be a pointer to a null-terminated string. - then peek p_argv >>= peek >>= peekFilePath - else error $ "getExecutablePath: " ++ msg - where msg = "no OS specific implementation and program name couldn't be " ++ - "found in argv" - --------------------------------------------------------------------------------- - -#endif diff --git a/Distribution/Client/Compat/FilePerms.hs b/Distribution/Client/Compat/FilePerms.hs deleted file mode 100644 --- a/Distribution/Client/Compat/FilePerms.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK hide #-} -module Distribution.Client.Compat.FilePerms ( - setFileOrdinary, - setFileExecutable, - setFileHidden, - ) where - -import Prelude (FilePath, IO, return, ($)) - -#ifndef mingw32_HOST_OS -import System.Posix.Types - ( FileMode ) -import System.Posix.Internals - ( c_chmod ) -import Foreign.C - ( withCString - , throwErrnoPathIfMinus1_ ) -#else -import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN) -#endif /* mingw32_HOST_OS */ - -setFileHidden, setFileOrdinary, setFileExecutable :: FilePath -> IO () -#ifndef mingw32_HOST_OS -setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- -setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x -setFileHidden _ = return () - -setFileMode :: FilePath -> FileMode -> IO () -setFileMode name m = - withCString name $ \s -> - throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) -#else -setFileOrdinary _ = return () -setFileExecutable _ = return () -setFileHidden path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN -#endif diff --git a/Distribution/Client/Compat/Orphans.hs b/Distribution/Client/Compat/Orphans.hs deleted file mode 100644 --- a/Distribution/Client/Compat/Orphans.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Distribution.Client.Compat.Orphans () where - -import Control.Exception (SomeException) -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Compat.Typeable (typeRep) -import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) -import Network.URI (URI (..), URIAuth (..)) -import Prelude (error, return) - -------------------------------------------------------------------------------- --- network-uri -------------------------------------------------------------------------------- - --- note, network-uri-2.6.0.3+ provide a Generic instance but earlier --- versions do not, so we use manual Binary instances here -instance Binary URI where - put (URI a b c d e) = do put a; put b; put c; put d; put e - get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get - return (URI a b c d e) - -instance Structured URI where - structure p = Nominal (typeRep p) 0 "URI" [] - -instance Binary URIAuth where - put (URIAuth a b c) = do put a; put b; put c - get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) - -------------------------------------------------------------------------------- --- base -------------------------------------------------------------------------------- - ---FIXME: Duncan Coutts: this is a total cheat ---Added in 46aa019ec85e313e257d122a3549cce01996c566 -instance Binary SomeException where - put _ = return () - get = error "cannot serialise exceptions" - -instance Structured SomeException where - structure p = Nominal (typeRep p) 0 "SomeException" [] diff --git a/Distribution/Client/Compat/Prelude.hs b/Distribution/Client/Compat/Prelude.hs deleted file mode 100644 --- a/Distribution/Client/Compat/Prelude.hs +++ /dev/null @@ -1,24 +0,0 @@ --- to suppress WARNING in "Distribution.Compat.Prelude.Internal" -{-# OPTIONS_GHC -fno-warn-deprecations #-} - --- | This module does two things: --- --- * Acts as a compatibility layer, like @base-compat@. --- --- * Provides commonly used imports. --- --- This module is a superset of "Distribution.Compat.Prelude" (which --- this module re-exports) --- -module Distribution.Client.Compat.Prelude - ( module Distribution.Compat.Prelude.Internal - , module X - ) where - -import Distribution.Client.Compat.Orphans () -import Distribution.Compat.Prelude.Internal -import Prelude () - -import Distribution.Parsec as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec) -import Distribution.Pretty as X (Pretty (..), prettyShow) -import Distribution.Verbosity as X (Verbosity) diff --git a/Distribution/Client/Compat/Process.hs b/Distribution/Client/Compat/Process.hs deleted file mode 100644 --- a/Distribution/Client/Compat/Process.hs +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Compat.Process --- Copyright : (c) 2013 Liu Hao, Brent Yorgey --- License : BSD-style (see the file LICENSE) --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Cross-platform utilities for invoking processes. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Compat.Process ( - readProcessWithExitCode -) where - -import Prelude (FilePath, IO, String, return, (||)) - -import Control.Exception (catch, throw) -import System.Exit (ExitCode (ExitFailure)) -import System.IO.Error (isDoesNotExistError, isPermissionError) -import qualified System.Process as P - --- | @readProcessWithExitCode@ creates an external process, reads its --- standard output and standard error strictly, waits until the --- process terminates, and then returns the @ExitCode@ of the --- process, the standard output, and the standard error. --- --- See the documentation of the version from @System.Process@ for --- more information. --- --- The version from @System.Process@ behaves inconsistently across --- platforms when an executable with the given name is not found: in --- some cases it returns an @ExitFailure@, in others it throws an --- exception. This variant catches \"does not exist\" and --- \"permission denied\" exceptions and turns them into --- @ExitFailure@s. --- --- TODO: this doesn't use 'Distrubution.Compat.Process'. --- -readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) -readProcessWithExitCode cmd args input = - P.readProcessWithExitCode cmd args input - `catch` \e -> if isDoesNotExistError e || isPermissionError e - then return (ExitFailure 127, "", "") - else throw e diff --git a/Distribution/Client/Compat/Semaphore.hs b/Distribution/Client/Compat/Semaphore.hs deleted file mode 100644 --- a/Distribution/Client/Compat/Semaphore.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -module Distribution.Client.Compat.Semaphore - ( QSem - , newQSem - , waitQSem - , signalQSem - ) where - -import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip) - -import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, - writeTVar) -import Control.Exception (mask_, onException) -import Control.Monad (join, unless) -import Data.Typeable (Typeable) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE - --- | 'QSem' is a quantity semaphore in which the resource is aqcuired --- and released in units of one. It provides guaranteed FIFO ordering --- for satisfying blocked `waitQSem` calls. --- -data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool]) - deriving (Eq, Typeable) - -newQSem :: Int -> IO QSem -newQSem i = atomically $ do - q <- newTVar i - b1 <- newTVar [] - b2 <- newTVar [] - return (QSem q b1 b2) - -waitQSem :: QSem -> IO () -waitQSem s@(QSem q _b1 b2) = - mask_ $ join $ atomically $ do - -- join, because if we need to block, we have to add a TVar to - -- the block queue. - -- mask_, because we need a chance to set up an exception handler - -- after the join returns. - v <- readTVar q - if v == 0 - then do b <- newTVar False - ys <- readTVar b2 - writeTVar b2 (b:ys) - return (wait b) - else do writeTVar q $! v - 1 - return (return ()) - where - -- - -- very careful here: if we receive an exception, then we need to - -- (a) write True into the TVar, so that another signalQSem doesn't - -- try to wake up this thread, and - -- (b) if the TVar is *already* True, then we need to do another - -- signalQSem to avoid losing a unit of the resource. - -- - -- The 'wake' function does both (a) and (b), so we can just call - -- it here. - -- - wait t = - flip onException (wake s t) $ - atomically $ do - b <- readTVar t - unless b retry - - -wake :: QSem -> TVar Bool -> IO () -wake s x = join $ atomically $ do - b <- readTVar x - if b then return (signalQSem s) - else do writeTVar x True - return (return ()) - -{- - property we want: - - bracket waitQSem (\_ -> signalQSem) (\_ -> ...) - - never loses a unit of the resource. --} - -signalQSem :: QSem -> IO () -signalQSem s@(QSem q b1 b2) = - mask_ $ join $ atomically $ do - -- join, so we don't force the reverse inside the txn - -- mask_ is needed so we don't lose a wakeup - v <- readTVar q - if v /= 0 - then do writeTVar q $! v + 1 - return (return ()) - else do xs <- readTVar b1 - checkwake1 xs - where - checkwake1 [] = do - ys <- readTVar b2 - checkwake2 ys - checkwake1 (x:xs) = do - writeTVar b1 xs - return (wake s x) - - checkwake2 [] = do - writeTVar q 1 - return (return ()) - checkwake2 (y:ys) = do - let (z:|zs) = NE.reverse (y:|ys) - writeTVar b1 zs - writeTVar b2 [] - return (wake s z) diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs deleted file mode 100644 --- a/Distribution/Client/Config.hs +++ /dev/null @@ -1,1477 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Config --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- Utilities for handling saved state such as known packages, known servers and --- downloaded packages. ------------------------------------------------------------------------------ -module Distribution.Client.Config ( - SavedConfig(..), - loadConfig, - getConfigFilePath, - - showConfig, - showConfigWithComments, - parseConfig, - - getCabalDir, - defaultConfigFile, - defaultCacheDir, - defaultCompiler, - defaultInstallPath, - defaultLogsDir, - defaultUserInstall, - - baseSavedConfig, - commentSavedConfig, - initialSavedConfig, - configFieldDescriptions, - haddockFlagsFields, - installDirsFields, - withProgramsFields, - withProgramOptionsFields, - userConfigDiff, - userConfigUpdate, - createDefaultConfigFile, - - remoteRepoFields, - postProcessRepo, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Language.Haskell.Extension ( Language(Haskell2010) ) - -import Distribution.Deprecated.ViewAsFieldDescr - ( viewAsFieldDescr ) - -import Distribution.Client.Types - ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo - , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps - , RepoName (..), unRepoName - ) -import Distribution.Client.Types.Credentials (Username (..), Password (..)) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import qualified Distribution.Client.Init.Types as IT - ( InitFlags(..) ) -import qualified Distribution.Client.Init.Defaults as IT -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand, defaultGlobalFlags - , ConfigExFlags(..), configureExOptions, defaultConfigExFlags - , initOptions - , InstallFlags(..), installOptions, defaultInstallFlags - , UploadFlags(..), uploadCommand - , ReportFlags(..), reportCommand ) -import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..), defaultClientInstallFlags - , clientInstallOptions ) -import Distribution.Utils.NubList - ( NubList, fromNubList, toNubList, overNubList ) - -import Distribution.Simple.Compiler - ( DebugInfoLevel(..), OptimisationLevel(..) ) -import Distribution.Simple.Setup - ( ConfigFlags(..), configureOptions, defaultConfigFlags - , HaddockFlags(..), haddockOptions, defaultHaddockFlags - , TestFlags(..), defaultTestFlags - , BenchmarkFlags(..), defaultBenchmarkFlags - , installDirsOptions, optionDistPref - , programDbPaths', programDbOptions - , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), defaultInstallDirs - , PathTemplate, toPathTemplate ) -import Distribution.Deprecated.ParseUtils - ( FieldDescr(..), liftField, runP - , ParseResult(..), PError(..), PWarning(..) - , locatedErrorMsg, showPWarning - , readFields, warning, lineNo - , simpleField, listField, spaceListField - , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError - , simpleFieldParsec, listFieldParsec - ) -import Distribution.Client.ParseUtils - ( parseFields, ppFields, ppSection ) -import Distribution.Client.HttpUtils - ( isOldHackageURI ) -import qualified Distribution.Deprecated.ParseUtils as ParseUtils - ( Field(..) ) -import Distribution.Simple.Command - ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) ) -import Distribution.Simple.Program - ( defaultProgramDb ) -import Distribution.Simple.Utils - ( die', notice, warn, lowercase, cabalVersion ) -import Distribution.Client.Utils - ( cabalInstallVersion ) -import Distribution.Compiler - ( CompilerFlavor(..), defaultCompilerFlavor ) -import Distribution.Verbosity - ( normal ) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Client.ProjectFlags (ProjectFlags (..)) -import Distribution.Solver.Types.ConstraintSource - -import qualified Distribution.Deprecated.ReadP as Parse - ( (<++), option ) -import qualified Text.PrettyPrint as Disp - ( render, text, empty ) -import Distribution.Parsec (parsecOptCommaList) -import Text.PrettyPrint - ( ($+$) ) -import Text.PrettyPrint.HughesPJ - ( text, Doc ) -import System.Directory - ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) -import Network.URI - ( URI(..), URIAuth(..), parseURI ) -import System.FilePath - ( (<.>), (), takeDirectory ) -import System.IO.Error - ( isDoesNotExistError ) -import Distribution.Compat.Environment - ( getEnvironment, lookupEnv ) -import qualified Data.Map as M - --- --- * Configuration saved in the config file --- - -data SavedConfig = SavedConfig - { savedGlobalFlags :: GlobalFlags - , savedInitFlags :: IT.InitFlags - , savedInstallFlags :: InstallFlags - , savedClientInstallFlags :: ClientInstallFlags - , savedConfigureFlags :: ConfigFlags - , savedConfigureExFlags :: ConfigExFlags - , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) - , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) - , savedUploadFlags :: UploadFlags - , savedReportFlags :: ReportFlags - , savedHaddockFlags :: HaddockFlags - , savedTestFlags :: TestFlags - , savedBenchmarkFlags :: BenchmarkFlags - , savedProjectFlags :: ProjectFlags - } deriving Generic - -instance Monoid SavedConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup SavedConfig where - a <> b = SavedConfig { - savedGlobalFlags = combinedSavedGlobalFlags, - savedInitFlags = combinedSavedInitFlags, - savedInstallFlags = combinedSavedInstallFlags, - savedClientInstallFlags = combinedSavedClientInstallFlags, - savedConfigureFlags = combinedSavedConfigureFlags, - savedConfigureExFlags = combinedSavedConfigureExFlags, - savedUserInstallDirs = combinedSavedUserInstallDirs, - savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, - savedUploadFlags = combinedSavedUploadFlags, - savedReportFlags = combinedSavedReportFlags, - savedHaddockFlags = combinedSavedHaddockFlags, - savedTestFlags = combinedSavedTestFlags, - savedBenchmarkFlags = combinedSavedBenchmarkFlags, - savedProjectFlags = combinedSavedProjectFlags - } - where - -- This is ugly, but necessary. If we're mappending two config files, we - -- want the values of the *non-empty* list fields from the second one to - -- *override* the corresponding values from the first one. Default - -- behaviour (concatenation) is confusing and makes some use cases (see - -- #1884) impossible. - -- - -- However, we also want to allow specifying multiple values for a list - -- field in a *single* config file. For example, we want the following to - -- continue to work: - -- - -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/ - -- remote-repo: private-collection:http://hackage.local/ - -- - -- So we can't just wrap the list fields inside Flags; we have to do some - -- special-casing just for SavedConfig. - - -- NB: the signature prevents us from using 'combine' on lists. - combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a - combine' field subfield = - (subfield . field $ a) `mappend` (subfield . field $ b) - - combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon) - -> mon - combineMonoid field subfield = - (subfield . field $ a) `mappend` (subfield . field $ b) - - lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a] - lastNonEmpty' field subfield = - let a' = subfield . field $ a - b' = subfield . field $ b - in case b' of [] -> a' - _ -> b' - - lastNonMempty' - :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a - lastNonMempty' field subfield = - let a' = subfield . field $ a - b' = subfield . field $ b - in if b' == mempty then a' else b' - - lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) - -> NubList a - lastNonEmptyNL' field subfield = - let a' = subfield . field $ a - b' = subfield . field $ b - in case fromNubList b' of [] -> a' - _ -> b' - - combinedSavedGlobalFlags = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion, - globalConfigFile = combine globalConfigFile, - globalConstraintsFile = combine globalConstraintsFile, - globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, - globalCacheDir = combine globalCacheDir, - globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, - globalActiveRepos = combine globalActiveRepos, - globalLogsDir = combine globalLogsDir, - globalWorldFile = combine globalWorldFile, - globalIgnoreExpiry = combine globalIgnoreExpiry, - globalHttpTransport = combine globalHttpTransport, - globalNix = combine globalNix, - globalStoreDir = combine globalStoreDir, - globalProgPathExtra = lastNonEmptyNL globalProgPathExtra - } - where - combine = combine' savedGlobalFlags - lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags - - combinedSavedInitFlags = IT.InitFlags { - IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs, - IT.author = combine IT.author, - IT.buildTools = combineMonoid savedInitFlags IT.buildTools, - IT.cabalVersion = combine IT.cabalVersion, - IT.category = combine IT.category, - IT.dependencies = combineMonoid savedInitFlags IT.dependencies, - IT.email = combine IT.email, - IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules, - IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc, - IT.homepage = combine IT.homepage, - IT.initHcPath = combine IT.initHcPath, - IT.initVerbosity = combine IT.initVerbosity, - IT.initializeTestSuite = combine IT.initializeTestSuite, - IT.interactive = combine IT.interactive, - IT.language = combine IT.language, - IT.license = combine IT.license, - IT.mainIs = combine IT.mainIs, - IT.minimal = combine IT.minimal, - IT.noComments = combine IT.noComments, - IT.otherExts = combineMonoid savedInitFlags IT.otherExts, - IT.otherModules = combineMonoid savedInitFlags IT.otherModules, - IT.overwrite = combine IT.overwrite, - IT.packageDir = combine IT.packageDir, - IT.packageName = combine IT.packageName, - IT.packageType = combine IT.packageType, - IT.quiet = combine IT.quiet, - IT.simpleProject = combine IT.simpleProject, - IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs, - IT.synopsis = combine IT.synopsis, - IT.testDirs = combineMonoid savedInitFlags IT.testDirs, - IT.version = combine IT.version - } - where - combine = combine' savedInitFlags - - combinedSavedInstallFlags = InstallFlags { - installDocumentation = combine installDocumentation, - installHaddockIndex = combine installHaddockIndex, - installDryRun = combine installDryRun, - installDest = combine installDest, - installMaxBackjumps = combine installMaxBackjumps, - installReorderGoals = combine installReorderGoals, - installCountConflicts = combine installCountConflicts, - installFineGrainedConflicts = combine installFineGrainedConflicts, - installMinimizeConflictSet = combine installMinimizeConflictSet, - installIndependentGoals = combine installIndependentGoals, - installShadowPkgs = combine installShadowPkgs, - installStrongFlags = combine installStrongFlags, - installAllowBootLibInstalls = combine installAllowBootLibInstalls, - installOnlyConstrained = combine installOnlyConstrained, - installReinstall = combine installReinstall, - installAvoidReinstalls = combine installAvoidReinstalls, - installOverrideReinstall = combine installOverrideReinstall, - installUpgradeDeps = combine installUpgradeDeps, - installOnly = combine installOnly, - installOnlyDeps = combine installOnlyDeps, - installIndexState = combine installIndexState, - installRootCmd = combine installRootCmd, - installSummaryFile = lastNonEmptyNL installSummaryFile, - installLogFile = combine installLogFile, - installBuildReports = combine installBuildReports, - installReportPlanningFailure = combine installReportPlanningFailure, - installSymlinkBinDir = combine installSymlinkBinDir, - installPerComponent = combine installPerComponent, - installOneShot = combine installOneShot, - installNumJobs = combine installNumJobs, - installKeepGoing = combine installKeepGoing, - installRunTests = combine installRunTests, - installOfflineMode = combine installOfflineMode - } - where - combine = combine' savedInstallFlags - lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags - - combinedSavedClientInstallFlags = ClientInstallFlags - { cinstInstallLibs = combine cinstInstallLibs - , cinstEnvironmentPath = combine cinstEnvironmentPath - , cinstOverwritePolicy = combine cinstOverwritePolicy - , cinstInstallMethod = combine cinstInstallMethod - , cinstInstalldir = combine cinstInstalldir - } - where - combine = combine' savedClientInstallFlags - - combinedSavedConfigureFlags = ConfigFlags { - configArgs = lastNonEmpty configArgs, - configPrograms_ = configPrograms_ . savedConfigureFlags $ b, - -- TODO: NubListify - configProgramPaths = lastNonEmpty configProgramPaths, - -- TODO: NubListify - configProgramArgs = lastNonEmpty configProgramArgs, - configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, - configInstantiateWith = lastNonEmpty configInstantiateWith, - configHcFlavor = combine configHcFlavor, - configHcPath = combine configHcPath, - configHcPkg = combine configHcPkg, - configVanillaLib = combine configVanillaLib, - configProfLib = combine configProfLib, - configProf = combine configProf, - configSharedLib = combine configSharedLib, - configStaticLib = combine configStaticLib, - configDynExe = combine configDynExe, - configFullyStaticExe = combine configFullyStaticExe, - configProfExe = combine configProfExe, - configProfDetail = combine configProfDetail, - configProfLibDetail = combine configProfLibDetail, - -- TODO: NubListify - configConfigureArgs = lastNonEmpty configConfigureArgs, - configOptimization = combine configOptimization, - configDebugInfo = combine configDebugInfo, - configProgPrefix = combine configProgPrefix, - configProgSuffix = combine configProgSuffix, - -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - configInstallDirs = - (configInstallDirs . savedConfigureFlags $ a) - `mappend` (configInstallDirs . savedConfigureFlags $ b), - configScratchDir = combine configScratchDir, - -- TODO: NubListify - configExtraLibDirs = lastNonEmpty configExtraLibDirs, - -- TODO: NubListify - configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, - -- TODO: NubListify - configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, - configDeterministic = combine configDeterministic, - configIPID = combine configIPID, - configCID = combine configCID, - configDistPref = combine configDistPref, - configCabalFilePath = combine configCabalFilePath, - configVerbosity = combine configVerbosity, - configUserInstall = combine configUserInstall, - -- TODO: NubListify - configPackageDBs = lastNonEmpty configPackageDBs, - configGHCiLib = combine configGHCiLib, - configSplitSections = combine configSplitSections, - configSplitObjs = combine configSplitObjs, - configStripExes = combine configStripExes, - configStripLibs = combine configStripLibs, - -- TODO: NubListify - configConstraints = lastNonEmpty configConstraints, - -- TODO: NubListify - configDependencies = lastNonEmpty configDependencies, - -- TODO: NubListify - configConfigurationsFlags = lastNonMempty configConfigurationsFlags, - configTests = combine configTests, - configBenchmarks = combine configBenchmarks, - configCoverage = combine configCoverage, - configLibCoverage = combine configLibCoverage, - configExactConfiguration = combine configExactConfiguration, - configFlagError = combine configFlagError, - configRelocatable = combine configRelocatable, - configUseResponseFiles = combine configUseResponseFiles, - configAllowDependingOnPrivateLibs = - combine configAllowDependingOnPrivateLibs - } - where - combine = combine' savedConfigureFlags - lastNonEmpty = lastNonEmpty' savedConfigureFlags - lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags - lastNonMempty = lastNonMempty' savedConfigureFlags - - combinedSavedConfigureExFlags = ConfigExFlags { - configCabalVersion = combine configCabalVersion, - -- TODO: NubListify - configExConstraints = lastNonEmpty configExConstraints, - -- TODO: NubListify - configPreferences = lastNonEmpty configPreferences, - configSolver = combine configSolver, - configAllowNewer = - combineMonoid savedConfigureExFlags configAllowNewer, - configAllowOlder = - combineMonoid savedConfigureExFlags configAllowOlder, - configWriteGhcEnvironmentFilesPolicy - = combine configWriteGhcEnvironmentFilesPolicy - } - where - combine = combine' savedConfigureExFlags - lastNonEmpty = lastNonEmpty' savedConfigureExFlags - - -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - combinedSavedUserInstallDirs = savedUserInstallDirs a - `mappend` savedUserInstallDirs b - - -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a - `mappend` savedGlobalInstallDirs b - - combinedSavedUploadFlags = UploadFlags { - uploadCandidate = combine uploadCandidate, - uploadDoc = combine uploadDoc, - uploadUsername = combine uploadUsername, - uploadPassword = combine uploadPassword, - uploadPasswordCmd = combine uploadPasswordCmd, - uploadVerbosity = combine uploadVerbosity - } - where - combine = combine' savedUploadFlags - - combinedSavedReportFlags = ReportFlags { - reportUsername = combine reportUsername, - reportPassword = combine reportPassword, - reportVerbosity = combine reportVerbosity - } - where - combine = combine' savedReportFlags - - combinedSavedHaddockFlags = HaddockFlags { - -- TODO: NubListify - haddockProgramPaths = lastNonEmpty haddockProgramPaths, - -- TODO: NubListify - haddockProgramArgs = lastNonEmpty haddockProgramArgs, - haddockHoogle = combine haddockHoogle, - haddockHtml = combine haddockHtml, - haddockHtmlLocation = combine haddockHtmlLocation, - haddockForHackage = combine haddockForHackage, - haddockExecutables = combine haddockExecutables, - haddockTestSuites = combine haddockTestSuites, - haddockBenchmarks = combine haddockBenchmarks, - haddockForeignLibs = combine haddockForeignLibs, - haddockInternal = combine haddockInternal, - haddockCss = combine haddockCss, - haddockLinkedSource = combine haddockLinkedSource, - haddockQuickJump = combine haddockQuickJump, - haddockHscolourCss = combine haddockHscolourCss, - haddockContents = combine haddockContents, - haddockDistPref = combine haddockDistPref, - haddockKeepTempFiles = combine haddockKeepTempFiles, - haddockVerbosity = combine haddockVerbosity, - haddockCabalFilePath = combine haddockCabalFilePath, - haddockArgs = lastNonEmpty haddockArgs - } - where - combine = combine' savedHaddockFlags - lastNonEmpty = lastNonEmpty' savedHaddockFlags - - combinedSavedTestFlags = TestFlags { - testDistPref = combine testDistPref, - testVerbosity = combine testVerbosity, - testHumanLog = combine testHumanLog, - testMachineLog = combine testMachineLog, - testShowDetails = combine testShowDetails, - testKeepTix = combine testKeepTix, - testWrapper = combine testWrapper, - testFailWhenNoTestSuites = combine testFailWhenNoTestSuites, - testOptions = lastNonEmpty testOptions - } - where - combine = combine' savedTestFlags - lastNonEmpty = lastNonEmpty' savedTestFlags - - combinedSavedBenchmarkFlags = BenchmarkFlags { - benchmarkDistPref = combine benchmarkDistPref, - benchmarkVerbosity = combine benchmarkVerbosity, - benchmarkOptions = lastNonEmpty benchmarkOptions - } - where - combine = combine' savedBenchmarkFlags - lastNonEmpty = lastNonEmpty' savedBenchmarkFlags - - combinedSavedProjectFlags = ProjectFlags - { flagProjectFileName = combine flagProjectFileName - , flagIgnoreProject = combine flagIgnoreProject - } - where - combine = combine' savedProjectFlags - --- --- * Default config --- - --- | These are the absolute basic defaults. The fields that must be --- initialised. When we load the config from the file we layer the loaded --- values over these ones, so any missing fields in the file take their values --- from here. --- -baseSavedConfig :: IO SavedConfig -baseSavedConfig = do - userPrefix <- getCabalDir - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - worldFile <- defaultWorldFile - return mempty { - savedConfigureFlags = mempty { - configHcFlavor = toFlag defaultCompiler, - configUserInstall = toFlag defaultUserInstall, - configVerbosity = toFlag normal - }, - savedUserInstallDirs = mempty { - prefix = toFlag (toPathTemplate userPrefix) - }, - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalLogsDir = toFlag logsDir, - globalWorldFile = toFlag worldFile - } - } - --- | This is the initial configuration that we write out to the config file --- if the file does not exist (or the config we use if the file cannot be read --- for some other reason). When the config gets loaded it gets layered on top --- of 'baseSavedConfig' so we do not need to include it into the initial --- values we save into the config file. --- -initialSavedConfig :: IO SavedConfig -initialSavedConfig = do - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - worldFile <- defaultWorldFile - extraPath <- defaultExtraPath - installPath <- defaultInstallPath - return mempty { - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalRemoteRepos = toNubList [defaultRemoteRepo], - globalWorldFile = toFlag worldFile - }, - savedConfigureFlags = mempty { - configProgramPathExtra = toNubList extraPath - }, - savedInstallFlags = mempty { - installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag NoReports, - installNumJobs = toFlag Nothing - }, - savedClientInstallFlags = mempty { - cinstInstalldir = toFlag installPath - } - } - -defaultCabalDir :: IO FilePath -defaultCabalDir = getAppUserDataDirectory "cabal" - -getCabalDir :: IO FilePath -getCabalDir = do - mDir <- lookupEnv "CABAL_DIR" - case mDir of - Nothing -> defaultCabalDir - Just dir -> return dir - -defaultConfigFile :: IO FilePath -defaultConfigFile = do - dir <- getCabalDir - return $ dir "config" - -defaultCacheDir :: IO FilePath -defaultCacheDir = do - dir <- getCabalDir - return $ dir "packages" - -defaultLogsDir :: IO FilePath -defaultLogsDir = do - dir <- getCabalDir - return $ dir "logs" - --- | Default position of the world file -defaultWorldFile :: IO FilePath -defaultWorldFile = do - dir <- getCabalDir - return $ dir "world" - -defaultExtraPath :: IO [FilePath] -defaultExtraPath = do - dir <- getCabalDir - return [dir "bin"] - -defaultInstallPath :: IO FilePath -defaultInstallPath = do - dir <- getCabalDir - return (dir "bin") - -defaultCompiler :: CompilerFlavor -defaultCompiler = fromMaybe GHC defaultCompilerFlavor - -defaultUserInstall :: Bool -defaultUserInstall = True --- We do per-user installs by default on all platforms. We used to default to --- global installs on Windows but that no longer works on Windows Vista or 7. - -defaultRemoteRepo :: RemoteRepo -defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False - where - str = "hackage.haskell.org" - name = RepoName str - uri = URI "http:" (Just (URIAuth "" str "")) "/" "" "" - -- Note that lots of old ~/.cabal/config files will have the old url - -- http://hackage.haskell.org/packages/archive - -- but new config files can use the new url (without the /packages/archive) - -- and avoid having to do a http redirect - --- For the default repo we know extra information, fill this in. --- --- We need this because the 'defaultRemoteRepo' above is only used for the --- first time when a config file is made. So for users with older config files --- we might have only have older info. This lets us fill that in even for old --- config files. --- -addInfoForKnownRepos :: RemoteRepo -> RemoteRepo -addInfoForKnownRepos repo - | remoteRepoName repo == remoteRepoName defaultRemoteRepo - = useSecure . tryHttps . fixOldURI $ repo - where - fixOldURI r - | isOldHackageURI (remoteRepoURI r) - = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo } - | otherwise = r - - tryHttps r = r { remoteRepoShouldTryHttps = True } - - useSecure r@RemoteRepo{ - remoteRepoSecure = secure, - remoteRepoRootKeys = [], - remoteRepoKeyThreshold = 0 - } | secure /= Just False - = r { - -- Use hackage-security by default unless you opt-out with - -- secure: False - remoteRepoSecure = Just True, - remoteRepoRootKeys = defaultHackageRemoteRepoKeys, - remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold - } - useSecure r = r -addInfoForKnownRepos other = other - --- | The current hackage.haskell.org repo root keys that we ship with cabal. ---- --- This lets us bootstrap trust in this repo without user intervention. --- These keys need to be periodically updated when new root keys are added. --- See the root key procedures for details. --- -defaultHackageRemoteRepoKeys :: [String] -defaultHackageRemoteRepoKeys = - [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0", - "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42", - "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3", - "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d", - "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" - ] - --- | The required threshold of root key signatures for hackage.haskell.org --- -defaultHackageRemoteRepoKeyThreshold :: Int -defaultHackageRemoteRepoKeyThreshold = 3 - --- --- * Config file reading --- - --- | Loads the main configuration, and applies additional defaults to give the --- effective configuration. To loads just what is actually in the config file, --- use 'loadRawConfig'. --- -loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig -loadConfig verbosity configFileFlag = do - config <- loadRawConfig verbosity configFileFlag - extendToEffectiveConfig config - -extendToEffectiveConfig :: SavedConfig -> IO SavedConfig -extendToEffectiveConfig config = do - base <- baseSavedConfig - let effective0 = base `mappend` config - globalFlags0 = savedGlobalFlags effective0 - effective = effective0 { - savedGlobalFlags = globalFlags0 { - globalRemoteRepos = - overNubList (map addInfoForKnownRepos) - (globalRemoteRepos globalFlags0) - } - } - return effective - --- | Like 'loadConfig' but does not apply any additional defaults, it just --- loads what is actually in the config file. This is thus suitable for --- comparing or editing a config file, but not suitable for using as the --- effective configuration. --- -loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig -loadRawConfig verbosity configFileFlag = do - (source, configFile) <- getConfigFilePathAndSource configFileFlag - minp <- readConfigFile mempty configFile - case minp of - Nothing -> do - notice verbosity $ - "Config file path source is " ++ sourceMsg source ++ "." - notice verbosity $ "Config file " ++ configFile ++ " not found." - createDefaultConfigFile verbosity [] configFile - Just (ParseOk ws conf) -> do - unless (null ws) $ warn verbosity $ - unlines (map (showPWarning configFile) ws) - return conf - Just (ParseFailed err) -> do - let (line, msg) = locatedErrorMsg err - die' verbosity $ - "Error parsing config file " ++ configFile - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - - where - sourceMsg CommandlineOption = "commandline option" - sourceMsg EnvironmentVariable = "env var CABAL_CONFIG" - sourceMsg Default = "default config file" - -data ConfigFileSource = CommandlineOption - | EnvironmentVariable - | Default - --- | Returns the config file path, without checking that the file exists. --- The order of precedence is: input flag, CABAL_CONFIG, default location. -getConfigFilePath :: Flag FilePath -> IO FilePath -getConfigFilePath = fmap snd . getConfigFilePathAndSource - -getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath) -getConfigFilePathAndSource configFileFlag = - getSource sources - where - sources = - [ (CommandlineOption, return . flagToMaybe $ configFileFlag) - , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment) - , (Default, Just `liftM` defaultConfigFile) ] - - getSource [] = error "no config file path candidate found." - getSource ((source,action): xs) = - action >>= maybe (getSource xs) (return . (,) source) - -readConfigFile - :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) -readConfigFile initial file = handleNotExists $ - fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) - (readFile file) - - where - handleNotExists action = catchIO action $ \ioe -> - if isDoesNotExistError ioe - then return Nothing - else ioError ioe - -createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig -createDefaultConfigFile verbosity extraLines filePath = do - commentConf <- commentSavedConfig - initialConf <- initialSavedConfig - extraConf <- parseExtraLines verbosity extraLines - notice verbosity $ "Writing default configuration to " ++ filePath - writeConfigFile filePath commentConf (initialConf `mappend` extraConf) - return initialConf - -writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () -writeConfigFile file comments vals = do - let tmpFile = file <.> "tmp" - createDirectoryIfMissing True (takeDirectory file) - writeFile tmpFile $ - explanation ++ showConfigWithComments comments vals ++ "\n" - renameFile tmpFile file - where - explanation = unlines - ["-- This is the configuration file for the 'cabal' command line tool." - ,"--" - ,"-- The available configuration options are listed below." - ,"-- Some of them have default values listed." - ,"--" - ,"-- Lines (like this one) beginning with '--' are comments." - ,"-- Be careful with spaces and indentation because they are" - ,"-- used to indicate layout for nested sections." - ,"--" - ,"-- This config file was generated using the following versions" - ,"-- of Cabal and cabal-install:" - ,"-- Cabal library version: " ++ prettyShow cabalVersion - ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion - ,"","" - ] - --- | These are the default values that get used in Cabal if a no value is --- given. We use these here to include in comments when we write out the --- initial config file so that the user can see what default value they are --- overriding. --- -commentSavedConfig :: IO SavedConfig -commentSavedConfig = do - userInstallDirs <- defaultInstallDirs defaultCompiler True True - globalInstallDirs <- defaultInstallDirs defaultCompiler False True - let conf0 = mempty { - savedGlobalFlags = defaultGlobalFlags { - globalRemoteRepos = toNubList [defaultRemoteRepo] - }, - savedInitFlags = mempty { - IT.interactive = toFlag False, - IT.cabalVersion = toFlag IT.defaultCabalVersion, - IT.language = toFlag Haskell2010, - IT.license = NoFlag, - IT.sourceDirs = Just [IT.defaultSourceDir], - IT.applicationDirs = Just [IT.defaultApplicationDir] - }, - savedInstallFlags = defaultInstallFlags, - savedClientInstallFlags= defaultClientInstallFlags, - savedConfigureExFlags = defaultConfigExFlags { - configAllowNewer = Just (AllowNewer mempty), - configAllowOlder = Just (AllowOlder mempty) - }, - savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { - configUserInstall = toFlag defaultUserInstall - }, - savedUserInstallDirs = fmap toFlag userInstallDirs, - savedGlobalInstallDirs = fmap toFlag globalInstallDirs, - savedUploadFlags = commandDefaultFlags uploadCommand, - savedReportFlags = commandDefaultFlags reportCommand, - savedHaddockFlags = defaultHaddockFlags, - savedTestFlags = defaultTestFlags, - savedBenchmarkFlags = defaultBenchmarkFlags - } - conf1 <- extendToEffectiveConfig conf0 - let globalFlagsConf1 = savedGlobalFlags conf1 - conf2 = conf1 { - savedGlobalFlags = globalFlagsConf1 { - globalRemoteRepos = overNubList (map removeRootKeys) - (globalRemoteRepos globalFlagsConf1) - } - } - return conf2 - where - -- Most people don't want to see default root keys, so don't print them. - removeRootKeys :: RemoteRepo -> RemoteRepo - removeRootKeys r = r { remoteRepoRootKeys = [] } - --- | All config file fields. --- -configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig] -configFieldDescriptions src = - - toSavedConfig liftGlobalFlag - (commandOptions (globalCommand []) ParseArgs) - ["version", "numeric-version", "config-file"] [] - - ++ toSavedConfig liftConfigFlag - (configureOptions ParseArgs) - (["builddir", "constraint", "dependency", "ipid"] - ++ map fieldName installDirsFields) - - -- This is only here because viewAsFieldDescr gives us a parser - -- that only recognises 'ghc' etc, the case-sensitive flag names, not - -- what the normal case-insensitive parser gives us. - [simpleFieldParsec "compiler" - (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - - -- TODO: The following is a temporary fix. The "optimization" - -- and "debug-info" fields are OptArg, and viewAsFieldDescr - -- fails on that. Instead of a hand-written hackaged parser - -- and printer, we should handle this case properly in the - -- library. - ,liftField configOptimization (\v flags -> - flags { configOptimization = v }) $ - let name = "optimization" in - FieldDescr name - (\f -> case f of - Flag NoOptimisation -> Disp.text "False" - Flag NormalOptimisation -> Disp.text "True" - Flag MaximumOptimisation -> Disp.text "2" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoOptimisation) - | str == "True" -> ParseOk [] (Flag NormalOptimisation) - | str == "0" -> ParseOk [] (Flag NoOptimisation) - | str == "1" -> ParseOk [] (Flag NormalOptimisation) - | str == "2" -> ParseOk [] (Flag MaximumOptimisation) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) - | lstr == "true" -> ParseOk [caseWarning] - (Flag NormalOptimisation) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name - ++ "' field is case sensitive, use 'True' or 'False'.") - ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ - let name = "debug-info" in - FieldDescr name - (\f -> case f of - Flag NoDebugInfo -> Disp.text "False" - Flag MinimalDebugInfo -> Disp.text "1" - Flag NormalDebugInfo -> Disp.text "True" - Flag MaximalDebugInfo -> Disp.text "3" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) - | str == "True" -> ParseOk [] (Flag NormalDebugInfo) - | str == "0" -> ParseOk [] (Flag NoDebugInfo) - | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) - | str == "2" -> ParseOk [] (Flag NormalDebugInfo) - | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name - ++ "' field is case sensitive, use 'True' or 'False'.") - ] - - ++ toSavedConfig liftConfigExFlag - (configureExOptions ParseArgs src) - [] - [let pkgs = (Just . AllowOlder . RelaxDepsSome) - `fmap` parsecOptCommaList parsec - parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) - `fmap` parsec) Parse.<++ pkgs - in simpleField "allow-older" - (showRelaxDeps . fmap unAllowOlder) parseAllowOlder - configAllowOlder (\v flags -> flags { configAllowOlder = v }) - ,let pkgs = (Just . AllowNewer . RelaxDepsSome) - `fmap` parsecOptCommaList parsec - parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) - `fmap` parsec) Parse.<++ pkgs - in simpleField "allow-newer" - (showRelaxDeps . fmap unAllowNewer) parseAllowNewer - configAllowNewer (\v flags -> flags { configAllowNewer = v }) - ] - - ++ toSavedConfig liftInstallFlag - (installOptions ParseArgs) - ["dry-run", "only", "only-dependencies", "dependencies-only"] [] - - ++ toSavedConfig liftClientInstallFlag - (clientInstallOptions ParseArgs) - [] [] - - ++ toSavedConfig liftUploadFlag - (commandOptions uploadCommand ParseArgs) - ["verbose", "check", "documentation", "publish"] [] - - ++ toSavedConfig liftReportFlag - (commandOptions reportCommand ParseArgs) - ["verbose", "username", "password"] [] - --FIXME: this is a hack, hiding the user name and password. - -- But otherwise it masks the upload ones. Either need to - -- share the options or make then distinct. In any case - -- they should probably be per-server. - - ++ [ viewAsFieldDescr - $ optionDistPref - (configDistPref . savedConfigureFlags) - (\distPref config -> - config - { savedConfigureFlags = (savedConfigureFlags config) { - configDistPref = distPref } - , savedHaddockFlags = (savedHaddockFlags config) { - haddockDistPref = distPref } - } - ) - ParseArgs - ] - - where - toSavedConfig lift options exclusions replacements = - [ lift (fromMaybe field replacement) - | opt <- options - , let field = viewAsFieldDescr opt - name = fieldName field - replacement = find ((== name) . fieldName) replacements - , name `notElem` exclusions ] - - showRelaxDeps Nothing = mempty - showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True" - | otherwise = Disp.text "False" - - toRelaxDeps True = RelaxDepsAll - toRelaxDeps False = mempty - - --- TODO: next step, make the deprecated fields elicit a warning. --- -deprecatedFieldDescriptions :: [FieldDescr SavedConfig] -deprecatedFieldDescriptions = - [ liftGlobalFlag $ - listFieldParsec "repos" - pretty parsec - (fromNubList . globalRemoteRepos) - (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) - , liftGlobalFlag $ - simpleField "cachedir" - (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) - globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) - , liftUploadFlag $ - simpleField "hackage-username" - (Disp.text . fromFlagOrDefault "" . fmap unUsername) - (optional (fmap Username parseTokenQ)) - uploadUsername (\d cfg -> cfg { uploadUsername = d }) - , liftUploadFlag $ - simpleField "hackage-password" - (Disp.text . fromFlagOrDefault "" . fmap unPassword) - (optional (fmap Password parseTokenQ)) - uploadPassword (\d cfg -> cfg { uploadPassword = d }) - , liftUploadFlag $ - spaceListField "hackage-password-command" - Disp.text parseTokenQ - (fromFlagOrDefault [] . uploadPasswordCmd) - (\d cfg -> cfg { uploadPasswordCmd = Flag d }) - ] - ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) - installDirsFields - ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) - installDirsFields - where - optional = Parse.option mempty . fmap toFlag - modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a - modifyFieldName f d = d { fieldName = f (fieldName d) } - -liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) - -> FieldDescr SavedConfig -liftUserInstallDirs = liftField - savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) - -liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) - -> FieldDescr SavedConfig -liftGlobalInstallDirs = - liftField savedGlobalInstallDirs - (\flags conf -> conf { savedGlobalInstallDirs = flags }) - -liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig -liftGlobalFlag = liftField - savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) - -liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig -liftConfigFlag = liftField - savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) - -liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig -liftConfigExFlag = liftField - savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) - -liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig -liftInstallFlag = liftField - savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) - -liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig -liftClientInstallFlag = - liftField savedClientInstallFlags - (\flags conf -> conf { savedClientInstallFlags = flags }) - -liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig -liftUploadFlag = liftField - savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) - -liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig -liftReportFlag = liftField - savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) - -parseConfig :: ConstraintSource - -> SavedConfig - -> String - -> ParseResult SavedConfig -parseConfig src initial = \str -> do - fields <- readFields str - let (knownSections, others) = partition isKnownSection fields - config <- parse others - let init0 = savedInitFlags config - user0 = savedUserInstallDirs config - global0 = savedGlobalInstallDirs config - (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- - foldM parseSections - ([], [], savedHaddockFlags config, init0, user0, global0, [], []) - knownSections - - let remoteRepoSections = - reverse - . nubBy ((==) `on` remoteRepoName) - $ remoteRepoSections0 - - let localRepoSections = - reverse - . nubBy ((==) `on` localRepoName) - $ localRepoSections0 - - return . fixConfigMultilines $ config { - savedGlobalFlags = (savedGlobalFlags config) { - globalRemoteRepos = toNubList remoteRepoSections, - globalLocalNoIndexRepos = toNubList localRepoSections, - -- the global extra prog path comes from the configure flag prog path - globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) - }, - savedConfigureFlags = (savedConfigureFlags config) { - configProgramPaths = paths, - configProgramArgs = args - }, - savedHaddockFlags = haddockFlags, - savedInitFlags = initFlags, - savedUserInstallDirs = user, - savedGlobalInstallDirs = global - } - - where - isKnownSection (ParseUtils.Section _ "repository" _ _) = True - isKnownSection (ParseUtils.F _ "remote-repo" _) = True - isKnownSection (ParseUtils.Section _ "haddock" _ _) = True - isKnownSection (ParseUtils.Section _ "init" _ _) = True - isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True - isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True - isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True - isKnownSection _ = False - - -- Attempt to split fields that can represent lists of paths into - -- actual lists on failure, leave the field untouched. - splitMultiPath :: [String] -> [String] - splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of - ParseOk _ res -> res - _ -> [s] - splitMultiPath xs = xs - - -- This is a fixup, pending a full config parser rewrite, to - -- ensure that config fields which can be comma-separated lists - -- actually parse as comma-separated lists. - fixConfigMultilines conf = conf { - savedConfigureFlags = - let scf = savedConfigureFlags conf - in scf { - configProgramPathExtra = - toNubList $ splitMultiPath - (fromNubList $ configProgramPathExtra scf) - , configExtraLibDirs = splitMultiPath - (configExtraLibDirs scf) - , configExtraFrameworkDirs = splitMultiPath - (configExtraFrameworkDirs scf) - , configExtraIncludeDirs = splitMultiPath - (configExtraIncludeDirs scf) - , configConfigureArgs = splitMultiPath - (configConfigureArgs scf) - } - } - - parse = parseFields (configFieldDescriptions src - ++ deprecatedFieldDescriptions) initial - - parseSections (rs, ls, h, i, u, g, p, a) - (ParseUtils.Section lineno "repository" name fs) = do - name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $ - simpleParsec name - r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs - r'' <- postProcessRepo lineno name r' - case r'' of - Left local -> return (rs, local:ls, h, i, u, g, p, a) - Right remote -> return (remote:rs, ls, h, i, u, g, p, a) - - parseSections (rs, ls, h, i, u, g, p, a) - (ParseUtils.F lno "remote-repo" raw) = do - let mr' = simpleParsec raw - r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' - return (r':rs, ls, h, i, u, g, p, a) - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "haddock" name fs) - | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (rs, ls, h', i, u, g, p, a) - | otherwise = do - warning "The 'haddock' section should be unnamed" - return accum - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "init" name fs) - | name == "" = do i' <- parseFields initFlagsFields i fs - return (rs, ls, h, i', u, g, p, a) - | otherwise = do - warning "The 'init' section should be unnamed" - return accum - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "install-dirs" name fs) - | name' == "user" = do u' <- parseFields installDirsFields u fs - return (rs, ls, h, i, u', g, p, a) - | name' == "global" = do g' <- parseFields installDirsFields g fs - return (rs, ls, h, i, u, g', p, a) - | otherwise = do - warning "The 'install-paths' section should be for 'user' or 'global'" - return accum - where name' = lowercase name - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "program-locations" name fs) - | name == "" = do p' <- parseFields withProgramsFields p fs - return (rs, ls, h, i, u, g, p', a) - | otherwise = do - warning "The 'program-locations' section should be unnamed" - return accum - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "program-default-options" name fs) - | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (rs, ls, h, i, u, g, p, a') - | otherwise = do - warning "The 'program-default-options' section should be unnamed" - return accum - parseSections accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - -postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) -postProcessRepo lineno reponameStr repo0 = do - when (null reponameStr) $ - syntaxError lineno $ "a 'repository' section requires the " - ++ "repository name as an argument" - - reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $ - simpleParsec reponameStr - - case uriScheme (remoteRepoURI repo0) of - -- TODO: check that there are no authority, query or fragment - -- Note: the trailing colon is important - "file+noindex:" -> do - let uri = remoteRepoURI repo0 - return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") - - _ -> do - let repo = repo0 { remoteRepoName = reponame } - - when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ - warning $ "'key-threshold' for repository " - ++ show (remoteRepoName repo) - ++ " higher than number of keys" - - when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ - warning $ "'root-keys' for repository " - ++ show (remoteRepoName repo) - ++ " non-empty, but 'secure' not set to True." - - return $ Right repo - -showConfig :: SavedConfig -> String -showConfig = showConfigWithComments mempty - -showConfigWithComments :: SavedConfig -> SavedConfig -> String -showConfigWithComments comment vals = Disp.render $ - case fmap (uncurry ppRemoteRepoSection) - (zip (getRemoteRepos comment) (getRemoteRepos vals)) of - [] -> Disp.text "" - (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs - $+$ Disp.text "" - $+$ ppFields - (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) - mcomment vals - $+$ Disp.text "" - $+$ ppSection "haddock" "" haddockFlagsFields - (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) - $+$ Disp.text "" - $+$ ppSection "init" "" initFlagsFields - (fmap savedInitFlags mcomment) (savedInitFlags vals) - $+$ Disp.text "" - $+$ installDirsSection "user" savedUserInstallDirs - $+$ Disp.text "" - $+$ installDirsSection "global" savedGlobalInstallDirs - $+$ Disp.text "" - $+$ configFlagsSection "program-locations" withProgramsFields - configProgramPaths - $+$ Disp.text "" - $+$ configFlagsSection "program-default-options" withProgramOptionsFields - configProgramArgs - where - getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags - mcomment = Just comment - installDirsSection name field = - ppSection "install-dirs" name installDirsFields - (fmap field mcomment) (field vals) - configFlagsSection name fields field = - ppSection name "" fields - (fmap (field . savedConfigureFlags) mcomment) - ((field . savedConfigureFlags) vals) - - -- skip fields based on field name. currently only skips "remote-repo", - -- because that is rendered as a section. (see 'ppRemoteRepoSection'.) - skipSomeFields = filter ((/= "remote-repo") . fieldName) - --- | Fields for the 'install-dirs' sections. -installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] -installDirsFields = map viewAsFieldDescr installDirsOptions - -ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc -ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals)) - remoteRepoFields (Just def) vals - -remoteRepoFields :: [FieldDescr RemoteRepo] -remoteRepoFields = - [ simpleField "url" - (text . show) (parseTokenQ >>= parseURI') - remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) - , simpleFieldParsec "secure" - showSecure (Just `fmap` parsec) - remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) - , listField "root-keys" - text parseTokenQ - remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) - , simpleFieldParsec "key-threshold" - showThreshold P.integral - remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) - ] - where - parseURI' uriString = - case parseURI uriString of - Nothing -> fail $ "remote-repo: no parse on " ++ show uriString - Just uri -> return uri - - showSecure Nothing = mempty -- default 'secure' setting - showSecure (Just True) = text "True" -- user explicitly enabled it - showSecure (Just False) = text "False" -- user explicitly disabled it - - -- If the key-threshold is set to 0, we omit it as this is the default - -- and it looks odd to have a value for key-threshold but not for 'secure' - -- (note that an empty list of keys is already omitted by default, since - -- that is what we do for all list fields) - showThreshold 0 = mempty - showThreshold t = text (show t) - --- | Fields for the 'haddock' section. -haddockFlagsFields :: [FieldDescr HaddockFlags] -haddockFlagsFields = [ field - | opt <- haddockOptions ParseArgs - , let field = viewAsFieldDescr opt - name = fieldName field - , name `notElem` exclusions ] - where - exclusions = ["verbose", "builddir", "for-hackage"] - --- | Fields for the 'init' section. -initFlagsFields :: [FieldDescr IT.InitFlags] -initFlagsFields = [ field - | opt <- initOptions ParseArgs - , let field = viewAsFieldDescr opt - name = fieldName field - , name `notElem` exclusions ] - where - exclusions = - [ "author", "email", "quiet", "no-comments", "minimal", "overwrite" - , "package-dir", "packagedir", "package-name", "version", "homepage" - , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe" - , "simple", "main-is", "expose-module", "exposed-modules", "extension" - , "dependency", "build-tool", "with-compiler" - , "verbose" - ] - --- | Fields for the 'program-locations' section. -withProgramsFields :: [FieldDescr [(String, FilePath)]] -withProgramsFields = - map viewAsFieldDescr $ - programDbPaths' (++ "-location") defaultProgramDb - ParseArgs id (++) - --- | Fields for the 'program-default-options' section. -withProgramOptionsFields :: [FieldDescr [(String, [String])]] -withProgramOptionsFields = - map viewAsFieldDescr $ - programDbOptions defaultProgramDb ParseArgs id (++) - -parseExtraLines :: Verbosity -> [String] -> IO SavedConfig -parseExtraLines verbosity extraLines = - case parseConfig (ConstraintSourceMainConfig "additional lines") - mempty (unlines extraLines) of - ParseFailed err -> - let (line, msg) = locatedErrorMsg err - in die' verbosity $ - "Error parsing additional config lines\n" - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - ParseOk [] r -> return r - ParseOk ws _ -> - die' verbosity $ - unlines (map (showPWarning "Error parsing additional config lines") ws) - --- | Get the differences (as a pseudo code diff) between the user's --- '~/.cabal/config' and the one that cabal would generate if it didn't exist. -userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] -userConfigDiff verbosity globalFlags extraLines = do - userConfig <- loadRawConfig normal (globalConfigFile globalFlags) - extraConfig <- parseExtraLines verbosity extraLines - testConfig <- initialSavedConfig - return $ - reverse . foldl' createDiff [] . M.toList - $ M.unionWith combine - (M.fromList . map justFst $ filterShow testConfig) - (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) - where - justFst (a, b) = (a, (Just b, Nothing)) - justSnd (a, b) = (a, (Nothing, Just b)) - - combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b) - combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b) - combine x y = error $ "Can't happen : userConfigDiff " - ++ show x ++ " " ++ show y - - createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String] - createDiff acc (key, (Just a, Just b)) - | a == b = acc - | otherwise = ("+ " ++ key ++ ": " ++ b) - : ("- " ++ key ++ ": " ++ a) : acc - createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc - createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc - createDiff acc (_, (Nothing, Nothing)) = acc - - filterShow :: SavedConfig -> [(String, String)] - filterShow cfg = map keyValueSplit - . filter (\s -> not (null s) && ':' `elem` s) - . map nonComment - . lines - $ showConfig cfg - - nonComment [] = [] - nonComment ('-':'-':_) = [] - nonComment (x:xs) = x : nonComment xs - - topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace - - keyValueSplit s = - let (left, right) = break (== ':') s - in (topAndTail left, topAndTail (drop 1 right)) - - --- | Update the user's ~/.cabal/config' keeping the user's customizations. -userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () -userConfigUpdate verbosity globalFlags extraLines = do - userConfig <- loadRawConfig normal (globalConfigFile globalFlags) - extraConfig <- parseExtraLines verbosity extraLines - newConfig <- initialSavedConfig - commentConf <- commentSavedConfig - cabalFile <- getConfigFilePath $ globalConfigFile globalFlags - let backup = cabalFile ++ ".backup" - notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." - renameFile cabalFile backup - notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." - writeConfigFile cabalFile commentConf - (newConfig `mappend` userConfig `mappend` extraConfig) diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs deleted file mode 100644 --- a/Distribution/Client/Configure.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Configure --- Copyright : (c) David Himmelstrup 2005, --- Duncan Coutts 2005 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- High level interface to configuring a package. ------------------------------------------------------------------------------ -module Distribution.Client.Configure ( - configure, - configureSetupScript, - chooseCabalVersion, - checkConfigExFlags, - -- * Saved configure flags - readConfigFlagsFrom, readConfigFlags, - cabalConfigFlagsFile, - writeConfigFlagsTo, writeConfigFlags, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic (safeHead) - -import Distribution.Client.Dependency -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.Setup - ( ConfigExFlags(..), RepoContext(..) - , configureCommand, configureExCommand, filterConfigureFlags ) -import Distribution.Client.Types as Source -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.Targets - ( userToPackageConstraint, userConstraintPackageName ) -import Distribution.Client.JobControl (Lock) - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageIndex - ( PackageIndex, elemByPackageName ) -import Distribution.Solver.Types.PkgConfigDb - (PkgConfigDb, readPkgConfigDb) -import Distribution.Solver.Types.SourcePackage - -import Distribution.Simple.Compiler - ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) -import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) -import Distribution.Simple.Setup - ( ConfigFlags(..) - , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) -import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, lookupPackageName ) -import Distribution.Package - ( Package(..), packageName, PackageId ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..), thisPackageVersionConstraint ) -import qualified Distribution.PackageDescription as PkgDesc -import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Version - ( Version, mkVersion, anyVersion, thisVersion - , VersionRange, orLaterVersion ) -import Distribution.Simple.Utils as Utils - ( warn, notice, debug, die' - , defaultPackageDesc ) -import Distribution.System - ( Platform ) - -import System.FilePath ( () ) - --- | Choose the Cabal version such that the setup scripts compiled against this --- version will support the given command-line flags. -chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange -chooseCabalVersion configExFlags maybeVersion = - maybe defaultVersionRange thisVersion maybeVersion - where - -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed - -- for '--allow-newer' to work. - allowNewer = isRelaxDeps - (maybe mempty unAllowNewer $ configAllowNewer configExFlags) - allowOlder = isRelaxDeps - (maybe mempty unAllowOlder $ configAllowOlder configExFlags) - - defaultVersionRange = if allowOlder || allowNewer - then orLaterVersion (mkVersion [1,19,2]) - else anyVersion - --- | Configure the package found in the local directory -configure :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> ConfigFlags - -> ConfigExFlags - -> [String] - -> IO () -configure verbosity packageDBs repoCtxt comp platform progdb - configFlags configExFlags extraArgs = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb - - checkConfigExFlags verbosity installedPkgIndex - (packageIndex sourcePkgDb) configExFlags - - progress <- planLocalPackage verbosity comp platform configFlags configExFlags - installedPkgIndex sourcePkgDb pkgConfigDb - - notice verbosity "Resolving dependencies..." - maybePlan <- foldProgress logMsg (return . Left) (return . Right) - progress - case maybePlan of - Left message -> do - warn verbosity $ - "solver failed to find a solution:\n" - ++ message - ++ "\nTrying configure anyway." - setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) - Nothing configureCommand (const configFlags) (const extraArgs) - - Right installPlan0 -> - let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 - in case fst (InstallPlan.ready installPlan) of - [pkg@(ReadyPackage - (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _) - _ _ _))] -> do - configurePackage verbosity - platform (compilerInfo comp) - (setupScriptOptions installedPkgIndex (Just pkg)) - configFlags pkg extraArgs - - _ -> die' verbosity $ "internal error: configure install plan should have exactly " - ++ "one local ready package." - - where - setupScriptOptions :: InstalledPackageIndex - -> Maybe ReadyPackage - -> SetupScriptOptions - setupScriptOptions = - configureSetupScript - packageDBs - comp - platform - progdb - (fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags)) - (chooseCabalVersion - configExFlags - (flagToMaybe (configCabalVersion configExFlags))) - Nothing - False - - logMsg message rest = debug verbosity message >> rest - -configureSetupScript :: PackageDBStack - -> Compiler - -> Platform - -> ProgramDb - -> FilePath - -> VersionRange - -> Maybe Lock - -> Bool - -> InstalledPackageIndex - -> Maybe ReadyPackage - -> SetupScriptOptions -configureSetupScript packageDBs - comp - platform - progdb - distPref - cabalVersion - lock - forceExternal - index - mpkg - = SetupScriptOptions { - useCabalVersion = cabalVersion - , useCabalSpecVersion = Nothing - , useCompiler = Just comp - , usePlatform = Just platform - , usePackageDB = packageDBs' - , usePackageIndex = index' - , useProgramDb = progdb - , useDistPref = distPref - , useLoggingHandle = Nothing - , useWorkingDir = Nothing - , useExtraPathEnv = [] - , useExtraEnvOverrides = [] - , setupCacheLock = lock - , useWin32CleanHack = False - , forceExternalSetupMethod = forceExternal - -- If we have explicit setup dependencies, list them; otherwise, we give - -- the empty list of dependencies; ideally, we would fix the version of - -- Cabal here, so that we no longer need the special case for that in - -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet - -- know the version of Cabal at this point, but only find this there. - -- Therefore, for now, we just leave this blank. - , useDependencies = fromMaybe [] explicitSetupDeps - , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps - , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps - , isInteractive = False - } - where - -- When we are compiling a legacy setup script without an explicit - -- setup stanza, we typically want to allow the UserPackageDB for - -- finding the Cabal lib when compiling any Setup.hs even if we're doing - -- a global install. However we also allow looking in a specific package - -- db. - packageDBs' :: PackageDBStack - index' :: Maybe InstalledPackageIndex - (packageDBs', index') = - case packageDBs of - (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs - , Nothing <- explicitSetupDeps - -> (GlobalPackageDB:UserPackageDB:dbs, Nothing) - -- but if the user is using an odd db stack, don't touch it - _otherwise -> (packageDBs, Just index) - - maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo - maybeSetupBuildInfo = do - ReadyPackage cpkg <- mpkg - let gpkg = srcpkgDescription (confPkgSource cpkg) - PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg) - - -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If - -- so, 'setup-depends' must not be exclusive. See #3199. - defaultSetupDeps :: Bool - defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends - maybeSetupBuildInfo - - explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)] - explicitSetupDeps = do - -- Check if there is an explicit setup stanza. - _buildInfo <- maybeSetupBuildInfo - -- Return the setup dependencies computed by the solver - ReadyPackage cpkg <- mpkg - return [ ( cid, srcid ) - | ConfiguredId srcid - (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid - <- CD.setupDeps (confPkgDeps cpkg) - ] - --- | Warn if any constraints or preferences name packages that are not in the --- source package index or installed package index. -checkConfigExFlags :: Package pkg - => Verbosity - -> InstalledPackageIndex - -> PackageIndex pkg - -> ConfigExFlags - -> IO () -checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do - for_ (safeHead unknownConstraints) $ \h -> - warn verbosity $ "Constraint refers to an unknown package: " - ++ showConstraint h - for_ (safeHead unknownPreferences) $ \h -> - warn verbosity $ "Preference refers to an unknown package: " - ++ prettyShow h - where - unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ - configExConstraints flags - unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $ - configPreferences flags - unknown pkg = null (lookupPackageName installedPkgIndex pkg) - && not (elemByPackageName sourcePkgIndex pkg) - showConstraint (uc, src) = - prettyShow uc ++ " (" ++ showConstraintSource src ++ ")" - --- | Make an 'InstallPlan' for the unpacked package in the current directory, --- and all its dependencies. --- -planLocalPackage :: Verbosity -> Compiler - -> Platform - -> ConfigFlags -> ConfigExFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> IO (Progress String String SolverInstallPlan) -planLocalPackage verbosity comp platform configFlags configExFlags - installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do - pkg <- readGenericPackageDescription verbosity =<< - case flagToMaybe (configCabalFilePath configFlags) of - Nothing -> defaultPackageDesc verbosity - Just fp -> return fp - solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) - (compilerInfo comp) - - let -- We create a local package and ask to resolve a dependency on it - localPkg = SourcePackage { - srcpkgPackageId = packageId pkg, - srcpkgDescription = pkg, - srcpkgSource = LocalUnpackedPackage ".", - srcpkgDescrOverride = Nothing - } - - testsEnabled = fromFlagOrDefault False $ configTests configFlags - benchmarksEnabled = - fromFlagOrDefault False $ configBenchmarks configFlags - - resolverParams = - removeLowerBounds - (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags) - . removeUpperBounds - (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags) - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- configPreferences configExFlags ] - - . addConstraints - -- version constraints from the config file or command line - -- TODO: should warn or error on constraints that are not on direct - -- deps or flag constraints not on the package in question. - [ LabeledPackageConstraint (userToPackageConstraint uc) src - | (uc, src) <- configExConstraints configExFlags ] - - . addConstraints - -- package flags from the config file or command line - [ let pc = PackageConstraint - (scopeToplevel $ packageName pkg) - (PackagePropertyFlags $ configConfigurationsFlags configFlags) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - ] - - . addConstraints - -- '--enable-tests' and '--enable-benchmarks' constraints from - -- the config file or command line - [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) . - PackagePropertyStanzas $ - [ TestStanzas | testsEnabled ] ++ - [ BenchStanzas | benchmarksEnabled ] - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - ] - - -- Don't solve for executables, since we use an empty source - -- package database and executables never show up in the - -- installed package index - . setSolveExecutables (SolveExecutables False) - - . setSolverVerbosity verbosity - - $ standardInstallPolicy - installedPkgIndex - -- NB: We pass in an *empty* source package database, - -- because cabal configure assumes that all dependencies - -- have already been installed - (SourcePackageDb mempty packagePrefs) - [SpecificSourcePackage localPkg] - - return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams) - - --- | Call an installer for an 'SourcePackage' but override the configure --- flags with the ones given by the 'ReadyPackage'. In particular the --- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly --- versioned package dependencies. So we ignore any previous partial flag --- assignment or dependency constraints and use the new ones. --- --- NB: when updating this function, don't forget to also update --- 'installReadyPackage' in D.C.Install. -configurePackage :: Verbosity - -> Platform -> CompilerInfo - -> SetupScriptOptions - -> ConfigFlags - -> ReadyPackage - -> [String] - -> IO () -configurePackage verbosity platform comp scriptOptions configFlags - (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps)) - extraArgs = - - setupWrapper verbosity - scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs) - - where - gpkg = srcpkgDescription spkg - configureFlags = filterConfigureFlags configFlags { - configIPID = if isJust (flagToMaybe (configIPID configFlags)) - -- Make sure cabal configure --ipid works. - then configIPID configFlags - else toFlag (prettyShow ipid), - configConfigurationsFlags = flags, - -- We generate the legacy constraints as well as the new style precise - -- deps. In the end only one set gets passed to Setup.hs configure, - -- depending on the Cabal version we are talking to. - configConstraints = [ thisPackageVersionConstraint srcid - | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid - <- CD.nonSetupDeps deps ], - configDependencies = [ GivenComponent (packageName srcid) cname uid - | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid - <- CD.nonSetupDeps deps ], - -- Use '--exact-configuration' if supported. - configExactConfiguration = toFlag True, - configVerbosity = toFlag verbosity, - -- NB: if the user explicitly specified - -- --enable-tests/--enable-benchmarks, always respect it. - -- (But if they didn't, let solver decide.) - configBenchmarks = toFlag (BenchStanzas `elem` stanzas) - `mappend` configBenchmarks configFlags, - configTests = toFlag (TestStanzas `elem` stanzas) - `mappend` configTests configFlags - } - - pkg = case finalizePD flags (enableStanzas stanzas) - (const True) - platform comp [] gpkg of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc - --- ----------------------------------------------------------------------------- --- * Saved configure environments and flags --- ----------------------------------------------------------------------------- - --- | Read saved configure flags and restore the saved environment from the --- specified files. -readConfigFlagsFrom :: FilePath -- ^ path to saved flags file - -> IO (ConfigFlags, ConfigExFlags) -readConfigFlagsFrom flags = do - readCommandFlags flags configureExCommand - --- | The path (relative to @--build-dir@) where the arguments to @configure@ --- should be saved. -cabalConfigFlagsFile :: FilePath -> FilePath -cabalConfigFlagsFile dist = dist "cabal-config-flags" - --- | Read saved configure flags and restore the saved environment from the --- usual location. -readConfigFlags :: FilePath -- ^ @--build-dir@ - -> IO (ConfigFlags, ConfigExFlags) -readConfigFlags dist = - readConfigFlagsFrom (cabalConfigFlagsFile dist) - --- | Save the configure flags and environment to the specified files. -writeConfigFlagsTo :: FilePath -- ^ path to saved flags file - -> Verbosity -> (ConfigFlags, ConfigExFlags) - -> IO () -writeConfigFlagsTo file verb flags = do - writeCommandFlags verb file configureExCommand flags - --- | Save the build flags to the usual location. -writeConfigFlags :: Verbosity - -> FilePath -- ^ @--build-dir@ - -> (ConfigFlags, ConfigExFlags) -> IO () -writeConfigFlags verb dist = - writeConfigFlagsTo (cabalConfigFlagsFile dist) verb diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs deleted file mode 100644 --- a/Distribution/Client/Dependency.hs +++ /dev/null @@ -1,1053 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007 --- Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Top level interface to dependency resolution. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency ( - -- * The main package dependency resolver - chooseSolver, - resolveDependencies, - Progress(..), - foldProgress, - - -- * Alternate, simple resolver that does not do dependencies recursively - resolveWithoutDependencies, - - -- * Constructing resolver policies - PackageProperty(..), - PackageConstraint(..), - scopeToplevel, - PackagesPreferenceDefault(..), - PackagePreference(..), - - -- ** Standard policy - basicInstallPolicy, - standardInstallPolicy, - PackageSpecifier(..), - - -- ** Extra policy options - upgradeDependencies, - reinstallTargets, - - -- ** Policy utils - addConstraints, - addPreferences, - setPreferenceDefault, - setReorderGoals, - setCountConflicts, - setFineGrainedConflicts, - setMinimizeConflictSet, - setIndependentGoals, - setAvoidReinstalls, - setShadowPkgs, - setStrongFlags, - setAllowBootLibInstalls, - setOnlyConstrained, - setMaxBackjumps, - setEnableBackjumping, - setSolveExecutables, - setGoalOrder, - setSolverVerbosity, - removeLowerBounds, - removeUpperBounds, - addDefaultSetupDependencies, - addSetupCabalMinVersionConstraint, - addSetupCabalMaxVersionConstraint, - ) where - -import Distribution.Client.Compat.Prelude -import qualified Prelude as Unsafe (head) - -import Distribution.Solver.Modular - ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Types - ( SourcePackageDb(SourcePackageDb) - , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints - , UnresolvedPkgLoc, UnresolvedSourcePackage - , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..) - , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps - ) -import Distribution.Client.Dependency.Types - ( PreSolver(..), Solver(..) - , PackagesPreferenceDefault(..) ) -import Distribution.Package - ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId - , Package(..), packageName, packageVersion ) -import Distribution.Types.Dependency -import qualified Distribution.PackageDescription as PD -import qualified Distribution.PackageDescription.Configuration as PD -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Compiler - ( CompilerInfo(..) ) -import Distribution.System - ( Platform ) -import Distribution.Client.Utils - ( duplicatesBy, mergeBy, MergeResult(..) ) -import Distribution.Simple.Setup - ( asBool ) -import Distribution.Verbosity - ( normal ) -import Distribution.Version -import qualified Distribution.Compat.Graph as Graph - -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.DependencyResolver -import Distribution.Solver.Types.InstalledPreference -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences -import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) -import Distribution.Solver.Types.Progress -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Variable - -import Data.List - ( maximumBy ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Exception - ( assert ) - - --- ------------------------------------------------------------ --- * High level planner policy --- ------------------------------------------------------------ - --- | The set of parameters to the dependency resolver. These parameters are --- relatively low level but many kinds of high level policies can be --- implemented in terms of adjustments to the parameters. --- -data DepResolverParams = DepResolverParams { - depResolverTargets :: Set PackageName, - depResolverConstraints :: [LabeledPackageConstraint], - depResolverPreferences :: [PackagePreference], - depResolverPreferenceDefault :: PackagesPreferenceDefault, - depResolverInstalledPkgIndex :: InstalledPackageIndex, - depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, - depResolverReorderGoals :: ReorderGoals, - depResolverCountConflicts :: CountConflicts, - depResolverFineGrainedConflicts :: FineGrainedConflicts, - depResolverMinimizeConflictSet :: MinimizeConflictSet, - depResolverIndependentGoals :: IndependentGoals, - depResolverAvoidReinstalls :: AvoidReinstalls, - depResolverShadowPkgs :: ShadowPkgs, - depResolverStrongFlags :: StrongFlags, - - -- | Whether to allow base and its dependencies to be installed. - depResolverAllowBootLibInstalls :: AllowBootLibInstalls, - - -- | Whether to only allow explicitly constrained packages plus - -- goals or to allow any package. - depResolverOnlyConstrained :: OnlyConstrained, - - depResolverMaxBackjumps :: Maybe Int, - depResolverEnableBackjumping :: EnableBackjumping, - -- | Whether or not to solve for dependencies on executables. - -- This should be true, except in the legacy code path where - -- we can't tell if an executable has been installed or not, - -- so we shouldn't solve for them. See #3875. - depResolverSolveExecutables :: SolveExecutables, - - -- | Function to override the solver's goal-ordering heuristics. - depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), - depResolverVerbosity :: Verbosity - } - -showDepResolverParams :: DepResolverParams -> String -showDepResolverParams p = - "targets: " ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p)) - ++ "\nconstraints: " - ++ concatMap (("\n " ++) . showLabeledConstraint) - (depResolverConstraints p) - ++ "\npreferences: " - ++ concatMap (("\n " ++) . showPackagePreference) - (depResolverPreferences p) - ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) - ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p)) - ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p)) - ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p)) - ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p)) - ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) - ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) - ++ "\nshadow packages: " ++ show (asBool (depResolverShadowPkgs p)) - ++ "\nstrong flags: " ++ show (asBool (depResolverStrongFlags p)) - ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p)) - ++ "\nonly constrained packages: " ++ show (depResolverOnlyConstrained p) - ++ "\nmax backjumps: " ++ maybe "infinite" show - (depResolverMaxBackjumps p) - where - showLabeledConstraint :: LabeledPackageConstraint -> String - showLabeledConstraint (LabeledPackageConstraint pc src) = - showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" - --- | A package selection preference for a particular package. --- --- Preferences are soft constraints that the dependency resolver should try to --- respect where possible. It is not specified if preferences on some packages --- are more important than others. --- -data PackagePreference = - - -- | A suggested constraint on the version number. - PackageVersionPreference PackageName VersionRange - - -- | If we prefer versions of packages that are already installed. - | PackageInstalledPreference PackageName InstalledPreference - - -- | If we would prefer to enable these optional stanzas - -- (i.e. test suites and/or benchmarks) - | PackageStanzasPreference PackageName [OptionalStanza] - - --- | Provide a textual representation of a package preference --- for debugging purposes. --- -showPackagePreference :: PackagePreference -> String -showPackagePreference (PackageVersionPreference pn vr) = - prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr) -showPackagePreference (PackageInstalledPreference pn ip) = - prettyShow pn ++ " " ++ show ip -showPackagePreference (PackageStanzasPreference pn st) = - prettyShow pn ++ " " ++ show st - -basicDepResolverParams :: InstalledPackageIndex - -> PackageIndex.PackageIndex UnresolvedSourcePackage - -> DepResolverParams -basicDepResolverParams installedPkgIndex sourcePkgIndex = - DepResolverParams { - depResolverTargets = Set.empty, - depResolverConstraints = [], - depResolverPreferences = [], - depResolverPreferenceDefault = PreferLatestForSelected, - depResolverInstalledPkgIndex = installedPkgIndex, - depResolverSourcePkgIndex = sourcePkgIndex, - depResolverReorderGoals = ReorderGoals False, - depResolverCountConflicts = CountConflicts True, - depResolverFineGrainedConflicts = FineGrainedConflicts True, - depResolverMinimizeConflictSet = MinimizeConflictSet False, - depResolverIndependentGoals = IndependentGoals False, - depResolverAvoidReinstalls = AvoidReinstalls False, - depResolverShadowPkgs = ShadowPkgs False, - depResolverStrongFlags = StrongFlags False, - depResolverAllowBootLibInstalls = AllowBootLibInstalls False, - depResolverOnlyConstrained = OnlyConstrainedNone, - depResolverMaxBackjumps = Nothing, - depResolverEnableBackjumping = EnableBackjumping True, - depResolverSolveExecutables = SolveExecutables True, - depResolverGoalOrder = Nothing, - depResolverVerbosity = normal - } - -addTargets :: [PackageName] - -> DepResolverParams -> DepResolverParams -addTargets extraTargets params = - params { - depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params - } - -addConstraints :: [LabeledPackageConstraint] - -> DepResolverParams -> DepResolverParams -addConstraints extraConstraints params = - params { - depResolverConstraints = extraConstraints - ++ depResolverConstraints params - } - -addPreferences :: [PackagePreference] - -> DepResolverParams -> DepResolverParams -addPreferences extraPreferences params = - params { - depResolverPreferences = extraPreferences - ++ depResolverPreferences params - } - -setPreferenceDefault :: PackagesPreferenceDefault - -> DepResolverParams -> DepResolverParams -setPreferenceDefault preferenceDefault params = - params { - depResolverPreferenceDefault = preferenceDefault - } - -setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams -setReorderGoals reorder params = - params { - depResolverReorderGoals = reorder - } - -setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams -setCountConflicts count params = - params { - depResolverCountConflicts = count - } - -setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams -setFineGrainedConflicts fineGrained params = - params { - depResolverFineGrainedConflicts = fineGrained - } - -setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams -setMinimizeConflictSet minimize params = - params { - depResolverMinimizeConflictSet = minimize - } - -setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams -setIndependentGoals indep params = - params { - depResolverIndependentGoals = indep - } - -setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams -setAvoidReinstalls avoid params = - params { - depResolverAvoidReinstalls = avoid - } - -setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams -setShadowPkgs shadow params = - params { - depResolverShadowPkgs = shadow - } - -setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams -setStrongFlags sf params = - params { - depResolverStrongFlags = sf - } - -setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams -setAllowBootLibInstalls i params = - params { - depResolverAllowBootLibInstalls = i - } - -setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams -setOnlyConstrained i params = - params { - depResolverOnlyConstrained = i - } - -setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams -setMaxBackjumps n params = - params { - depResolverMaxBackjumps = n - } - -setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams -setEnableBackjumping b params = - params { - depResolverEnableBackjumping = b - } - -setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams -setSolveExecutables b params = - params { - depResolverSolveExecutables = b - } - -setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) - -> DepResolverParams - -> DepResolverParams -setGoalOrder order params = - params { - depResolverGoalOrder = order - } - -setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams -setSolverVerbosity verbosity params = - params { - depResolverVerbosity = verbosity - } - --- | Some packages are specific to a given compiler version and should never be --- upgraded. -dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams -dontUpgradeNonUpgradeablePackages params = - addConstraints extraConstraints params - where - extraConstraints = - [ LabeledPackageConstraint - (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) - ConstraintSourceNonUpgradeablePackage - | Set.notMember (mkPackageName "base") (depResolverTargets params) - -- If you change this enumeration, make sure to update the list in - -- "Distribution.Solver.Modular.Solver" as well - , pkgname <- [ mkPackageName "base" - , mkPackageName "ghc-bignum" - , mkPackageName "ghc-prim" - , mkPackageName "integer-gmp" - , mkPackageName "integer-simple" - , mkPackageName "template-haskell" - ] - , isInstalled pkgname ] - - isInstalled = not . null - . InstalledPackageIndex.lookupPackageName - (depResolverInstalledPkgIndex params) - -addSourcePackages :: [UnresolvedSourcePackage] - -> DepResolverParams -> DepResolverParams -addSourcePackages pkgs params = - params { - depResolverSourcePkgIndex = - foldl (flip PackageIndex.insert) - (depResolverSourcePkgIndex params) pkgs - } - -hideInstalledPackagesSpecificBySourcePackageId :: [PackageId] - -> DepResolverParams - -> DepResolverParams -hideInstalledPackagesSpecificBySourcePackageId pkgids params = - --TODO: this should work using exclude constraints instead - params { - depResolverInstalledPkgIndex = - foldl' (flip InstalledPackageIndex.deleteSourcePackageId) - (depResolverInstalledPkgIndex params) pkgids - } - -hideInstalledPackagesAllVersions :: [PackageName] - -> DepResolverParams -> DepResolverParams -hideInstalledPackagesAllVersions pkgnames params = - --TODO: this should work using exclude constraints instead - params { - depResolverInstalledPkgIndex = - foldl' (flip InstalledPackageIndex.deletePackageName) - (depResolverInstalledPkgIndex params) pkgnames - } - - --- | Remove upper bounds in dependencies using the policy specified by the --- 'AllowNewer' argument (all/some/none). --- --- Note: It's important to apply 'removeUpperBounds' after --- 'addSourcePackages'. Otherwise, the packages inserted by --- 'addSourcePackages' won't have upper bounds in dependencies relaxed. --- -removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams -removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps - --- | Dual of 'removeUpperBounds' -removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams -removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps - -data RelaxKind = RelaxLower | RelaxUpper - --- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds' -removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams -removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation -removeBounds relKind relDeps params = - params { - depResolverSourcePkgIndex = sourcePkgIndex' - } - where - sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params - - relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage - relaxDeps srcPkg = srcPkg - { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg) - } - --- | Relax the dependencies of this package if needed. --- --- Helper function used by 'removeBounds' -relaxPackageDeps :: RelaxKind - -> RelaxDeps - -> PD.GenericPackageDescription -> PD.GenericPackageDescription -relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds' -relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd - where - relaxAll :: Dependency -> Dependency - relaxAll (Dependency pkgName verRange cs) = - Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs - -relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd = - PD.transformAllBuildDepends relaxSome gpd - where - thisPkgName = packageName gpd - thisPkgId = packageId gpd - depsToRelax = Map.fromList $ mapMaybe f depsToRelax0 - - f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod) - f (RelaxedDep scope rdm p) = case scope of - RelaxDepScopeAll -> Just (p,rdm) - RelaxDepScopePackage p0 - | p0 == thisPkgName -> Just (p,rdm) - | otherwise -> Nothing - RelaxDepScopePackageId p0 - | p0 == thisPkgId -> Just (p,rdm) - | otherwise -> Nothing - - relaxSome :: Dependency -> Dependency - relaxSome d@(Dependency depName verRange cs) - | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = - -- a '*'-subject acts absorbing, for consistency with - -- the 'Semigroup RelaxDeps' instance - Dependency depName (removeBound relKind relMod verRange) cs - | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = - Dependency depName (removeBound relKind relMod verRange) cs - | otherwise = d -- no-op - --- | Internal helper for 'relaxPackageDeps' -removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange -removeBound RelaxLower RelaxDepModNone = removeLowerBound -removeBound RelaxUpper RelaxDepModNone = removeUpperBound -removeBound relKind RelaxDepModCaret = hyloVersionRange embed projectVersionRange - where - embed (MajorBoundVersionF v) = caretTransformation v (majorUpperBound v) - embed vr = embedVersionRange vr - - -- This function is the interesting part as it defines the meaning - -- of 'RelaxDepModCaret', i.e. to transform only @^>=@ constraints; - caretTransformation l u = case relKind of - RelaxUpper -> orLaterVersion l -- rewrite @^>= x.y.z@ into @>= x.y.z@ - RelaxLower -> earlierVersion u -- rewrite @^>= x.y.z@ into @< x.(y+1)@ - --- | Supply defaults for packages without explicit Setup dependencies --- --- Note: It's important to apply 'addDefaultSetupDepends' after --- 'addSourcePackages'. Otherwise, the packages inserted by --- 'addSourcePackages' won't have upper bounds in dependencies relaxed. --- -addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency]) - -> DepResolverParams -> DepResolverParams -addDefaultSetupDependencies defaultSetupDeps params = - params { - depResolverSourcePkgIndex = - fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params) - } - where - applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage - applyDefaultSetupDeps srcpkg = - srcpkg { - srcpkgDescription = gpkgdesc { - PD.packageDescription = pkgdesc { - PD.setupBuildInfo = - case PD.setupBuildInfo pkgdesc of - Just sbi -> Just sbi - Nothing -> case defaultSetupDeps srcpkg of - Nothing -> Nothing - Just deps | isCustom -> Just PD.SetupBuildInfo { - PD.defaultSetupDepends = True, - PD.setupDepends = deps - } - | otherwise -> Nothing - } - } - } - where - isCustom = PD.buildType pkgdesc == PD.Custom - gpkgdesc = srcpkgDescription srcpkg - pkgdesc = PD.packageDescription gpkgdesc - --- | If a package has a custom setup then we need to add a setup-depends --- on Cabal. --- -addSetupCabalMinVersionConstraint :: Version - -> DepResolverParams -> DepResolverParams -addSetupCabalMinVersionConstraint minVersion = - addConstraints - [ LabeledPackageConstraint - (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) - (PackagePropertyVersion $ orLaterVersion minVersion)) - ConstraintSetupCabalMinVersion - ] - where - cabalPkgname = mkPackageName "Cabal" - --- | Variant of 'addSetupCabalMinVersionConstraint' which sets an --- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'. --- -addSetupCabalMaxVersionConstraint :: Version - -> DepResolverParams -> DepResolverParams -addSetupCabalMaxVersionConstraint maxVersion = - addConstraints - [ LabeledPackageConstraint - (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) - (PackagePropertyVersion $ earlierVersion maxVersion)) - ConstraintSetupCabalMaxVersion - ] - where - cabalPkgname = mkPackageName "Cabal" - - -upgradeDependencies :: DepResolverParams -> DepResolverParams -upgradeDependencies = setPreferenceDefault PreferAllLatest - - -reinstallTargets :: DepResolverParams -> DepResolverParams -reinstallTargets params = - hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params - - --- | A basic solver policy on which all others are built. --- -basicInstallPolicy :: InstalledPackageIndex - -> SourcePackageDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> DepResolverParams -basicInstallPolicy - installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) - pkgSpecifiers - - = addPreferences - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList sourcePkgPrefs ] - - . addConstraints - (concatMap pkgSpecifierConstraints pkgSpecifiers) - - . addTargets - (map pkgSpecifierTarget pkgSpecifiers) - - . hideInstalledPackagesSpecificBySourcePackageId - [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] - - . addSourcePackages - [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] - - $ basicDepResolverParams - installedPkgIndex sourcePkgIndex - - --- | The policy used by all the standard commands, install, fetch, freeze etc --- (but not the v2-build and related commands). --- --- It extends the 'basicInstallPolicy' with a policy on setup deps. --- -standardInstallPolicy :: InstalledPackageIndex - -> SourcePackageDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> DepResolverParams -standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - - = addDefaultSetupDependencies mkDefaultSetupDeps - - $ basicInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers - - where - -- Force Cabal >= 1.24 dep when the package is affected by #3199. - mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] - mkDefaultSetupDeps srcpkg | affected = - Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet] - | otherwise = Nothing - where - gpkgdesc = srcpkgDescription srcpkg - pkgdesc = PD.packageDescription gpkgdesc - bt = PD.buildType pkgdesc - affected = bt == PD.Custom && hasBuildableFalse gpkgdesc - - -- Does this package contain any components with non-empty 'build-depends' - -- and a 'buildable' field that could potentially be set to 'False'? False - -- positives are possible. - hasBuildableFalse :: PD.GenericPackageDescription -> Bool - hasBuildableFalse gpkg = - not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions)) - where - buildableConditions = PD.extractConditions PD.buildable gpkg - noDepConditions = PD.extractConditions - (null . PD.targetBuildDepends) gpkg - alwaysTrue (PD.Lit True) = True - alwaysTrue _ = False - --- ------------------------------------------------------------ --- * Interface to the standard resolver --- ------------------------------------------------------------ - -chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver -chooseSolver _verbosity preSolver _cinfo = - case preSolver of - AlwaysModular -> do - return Modular - -runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc -runSolver Modular = modularResolver - --- | Run the dependency solver. --- --- Since this is potentially an expensive operation, the result is wrapped in a --- a 'Progress' structure that can be unfolded to provide progress information, --- logging messages and the final result or an error. --- -resolveDependencies :: Platform - -> CompilerInfo - -> PkgConfigDb - -> Solver - -> DepResolverParams - -> Progress String String SolverInstallPlan - - --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages -resolveDependencies platform comp _pkgConfigDB _solver params - | Set.null (depResolverTargets params) - = return (validateSolverResult platform comp indGoals []) - where - indGoals = depResolverIndependentGoals params - -resolveDependencies platform comp pkgConfigDB solver params = - - Step (showDepResolverParams finalparams) - $ fmap (validateSolverResult platform comp indGoals) - $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize - indGoals noReinstalls - shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj - solveExes order verbosity (PruneAfterFirstSuccess False)) - platform comp installedPkgIndex sourcePkgIndex - pkgConfigDB preferences constraints targets - where - - finalparams@(DepResolverParams - targets constraints - prefs defpref - installedPkgIndex - sourcePkgIndex - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - allowBootLibs - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity) = - if asBool (depResolverAllowBootLibInstalls params) - then params - else dontUpgradeNonUpgradeablePackages params - - preferences = interpretPackagesPreference targets defpref prefs - - --- | Give an interpretation to the global 'PackagesPreference' as --- specific per-package 'PackageVersionPreference'. --- -interpretPackagesPreference :: Set PackageName - -> PackagesPreferenceDefault - -> [PackagePreference] - -> (PackageName -> PackagePreferences) -interpretPackagesPreference selected defaultPref prefs = - \pkgname -> PackagePreferences (versionPref pkgname) - (installPref pkgname) - (stanzasPref pkgname) - where - versionPref pkgname = - fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs) - versionPrefs = Map.fromListWith (++) - [(pkgname, [pref]) - | PackageVersionPreference pkgname pref <- prefs] - - installPref pkgname = - fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) - installPrefs = Map.fromList - [ (pkgname, pref) - | PackageInstalledPreference pkgname pref <- prefs ] - installPrefDefault = case defaultPref of - PreferAllLatest -> const PreferLatest - PreferAllInstalled -> const PreferInstalled - PreferLatestForSelected -> \pkgname -> - -- When you say cabal install foo, what you really mean is, prefer the - -- latest version of foo, but the installed version of everything else - if pkgname `Set.member` selected then PreferLatest - else PreferInstalled - - stanzasPref pkgname = - fromMaybe [] (Map.lookup pkgname stanzasPrefs) - stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b)) - [ (pkgname, pref) - | PackageStanzasPreference pkgname pref <- prefs ] - - --- ------------------------------------------------------------ --- * Checking the result of the solver --- ------------------------------------------------------------ - --- | Make an install plan from the output of the dep resolver. --- It checks that the plan is valid, or it's an error in the dep resolver. --- -validateSolverResult :: Platform - -> CompilerInfo - -> IndependentGoals - -> [ResolverPackage UnresolvedPkgLoc] - -> SolverInstallPlan -validateSolverResult platform comp indepGoals pkgs = - case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals graph of - Right plan -> plan - Left problems -> error (formatPlanProblems problems) - problems -> error (formatPkgProblems problems) - - where - graph = Graph.fromDistinctList pkgs - - formatPkgProblems = formatProblemMessage . map showPlanPackageProblem - formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem - - formatProblemMessage problems = - unlines $ - "internal error: could not construct a valid install plan." - : "The proposed (invalid) plan contained the following problems:" - : problems - ++ "Proposed plan:" - : [SolverInstallPlan.showPlanIndex pkgs] - - -data PlanPackageProblem = - InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) - [PackageProblem] - | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc] - -showPlanPackageProblem :: PlanPackageProblem -> String -showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) = - "Package " ++ prettyShow (packageId pkg) - ++ " has an invalid configuration, in particular:\n" - ++ unlines [ " " ++ showPackageProblem problem - | problem <- packageProblems ] -showPlanPackageProblem (DuplicatePackageSolverId pid dups) = - "Package " ++ prettyShow (packageId pid) ++ " has " - ++ show (length dups) ++ " duplicate instances." - -planPackagesProblems :: Platform -> CompilerInfo - -> [ResolverPackage UnresolvedPkgLoc] - -> [PlanPackageProblem] -planPackagesProblems platform cinfo pkgs = - [ InvalidConfiguredPackage pkg packageProblems - | Configured pkg <- pkgs - , let packageProblems = configuredPackageProblems platform cinfo pkg - , not (null packageProblems) ] - ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups - | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ] - -data PackageProblem = DuplicateFlag PD.FlagName - | MissingFlag PD.FlagName - | ExtraFlag PD.FlagName - | DuplicateDeps [PackageId] - | MissingDep Dependency - | ExtraDep PackageId - | InvalidDep Dependency PackageId - -showPackageProblem :: PackageProblem -> String -showPackageProblem (DuplicateFlag flag) = - "duplicate flag in the flag assignment: " ++ PD.unFlagName flag - -showPackageProblem (MissingFlag flag) = - "missing an assignment for the flag: " ++ PD.unFlagName flag - -showPackageProblem (ExtraFlag flag) = - "extra flag given that is not used by the package: " ++ PD.unFlagName flag - -showPackageProblem (DuplicateDeps pkgids) = - "duplicate packages specified as selected dependencies: " - ++ intercalate ", " (map prettyShow pkgids) - -showPackageProblem (MissingDep dep) = - "the package has a dependency " ++ prettyShow dep - ++ " but no package has been selected to satisfy it." - -showPackageProblem (ExtraDep pkgid) = - "the package configuration specifies " ++ prettyShow pkgid - ++ " but (with the given flag assignment) the package does not actually" - ++ " depend on any version of that package." - -showPackageProblem (InvalidDep dep pkgid) = - "the package depends on " ++ prettyShow dep - ++ " but the configuration specifies " ++ prettyShow pkgid - ++ " which does not satisfy the dependency." - --- | A 'ConfiguredPackage' is valid if the flag assignment is total and if --- in the configuration given by the flag assignment, all the package --- dependencies are satisfied by the specified packages. --- -configuredPackageProblems :: Platform -> CompilerInfo - -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] -configuredPackageProblems platform cinfo - (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = - [ DuplicateFlag flag - | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] - ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] - ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] - ++ [ DuplicateDeps pkgs - | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName)) - specifiedDeps1) ] - ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] - ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] - ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps - , not (packageSatisfiesDependency pkgid dep) ] - -- TODO: sanity tests on executable deps - where - thisPkgName = packageName (srcpkgDescription pkg) - - specifiedDeps1 :: ComponentDeps [PackageId] - specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0 - - specifiedDeps :: [PackageId] - specifiedDeps = CD.flatDeps specifiedDeps1 - - mergedFlags = mergeBy compare - (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg))) - (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO - - packageSatisfiesDependency - (PackageIdentifier name version) - (Dependency name' versionRange _) = assert (name == name') $ - version `withinRange` versionRange - - dependencyName (Dependency name _ _) = name - - mergedDeps :: [MergeResult Dependency PackageId] - mergedDeps = mergeDeps requiredDeps specifiedDeps - - mergeDeps :: [Dependency] -> [PackageId] - -> [MergeResult Dependency PackageId] - mergeDeps required specified = - let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in - mergeBy - (\dep pkgid -> dependencyName dep `compare` packageName pkgid) - (sortNubOn dependencyName required) - (sortNubOn packageName specified) - - compSpec = enableStanzas stanzas - -- TODO: It would be nicer to use ComponentDeps here so we can be more - -- precise in our checks. In fact, this no longer relies on buildDepends and - -- thus should be easier to fix. As long as we _do_ use a flat list here, we - -- have to allow for duplicates when we fold specifiedDeps; once we have - -- proper ComponentDeps here we should get rid of the `nubOn` in - -- `mergeDeps`. - requiredDeps :: [Dependency] - requiredDeps = - --TODO: use something lower level than finalizePD - case finalizePD specifiedFlags - compSpec - (const True) - platform cinfo - [] - (srcpkgDescription pkg) of - Right (resolvedPkg, _) -> - -- we filter self/internal dependencies. They are still there. - -- This is INCORRECT. - -- - -- If we had per-component solver, it would make this unnecessary, - -- but no finalizePDs picks components we are not building, eg. exes. - -- See #3775 - -- - filter ((/= thisPkgName) . dependencyName) - (PD.enabledBuildDepends resolvedPkg compSpec) - ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg) - Left _ -> - error "configuredPackageInvalidDeps internal error" - - --- ------------------------------------------------------------ --- * Simple resolver that ignores dependencies --- ------------------------------------------------------------ - --- | A simplistic method of resolving a list of target package names to --- available packages. --- --- Specifically, it does not consider package dependencies at all. Unlike --- 'resolveDependencies', no attempt is made to ensure that the selected --- packages have dependencies that are satisfiable or consistent with --- each other. --- --- It is suitable for tasks such as selecting packages to download for user --- inspection. It is not suitable for selecting packages to install. --- --- Note: if no installed package index is available, it is OK to pass 'mempty'. --- It simply means preferences for installed packages will be ignored. --- -resolveWithoutDependencies :: DepResolverParams - -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] -resolveWithoutDependencies (DepResolverParams targets constraints - prefs defpref installedPkgIndex sourcePkgIndex - _reorderGoals _countConflicts _fineGrained - _minimizeConflictSet _indGoals _avoidReinstalls - _shadowing _strFlags _maxBjumps _enableBj _solveExes - _allowBootLibInstalls _onlyConstrained _order _verbosity) = - collectEithers $ map selectPackage (Set.toList targets) - where - selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage - selectPackage pkgname - | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions - | otherwise = Right $! maximumBy bestByPrefs choices - - where - -- Constraints - requiredVersions = packageConstraints pkgname - choices = PackageIndex.lookupDependency sourcePkgIndex - pkgname - requiredVersions - - -- Preferences - PackagePreferences preferredVersions preferInstalled _ - = packagePreferences pkgname - - bestByPrefs = comparing $ \pkg -> - (installPref pkg, versionPref pkg, packageVersion pkg) - installPref = case preferInstalled of - PreferLatest -> const False - PreferInstalled -> not . null - . InstalledPackageIndex.lookupSourcePackageId - installedPkgIndex - . packageId - versionPref pkg = length . filter (packageVersion pkg `withinRange`) $ - preferredVersions - - packageConstraints :: PackageName -> VersionRange - packageConstraints pkgname = - Map.findWithDefault anyVersion pkgname packageVersionConstraintMap - packageVersionConstraintMap = - let pcs = map unlabelPackageConstraint constraints - in Map.fromList [ (scopeToPackageName scope, range) - | PackageConstraint - scope (PackagePropertyVersion range) <- pcs ] - - packagePreferences :: PackageName -> PackagePreferences - packagePreferences = interpretPackagesPreference targets defpref prefs - - -collectEithers :: [Either a b] -> Either [a] [b] -collectEithers = collect . partitionEithers - where - collect ([], xs) = Right xs - collect (errs,_) = Left errs - --- | Errors for 'resolveWithoutDependencies'. --- -data ResolveNoDepsError = - - -- | A package name which cannot be resolved to a specific package. - -- Also gives the constraint on the version and whether there was - -- a constraint on the package being installed. - ResolveUnsatisfiable PackageName VersionRange - -instance Show ResolveNoDepsError where - show (ResolveUnsatisfiable name ver) = - "There is no available version of " ++ prettyShow name - ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver) diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Types.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Dependency.Types ( - PreSolver(..), - Solver(..), - PackagesPreferenceDefault(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Text.PrettyPrint (text) - -import qualified Distribution.Compat.CharParsing as P - - --- | All the solvers that can be selected. -data PreSolver = AlwaysModular - deriving (Eq, Ord, Show, Bounded, Enum, Generic) - --- | All the solvers that can be used. -data Solver = Modular - deriving (Eq, Ord, Show, Bounded, Enum, Generic) - -instance Binary PreSolver -instance Binary Solver - -instance Structured PreSolver -instance Structured Solver - -instance Pretty PreSolver where - pretty AlwaysModular = text "modular" - -instance Parsec PreSolver where - parsec = do - name <- P.munch1 isAlpha - case map toLower name of - "modular" -> return AlwaysModular - _ -> P.unexpected $ "PreSolver: " ++ name - --- | Global policy for all packages to say if we prefer package versions that --- are already installed locally or if we just prefer the latest available. --- -data PackagesPreferenceDefault = - - -- | Always prefer the latest version irrespective of any existing - -- installed version. - -- - -- * This is the standard policy for upgrade. - -- - PreferAllLatest - - -- | Always prefer the installed versions over ones that would need to be - -- installed. Secondarily, prefer latest versions (eg the latest installed - -- version or if there are none then the latest source version). - | PreferAllInstalled - - -- | Prefer the latest version for packages that are explicitly requested - -- but prefers the installed version for any other packages. - -- - -- * This is the standard policy for install. - -- - | PreferLatestForSelected - deriving Show diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs deleted file mode 100644 --- a/Distribution/Client/DistDirLayout.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | --- --- The layout of the .\/dist\/ directory where cabal keeps all of its state --- and build artifacts. --- -module Distribution.Client.DistDirLayout ( - -- * 'DistDirLayout' - DistDirLayout(..), - DistDirParams(..), - defaultDistDirLayout, - ProjectRoot(..), - - -- * 'StoreDirLayout' - StoreDirLayout(..), - defaultStoreDirLayout, - - -- * 'CabalDirLayout' - CabalDirLayout(..), - mkCabalDirLayout, - defaultCabalDirLayout -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import System.FilePath - -import Distribution.Package - ( PackageId, ComponentId, UnitId ) -import Distribution.Compiler -import Distribution.Simple.Compiler - ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.System - - --- | Information which can be used to construct the path to --- the build directory of a build. This is LESS fine-grained --- than what goes into the hashed 'InstalledPackageId', --- and for good reason: we don't want this path to change if --- the user, say, adds a dependency to their project. -data DistDirParams = DistDirParams { - distParamUnitId :: UnitId, - distParamPackageId :: PackageId, - distParamComponentId :: ComponentId, - distParamComponentName :: Maybe ComponentName, - distParamCompilerId :: CompilerId, - distParamPlatform :: Platform, - distParamOptimization :: OptimisationLevel - -- TODO (see #3343): - -- Flag assignments - -- Optimization - } - - --- | The layout of the project state directory. Traditionally this has been --- called the @dist@ directory. --- -data DistDirLayout = DistDirLayout { - - -- | The root directory of the project. Many other files are relative to - -- this location. In particular, the @cabal.project@ lives here. - -- - distProjectRootDirectory :: FilePath, - - -- | The @cabal.project@ file and related like @cabal.project.freeze@. - -- The parameter is for the extension, like \"freeze\", or \"\" for the - -- main file. - -- - distProjectFile :: String -> FilePath, - - -- | The \"dist\" directory, which is the root of where cabal keeps all - -- its state including the build artifacts from each package we build. - -- - distDirectory :: FilePath, - - -- | The directory under dist where we keep the build artifacts for a - -- package we're building from a local directory. - -- - -- This uses a 'UnitId' not just a 'PackageName' because technically - -- we can have multiple instances of the same package in a solution - -- (e.g. setup deps). - -- - distBuildDirectory :: DistDirParams -> FilePath, - distBuildRootDirectory :: FilePath, - - -- | The directory under dist where we download tarballs and source - -- control repos to. - -- - distDownloadSrcDirectory :: FilePath, - - -- | The directory under dist where we put the unpacked sources of - -- packages, in those cases where it makes sense to keep the build - -- artifacts to reduce rebuild times. - -- - distUnpackedSrcDirectory :: PackageId -> FilePath, - distUnpackedSrcRootDirectory :: FilePath, - - -- | The location for project-wide cache files (e.g. state used in - -- incremental rebuilds). - -- - distProjectCacheFile :: String -> FilePath, - distProjectCacheDirectory :: FilePath, - - -- | The location for package-specific cache files (e.g. state used in - -- incremental rebuilds). - -- - distPackageCacheFile :: DistDirParams -> String -> FilePath, - distPackageCacheDirectory :: DistDirParams -> FilePath, - - -- | The location that sdists are placed by default. - distSdistFile :: PackageId -> FilePath, - distSdistDirectory :: FilePath, - - distTempDirectory :: FilePath, - distBinDirectory :: FilePath, - - distPackageDB :: CompilerId -> PackageDB - } - - --- | The layout of a cabal nix-style store. --- -data StoreDirLayout = StoreDirLayout { - storeDirectory :: CompilerId -> FilePath, - storePackageDirectory :: CompilerId -> UnitId -> FilePath, - storePackageDBPath :: CompilerId -> FilePath, - storePackageDB :: CompilerId -> PackageDB, - storePackageDBStack :: CompilerId -> PackageDBStack, - storeIncomingDirectory :: CompilerId -> FilePath, - storeIncomingLock :: CompilerId -> UnitId -> FilePath - } - - ---TODO: move to another module, e.g. CabalDirLayout? --- or perhaps rename this module to DirLayouts. - --- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir --- on unix, and equivalents on other systems. --- --- At the moment this is just a partial specification, but the idea is --- eventually to cover it all. --- -data CabalDirLayout = CabalDirLayout { - cabalStoreDirLayout :: StoreDirLayout, - - cabalLogsDirectory :: FilePath, - cabalWorldFile :: FilePath - } - - --- | Information about the root directory of the project. --- --- It can either be an implicit project root in the current dir if no --- @cabal.project@ file is found, or an explicit root if the file is found. --- -data ProjectRoot = - -- | -- ^ An implicit project root. It contains the absolute project - -- root dir. - ProjectRootImplicit FilePath - - -- | -- ^ An explicit project root. It contains the absolute project - -- root dir and the relative @cabal.project@ file (or explicit override) - | ProjectRootExplicit FilePath FilePath - deriving (Eq, Show) - --- | Make the default 'DistDirLayout' based on the project root dir and --- optional overrides for the location of the @dist@ directory and the --- @cabal.project@ file. --- -defaultDistDirLayout :: ProjectRoot -- ^ the project root - -> Maybe FilePath -- ^ the @dist@ directory or default - -- (absolute or relative to the root) - -> DistDirLayout -defaultDistDirLayout projectRoot mdistDirectory = - DistDirLayout {..} - where - (projectRootDir, projectFile) = case projectRoot of - ProjectRootImplicit dir -> (dir, dir "cabal.project") - ProjectRootExplicit dir file -> (dir, dir file) - - distProjectRootDirectory = projectRootDir - distProjectFile ext = projectFile <.> ext - - distDirectory = distProjectRootDirectory - fromMaybe "dist-newstyle" mdistDirectory - --TODO: switch to just dist at some point, or some other new name - - distBuildRootDirectory = distDirectory "build" - distBuildDirectory params = - distBuildRootDirectory - prettyShow (distParamPlatform params) - prettyShow (distParamCompilerId params) - prettyShow (distParamPackageId params) - (case distParamComponentName params of - Nothing -> "" - Just (CLibName LMainLibName) -> "" - Just (CLibName (LSubLibName name)) -> "l" prettyShow name - Just (CFLibName name) -> "f" prettyShow name - Just (CExeName name) -> "x" prettyShow name - Just (CTestName name) -> "t" prettyShow name - Just (CBenchName name) -> "b" prettyShow name) - (case distParamOptimization params of - NoOptimisation -> "noopt" - NormalOptimisation -> "" - MaximumOptimisation -> "opt") - (let uid_str = prettyShow (distParamUnitId params) - in if uid_str == prettyShow (distParamComponentId params) - then "" - else uid_str) - - distUnpackedSrcRootDirectory = distDirectory "src" - distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory - prettyShow pkgid - -- we shouldn't get name clashes so this should be fine: - distDownloadSrcDirectory = distUnpackedSrcRootDirectory - - distProjectCacheDirectory = distDirectory "cache" - distProjectCacheFile name = distProjectCacheDirectory name - - distPackageCacheDirectory params = distBuildDirectory params "cache" - distPackageCacheFile params name = distPackageCacheDirectory params name - - distSdistFile pid = distSdistDirectory prettyShow pid <.> "tar.gz" - - distSdistDirectory = distDirectory "sdist" - - distTempDirectory = distDirectory "tmp" - - distBinDirectory = distDirectory "bin" - - distPackageDBPath compid = distDirectory "packagedb" prettyShow compid - distPackageDB = SpecificPackageDB . distPackageDBPath - - -defaultStoreDirLayout :: FilePath -> StoreDirLayout -defaultStoreDirLayout storeRoot = - StoreDirLayout {..} - where - storeDirectory compid = - storeRoot prettyShow compid - - storePackageDirectory compid ipkgid = - storeDirectory compid prettyShow ipkgid - - storePackageDBPath compid = - storeDirectory compid "package.db" - - storePackageDB compid = - SpecificPackageDB (storePackageDBPath compid) - - storePackageDBStack compid = - [GlobalPackageDB, storePackageDB compid] - - storeIncomingDirectory compid = - storeDirectory compid "incoming" - - storeIncomingLock compid unitid = - storeIncomingDirectory compid prettyShow unitid <.> "lock" - - -defaultCabalDirLayout :: FilePath -> CabalDirLayout -defaultCabalDirLayout cabalDir = - mkCabalDirLayout cabalDir Nothing Nothing - -mkCabalDirLayout :: FilePath -- ^ Cabal directory - -> Maybe FilePath -- ^ Store directory. Must be absolute - -> Maybe FilePath -- ^ Log directory - -> CabalDirLayout -mkCabalDirLayout cabalDir mstoreDir mlogDir = - CabalDirLayout {..} - where - cabalStoreDirLayout = - defaultStoreDirLayout (fromMaybe (cabalDir "store") mstoreDir) - cabalLogsDirectory = fromMaybe (cabalDir "logs") mlogDir - cabalWorldFile = cabalDir "world" diff --git a/Distribution/Client/Exec.hs b/Distribution/Client/Exec.hs deleted file mode 100644 --- a/Distribution/Client/Exec.hs +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Exec --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Implementation of the 'exec' command. Runs an arbitrary executable in an --- environment suitable for making use of the sandbox. ------------------------------------------------------------------------------ - -module Distribution.Client.Exec ( exec - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Simple.Compiler (Compiler) -import Distribution.Simple.Program.Db (ProgramDb, requireProgram, modifyProgramSearchPath) -import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) -import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) ) -import Distribution.Simple.Utils (die') - -import Distribution.System (Platform(..)) - --- | Execute the given command in the package's environment. --- --- The given command is executed with GHC configured to use the correct --- package database and with the sandbox bin directory added to the PATH. -exec :: Verbosity - -> Compiler - -> Platform - -> ProgramDb - -> [String] - -> IO () -exec verbosity _comp _platform programDb extraArgs = - case extraArgs of - (exe:args) -> do - program <- requireProgram' verbosity programDb exe - env <- environmentOverrides (programOverrideEnv program) - let invocation = programInvocation - program { programOverrideEnv = env } - args - runProgramInvocation verbosity invocation - - [] -> die' verbosity "Please specify an executable to run" - where - environmentOverrides env = return env - --- | Check that a program is configured and available to be run. If --- a sandbox is available check in the sandbox's directory. -requireProgram' :: Verbosity - -> ProgramDb - -> String - -> IO ConfiguredProgram -requireProgram' verbosity programDb exe = do - (program, _) <- requireProgram - verbosity - (simpleProgram exe) - updateSearchPath - return program - where - updateSearchPath = - flip modifyProgramSearchPath programDb $ \searchPath -> searchPath diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs deleted file mode 100644 --- a/Distribution/Client/Fetch.hs +++ /dev/null @@ -1,232 +0,0 @@ -------------------------------------------------------------------------------- | --- Module : Distribution.Client.Fetch --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- The cabal fetch command ------------------------------------------------------------------------------ -module Distribution.Client.Fetch ( - fetch, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Types -import Distribution.Client.Targets -import Distribution.Client.FetchUtils hiding (fetchPackage) -import Distribution.Client.Dependency -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Setup - ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.SourcePackage - -import Distribution.Package - ( packageId ) -import Distribution.Simple.Compiler - ( Compiler, compilerInfo, PackageDBStack ) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.Setup - ( fromFlag, fromFlagOrDefault ) -import Distribution.Simple.Utils - ( die', notice, debug ) -import Distribution.System - ( Platform ) - --- ------------------------------------------------------------ --- * The fetch command --- ------------------------------------------------------------ - ---TODO: --- * add fetch -o support --- * support tarball URLs via ad-hoc download cache (or in -o mode?) --- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied --- * Port various flags from install: --- * --updage-dependencies --- * --constraint and --preference --- * --only-dependencies, but note it conflicts with --no-deps - - --- | Fetch a list of packages and their dependencies. --- -fetch :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FetchFlags - -> [UserTarget] - -> IO () -fetch verbosity _ _ _ _ _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -fetch verbosity packageDBs repoCtxt comp platform progdb - globalFlags fetchFlags userTargets = do - - traverse_ (checkTarget verbosity) userTargets - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - userTargets - - pkgs <- planPackages - verbosity comp platform fetchFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - - pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs - if null pkgs' - --TODO: when we add support for remote tarballs then this message - -- will need to be changed because for remote tarballs we fetch them - -- at the earlier phase. - then notice verbosity $ "No packages need to be fetched. " - ++ "All the requested packages are already local " - ++ "or cached locally." - else if dryRun - then notice verbosity $ unlines $ - "The following packages would be fetched:" - : map (prettyShow . packageId) pkgs' - - else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs' - - where - dryRun = fromFlag (fetchDryRun fetchFlags) - -planPackages :: Verbosity - -> Compiler - -> Platform - -> FetchFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO [UnresolvedSourcePackage] -planPackages verbosity comp platform fetchFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - - | includeDependencies = do - solver <- chooseSolver verbosity - (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) - notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg (die' verbosity) return $ - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - -- The packages we want to fetch are those packages the 'InstallPlan' - -- that are in the 'InstallPlan.Configured' state. - return - [ solverPkgSource cpkg - | (SolverInstallPlan.Configured cpkg) - <- SolverInstallPlan.toList installPlan ] - - | otherwise = - either (die' verbosity . unlines . map show) return $ - resolveWithoutDependencies resolverParams - - where - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . addConstraints - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | pkgSpecifier <- pkgSpecifiers ] - - -- Reinstall the targets given on the command line so that the dep - -- resolver will decide that they need fetching, even if they're - -- already installed. Since we want to get the source packages of - -- things we might have installed (but not have the sources for). - . reinstallTargets - - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - - includeDependencies = fromFlag (fetchDeps fetchFlags) - logMsg message rest = debug verbosity message >> rest - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags - benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags - - reorderGoals = fromFlag (fetchReorderGoals fetchFlags) - countConflicts = fromFlag (fetchCountConflicts fetchFlags) - fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) - minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) - independentGoals = fromFlag (fetchIndependentGoals fetchFlags) - shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) - strongFlags = fromFlag (fetchStrongFlags fetchFlags) - maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) - allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) - onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags) - - -checkTarget :: Verbosity -> UserTarget -> IO () -checkTarget verbosity target = case target of - UserTargetRemoteTarball _uri - -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " - ++ "In the meantime you can use the 'unpack' commands." - _ -> return () - -fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO () -fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of - LocalUnpackedPackage _dir -> return () - LocalTarballPackage _file -> return () - - RemoteTarballPackage _uri _ -> - die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " - ++ "In the meantime you can use the 'unpack' commands." - - RemoteSourceRepoPackage _repo _ -> - die' verbosity $ "The 'fetch' command does not yet support remote " - ++ "source repositores." - - RepoTarballPackage repo pkgid _ -> do - _ <- fetchRepoTarball verbosity repoCtxt repo pkgid - return () diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs deleted file mode 100644 --- a/Distribution/Client/FetchUtils.hs +++ /dev/null @@ -1,317 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.FetchUtils --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Functions for fetching packages ------------------------------------------------------------------------------ -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.FetchUtils ( - - -- * fetching packages - fetchPackage, - isFetched, - checkFetched, - - -- ** specifically for repo packages - checkRepoTarballFetched, - fetchRepoTarball, - - -- ** fetching packages asynchronously - asyncFetchPackages, - waitAsyncFetchPackage, - AsyncFetchMap, - - -- * fetching other things - downloadIndex, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Types -import Distribution.Client.HttpUtils - ( downloadURI, isOldHackageURI, DownloadResult(..) - , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps ) - -import Distribution.Package - ( PackageId, packageName, packageVersion ) -import Distribution.Simple.Utils - ( notice, info, debug, die' ) -import Distribution.Verbosity - ( verboseUnmarkOutput ) -import Distribution.Client.GlobalFlags - ( RepoContext(..) ) -import Distribution.Client.Utils - ( ProgressPhase(..), progressMessage ) - -import qualified Data.Map as Map -import Control.Exception -import Control.Concurrent.Async -import Control.Concurrent.MVar -import System.Directory - ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) -import System.IO - ( openTempFile, hClose ) -import System.FilePath - ( (), (<.>) ) -import qualified System.FilePath.Posix as FilePath.Posix - ( combine, joinPath ) -import Network.URI - ( URI(uriPath) ) - -import qualified Hackage.Security.Client as Sec - --- ------------------------------------------------------------ --- * Actually fetch things --- ------------------------------------------------------------ - --- | Returns @True@ if the package has already been fetched --- or does not need fetching. --- -isFetched :: UnresolvedPkgLoc -> IO Bool -isFetched loc = case loc of - LocalUnpackedPackage _dir -> return True - LocalTarballPackage _file -> return True - RemoteTarballPackage _uri local -> return (isJust local) - RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) - RemoteSourceRepoPackage _ local -> return (isJust local) - - --- | Checks if the package has already been fetched (or does not need --- fetching) and if so returns evidence in the form of a 'PackageLocation' --- with a resolved local file location. --- -checkFetched :: UnresolvedPkgLoc - -> IO (Maybe ResolvedPkgLoc) -checkFetched loc = case loc of - LocalUnpackedPackage dir -> - return (Just $ LocalUnpackedPackage dir) - LocalTarballPackage file -> - return (Just $ LocalTarballPackage file) - RemoteTarballPackage uri (Just file) -> - return (Just $ RemoteTarballPackage uri file) - RepoTarballPackage repo pkgid (Just file) -> - return (Just $ RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just file) -> - return (Just $ RemoteSourceRepoPackage repo file) - - RemoteTarballPackage _uri Nothing -> return Nothing - RemoteSourceRepoPackage _repo Nothing -> return Nothing - RepoTarballPackage repo pkgid Nothing -> - fmap (fmap (RepoTarballPackage repo pkgid)) - (checkRepoTarballFetched repo pkgid) - --- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'. --- -checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath) -checkRepoTarballFetched repo pkgid = do - let file = packageFile repo pkgid - exists <- doesFileExist file - if exists - then return (Just file) - else return Nothing - - --- | Fetch a package if we don't have it already. --- -fetchPackage :: Verbosity - -> RepoContext - -> UnresolvedPkgLoc - -> IO ResolvedPkgLoc -fetchPackage verbosity repoCtxt loc = case loc of - LocalUnpackedPackage dir -> - return (LocalUnpackedPackage dir) - LocalTarballPackage file -> - return (LocalTarballPackage file) - RemoteTarballPackage uri (Just file) -> - return (RemoteTarballPackage uri file) - RepoTarballPackage repo pkgid (Just file) -> - return (RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just dir) -> - return (RemoteSourceRepoPackage repo dir) - - RemoteTarballPackage uri Nothing -> do - path <- downloadTarballPackage uri - return (RemoteTarballPackage uri path) - RepoTarballPackage repo pkgid Nothing -> do - local <- fetchRepoTarball verbosity repoCtxt repo pkgid - return (RepoTarballPackage repo pkgid local) - RemoteSourceRepoPackage _repo Nothing -> - die' verbosity "fetchPackage: source repos not supported" - where - downloadTarballPackage uri = do - transport <- repoContextGetTransport repoCtxt - transportCheckHttps verbosity transport uri - notice verbosity ("Downloading " ++ show uri) - tmpdir <- getTemporaryDirectory - (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" - hClose hnd - _ <- downloadURI transport verbosity uri path - return path - - --- | Fetch a repo package if we don't have it already. --- -fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath -fetchRepoTarball verbosity' repoCtxt repo pkgid = do - fetched <- doesFileExist (packageFile repo pkgid) - if fetched - then do info verbosity $ prettyShow pkgid ++ " has already been downloaded." - return (packageFile repo pkgid) - else do progressMessage verbosity ProgressDownloading (prettyShow pkgid) - res <- downloadRepoPackage - progressMessage verbosity ProgressDownloaded (prettyShow pkgid) - return res - where - -- whether we download or not is non-deterministic - verbosity = verboseUnmarkOutput verbosity' - - downloadRepoPackage = case repo of - RepoLocalNoIndex{} -> return (packageFile repo pkgid) - - RepoRemote{..} -> do - transport <- repoContextGetTransport repoCtxt - remoteRepoCheckHttps verbosity transport repoRemote - let uri = packageURI repoRemote pkgid - dir = packageDir repo pkgid - path = packageFile repo pkgid - createDirectoryIfMissing True dir - _ <- downloadURI transport verbosity uri path - return path - - RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do - let dir = packageDir repo pkgid - path = packageFile repo pkgid - createDirectoryIfMissing True dir - Sec.uncheckClientErrors $ do - info verbosity ("Writing " ++ path) - Sec.downloadPackage' rep pkgid path - return path - --- | Downloads an index file to [config-dir/packages/serv-id] without --- hackage-security. You probably don't want to call this directly; --- use 'updateRepo' instead. --- -downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult -downloadIndex transport verbosity remoteRepo cacheDir = do - remoteRepoCheckHttps verbosity transport remoteRepo - let uri = (remoteRepoURI remoteRepo) { - uriPath = uriPath (remoteRepoURI remoteRepo) - `FilePath.Posix.combine` "00-index.tar.gz" - } - path = cacheDir "00-index" <.> "tar.gz" - createDirectoryIfMissing True cacheDir - downloadURI transport verbosity uri path - - --- ------------------------------------------------------------ --- * Async fetch wrapper utilities --- ------------------------------------------------------------ - -type AsyncFetchMap = Map UnresolvedPkgLoc - (MVar (Either SomeException ResolvedPkgLoc)) - --- | Fork off an async action to download the given packages (by location). --- --- The downloads are initiated in order, so you can arrange for packages that --- will likely be needed sooner to be earlier in the list. --- --- The body action is passed a map from those packages (identified by their --- location) to a completion var for that package. So the body action should --- lookup the location and use 'asyncFetchPackage' to get the result. --- -asyncFetchPackages :: Verbosity - -> RepoContext - -> [UnresolvedPkgLoc] - -> (AsyncFetchMap -> IO a) - -> IO a -asyncFetchPackages verbosity repoCtxt pkglocs body = do - --TODO: [nice to have] use parallel downloads? - - asyncDownloadVars <- sequenceA - [ do v <- newEmptyMVar - return (pkgloc, v) - | pkgloc <- pkglocs - ] - - let fetchPackages :: IO () - fetchPackages = - for_ asyncDownloadVars $ \(pkgloc, var) -> do - -- Suppress marking here, because 'withAsync' means - -- that we get nondeterministic interleaving - result <- try $ fetchPackage (verboseUnmarkOutput verbosity) - repoCtxt pkgloc - putMVar var result - - withAsync fetchPackages $ \_ -> - body (Map.fromList asyncDownloadVars) - - --- | Expect to find a download in progress in the given 'AsyncFetchMap' --- and wait on it to finish. --- --- If the download failed with an exception then this will be thrown. --- --- Note: This function is supposed to be idempotent, as our install plans --- can now use the same tarball for many builds, e.g. different --- components and/or qualified goals, and these all go through the --- download phase so we end up using 'waitAsyncFetchPackage' twice on --- the same package. C.f. #4461. -waitAsyncFetchPackage :: Verbosity - -> AsyncFetchMap - -> UnresolvedPkgLoc - -> IO ResolvedPkgLoc -waitAsyncFetchPackage verbosity downloadMap srcloc = - case Map.lookup srcloc downloadMap of - Just hnd -> do - debug verbosity $ "Waiting for download of " ++ show srcloc - either throwIO return =<< readMVar hnd - Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" - - --- ------------------------------------------------------------ --- * Path utilities --- ------------------------------------------------------------ - --- | Generate the full path to the locally cached copy of --- the tarball for a given @PackageIdentifer@. --- -packageFile :: Repo -> PackageId -> FilePath -packageFile repo pkgid = packageDir repo pkgid - prettyShow pkgid - <.> "tar.gz" - --- | Generate the full path to the directory where the local cached copy of --- the tarball for a given @PackageIdentifer@ is stored. --- -packageDir :: Repo -> PackageId -> FilePath -packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir -packageDir repo pkgid = repoLocalDir repo - prettyShow (packageName pkgid) - prettyShow (packageVersion pkgid) - --- | Generate the URI of the tarball for a given package. --- -packageURI :: RemoteRepo -> PackageId -> URI -packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,prettyShow (packageName pkgid) - ,prettyShow (packageVersion pkgid) - ,prettyShow pkgid <.> "tar.gz"] - } -packageURI repo pkgid = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,"package" - ,prettyShow pkgid <.> "tar.gz"] - } diff --git a/Distribution/Client/FileMonitor.hs b/Distribution/Client/FileMonitor.hs deleted file mode 100644 --- a/Distribution/Client/FileMonitor.hs +++ /dev/null @@ -1,1130 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, - NamedFieldPuns, BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | An abstraction to help with re-running actions when files or other --- input values they depend on have changed. --- -module Distribution.Client.FileMonitor ( - - -- * Declaring files to monitor - MonitorFilePath(..), - MonitorKindFile(..), - MonitorKindDir(..), - FilePathGlob(..), - monitorFile, - monitorFileHashed, - monitorNonExistentFile, - monitorFileExistence, - monitorDirectory, - monitorNonExistentDirectory, - monitorDirectoryExistence, - monitorFileOrDirectory, - monitorFileGlob, - monitorFileGlobExistence, - monitorFileSearchPath, - monitorFileHashedSearchPath, - - -- * Creating and checking sets of monitored files - FileMonitor(..), - newFileMonitor, - MonitorChanged(..), - MonitorChangedReason(..), - checkFileMonitorChanged, - updateFileMonitor, - MonitorTimestamp, - beginUpdateFileMonitor, - - -- * Internal - MonitorStateFileSet, - MonitorStateFile, - MonitorStateGlob, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import qualified Data.Map.Strict as Map -import qualified Data.ByteString.Lazy as BS -import qualified Data.Hashable as Hashable - -import Control.Monad -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Monad.State (StateT, mapStateT) -import qualified Control.Monad.State as State -import Control.Monad.Except (ExceptT, runExceptT, withExceptT, - throwError) -import Control.Exception - -import Distribution.Compat.Time -import Distribution.Client.Glob -import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) -import Distribution.Client.Utils (mergeBy, MergeResult(..)) -import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) -import System.FilePath -import System.Directory -import System.IO - ------------------------------------------------------------------------------- --- Types for specifying files to monitor --- - - --- | A description of a file (or set of files) to monitor for changes. --- --- Where file paths are relative they are relative to a common directory --- (e.g. project root), not necessarily the process current directory. --- -data MonitorFilePath = - MonitorFile { - monitorKindFile :: !MonitorKindFile, - monitorKindDir :: !MonitorKindDir, - monitorPath :: !FilePath - } - | MonitorFileGlob { - monitorKindFile :: !MonitorKindFile, - monitorKindDir :: !MonitorKindDir, - monitorPathGlob :: !FilePathGlob - } - deriving (Eq, Show, Generic) - -data MonitorKindFile = FileExists - | FileModTime - | FileHashed - | FileNotExists - deriving (Eq, Show, Generic) - -data MonitorKindDir = DirExists - | DirModTime - | DirNotExists - deriving (Eq, Show, Generic) - -instance Binary MonitorFilePath -instance Binary MonitorKindFile -instance Binary MonitorKindDir - -instance Structured MonitorFilePath -instance Structured MonitorKindFile -instance Structured MonitorKindDir - --- | Monitor a single file for changes, based on its modification time. --- The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. --- -monitorFile :: FilePath -> MonitorFilePath -monitorFile = MonitorFile FileModTime DirNotExists - --- | Monitor a single file for changes, based on its modification time --- and content hash. The monitored file is considered to have changed if --- it no longer exists or if its modification time and content hash have --- changed. --- -monitorFileHashed :: FilePath -> MonitorFilePath -monitorFileHashed = MonitorFile FileHashed DirNotExists - --- | Monitor a single non-existent file for changes. The monitored file --- is considered to have changed if it exists. --- -monitorNonExistentFile :: FilePath -> MonitorFilePath -monitorNonExistentFile = MonitorFile FileNotExists DirNotExists - --- | Monitor a single file for existence only. The monitored file is --- considered to have changed if it no longer exists. --- -monitorFileExistence :: FilePath -> MonitorFilePath -monitorFileExistence = MonitorFile FileExists DirNotExists - --- | Monitor a single directory for changes, based on its modification --- time. The monitored directory is considered to have changed if it no --- longer exists or if its modification time has changed. --- -monitorDirectory :: FilePath -> MonitorFilePath -monitorDirectory = MonitorFile FileNotExists DirModTime - --- | Monitor a single non-existent directory for changes. The monitored --- directory is considered to have changed if it exists. --- -monitorNonExistentDirectory :: FilePath -> MonitorFilePath --- Just an alias for monitorNonExistentFile, since you can't --- tell the difference between a non-existent directory and --- a non-existent file :) -monitorNonExistentDirectory = monitorNonExistentFile - --- | Monitor a single directory for existence. The monitored directory is --- considered to have changed only if it no longer exists. --- -monitorDirectoryExistence :: FilePath -> MonitorFilePath -monitorDirectoryExistence = MonitorFile FileNotExists DirExists - --- | Monitor a single file or directory for changes, based on its modification --- time. The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. --- -monitorFileOrDirectory :: FilePath -> MonitorFilePath -monitorFileOrDirectory = MonitorFile FileModTime DirModTime - --- | Monitor a set of files (or directories) identified by a file glob. --- The monitored glob is considered to have changed if the set of files --- matching the glob changes (i.e. creations or deletions), or for files if the --- modification time and content hash of any matching file has changed. --- -monitorFileGlob :: FilePathGlob -> MonitorFilePath -monitorFileGlob = MonitorFileGlob FileHashed DirExists - --- | Monitor a set of files (or directories) identified by a file glob for --- existence only. The monitored glob is considered to have changed if the set --- of files matching the glob changes (i.e. creations or deletions). --- -monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath -monitorFileGlobExistence = MonitorFileGlob FileExists DirExists - --- | Creates a list of files to monitor when you search for a file which --- unsuccessfully looked in @notFoundAtPaths@ before finding it at --- @foundAtPath@. -monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileSearchPath notFoundAtPaths foundAtPath = - monitorFile foundAtPath - : map monitorNonExistentFile notFoundAtPaths - --- | Similar to 'monitorFileSearchPath', but also instructs us to --- monitor the hash of the found file. -monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileHashedSearchPath notFoundAtPaths foundAtPath = - monitorFileHashed foundAtPath - : map monitorNonExistentFile notFoundAtPaths - - ------------------------------------------------------------------------------- --- Implementation types, files status --- - --- | The state necessary to determine whether a set of monitored --- files has changed. It consists of two parts: a set of specific --- files to be monitored (index by their path), and a list of --- globs, which monitor may files at once. -data MonitorStateFileSet - = MonitorStateFileSet ![MonitorStateFile] - ![MonitorStateGlob] - -- Morally this is not actually a set but a bag (represented by lists). - -- There is no principled reason to use a bag here rather than a set, but - -- there is also no particular gain either. That said, we do preserve the - -- order of the lists just to reduce confusion (and have predictable I/O - -- patterns). - deriving (Show, Generic) - -instance Binary MonitorStateFileSet -instance Structured MonitorStateFileSet - -type Hash = Int - --- | The state necessary to determine whether a monitored file has changed. --- --- This covers all the cases of 'MonitorFilePath' except for globs which is --- covered separately by 'MonitorStateGlob'. --- --- The @Maybe ModTime@ is to cover the case where we already consider the --- file to have changed, either because it had already changed by the time we --- did the snapshot (i.e. too new, changed since start of update process) or it --- no longer exists at all. --- -data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir - !FilePath !MonitorStateFileStatus - deriving (Show, Generic) - -data MonitorStateFileStatus - = MonitorStateFileExists - | MonitorStateFileModTime !ModTime -- ^ cached file mtime - | MonitorStateFileHashed !ModTime !Hash -- ^ cached mtime and content hash - | MonitorStateDirExists - | MonitorStateDirModTime !ModTime -- ^ cached dir mtime - | MonitorStateNonExistent - | MonitorStateAlreadyChanged - deriving (Show, Generic) - -instance Binary MonitorStateFile -instance Binary MonitorStateFileStatus -instance Structured MonitorStateFile -instance Structured MonitorStateFileStatus - --- | The state necessary to determine whether the files matched by a globbing --- match have changed. --- -data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir - !FilePathRoot !MonitorStateGlobRel - deriving (Show, Generic) - -data MonitorStateGlobRel - = MonitorStateGlobDirs - !Glob !FilePathGlobRel - !ModTime - ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted - - | MonitorStateGlobFiles - !Glob - !ModTime - ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted - - | MonitorStateGlobDirTrailing - deriving (Show, Generic) - -instance Binary MonitorStateGlob -instance Binary MonitorStateGlobRel - -instance Structured MonitorStateGlob -instance Structured MonitorStateGlobRel - --- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by --- inspecting the state of the file system, and we can go in the reverse --- direction by just forgetting the extra info. --- -reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] -reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = - map getSinglePath singlePaths - ++ map getGlobPath globPaths - where - getSinglePath (MonitorStateFile kindfile kinddir filepath _) = - MonitorFile kindfile kinddir filepath - - getGlobPath (MonitorStateGlob kindfile kinddir root gstate) = - MonitorFileGlob kindfile kinddir $ FilePathGlob root $ - case gstate of - MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs - MonitorStateGlobFiles glob _ _ -> GlobFile glob - MonitorStateGlobDirTrailing -> GlobDirTrailing - ------------------------------------------------------------------------------- --- Checking the status of monitored files --- - --- | A monitor for detecting changes to a set of files. It can be used to --- efficiently test if any of a set of files (specified individually or by --- glob patterns) has changed since some snapshot. In addition, it also checks --- for changes in a value (of type @a@), and when there are no changes in --- either it returns a saved value (of type @b@). --- --- The main use case looks like this: suppose we have some expensive action --- that depends on certain pure inputs and reads some set of files, and --- produces some pure result. We want to avoid re-running this action when it --- would produce the same result. So we need to monitor the files the action --- looked at, the other pure input values, and we need to cache the result. --- Then at some later point, if the input value didn't change, and none of the --- files changed, then we can re-use the cached result rather than re-running --- the action. --- --- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance --- saves state in a disk file, so the file for that has to be specified, --- making sure it is unique. The pattern is to use 'checkFileMonitorChanged' --- to see if there's been any change. If there is, re-run the action, keeping --- track of the files, then use 'updateFileMonitor' to record the current --- set of files to monitor, the current input value for the action, and the --- result of the action. --- --- The typical occurrence of this pattern is captured by 'rerunIfChanged' --- and the 'Rebuild' monad. More complicated cases may need to use --- 'checkFileMonitorChanged' and 'updateFileMonitor' directly. --- -data FileMonitor a b - = FileMonitor { - - -- | The file where this 'FileMonitor' should store its state. - -- - fileMonitorCacheFile :: FilePath, - - -- | Compares a new cache key with old one to determine if a - -- corresponding cached value is still valid. - -- - -- Typically this is just an equality test, but in some - -- circumstances it can make sense to do things like subset - -- comparisons. - -- - -- The first arg is the new value, the second is the old cached value. - -- - fileMonitorKeyValid :: a -> a -> Bool, - - -- | When this mode is enabled, if 'checkFileMonitorChanged' returns - -- 'MonitoredValueChanged' then we have the guarantee that no files - -- changed, that the value change was the only change. In the default - -- mode no such guarantee is provided which is slightly faster. - -- - fileMonitorCheckIfOnlyValueChanged :: Bool - } - --- | Define a new file monitor. --- --- It's best practice to define file monitor values once, and then use the --- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this --- ensures you get the same types @a@ and @b@ for reading and writing. --- --- The path of the file monitor itself must be unique because it keeps state --- on disk and these would clash. --- -newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the - -- file monitor. Must be unique. - -> FileMonitor a b -newFileMonitor path = FileMonitor path (==) False - --- | The result of 'checkFileMonitorChanged': either the monitored files or --- value changed (and it tells us which it was) or nothing changed and we get --- the cached result. --- -data MonitorChanged a b = - -- | The monitored files and value did not change. The cached result is - -- @b@. - -- - -- The set of monitored files is also returned. This is useful - -- for composing or nesting 'FileMonitor's. - MonitorUnchanged b [MonitorFilePath] - - -- | The monitor found that something changed. The reason is given. - -- - | MonitorChanged (MonitorChangedReason a) - deriving Show - --- | What kind of change 'checkFileMonitorChanged' detected. --- -data MonitorChangedReason a = - - -- | One of the files changed (existence, file type, mtime or file - -- content, depending on the 'MonitorFilePath' in question) - MonitoredFileChanged FilePath - - -- | The pure input value changed. - -- - -- The previous cached key value is also returned. This is sometimes - -- useful when using a 'fileMonitorKeyValid' function that is not simply - -- '(==)', when invalidation can be partial. In such cases it can make - -- sense to 'updateFileMonitor' with a key value that's a combination of - -- the new and old (e.g. set union). - | MonitoredValueChanged a - - -- | There was no saved monitor state, cached value etc. Ie the file - -- for the 'FileMonitor' does not exist. - | MonitorFirstRun - - -- | There was existing state, but we could not read it. This typically - -- happens when the code has changed compared to an existing 'FileMonitor' - -- cache file and type of the input value or cached value has changed such - -- that we cannot decode the values. This is completely benign as we can - -- treat is just as if there were no cache file and re-run. - | MonitorCorruptCache - deriving (Eq, Show, Functor) - --- | Test if the input value or files monitored by the 'FileMonitor' have --- changed. If not, return the cached value. --- --- See 'FileMonitor' for a full explanation. --- -checkFileMonitorChanged - :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -- ^ cache file path - -> FilePath -- ^ root directory - -> a -- ^ guard or key value - -> IO (MonitorChanged a b) -- ^ did the key or any paths change? -checkFileMonitorChanged - monitor@FileMonitor { fileMonitorKeyValid, - fileMonitorCheckIfOnlyValueChanged } - root currentKey = - - -- Consider it a change if the cache file does not exist, - -- or we cannot decode it. Sadly ErrorCall can still happen, despite - -- using decodeFileOrFail, e.g. Data.Char.chr errors - - handleDoesNotExist (MonitorChanged MonitorFirstRun) $ - handleErrorCall (MonitorChanged MonitorCorruptCache) $ - readCacheFile monitor - >>= either (\_ -> return (MonitorChanged MonitorCorruptCache)) - checkStatusCache - - where - checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do - change <- checkForChanges - case change of - Just reason -> return (MonitorChanged reason) - Nothing -> return (MonitorUnchanged cachedResult monitorFiles) - where monitorFiles = reconstructMonitorFilePaths cachedFileStatus - where - -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that - -- if we return MonitoredValueChanged that only the value changed. - -- We do that by checkin for file changes first. Otherwise it makes - -- more sense to do the cheaper test first. - checkForChanges - | fileMonitorCheckIfOnlyValueChanged - = checkFileChange cachedFileStatus cachedKey cachedResult - `mplusMaybeT` - checkValueChange cachedKey - - | otherwise - = checkValueChange cachedKey - `mplusMaybeT` - checkFileChange cachedFileStatus cachedKey cachedResult - - mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) - mplusMaybeT ma mb = do - mx <- ma - case mx of - Nothing -> mb - Just x -> return (Just x) - - -- Check if the guard value has changed - checkValueChange cachedKey - | not (fileMonitorKeyValid currentKey cachedKey) - = return (Just (MonitoredValueChanged cachedKey)) - | otherwise - = return Nothing - - -- Check if any file has changed - checkFileChange cachedFileStatus cachedKey cachedResult = do - res <- probeFileSystem root cachedFileStatus - case res of - -- Some monitored file has changed - Left changedPath -> - return (Just (MonitoredFileChanged (normalise changedPath))) - - -- No monitored file has changed - Right (cachedFileStatus', cacheStatus) -> do - - -- But we might still want to update the cache - whenCacheChanged cacheStatus $ - rewriteCacheFile monitor cachedFileStatus' cachedKey cachedResult - - return Nothing - --- | Helper for reading the cache file. --- --- This determines the type and format of the binary cache file. --- -readCacheFile :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> IO (Either String (MonitorStateFileSet, a, b)) -readCacheFile FileMonitor {fileMonitorCacheFile} = - withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do - contents <- BS.hGetContents hnd - structuredDecodeOrFailIO contents - --- | Helper for writing the cache file. --- --- This determines the type and format of the binary cache file. --- -rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> MonitorStateFileSet -> a -> b -> IO () -rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = - writeFileAtomic fileMonitorCacheFile $ - structuredEncode (fileset, key, result) - --- | Probe the file system to see if any of the monitored files have changed. --- --- It returns Nothing if any file changed, or returns a possibly updated --- file 'MonitorStateFileSet' plus an indicator of whether it actually changed. --- --- We may need to update the cache since there may be changes in the filesystem --- state which don't change any of our affected files. --- --- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a --- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run --- and find @proj2@ was created, yet contains no files matching @*.cabal@ then --- we want to update the cache despite no changes in our relevant file set. --- Specifically, we should add an mtime for this directory so we can avoid --- re-traversing the directory in future runs. --- -probeFileSystem :: FilePath -> MonitorStateFileSet - -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) -probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = - runChangedM $ do - sequence_ - [ probeMonitorStateFileStatus root file status - | MonitorStateFile _ _ file status <- singlePaths ] - -- The glob monitors can require state changes - globPaths' <- - sequence - [ probeMonitorStateGlob root globPath - | globPath <- globPaths ] - return (MonitorStateFileSet singlePaths globPaths') - - ------------------------------------------------ --- Monad for checking for file system changes --- --- We need to be able to bail out if we detect a change (using ExceptT), --- but if there's no change we need to be able to rebuild the monitor --- state. And we want to optimise that rebuilding by keeping track if --- anything actually changed (using StateT), so that in the typical case --- we can avoid rewriting the state file. - -newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a) - deriving (Functor, Applicative, Monad, MonadIO) - -runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged)) -runChangedM (ChangedM action) = - runExceptT $ State.runStateT action CacheUnchanged - -somethingChanged :: FilePath -> ChangedM a -somethingChanged path = ChangedM $ throwError path - -cacheChanged :: ChangedM () -cacheChanged = ChangedM $ State.put CacheChanged - -mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a -mapChangedFile adjust (ChangedM a) = - ChangedM (mapStateT (withExceptT adjust) a) - -data CacheChanged = CacheChanged | CacheUnchanged - -whenCacheChanged :: Monad m => CacheChanged -> m () -> m () -whenCacheChanged CacheChanged action = action -whenCacheChanged CacheUnchanged _ = return () - ----------------------- - --- | Probe the file system to see if a single monitored file has changed. --- -probeMonitorStateFileStatus :: FilePath -> FilePath - -> MonitorStateFileStatus - -> ChangedM () -probeMonitorStateFileStatus root file status = - case status of - MonitorStateFileExists -> - probeFileExistence root file - - MonitorStateFileModTime mtime -> - probeFileModificationTime root file mtime - - MonitorStateFileHashed mtime hash -> - probeFileModificationTimeAndHash root file mtime hash - - MonitorStateDirExists -> - probeDirExistence root file - - MonitorStateDirModTime mtime -> - probeFileModificationTime root file mtime - - MonitorStateNonExistent -> - probeFileNonExistence root file - - MonitorStateAlreadyChanged -> - somethingChanged file - - --- | Probe the file system to see if a monitored file glob has changed. --- -probeMonitorStateGlob :: FilePath -- ^ root path - -> MonitorStateGlob - -> ChangedM MonitorStateGlob -probeMonitorStateGlob relroot - (MonitorStateGlob kindfile kinddir globroot glob) = do - root <- liftIO $ getFilePathRootDirectory globroot relroot - case globroot of - FilePathRelative -> - MonitorStateGlob kindfile kinddir globroot <$> - probeMonitorStateGlobRel kindfile kinddir root "." glob - - -- for absolute cases, make the changed file we report absolute too - _ -> - mapChangedFile (root ) $ - MonitorStateGlob kindfile kinddir globroot <$> - probeMonitorStateGlobRel kindfile kinddir root "" glob - -probeMonitorStateGlobRel :: MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ root path - -> FilePath -- ^ path of the directory we are - -- looking in relative to @root@ - -> MonitorStateGlobRel - -> ChangedM MonitorStateGlobRel -probeMonitorStateGlobRel kindfile kinddir root dirName - (MonitorStateGlobDirs glob globPath mtime children) = do - change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime - case change of - Nothing -> do - children' <- sequence - [ do fstate' <- probeMonitorStateGlobRel - kindfile kinddir root - (dirName fname) fstate - return (fname, fstate') - | (fname, fstate) <- children ] - return $! MonitorStateGlobDirs glob globPath mtime children' - - Just mtime' -> do - -- directory modification time changed: - -- a matching subdir may have been added or deleted - matches <- filterM (\entry -> let subdir = root dirName entry - in liftIO $ doesDirectoryExist subdir) - . filter (matchGlob glob) - =<< liftIO (getDirectoryContents (root dirName)) - - children' <- traverse probeMergeResult $ - mergeBy (\(path1,_) path2 -> compare path1 path2) - children - (sort matches) - return $! MonitorStateGlobDirs glob globPath mtime' children' - -- Note that just because the directory has changed, we don't force - -- a cache rewrite with 'cacheChanged' since that has some cost, and - -- all we're saving is scanning the directory. But we do rebuild the - -- cache with the new mtime', so that if the cache is rewritten for - -- some other reason, we'll take advantage of that. - - where - probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath - -> ChangedM (FilePath, MonitorStateGlobRel) - - -- Only in cached (directory deleted) - probeMergeResult (OnlyInLeft (path, fstate)) = do - case allMatchingFiles (dirName path) fstate of - [] -> return (path, fstate) - -- Strictly speaking we should be returning 'CacheChanged' above - -- as we should prune the now-missing 'MonitorStateGlobRel'. However - -- we currently just leave these now-redundant entries in the - -- cache as they cost no IO and keeping them allows us to avoid - -- rewriting the cache. - (file:_) -> somethingChanged file - - -- Only in current filesystem state (directory added) - probeMergeResult (OnlyInRight path) = do - fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty - kindfile kinddir root (dirName path) globPath - case allMatchingFiles (dirName path) fstate of - (file:_) -> somethingChanged file - -- This is the only case where we use 'cacheChanged' because we can - -- have a whole new dir subtree (of unbounded size and cost), so we - -- need to save the state of that new subtree in the cache. - [] -> cacheChanged >> return (path, fstate) - - -- Found in path - probeMergeResult (InBoth (path, fstate) _) = do - fstate' <- probeMonitorStateGlobRel kindfile kinddir - root (dirName path) fstate - return (path, fstate') - - -- | Does a 'MonitorStateGlob' have any relevant files within it? - allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] - allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = - [ dir fname | (fname, _) <- entries ] - allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = - [ res - | (subdir, fstate) <- entries - , res <- allMatchingFiles (dir subdir) fstate ] - allMatchingFiles dir MonitorStateGlobDirTrailing = - [dir] - -probeMonitorStateGlobRel _ _ root dirName - (MonitorStateGlobFiles glob mtime children) = do - change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime - mtime' <- case change of - Nothing -> return mtime - Just mtime' -> do - -- directory modification time changed: - -- a matching file may have been added or deleted - matches <- return . filter (matchGlob glob) - =<< liftIO (getDirectoryContents (root dirName)) - - traverse_ probeMergeResult $ - mergeBy (\(path1,_) path2 -> compare path1 path2) - children - (sort matches) - return mtime' - - -- Check that none of the children have changed - for_ children $ \(file, status) -> - probeMonitorStateFileStatus root (dirName file) status - - - return (MonitorStateGlobFiles glob mtime' children) - -- Again, we don't force a cache rewite with 'cacheChanged', but we do use - -- the new mtime' if any. - where - probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath - -> ChangedM () - probeMergeResult mr = case mr of - InBoth _ _ -> return () - -- this is just to be able to accurately report which file changed: - OnlyInLeft (path, _) -> somethingChanged (dirName path) - OnlyInRight path -> somethingChanged (dirName path) - -probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = - return MonitorStateGlobDirTrailing - ------------------------------------------------------------------------------- - --- | Update the input value and the set of files monitored by the --- 'FileMonitor', plus the cached value that may be returned in future. --- --- This takes a snapshot of the state of the monitored files right now, so --- 'checkFileMonitorChanged' will look for file system changes relative to --- this snapshot. --- --- This is typically done once the action has been completed successfully and --- we have the action's result and we know what files it looked at. See --- 'FileMonitor' for a full explanation. --- --- If we do take the snapshot after the action has completed then we have a --- problem. The problem is that files might have changed /while/ the action was --- running but /after/ the action read them. If we take the snapshot after the --- action completes then we will miss these changes. The solution is to record --- a timestamp before beginning execution of the action and then we make the --- conservative assumption that any file that has changed since then has --- already changed, ie the file monitor state for these files will be such that --- 'checkFileMonitorChanged' will report that they have changed. --- --- So if you do use 'updateFileMonitor' after the action (so you can discover --- the files used rather than predicting them in advance) then use --- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively, --- if you take the snapshot in advance of the action, or you're not monitoring --- any files then you can use @Nothing@ for the timestamp parameter. --- -updateFileMonitor - :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -- ^ cache file path - -> FilePath -- ^ root directory - -> Maybe MonitorTimestamp -- ^ timestamp when the update action started - -> [MonitorFilePath] -- ^ files of interest relative to root - -> a -- ^ the current key value - -> b -- ^ the current result value - -> IO () -updateFileMonitor monitor root startTime monitorFiles - cachedKey cachedResult = do - hashcache <- readCacheFileHashes monitor - msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles - rewriteCacheFile monitor msfs cachedKey cachedResult - --- | A timestamp to help with the problem of file changes during actions. --- See 'updateFileMonitor' for details. --- -newtype MonitorTimestamp = MonitorTimestamp ModTime - --- | Record a timestamp at the beginning of an action, and when the action --- completes call 'updateFileMonitor' passing it the timestamp. --- See 'updateFileMonitor' for details. --- -beginUpdateFileMonitor :: IO MonitorTimestamp -beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime - --- | Take the snapshot of the monitored files. That is, given the --- specification of the set of files we need to monitor, inspect the state --- of the file system now and collect the information we'll need later to --- determine if anything has changed. --- -buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp - -- of the start of the action - -> FileHashCache -- ^ existing file hashes - -> FilePath -- ^ root directory - -> [MonitorFilePath] -- ^ patterns of interest - -- relative to root - -> IO MonitorStateFileSet -buildMonitorStateFileSet mstartTime hashcache root = - go [] [] - where - go :: [MonitorStateFile] -> [MonitorStateGlob] - -> [MonitorFilePath] -> IO MonitorStateFileSet - go !singlePaths !globPaths [] = - return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) - - go !singlePaths !globPaths - (MonitorFile kindfile kinddir path : monitors) = do - monitorState <- MonitorStateFile kindfile kinddir path - <$> buildMonitorStateFile mstartTime hashcache - kindfile kinddir root path - go (monitorState : singlePaths) globPaths monitors - - go !singlePaths !globPaths - (MonitorFileGlob kindfile kinddir globPath : monitors) = do - monitorState <- buildMonitorStateGlob mstartTime hashcache - kindfile kinddir root globPath - go singlePaths (monitorState : globPaths) monitors - - -buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePath - -> IO MonitorStateFileStatus -buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do - let abspath = root path - isFile <- doesFileExist abspath - isDir <- doesDirectoryExist abspath - case (isFile, kindfile, isDir, kinddir) of - (_, FileNotExists, _, DirNotExists) -> - -- we don't need to care if it exists now, since we check at probe time - return MonitorStateNonExistent - - (False, _, False, _) -> - return MonitorStateAlreadyChanged - - (True, FileExists, _, _) -> - return MonitorStateFileExists - - (True, FileModTime, _, _) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else return (MonitorStateFileModTime mtime) - - (True, FileHashed, _, _) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else do hash <- getFileHash hashcache abspath abspath mtime - return (MonitorStateFileHashed mtime hash) - - (_, _, True, DirExists) -> - return MonitorStateDirExists - - (_, _, True, DirModTime) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else return (MonitorStateDirModTime mtime) - - (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged - (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged - --- | If we have a timestamp for the beginning of the update, then any file --- mtime later than this means that it changed during the update and we ought --- to consider the file as already changed. --- -changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool -changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime - = mtime > startTime -changedDuringUpdate _ _ = False - --- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case --- of a file glob. --- --- This gets used both by 'buildMonitorStateFileSet' when we're taking the --- file system snapshot, but also by 'probeGlobStatus' as part of checking --- the monitored (globed) files for changes when we find a whole new subtree. --- -buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePathGlob -- ^ the matching glob - -> IO MonitorStateGlob -buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot - (FilePathGlob globroot globPath) = do - root <- liftIO $ getFilePathRootDirectory globroot relroot - MonitorStateGlob kindfile kinddir globroot <$> - buildMonitorStateGlobRel - mstartTime hashcache kindfile kinddir root "." globPath - -buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePath -- ^ directory we are examining - -- relative to the root - -> FilePathGlobRel -- ^ the matching glob - -> IO MonitorStateGlobRel -buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root - dir globPath = do - let absdir = root dir - dirEntries <- getDirectoryContents absdir - dirMTime <- getModTime absdir - case globPath of - GlobDir glob globPath' -> do - subdirs <- filterM (\subdir -> doesDirectoryExist (absdir subdir)) - $ filter (matchGlob glob) dirEntries - subdirStates <- - for (sort subdirs) $ \subdir -> do - fstate <- buildMonitorStateGlobRel - mstartTime hashcache kindfile kinddir root - (dir subdir) globPath' - return (subdir, fstate) - return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates - - GlobFile glob -> do - let files = filter (matchGlob glob) dirEntries - filesStates <- - for (sort files) $ \file -> do - fstate <- buildMonitorStateFile - mstartTime hashcache kindfile kinddir root - (dir file) - return (file, fstate) - return $! MonitorStateGlobFiles glob dirMTime filesStates - - GlobDirTrailing -> - return MonitorStateGlobDirTrailing - - --- | We really want to avoid re-hashing files all the time. We already make --- the assumption that if a file mtime has not changed then we don't need to --- bother checking if the content hash has changed. We can apply the same --- assumption when updating the file monitor state. In the typical case of --- updating a file monitor the set of files is the same or largely the same so --- we can grab the previously known content hashes with their corresponding --- mtimes. --- -type FileHashCache = Map FilePath (ModTime, Hash) - --- | We declare it a cache hit if the mtime of a file is the same as before. --- -lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash -lookupFileHashCache hashcache file mtime = do - (mtime', hash) <- Map.lookup file hashcache - guard (mtime' == mtime) - return hash - --- | Either get it from the cache or go read the file -getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash -getFileHash hashcache relfile absfile mtime = - case lookupFileHashCache hashcache relfile mtime of - Just hash -> return hash - Nothing -> readFileHash absfile - --- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While --- in principle we could preserve the structure of the previous state, given --- that the set of files to monitor can change then it's simpler just to throw --- away the structure and use a finite map. --- -readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -> IO FileHashCache -readCacheFileHashes monitor = - handleDoesNotExist Map.empty $ - handleErrorCall Map.empty $ do - res <- readCacheFile monitor - case res of - Left _ -> return Map.empty - Right (msfs, _, _) -> return (mkFileHashCache msfs) - where - mkFileHashCache :: MonitorStateFileSet -> FileHashCache - mkFileHashCache (MonitorStateFileSet singlePaths globPaths) = - collectAllFileHashes singlePaths - `Map.union` collectAllGlobHashes globPaths - - collectAllFileHashes singlePaths = - Map.fromList [ (fpath, (mtime, hash)) - | MonitorStateFile _ _ fpath - (MonitorStateFileHashed mtime hash) <- singlePaths ] - - collectAllGlobHashes globPaths = - Map.fromList [ (fpath, (mtime, hash)) - | MonitorStateGlob _ _ _ gstate <- globPaths - , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] - - collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = - [ res - | (subdir, fstate) <- entries - , res <- collectGlobHashes (dir subdir) fstate ] - - collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) = - [ (dir fname, (mtime, hash)) - | (fname, MonitorStateFileHashed mtime hash) <- entries ] - - collectGlobHashes _dir MonitorStateGlobDirTrailing = - [] - - ------------------------------------------------------------------------------- --- Utils --- - --- | Within the @root@ directory, check if @file@ has its 'ModTime' is --- the same as @mtime@, short-circuiting if it is different. -probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM () -probeFileModificationTime root file mtime = do - unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime - unless unchanged (somethingChanged file) - --- | Within the @root@ directory, check if @file@ has its 'ModTime' and --- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is --- different. -probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash - -> ChangedM () -probeFileModificationTimeAndHash root file mtime hash = do - unchanged <- liftIO $ - checkFileModificationTimeAndHashUnchanged root file mtime hash - unless unchanged (somethingChanged file) - --- | Within the @root@ directory, check if @file@ still exists as a file. --- If it *does not* exist, short-circuit. -probeFileExistence :: FilePath -> FilePath -> ChangedM () -probeFileExistence root file = do - existsFile <- liftIO $ doesFileExist (root file) - unless existsFile (somethingChanged file) - --- | Within the @root@ directory, check if @dir@ still exists. --- If it *does not* exist, short-circuit. -probeDirExistence :: FilePath -> FilePath -> ChangedM () -probeDirExistence root dir = do - existsDir <- liftIO $ doesDirectoryExist (root dir) - unless existsDir (somethingChanged dir) - --- | Within the @root@ directory, check if @file@ still does not exist. --- If it *does* exist, short-circuit. -probeFileNonExistence :: FilePath -> FilePath -> ChangedM () -probeFileNonExistence root file = do - existsFile <- liftIO $ doesFileExist (root file) - existsDir <- liftIO $ doesDirectoryExist (root file) - when (existsFile || existsDir) (somethingChanged file) - --- | Returns @True@ if, inside the @root@ directory, @file@ has the same --- 'ModTime' as @mtime@. -checkModificationTimeUnchanged :: FilePath -> FilePath - -> ModTime -> IO Bool -checkModificationTimeUnchanged root file mtime = - handleIOException False $ do - mtime' <- getModTime (root file) - return (mtime == mtime') - --- | Returns @True@ if, inside the @root@ directory, @file@ has the --- same 'ModTime' and 'Hash' as @mtime and @chash@. -checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath - -> ModTime -> Hash -> IO Bool -checkFileModificationTimeAndHashUnchanged root file mtime chash = - handleIOException False $ do - mtime' <- getModTime (root file) - if mtime == mtime' - then return True - else do - chash' <- readFileHash (root file) - return (chash == chash') - --- | Read a non-cryptographic hash of a @file@. -readFileHash :: FilePath -> IO Hash -readFileHash file = - withBinaryFile file ReadMode $ \hnd -> - evaluate . Hashable.hash =<< BS.hGetContents hnd - --- | Given a directory @dir@, return @Nothing@ if its 'ModTime' --- is the same as @mtime@, and the new 'ModTime' if it is not. -checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime) -checkDirectoryModificationTime dir mtime = - handleIOException Nothing $ do - mtime' <- getModTime dir - if mtime == mtime' - then return Nothing - else return (Just mtime') - --- | Run an IO computation, returning the first argument @e@ if there is an 'error' --- call. ('ErrorCall') -handleErrorCall :: a -> IO a -> IO a -handleErrorCall e = handle handler where -#if MIN_VERSION_base(4,9,0) - handler (ErrorCallWithLocation _ _) = return e -#else - handler (ErrorCall _) = return e -#endif - - --- | Run an IO computation, returning @e@ if there is any 'IOException'. --- --- This policy is OK in the file monitor code because it just causes the --- monitor to report that something changed, and then code reacting to that --- will normally encounter the same IO exception when it re-runs the action --- that uses the file. --- -handleIOException :: a -> IO a -> IO a -handleIOException e = - handle (anyIOException e) - where - anyIOException :: a -> IOException -> IO a - anyIOException x _ = return x - - ------------------------------------------------------------------------------- --- Instances --- - diff --git a/Distribution/Client/Freeze.hs b/Distribution/Client/Freeze.hs deleted file mode 100644 --- a/Distribution/Client/Freeze.hs +++ /dev/null @@ -1,266 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Freeze --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- The cabal freeze command ------------------------------------------------------------------------------ -module Distribution.Client.Freeze ( - freeze, getFreezePkgs - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.Config ( SavedConfig(..) ) -import Distribution.Client.Types -import Distribution.Client.Targets -import Distribution.Client.Dependency -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.SolverInstallPlan - ( SolverInstallPlan, SolverPlanPackage ) -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Setup - ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) - , RepoContext(..) ) -import Distribution.Client.Sandbox.PackageEnvironment - ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment, - userPackageEnvironmentFile ) - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb -import Distribution.Solver.Types.SolverId - -import Distribution.Package - ( Package, packageId, packageName, packageVersion ) -import Distribution.Simple.Compiler - ( Compiler, compilerInfo, PackageDBStack ) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.Setup - ( fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.Simple.Utils - ( die', notice, debug, writeFileAtomic, toUTF8LBS) -import Distribution.System - ( Platform ) - -import Distribution.Version - ( thisVersion ) - --- ------------------------------------------------------------ --- * The freeze command --- ------------------------------------------------------------ - --- | Freeze all of the dependencies by writing a constraints section --- constraining each dependency to an exact version. --- -freeze :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO () -freeze verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags = do - - pkgs <- getFreezePkgs - verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags - - if null pkgs - then notice verbosity $ "No packages to be frozen. " - ++ "As this package has no dependencies." - else if dryRun - then notice verbosity $ unlines $ - "The following packages would be frozen:" - : formatPkgs pkgs - - else freezePackages verbosity globalFlags pkgs - - where - dryRun = fromFlag (freezeDryRun freezeFlags) - --- | Get the list of packages whose versions would be frozen by the @freeze@ --- command. -getFreezePkgs :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO [SolverPlanPackage] -getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - [UserTargetLocalDir "."] - - sanityCheck pkgSpecifiers - planPackages - verbosity comp platform freezeFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - where - sanityCheck pkgSpecifiers = do - when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ - die' verbosity $ "internal error: 'resolveUserTargets' returned " - ++ "unexpected named package specifiers!" - when (length pkgSpecifiers /= 1) $ - die' verbosity $ "internal error: 'resolveUserTargets' returned " - ++ "unexpected source package specifiers!" - -planPackages :: Verbosity - -> Compiler - -> Platform - -> FreezeFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO [SolverPlanPackage] -planPackages verbosity comp platform freezeFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do - - solver <- chooseSolver verbosity - (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) - notice verbosity "Resolving dependencies..." - - installPlan <- foldProgress logMsg (die' verbosity) return $ - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - return $ pruneInstallPlan installPlan pkgSpecifiers - - where - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . addConstraints - [ let pkg = pkgSpecifierTarget pkgSpecifier - pc = PackageConstraint (scopeToplevel pkg) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceFreeze - | pkgSpecifier <- pkgSpecifiers ] - - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - - logMsg message rest = debug verbosity message >> rest - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags - benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags - - reorderGoals = fromFlag (freezeReorderGoals freezeFlags) - countConflicts = fromFlag (freezeCountConflicts freezeFlags) - fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) - minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) - independentGoals = fromFlag (freezeIndependentGoals freezeFlags) - shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) - strongFlags = fromFlag (freezeStrongFlags freezeFlags) - maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) - allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) - onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags) - - --- | Remove all unneeded packages from an install plan. --- --- A package is unneeded if it is either --- --- 1) the package that we are freezing, or --- --- 2) not a dependency (directly or transitively) of the package we are --- freezing. This is useful for removing previously installed packages --- which are no longer required from the install plan. --- --- Invariant: @pkgSpecifiers@ must refer to packages which are not --- 'PreExisting' in the 'SolverInstallPlan'. -pruneInstallPlan :: SolverInstallPlan - -> [PackageSpecifier UnresolvedSourcePackage] - -> [SolverPlanPackage] -pruneInstallPlan installPlan pkgSpecifiers = - removeSelf pkgIds $ - SolverInstallPlan.dependencyClosure installPlan pkgIds - where - pkgIds = [ PlannedId (packageId pkg) - | SpecificSourcePackage pkg <- pkgSpecifiers ] - removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) - removeSelf _ = error $ "internal error: 'pruneInstallPlan' given " - ++ "unexpected package specifiers!" - - -freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO () -freezePackages verbosity globalFlags pkgs = do - - pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ - loadUserConfig verbosity "" - (flagToMaybe . globalConstraintsFile $ globalFlags) - writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv - where - addFrozenConstraints config = - config { - savedConfigureExFlags = (savedConfigureExFlags config) { - configExConstraints = map constraint pkgs - } - } - constraint pkg = - (pkgIdToConstraint $ packageId pkg - ,ConstraintSourceUserConfig userPackageEnvironmentFile) - where - pkgIdToConstraint pkgId = - UserConstraint (UserQualified UserQualToplevel (packageName pkgId)) - (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) - createPkgEnv config = mempty { pkgEnvSavedConfig = config } - showPkgEnv = toUTF8LBS . showPackageEnvironment - - -formatPkgs :: Package pkg => [pkg] -> [String] -formatPkgs = map $ showPkg . packageId - where - showPkg pid = name pid ++ " == " ++ version pid - name = prettyShow . packageName - version = prettyShow . packageVersion diff --git a/Distribution/Client/GZipUtils.hs b/Distribution/Client/GZipUtils.hs deleted file mode 100644 --- a/Distribution/Client/GZipUtils.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.GZipUtils --- Copyright : (c) Dmitry Astapov 2010 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Provides a convenience functions for working with files that may or may not --- be zipped. ------------------------------------------------------------------------------ -module Distribution.Client.GZipUtils ( - maybeDecompress, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Codec.Compression.Zlib.Internal -import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) - -#ifndef MIN_VERSION_zlib -#define MIN_VERSION_zlib(x,y,z) 1 -#endif - -#if MIN_VERSION_zlib(0,6,0) -import Control.Exception (throw) -import Control.Monad.ST.Lazy (ST, runST) -import qualified Data.ByteString as Strict -#endif - --- | Attempts to decompress the `bytes' under the assumption that --- "data format" error at the very beginning of the stream means --- that it is already decompressed. Caller should make sanity checks --- to verify that it is not, in fact, garbage. --- --- This is to deal with http proxies that lie to us and transparently --- decompress without removing the content-encoding header. See: --- --- -maybeDecompress :: ByteString -> ByteString -#if MIN_VERSION_zlib(0,6,0) -maybeDecompress bytes = runST (go bytes decompressor) - where - decompressor :: DecompressStream (ST s) - decompressor = decompressST gzipOrZlibFormat defaultDecompressParams - - -- DataError at the beginning of the stream probably means that stream is - -- not compressed, so we return it as-is. - -- TODO: alternatively, we might consider looking for the two magic bytes - -- at the beginning of the gzip header. (not an option for zlib, though.) - go :: Monad m => ByteString -> DecompressStream m -> m ByteString - go cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k - go _ (DecompressStreamEnd _bs ) = return Empty - go _ (DecompressStreamError _err ) = return bytes - go cs (DecompressInputRequired k) = go cs' =<< k c - where - (c, cs') = uncons cs - - -- Once we have received any output though we regard errors as actual errors - -- and we throw them (as pure exceptions). - -- TODO: We could (and should) avoid these pure exceptions. - go' :: Monad m => ByteString -> DecompressStream m -> m ByteString - go' cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k - go' _ (DecompressStreamEnd _bs ) = return Empty - go' _ (DecompressStreamError err ) = throw err - go' cs (DecompressInputRequired k) = go' cs' =<< k c - where - (c, cs') = uncons cs - - uncons :: ByteString -> (Strict.ByteString, ByteString) - uncons Empty = (Strict.empty, Empty) - uncons (Chunk c cs) = (c, cs) -#else -maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes - where - -- DataError at the beginning of the stream probably means that stream is not compressed. - -- Returning it as-is. - -- TODO: alternatively, we might consider looking for the two magic bytes - -- at the beginning of the gzip header. - foldStream (StreamError _ _) = bytes - foldStream somethingElse = doFold somethingElse - - doFold StreamEnd = BS.Empty - doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream) - doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg -#endif diff --git a/Distribution/Client/GenBounds.hs b/Distribution/Client/GenBounds.hs deleted file mode 100644 --- a/Distribution/Client/GenBounds.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.GenBounds --- Copyright : (c) Doug Beardsley 2015 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- The cabal gen-bounds command for generating PVP-compliant version bounds. ------------------------------------------------------------------------------ -module Distribution.Client.GenBounds ( - genBounds - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic (safeLast) - -import Distribution.Client.Init - ( incVersion ) -import Distribution.Client.Freeze - ( getFreezePkgs ) -import Distribution.Client.Setup - ( GlobalFlags(..), FreezeFlags(..), RepoContext ) -import Distribution.Package - ( Package(..), unPackageName, packageName, packageVersion ) -import Distribution.PackageDescription - ( enabledBuildDepends ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription ) -import Distribution.Types.ComponentRequestedSpec - ( defaultComponentRequestedSpec ) -import Distribution.Types.Dependency -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack, compilerInfo ) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.Utils - ( tryFindPackageDesc ) -import Distribution.System - ( Platform ) -import Distribution.Version - ( Version, alterVersion - , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals - , orLaterVersion, earlierVersion, intersectVersionRanges ) -import System.Directory - ( getCurrentDirectory ) - --- | Does this version range have an upper bound? -hasUpperBound :: VersionRange -> Bool -hasUpperBound vr = - case safeLast (asVersionIntervals vr) of - Nothing -> False - Just l -> if snd l == NoUpperBound then False else True - --- | Given a version, return an API-compatible (according to PVP) version range. --- --- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@. --- --- This version is slightly different than the one in --- 'Distribution.Client.Init'. This one uses a.b.c as the lower bound because --- the user could be using a new function introduced in a.b.c which would make --- ">= a.b" incorrect. -pvpize :: Version -> VersionRange -pvpize v = orLaterVersion (vn 3) - `intersectVersionRanges` - earlierVersion (incVersion 1 (vn 2)) - where - vn n = alterVersion (take n) v - --- | Show the PVP-mandated version range for this package. The @padTo@ parameter --- specifies the width of the package name column. -showBounds :: Package pkg => Int -> pkg -> String -showBounds padTo p = unwords $ - (padAfter padTo $ unPackageName $ packageName p) : - map showInterval (asVersionIntervals $ pvpize $ packageVersion p) - where - padAfter :: Int -> String -> String - padAfter n str = str ++ replicate (n - length str) ' ' - - showInterval :: (LowerBound, UpperBound) -> String - showInterval (LowerBound _ _, NoUpperBound) = - error "Error: expected upper bound...this should never happen!" - showInterval (LowerBound l _, UpperBound u _) = - unwords [">=", prettyShow l, "&& <", prettyShow u] - --- | Entry point for the @gen-bounds@ command. -genBounds - :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO () -genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do - let cinfo = compilerInfo comp - - cwd <- getCurrentDirectory - path <- tryFindPackageDesc verbosity cwd - gpd <- readGenericPackageDescription verbosity path - -- NB: We don't enable tests or benchmarks, since often they - -- don't really have useful bounds. - let epd = finalizePD mempty defaultComponentRequestedSpec - (const True) platform cinfo [] gpd - case epd of - Left _ -> putStrLn "finalizePD failed" - Right (pd,_) -> do - let needBounds = filter (not . hasUpperBound . depVersion) $ - enabledBuildDepends pd defaultComponentRequestedSpec - - if (null needBounds) - then putStrLn - "Congratulations, all your dependencies have upper bounds!" - else go needBounds - where - go needBounds = do - pkgs <- getFreezePkgs - verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags - - putStrLn boundsNeededMsg - - let isNeeded pkg = unPackageName (packageName pkg) - `elem` map depName needBounds - let thePkgs = filter isNeeded pkgs - - let padTo = maximum $ map (length . unPackageName . packageName) pkgs - traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs - - depName :: Dependency -> String - depName (Dependency pn _ _) = unPackageName pn - - depVersion :: Dependency -> VersionRange - depVersion (Dependency _ vr _) = vr - --- | The message printed when some dependencies are found to be lacking proper --- PVP-mandated bounds. -boundsNeededMsg :: String -boundsNeededMsg = unlines - [ "" - , "The following packages need bounds and here is a suggested starting point." - , "You can copy and paste this into the build-depends section in your .cabal" - , "file and it should work (with the appropriate removal of commas)." - , "" - , "Note that version bounds are a statement that you've successfully built and" - , "tested your package and expect it to work with any of the specified package" - , "versions (PROVIDED that those packages continue to conform with the PVP)." - , "Therefore, the version bounds generated here are the most conservative" - , "based on the versions that you are currently building with. If you know" - , "your package will work with versions outside the ranges generated here," - , "feel free to widen them." - , "" - ] diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs deleted file mode 100644 --- a/Distribution/Client/Get.hs +++ /dev/null @@ -1,333 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Get --- Copyright : (c) Andrea Vezzosi 2008 --- Duncan Coutts 2011 --- John Millikin 2012 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- The 'cabal get' command. ------------------------------------------------------------------------------ - -module Distribution.Client.Get ( - get, - - -- * Cloning 'SourceRepo's - -- | Mainly exported for testing purposes - clonePackagesFromSourceRepo, - ClonePackageException(..), - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (get) -import Distribution.Compat.Directory - ( listDirectory ) -import Distribution.Package - ( PackageId, packageId, packageName ) -import Distribution.Simple.Setup - ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.Simple.Utils - ( notice, die', info, writeFileAtomic ) -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Program - ( programName ) -import Distribution.Types.SourceRepo (RepoKind (..)) -import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) - -import Distribution.Client.Setup - ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) -import Distribution.Client.Types -import Distribution.Client.Targets -import Distribution.Client.Dependency -import Distribution.Client.VCS -import Distribution.Client.FetchUtils -import qualified Distribution.Client.Tar as Tar (extractTarGzFile) -import Distribution.Client.IndexUtils - ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos ) -import Distribution.Solver.Types.SourcePackage - -import qualified Data.Map as Map -import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) -import System.FilePath - ( (), (<.>), addTrailingPathSeparator ) - - --- | Entry point for the 'cabal get' command. -get :: Verbosity - -> RepoContext - -> GlobalFlags - -> GetFlags - -> [UserTarget] - -> IO () -get verbosity _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -get verbosity repoCtxt globalFlags getFlags userTargets = do - let useSourceRepo = case getSourceRepository getFlags of - NoFlag -> False - _ -> True - - unless useSourceRepo $ - traverse_ (checkTarget verbosity) userTargets - - let idxState :: Maybe TotalIndexState - idxState = flagToMaybe $ getIndexState getFlags - - activeRepos :: Maybe ActiveRepos - activeRepos = flagToMaybe $ getActiveRepos getFlags - - (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - userTargets - - pkgs <- either (die' verbosity . unlines . map show) return $ - resolveWithoutDependencies - (resolverParams sourcePkgDb pkgSpecifiers) - - unless (null prefix) $ - createDirectoryIfMissing True prefix - - if useSourceRepo - then clone pkgs - else unpack pkgs - - where - resolverParams sourcePkgDb pkgSpecifiers = - --TODO: add command-line constraint and preference args for unpack - standardInstallPolicy mempty sourcePkgDb pkgSpecifiers - - prefix = fromFlagOrDefault "" (getDestDir getFlags) - - clone :: [UnresolvedSourcePackage] -> IO () - clone = clonePackagesFromSourceRepo verbosity prefix kind - . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) - where - kind = fromFlag . getSourceRepository $ getFlags - packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo] - packageSourceRepos = PD.sourceRepos - . PD.packageDescription - . srcpkgDescription - - unpack :: [UnresolvedSourcePackage] -> IO () - unpack pkgs = do - for_ pkgs $ \pkg -> do - location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg) - let pkgid = packageId pkg - descOverride | usePristine = Nothing - | otherwise = srcpkgDescrOverride pkg - case location of - LocalTarballPackage tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - RemoteTarballPackage _tarballURL tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - RepoTarballPackage _repo _pkgid tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - RemoteSourceRepoPackage _repo _ -> - die' verbosity $ "The 'get' command does no yet support targets " - ++ "that are remote source repositories." - - LocalUnpackedPackage _ -> - error "Distribution.Client.Get.unpack: the impossible happened." - where - usePristine = fromFlagOrDefault False (getPristine getFlags) - -checkTarget :: Verbosity -> UserTarget -> IO () -checkTarget verbosity target = case target of - UserTargetLocalDir dir -> die' verbosity (notTarball dir) - UserTargetLocalCabalFile file -> die' verbosity (notTarball file) - _ -> return () - where - notTarball t = - "The 'get' command is for tarball packages. " - ++ "The target '" ++ t ++ "' is not a tarball." - --- ------------------------------------------------------------ --- * Unpacking the source tarball --- ------------------------------------------------------------ - -unpackPackage :: Verbosity -> FilePath -> PackageId - -> PackageDescriptionOverride - -> FilePath -> IO () -unpackPackage verbosity prefix pkgid descOverride pkgPath = do - let pkgdirname = prettyShow pkgid - pkgdir = prefix pkgdirname - pkgdir' = addTrailingPathSeparator pkgdir - emptyDirectory directory = null <$> listDirectory directory - existsDir <- doesDirectoryExist pkgdir - when existsDir $ do - isEmpty <- emptyDirectory pkgdir - unless isEmpty $ - die' verbosity $ - "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking." - existsFile <- doesFileExist pkgdir - when existsFile $ die' verbosity $ - "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." - notice verbosity $ "Unpacking to " ++ pkgdir' - Tar.extractTarGzFile prefix pkgdirname pkgPath - - case descOverride of - Nothing -> return () - Just pkgtxt -> do - let descFilePath = pkgdir prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ - "Updating " ++ descFilePath - ++ " with the latest revision from the index." - writeFileAtomic descFilePath pkgtxt - - --- ------------------------------------------------------------ --- * Cloning packages from their declared source repositories --- ------------------------------------------------------------ - - -data ClonePackageException = - ClonePackageNoSourceRepos PackageId - | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) - | ClonePackageNoRepoType PackageId PD.SourceRepo - | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType - | ClonePackageNoRepoLocation PackageId PD.SourceRepo - | ClonePackageDestinationExists PackageId FilePath Bool - | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode - deriving (Show, Eq) - -instance Exception ClonePackageException where - displayException (ClonePackageNoSourceRepos pkgid) = - "Cannot fetch a source repository for package " ++ prettyShow pkgid - ++ ". The package does not specify any source repositories." - - displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) = - "Cannot fetch a source repository for package " ++ prettyShow pkgid - ++ ". The package does not specify a source repository of the requested " - ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind - - displayException (ClonePackageNoRepoType pkgid _repo) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The package's description specifies a source repository but does " - ++ "not specify the repository 'type' field (e.g. git, darcs or hg)." - - displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The repository type '" ++ prettyShow repoType - ++ "' is not yet supported." - - displayException (ClonePackageNoRepoLocation pkgid _repo) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The package's description specifies a source repository but does " - ++ "not specify the repository 'location' field (i.e. the URL)." - - displayException (ClonePackageDestinationExists pkgid dest isdir) = - "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". " - ++ if isdir then "The destination directory " ++ dest ++ " already exists." - else "A file " ++ dest ++ " is in the way." - - displayException (ClonePackageFailedWithExitCode - pkgid repo vcsprogname exitcode) = - "Failed to fetch the source repository for package " ++ prettyShow pkgid - ++ ", repository location " ++ srpLocation repo ++ " (" - ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." - - --- | Given a bunch of package ids and their corresponding available --- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into --- new subdirs of the given directory. --- -clonePackagesFromSourceRepo :: Verbosity - -> FilePath -- ^ destination dir prefix - -> Maybe RepoKind -- ^ preferred 'RepoKind' - -> [(PackageId, [PD.SourceRepo])] - -- ^ the packages and their - -- available 'SourceRepo's - -> IO () -clonePackagesFromSourceRepo verbosity destDirPrefix - preferredRepoKind pkgrepos = do - - -- Do a bunch of checks and collect the required info - pkgrepos' <- traverse preCloneChecks pkgrepos - - -- Configure the VCS drivers for all the repository types we may need - vcss <- configureVCSs verbosity $ - Map.fromList [ (vcsRepoType vcs, vcs) - | (_, _, vcs, _) <- pkgrepos' ] - - -- Now execute all the required commands for each repo - sequence_ - [ cloneSourceRepo verbosity vcs' repo destDir - `catch` \exitcode -> - throwIO (ClonePackageFailedWithExitCode - pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode) - | (pkgid, repo, vcs, destDir) <- pkgrepos' - , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss - ] - - where - preCloneChecks :: (PackageId, [PD.SourceRepo]) - -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) - preCloneChecks (pkgid, repos) = do - repo <- case selectPackageSourceRepo preferredRepoKind repos of - Just repo -> return repo - Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid) - Nothing -> throwIO (ClonePackageNoSourceReposOfKind - pkgid preferredRepoKind) - - (repo', vcs) <- case validatePDSourceRepo repo of - Right (repo', _, _, vcs) -> return (repo', vcs) - Left SourceRepoRepoTypeUnspecified -> - throwIO (ClonePackageNoRepoType pkgid repo) - - Left (SourceRepoRepoTypeUnsupported repo' repoType) -> - throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) - - Left SourceRepoLocationUnspecified -> - throwIO (ClonePackageNoRepoLocation pkgid repo) - - let destDir = destDirPrefix prettyShow (packageName pkgid) - destDirExists <- doesDirectoryExist destDir - destFileExists <- doesFileExist destDir - when (destDirExists || destFileExists) $ - throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) - - return (pkgid, repo', vcs, destDir) - -------------------------------------------------------------------------------- --- Selecting -------------------------------------------------------------------------------- - --- | Pick the 'SourceRepo' to use to get the package sources from. --- --- Note that this does /not/ depend on what 'VCS' drivers we are able to --- successfully configure. It is based only on the 'SourceRepo's declared --- in the package, and optionally on a preferred 'RepoKind'. --- -selectPackageSourceRepo :: Maybe RepoKind - -> [PD.SourceRepo] - -> Maybe PD.SourceRepo -selectPackageSourceRepo preferredRepoKind = - listToMaybe - -- Sort repositories by kind, from This to Head to Unknown. Repositories - -- with equivalent kinds are selected based on the order they appear in - -- the Cabal description file. - . sortBy (comparing thisFirst) - -- If the user has specified the repo kind, filter out the repositories - -- they're not interested in. - . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind) - where - thisFirst :: PD.SourceRepo -> Int - thisFirst r = case PD.repoKind r of - RepoThis -> 0 - RepoHead -> case PD.repoTag r of - -- If the type is 'head' but the author specified a tag, they - -- probably meant to create a 'this' repository but screwed up. - Just _ -> 0 - Nothing -> 1 - RepoKindUnknown _ -> 2 diff --git a/Distribution/Client/Glob.hs b/Distribution/Client/Glob.hs deleted file mode 100644 --- a/Distribution/Client/Glob.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - ---TODO: [code cleanup] plausibly much of this module should be merged with --- similar functionality in Cabal. -module Distribution.Client.Glob - ( FilePathGlob(..) - , FilePathRoot(..) - , FilePathGlobRel(..) - , Glob - , GlobPiece(..) - , matchFileGlob - , matchFileGlobRel - , matchGlob - , isTrivialFilePathGlob - , getFilePathRootDirectory - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Data.List (stripPrefix) -import System.Directory -import System.FilePath - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - - --- | A file path specified by globbing --- -data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel - deriving (Eq, Show, Generic) - -data FilePathGlobRel - = GlobDir !Glob !FilePathGlobRel - | GlobFile !Glob - | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@ - deriving (Eq, Show, Generic) - --- | A single directory or file component of a globbed path -type Glob = [GlobPiece] - --- | A piece of a globbing pattern -data GlobPiece = WildCard - | Literal String - | Union [Glob] - deriving (Eq, Show, Generic) - -data FilePathRoot - = FilePathRelative - | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive' - | FilePathHomeDir - deriving (Eq, Show, Generic) - -instance Binary FilePathGlob -instance Binary FilePathRoot -instance Binary FilePathGlobRel -instance Binary GlobPiece - -instance Structured FilePathGlob -instance Structured FilePathRoot -instance Structured FilePathGlobRel -instance Structured GlobPiece - --- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and --- is in fact equivalent to a non-glob 'FilePath'. --- --- If it is trivial in this sense then the result is the equivalent constant --- 'FilePath'. On the other hand if it is not trivial (so could in principle --- match more than one file) then the result is @Nothing@. --- -isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath -isTrivialFilePathGlob (FilePathGlob root pathglob) = - case root of - FilePathRelative -> go [] pathglob - FilePathRoot root' -> go [root'] pathglob - FilePathHomeDir -> Nothing - where - go paths (GlobDir [Literal path] globs) = go (path:paths) globs - go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths))) - go paths GlobDirTrailing = Just (addTrailingPathSeparator - (joinPath (reverse paths))) - go _ _ = Nothing - --- | Get the 'FilePath' corresponding to a 'FilePathRoot'. --- --- The 'FilePath' argument is required to supply the path for the --- 'FilePathRelative' case. --- -getFilePathRootDirectory :: FilePathRoot - -> FilePath -- ^ root for relative paths - -> IO FilePath -getFilePathRootDirectory FilePathRelative root = return root -getFilePathRootDirectory (FilePathRoot root) _ = return root -getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory - - ------------------------------------------------------------------------------- --- Matching --- - --- | Match a 'FilePathGlob' against the file system, starting from a given --- root directory for relative paths. The results of relative globs are --- relative to the given root. Matches for absolute globs are absolute. --- -matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath] -matchFileGlob relroot (FilePathGlob globroot glob) = do - root <- getFilePathRootDirectory globroot relroot - matches <- matchFileGlobRel root glob - case globroot of - FilePathRelative -> return matches - _ -> return (map (root ) matches) - --- | Match a 'FilePathGlobRel' against the file system, starting from a --- given root directory. The results are all relative to the given root. --- -matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath] -matchFileGlobRel root glob0 = go glob0 "" - where - go (GlobFile glob) dir = do - entries <- getDirectoryContents (root dir) - let files = filter (matchGlob glob) entries - return (map (dir ) files) - - go (GlobDir glob globPath) dir = do - entries <- getDirectoryContents (root dir) - subdirs <- filterM (\subdir -> doesDirectoryExist - (root dir subdir)) - $ filter (matchGlob glob) entries - concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs - - go GlobDirTrailing dir = return [dir] - - --- | Match a globbing pattern against a file path component --- -matchGlob :: Glob -> String -> Bool -matchGlob = goStart - where - -- From the man page, glob(7): - -- "If a filename starts with a '.', this character must be - -- matched explicitly." - - go, goStart :: [GlobPiece] -> String -> Bool - - goStart (WildCard:_) ('.':_) = False - goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs) - globs - goStart rest cs = go rest cs - - go [] "" = True - go (Literal lit:rest) cs - | Just cs' <- stripPrefix lit cs - = go rest cs' - | otherwise = False - go [WildCard] "" = True - go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs - go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs - go [] (_:_) = False - go (_:_) "" = False - - ------------------------------------------------------------------------------- --- Parsing & printing --- - -instance Pretty FilePathGlob where - pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob - -instance Parsec FilePathGlob where - parsec = do - root <- parsec - case root of - FilePathRelative -> FilePathGlob root <$> parsec - _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing) - -instance Pretty FilePathRoot where - pretty FilePathRelative = Disp.empty - pretty (FilePathRoot root) = Disp.text root - pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' - -instance Parsec FilePathRoot where - parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where - root = FilePathRoot "/" <$ P.char '/' - home = FilePathHomeDir <$ P.string "~/" - drive = do - dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') - _ <- P.char ':' - _ <- P.char '/' <|> P.char '\\' - return (FilePathRoot (toUpper dr : ":\\")) - -instance Pretty FilePathGlobRel where - pretty (GlobDir glob pathglob) = dispGlob glob - Disp.<> Disp.char '/' - Disp.<> pretty pathglob - pretty (GlobFile glob) = dispGlob glob - pretty GlobDirTrailing = Disp.empty - -instance Parsec FilePathGlobRel where - parsec = parsecPath where - parsecPath :: CabalParsing m => m FilePathGlobRel - parsecPath = do - glob <- parsecGlob - dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) - - dirSep :: CabalParsing m => m () - dirSep = () <$ P.char '/' <|> P.try (do - _ <- P.char '\\' - -- check this isn't an escape code - P.notFollowedBy (P.satisfy isGlobEscapedChar)) - -dispGlob :: Glob -> Disp.Doc -dispGlob = Disp.hcat . map dispPiece - where - dispPiece WildCard = Disp.char '*' - dispPiece (Literal str) = Disp.text (escape str) - dispPiece (Union globs) = Disp.braces - (Disp.hcat (Disp.punctuate - (Disp.char ',') - (map dispGlob globs))) - escape [] = [] - escape (c:cs) - | isGlobEscapedChar c = '\\' : c : escape cs - | otherwise = c : escape cs - -parsecGlob :: CabalParsing m => m Glob -parsecGlob = some parsecPiece where - parsecPiece = P.choice [ literal, wildcard, union ] - - wildcard = WildCard <$ P.char '*' - union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) - literal = Literal <$> some litchar - - litchar = normal <|> escape - - normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') - escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar - -isGlobEscapedChar :: Char -> Bool -isGlobEscapedChar '*' = True -isGlobEscapedChar '{' = True -isGlobEscapedChar '}' = True -isGlobEscapedChar ',' = True -isGlobEscapedChar _ = False diff --git a/Distribution/Client/GlobalFlags.hs b/Distribution/Client/GlobalFlags.hs deleted file mode 100644 --- a/Distribution/Client/GlobalFlags.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} - -module Distribution.Client.GlobalFlags ( - GlobalFlags(..) - , defaultGlobalFlags - , RepoContext(..) - , withRepoContext - , withRepoContext' - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.Types - ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) -import Distribution.Simple.Setup - ( Flag(..), fromFlag, flagToMaybe ) -import Distribution.Utils.NubList - ( NubList, fromNubList ) -import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport ) -import Distribution.Simple.Utils - ( info, warn ) - -import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) - -import Control.Concurrent - ( MVar, newMVar, modifyMVar ) -import System.FilePath - ( () ) -import Network.URI - ( URI, uriScheme, uriPath ) -import qualified Data.Map as Map - -import qualified Hackage.Security.Client as Sec -import qualified Hackage.Security.Util.Path as Sec -import qualified Hackage.Security.Util.Pretty as Sec -import qualified Hackage.Security.Client.Repository.Cache as Sec -import qualified Hackage.Security.Client.Repository.Local as Sec.Local -import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote -import qualified Distribution.Client.Security.HTTP as Sec.HTTP -import qualified Distribution.Client.Security.DNS as Sec.DNS - -import qualified System.FilePath.Posix as FilePath.Posix - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- | Flags that apply at the top level, not to any sub-command. - -data GlobalFlags = GlobalFlags - { globalVersion :: Flag Bool - , globalNumericVersion :: Flag Bool - , globalConfigFile :: Flag FilePath - , globalConstraintsFile :: Flag FilePath - , globalRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. - , globalCacheDir :: Flag FilePath - , globalLocalNoIndexRepos :: NubList LocalRepo - , globalActiveRepos :: Flag ActiveRepos - , globalLogsDir :: Flag FilePath - , globalWorldFile :: Flag FilePath - , globalIgnoreExpiry :: Flag Bool -- ^ Ignore security expiry dates - , globalHttpTransport :: Flag String - , globalNix :: Flag Bool -- ^ Integrate with Nix - , globalStoreDir :: Flag FilePath - , globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) - } deriving Generic - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags - { globalVersion = Flag False - , globalNumericVersion = Flag False - , globalConfigFile = mempty - , globalConstraintsFile = mempty - , globalRemoteRepos = mempty - , globalCacheDir = mempty - , globalLocalNoIndexRepos = mempty - , globalActiveRepos = mempty - , globalLogsDir = mempty - , globalWorldFile = mempty - , globalIgnoreExpiry = Flag False - , globalHttpTransport = mempty - , globalNix = Flag False - , globalStoreDir = mempty - , globalProgPathExtra = mempty - } - -instance Monoid GlobalFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup GlobalFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Repo context --- ------------------------------------------------------------ - --- | Access to repositories -data RepoContext = RepoContext { - -- | All user-specified repositories - repoContextRepos :: [Repo] - - -- | Get the HTTP transport - -- - -- The transport will be initialized on the first call to this function. - -- - -- NOTE: It is important that we don't eagerly initialize the transport. - -- Initializing the transport is not free, and especially in contexts where - -- we don't know a-priori whether or not we need the transport (for instance - -- when using cabal in "nix mode") incurring the overhead of transport - -- initialization on _every_ invocation (eg @cabal build@) is undesirable. - , repoContextGetTransport :: IO HttpTransport - - -- | Get the (initialized) secure repo - -- - -- (the 'Repo' type itself is stateless and must remain so, because it - -- must be serializable) - , repoContextWithSecureRepo :: forall a. - Repo - -> (forall down. Sec.Repository down -> IO a) - -> IO a - - -- | Should we ignore expiry times (when checking security)? - , repoContextIgnoreExpiry :: Bool - } - --- | Wrapper around 'Repository', hiding the type argument -data SecureRepo = forall down. SecureRepo (Sec.Repository down) - -withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a -withRepoContext verbosity globalFlags = - withRepoContext' - verbosity - (fromNubList (globalRemoteRepos globalFlags)) - (fromNubList (globalLocalNoIndexRepos globalFlags)) - (fromFlag (globalCacheDir globalFlags)) - (flagToMaybe (globalHttpTransport globalFlags)) - (flagToMaybe (globalIgnoreExpiry globalFlags)) - (fromNubList (globalProgPathExtra globalFlags)) - -withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo] - -> FilePath -> Maybe String -> Maybe Bool - -> [FilePath] - -> (RepoContext -> IO a) - -> IO a -withRepoContext' verbosity remoteRepos localNoIndexRepos - sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do - for_ localNoIndexRepos $ \local -> - unless (FilePath.Posix.isAbsolute (localRepoPath local)) $ - warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended" - - transportRef <- newMVar Nothing - let httpLib = Sec.HTTP.transportAdapter - verbosity - (getTransport transportRef) - initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> - callback RepoContext { - repoContextRepos = allRemoteRepos - ++ allLocalNoIndexRepos - , repoContextGetTransport = getTransport transportRef - , repoContextWithSecureRepo = withSecureRepo secureRepos' - , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry - } - where - secureRemoteRepos = - [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ] - - allRemoteRepos :: [Repo] - allRemoteRepos = - [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir - | remote <- remoteRepos - , let cacheDir = sharedCacheDir unRepoName (remoteRepoName remote) - isSecure = remoteRepoSecure remote == Just True - ] - - allLocalNoIndexRepos :: [Repo] - allLocalNoIndexRepos = - [ RepoLocalNoIndex local cacheDir - | local <- localNoIndexRepos - , let cacheDir | localRepoSharedCache local = sharedCacheDir localRepoCacheKey local - | otherwise = localRepoPath local - ] - - getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport - getTransport transportRef = - modifyMVar transportRef $ \mTransport -> do - transport <- case mTransport of - Just tr -> return tr - Nothing -> configureTransport verbosity extraPaths httpTransport - return (Just transport, transport) - - withSecureRepo :: Map Repo SecureRepo - -> Repo - -> (forall down. Sec.Repository down -> IO a) - -> IO a - withSecureRepo secureRepos repo callback = - case Map.lookup repo secureRepos of - Just (SecureRepo secureRepo) -> callback secureRepo - Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo" - --- | Initialize the provided secure repositories --- --- Assumed invariant: `remoteRepoSecure` should be set for all these repos. -initSecureRepos :: forall a. Verbosity - -> Sec.HTTP.HttpLib - -> [(RemoteRepo, FilePath)] - -> (Map Repo SecureRepo -> IO a) - -> IO a -initSecureRepos verbosity httpLib repos callback = go Map.empty repos - where - go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a - go !acc [] = callback acc - go !acc ((r,cacheDir):rs) = do - cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir - initSecureRepo verbosity httpLib r cachePath $ \r' -> - go (Map.insert (RepoSecure r cacheDir) r' acc) rs - --- | Initialize the given secure repo --- --- The security library has its own concept of a "local" repository, distinct --- from @cabal-install@'s; these are secure repositories, but live in the local --- file system. We use the convention that these repositories are identified by --- URLs of the form @file:/path/to/local/repo@. -initSecureRepo :: Verbosity - -> Sec.HTTP.HttpLib - -> RemoteRepo -- ^ Secure repo ('remoteRepoSecure' assumed) - -> Sec.Path Sec.Absolute -- ^ Cache dir - -> (SecureRepo -> IO a) -- ^ Callback - -> IO a -initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do - requiresBootstrap <- withRepo [] Sec.requiresBootstrap - - mirrors <- if requiresBootstrap - then do - info verbosity $ "Trying to locate mirrors via DNS for " ++ - "initial bootstrap of secure " ++ - "repository '" ++ show remoteRepoURI ++ - "' ..." - - Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI - else pure [] - - withRepo mirrors $ \r -> do - when requiresBootstrap $ Sec.uncheckClientErrors $ - Sec.bootstrap r - (map Sec.KeyId remoteRepoRootKeys) - (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold)) - callback $ SecureRepo r - where - -- Initialize local or remote repo depending on the URI - withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a - withRepo _ callback | uriScheme remoteRepoURI == "file:" = do - dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI) - Sec.Local.withRepository dir - cache - Sec.hackageRepoLayout - Sec.hackageIndexLayout - logTUF - callback - withRepo mirrors callback = - Sec.Remote.withRepository httpLib - (remoteRepoURI:mirrors) - Sec.Remote.defaultRepoOpts - cache - Sec.hackageRepoLayout - Sec.hackageIndexLayout - logTUF - callback - - cache :: Sec.Cache - cache = Sec.Cache { - cacheRoot = cachePath - , cacheLayout = Sec.cabalCacheLayout { - Sec.cacheLayoutIndexTar = cacheFn "01-index.tar" - , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx" - , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz" - } - } - - cacheFn :: FilePath -> Sec.CachePath - cacheFn = Sec.rootPath . Sec.fragment - - -- We display any TUF progress only in verbose mode, including any transient - -- verification errors. If verification fails, then the final exception that - -- is thrown will of course be shown. - logTUF :: Sec.LogMessage -> IO () - logTUF = info verbosity . Sec.pretty diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs deleted file mode 100644 --- a/Distribution/Client/Haddock.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Haddock --- Copyright : (c) Andrea Vezzosi 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Interfacing with Haddock --- ------------------------------------------------------------------------------ -module Distribution.Client.Haddock - ( - regenerateHaddockIndex - ) - where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Data.List (maximumBy) -import System.Directory (createDirectoryIfMissing, renameFile) -import System.FilePath ((), splitFileName) -import Distribution.Package - ( packageVersion ) -import Distribution.Simple.Haddock (haddockPackagePaths) -import Distribution.Simple.Program (haddockProgram, ProgramDb - , runProgram, requireProgramVersion) -import Distribution.Version (mkVersion, orLaterVersion) -import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, allPackagesByName ) -import Distribution.Simple.Utils - ( debug, installDirectoryContents, withTempDirectory ) -import Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo(exposed) ) - -regenerateHaddockIndex :: Verbosity - -> InstalledPackageIndex -> ProgramDb - -> FilePath - -> IO () -regenerateHaddockIndex verbosity pkgs progdb index = do - (paths, warns) <- haddockPackagePaths pkgs' Nothing - let paths' = [ (interface, html) | (interface, Just html, _) <- paths] - for_ warns (debug verbosity) - - (confHaddock, _, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (mkVersion [0,6])) progdb - - createDirectoryIfMissing True destDir - - withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do - - let flags = [ "--gen-contents" - , "--gen-index" - , "--odir=" ++ tempDir - , "--title=Haskell modules on this system" ] - ++ [ "--read-interface=" ++ html ++ "," ++ interface - | (interface, html) <- paths' ] - runProgram verbosity confHaddock flags - renameFile (tempDir "index.html") (tempDir destFile) - installDirectoryContents verbosity tempDir destDir - - where - (destDir,destFile) = splitFileName index - pkgs' = [ maximumBy (comparing packageVersion) pkgvers' - | (_pname, pkgvers) <- allPackagesByName pkgs - , let pkgvers' = filter exposed pkgvers - , not (null pkgvers') ] diff --git a/Distribution/Client/HashValue.hs b/Distribution/Client/HashValue.hs deleted file mode 100644 --- a/Distribution/Client/HashValue.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.HashValue ( - HashValue, - hashValue, - truncateHash, - showHashValue, - readFileHashValue, - hashFromTUF, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Hackage.Security.Client as Sec - -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS - -import System.IO (IOMode (..), withBinaryFile) - ------------------------------------------------ --- The specific choice of hash implementation --- - --- Is a crypto hash necessary here? One thing to consider is who controls the --- inputs and what's the result of a hash collision. Obviously we should not --- install packages we don't trust because they can run all sorts of code, but --- if I've checked there's no TH, no custom Setup etc, is there still a --- problem? If someone provided us a tarball that hashed to the same value as --- some other package and we installed it, we could end up re-using that --- installed package in place of another one we wanted. So yes, in general --- there is some value in preventing intentional hash collisions in installed --- package ids. - -newtype HashValue = HashValue BS.ByteString - deriving (Eq, Generic, Show, Typeable) - --- Cannot do any sensible validation here. Although we use SHA256 --- for stuff we hash ourselves, we can also get hashes from TUF --- and that can in principle use different hash functions in future. --- --- Therefore, we simply derive this structurally. -instance Binary HashValue -instance Structured HashValue - --- | Hash some data. Currently uses SHA256. --- -hashValue :: LBS.ByteString -> HashValue -hashValue = HashValue . SHA256.hashlazy - -showHashValue :: HashValue -> String -showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) - --- | Hash the content of a file. Uses SHA256. --- -readFileHashValue :: FilePath -> IO HashValue -readFileHashValue tarball = - withBinaryFile tarball ReadMode $ \hnd -> - evaluate . hashValue =<< LBS.hGetContents hnd - --- | Convert a hash from TUF metadata into a 'PackageSourceHash'. --- --- Note that TUF hashes don't neessarily have to be SHA256, since it can --- support new algorithms in future. --- -hashFromTUF :: Sec.Hash -> HashValue -hashFromTUF (Sec.Hash hashstr) = - --TODO: [code cleanup] either we should get TUF to use raw bytestrings or - -- perhaps we should also just use a base16 string as the internal rep. - case Base16.decode (BS.pack hashstr) of -#if MIN_VERSION_base16_bytestring(1,0,0) - Right hash -> HashValue hash - Left _ -> error "hashFromTUF: cannot decode base16" -#else - (hash, trailing) | not (BS.null hash) && BS.null trailing - -> HashValue hash - _ -> error "hashFromTUF: cannot decode base16 hash" -#endif - --- | Truncate a 32 byte SHA256 hash to --- --- For example 20 bytes render as 40 hex chars, which we use for unit-ids. --- Or even 4 bytes for 'hashedInstalledPackageIdShort' --- -truncateHash :: Int -> HashValue -> HashValue -truncateHash n (HashValue h) = HashValue (BS.take n h) diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs deleted file mode 100644 --- a/Distribution/Client/HttpUtils.hs +++ /dev/null @@ -1,916 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | Separate module for HTTP actions, using a proxy server if one exists. ------------------------------------------------------------------------------ -module Distribution.Client.HttpUtils ( - DownloadResult(..), - configureTransport, - HttpTransport(..), - HttpCode, - downloadURI, - transportCheckHttps, - remoteRepoCheckHttps, - remoteRepoTryUpgradeToHttps, - isOldHackageURI - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (Proxy (..)) -import Distribution.Utils.Generic - -import Network.HTTP - ( Request (..), Response (..), RequestMethod (..) - , Header(..), HeaderName(..), lookupHeader ) -import Network.HTTP.Proxy ( Proxy(..), fetchProxy) -import Network.URI - ( URI (..), URIAuth (..), uriToString ) -import Network.Browser - ( browse, setOutHandler, setErrHandler, setProxy - , setAuthorityGen, request, setAllowBasicAuth, setUserAgent ) -import qualified Control.Exception as Exception -import Distribution.Simple.Utils - ( die', info, warn, debug, notice - , copyFileVerbose, withTempFile, IOData (..) ) -import Distribution.Client.Utils - ( withTempFileName, cabalInstallVersion ) -import Distribution.Client.Types - ( unRepoName, RemoteRepo(..) ) -import Distribution.System - ( buildOS, buildArch ) -import qualified System.FilePath.Posix as FilePath.Posix - ( splitDirectories ) -import System.FilePath - ( (<.>), takeFileName, takeDirectory ) -import System.Directory - ( doesFileExist, renameFile, canonicalizePath ) -import System.IO - ( withFile, IOMode(ReadMode), hGetContents, hClose ) -import System.IO.Error - ( isDoesNotExistError ) -import Distribution.Simple.Program - ( Program, simpleProgram, ConfiguredProgram, programPath - , ProgramInvocation(..), programInvocation - , ProgramSearchPathEntry(..) - , getProgramInvocationOutput ) -import Distribution.Simple.Program.Db - ( ProgramDb, emptyProgramDb, addKnownPrograms - , configureAllKnownPrograms - , requireProgram, lookupProgram - , modifyProgramSearchPath ) -import Distribution.Simple.Program.Run - ( getProgramInvocationOutputAndErrors ) -import Numeric (showHex) -import System.Random (randomRIO) - -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Distribution.Compat.CharParsing as P -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 - ------------------------------------------------------------------------------- --- Downloading a URI, given an HttpTransport --- - -data DownloadResult = FileAlreadyInCache - | FileDownloaded FilePath - deriving (Eq) - -data DownloadCheck - = Downloaded -- ^ already downloaded and sha256 matches - | CheckETag String -- ^ already downloaded and we have etag - | NeedsDownload (Maybe BS.ByteString) -- ^ needs download with optional hash check - deriving Eq - -downloadURI :: HttpTransport - -> Verbosity - -> URI -- ^ What to download - -> FilePath -- ^ Where to put it - -> IO DownloadResult -downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do - copyFileVerbose verbosity (uriPath uri) path - return (FileDownloaded path) - -- Can we store the hash of the file so we can safely return path when the - -- hash matches to avoid unnecessary computation? - -downloadURI transport verbosity uri path = do - - targetExists <- doesFileExist path - - downloadCheck <- - -- if we have uriFrag, then we expect there to be #sha256=... - if not (null uriFrag) - then case sha256parsed of - -- we know the hash, and target exists - Right expected | targetExists -> do - contents <- LBS.readFile path - let actual = SHA256.hashlazy contents - if expected == actual - then return Downloaded - else return (NeedsDownload (Just expected)) - - -- we known the hash, target doesn't exist - Right expected -> return (NeedsDownload (Just expected)) - - -- we failed to parse uriFragment - Left err -> die' verbosity $ - "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err - - -- if there are no uri fragment, use ETag - else do - etagPathExists <- doesFileExist etagPath - -- In rare cases the target file doesn't exist, but the etag does. - if targetExists && etagPathExists - then return (CheckETag etagPath) - else return (NeedsDownload Nothing) - - -- Only use the external http transports if we actually have to - -- (or have been told to do so) - let transport' - | uriScheme uri == "http:" - , not (transportManuallySelected transport) - = plainHttpTransport - - | otherwise - = transport - - case downloadCheck of - Downloaded -> return FileAlreadyInCache - CheckETag etag -> makeDownload transport' Nothing (Just etag) - NeedsDownload hash -> makeDownload transport' hash Nothing - - where - makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do - result <- getHttp transport' verbosity uri etag tmpFile [] - - -- Only write the etag if we get a 200 response code. - -- A 304 still sends us an etag header. - case result of - -- if we have hash, we don't care about etag. - (200, _) | Just expected <- sha256 -> do - contents <- LBS.readFile tmpFile - let actual = SHA256.hashlazy contents - unless (actual == expected) $ - die' verbosity $ unwords - [ "Failed to download", show uri - , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected) - , "actual:", BS8.unpack (Base16.encode actual) - ] - - (200, Just newEtag) -> writeFile etagPath newEtag - _ -> return () - - case fst result of - 200 -> do - info verbosity ("Downloaded to " ++ path) - renameFile tmpFile path - return (FileDownloaded path) - 304 -> do - notice verbosity "Skipping download: local and remote files match." - return FileAlreadyInCache - errCode -> die' verbosity $ "failed to download " ++ show uri - ++ " : HTTP code " ++ show errCode - - etagPath = path <.> "etag" - uriFrag = uriFragment uri - - sha256parsed :: Either String BS.ByteString - sha256parsed = explicitEitherParsec fragmentParser uriFrag - - fragmentParser = do - _ <- P.string "#sha256=" - str <- some P.hexDigit - let bs = Base16.decode (BS8.pack str) -#if MIN_VERSION_base16_bytestring(1,0,0) - either fail return bs -#else - return (fst bs) -#endif - ------------------------------------------------------------------------------- --- Utilities for repo url management --- - -remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () -remoteRepoCheckHttps verbosity transport repo - | uriScheme (remoteRepoURI repo) == "https:" - , not (transportSupportsHttps transport) - = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo) - ++ "' specifies a URL that " ++ requiresHttpsErrorMessage - | otherwise = return () - -transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () -transportCheckHttps verbosity transport uri - | uriScheme uri == "https:" - , not (transportSupportsHttps transport) - = die' verbosity $ "The URL " ++ show uri - ++ " " ++ requiresHttpsErrorMessage - | otherwise = return () - -requiresHttpsErrorMessage :: String -requiresHttpsErrorMessage = - "requires HTTPS however the built-in HTTP implementation " - ++ "does not support HTTPS. The transport implementations with HTTPS " - ++ "support are " ++ intercalate ", " - [ name | (name, _, True, _ ) <- supportedTransports ] - ++ ". One of these will be selected automatically if the corresponding " - ++ "external program is available, or one can be selected specifically " - ++ "with the global flag --http-transport=" - -remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo -remoteRepoTryUpgradeToHttps verbosity transport repo - | remoteRepoShouldTryHttps repo - , uriScheme (remoteRepoURI repo) == "http:" - , not (transportSupportsHttps transport) - , not (transportManuallySelected transport) - = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using " - ++ "HTTPS for authenticated uploads is recommended. " - ++ "The transport implementations with HTTPS support are " - ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] - ++ "but they require the corresponding external program to be " - ++ "available. You can either make one available or use plain HTTP by " - ++ "using the global flag --http-transport=plain-http (or putting the " - ++ "equivalent in the config file). With plain HTTP, your password " - ++ "is sent using HTTP digest authentication so it cannot be easily " - ++ "intercepted, but it is not as secure as using HTTPS." - - | remoteRepoShouldTryHttps repo - , uriScheme (remoteRepoURI repo) == "http:" - , transportSupportsHttps transport - = return repo { - remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" } - } - - | otherwise - = return repo - --- | Utility function for legacy support. -isOldHackageURI :: URI -> Bool -isOldHackageURI uri - = case uriAuthority uri of - Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> - FilePath.Posix.splitDirectories (uriPath uri) - == ["/","packages","archive"] - _ -> False - - ------------------------------------------------------------------------------- --- Setting up a HttpTransport --- - -data HttpTransport = HttpTransport { - -- | GET a URI, with an optional ETag (to do a conditional fetch), - -- write the resource to the given file and return the HTTP status code, - -- and optional ETag. - getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header] - -> IO (HttpCode, Maybe ETag), - - -- | POST a resource to a URI, with optional auth (username, password) - -- and return the HTTP status code and any redirect URL. - postHttp :: Verbosity -> URI -> String -> Maybe Auth - -> IO (HttpCode, String), - - -- | POST a file resource to a URI using multipart\/form-data encoding, - -- with optional auth (username, password) and return the HTTP status - -- code and any error string. - postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth - -> IO (HttpCode, String), - - -- | PUT a file resource to a URI, with optional auth - -- (username, password), extra headers and return the HTTP status code - -- and any error string. - putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header] - -> IO (HttpCode, String), - - -- | Whether this transport supports https or just http. - transportSupportsHttps :: Bool, - - -- | Whether this transport implementation was specifically chosen by - -- the user via configuration, or whether it was automatically selected. - -- Strictly speaking this is not a property of the transport itself but - -- about how it was chosen. Nevertheless it's convenient to keep here. - transportManuallySelected :: Bool - } - --TODO: why does postHttp return a redirect, but postHttpFile return errors? - -type HttpCode = Int -type ETag = String -type Auth = (String, String) - -noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) - -> IO (Int, String) -noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" - -supportedTransports :: [(String, Maybe Program, Bool, - ProgramDb -> Maybe HttpTransport)] -supportedTransports = - [ let prog = simpleProgram "curl" in - ( "curl", Just prog, True - , \db -> curlTransport <$> lookupProgram prog db ) - - , let prog = simpleProgram "wget" in - ( "wget", Just prog, True - , \db -> wgetTransport <$> lookupProgram prog db ) - - , let prog = simpleProgram "powershell" in - ( "powershell", Just prog, True - , \db -> powershellTransport <$> lookupProgram prog db ) - - , ( "plain-http", Nothing, False - , \_ -> Just plainHttpTransport ) - ] - -configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport - -configureTransport verbosity extraPath (Just name) = - -- the user specifically selected a transport by name so we'll try and - -- configure that one - - case find (\(name',_,_,_) -> name' == name) supportedTransports of - Just (_, mprog, _tls, mkTrans) -> do - - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - progdb <- case mprog of - Nothing -> return emptyProgramDb - Just prog -> snd <$> requireProgram verbosity prog baseProgDb - -- ^^ if it fails, it'll fail here - - let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb - return transport { transportManuallySelected = True } - - Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name - ++ ". The supported transports are " - ++ intercalate ", " - [ name' | (name', _, _, _ ) <- supportedTransports ] - -configureTransport verbosity extraPath Nothing = do - -- the user hasn't selected a transport, so we'll pick the first one we - -- can configure successfully, provided that it supports tls - - -- for all the transports except plain-http we need to try and find - -- their external executable - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - progdb <- configureAllKnownPrograms verbosity $ - addKnownPrograms - [ prog | (_, Just prog, _, _) <- supportedTransports ] - baseProgDb - - let availableTransports = - [ (name, transport) - | (name, _, _, mkTrans) <- supportedTransports - , transport <- maybeToList (mkTrans progdb) ] - let (name, transport) = - fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) - debug verbosity $ "Selected http transport implementation: " ++ name - - return transport { transportManuallySelected = False } - - ------------------------------------------------------------------------------- --- The HttpTransports based on external programs --- - -curlTransport :: ConfiguredProgram -> HttpTransport -curlTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False - where - gethttp verbosity uri etag destPath reqHeaders = do - withTempFile (takeDirectory destPath) - "curl-headers.txt" $ \tmpFile tmpHandle -> do - hClose tmpHandle - let args = [ show uri - , "--output", destPath - , "--location" - , "--write-out", "%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--dump-header", tmpFile ] - ++ concat - [ ["--header", "If-None-Match: " ++ t] - | t <- maybeToList etag ] - ++ concat - [ ["--header", show name ++ ": " ++ value] - | Header name value <- reqHeaders ] - - resp <- getProgramInvocationOutput verbosity - (programInvocation prog args) - withFile tmpFile ReadMode $ \hnd -> do - headers <- hGetContents hnd - (code, _err, etag') <- parseResponse verbosity uri resp headers - evaluate $ force (code, etag') - - posthttp = noPostYet - - addAuthConfig auth progInvocation = progInvocation - { progInvokeInput = do - (uname, passwd) <- auth - return $ IODataText $ unlines - [ "--digest" - , "--user " ++ uname ++ ":" ++ passwd - ] - , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation - } - - posthttpfile verbosity uri path auth = do - let args = [ show uri - , "--form", "package=@"++path - , "--write-out", "\n%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--header", "Accept: text/plain" - , "--location" - ] - resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth - (programInvocation prog args) - (code, err, _etag) <- parseResponse verbosity uri resp "" - return (code, err) - - puthttpfile verbosity uri path auth headers = do - let args = [ show uri - , "--request", "PUT", "--data-binary", "@"++path - , "--write-out", "\n%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--location" - , "--header", "Accept: text/plain" - ] - ++ concat - [ ["--header", show name ++ ": " ++ value] - | Header name value <- headers ] - resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth - (programInvocation prog args) - (code, err, _etag) <- parseResponse verbosity uri resp "" - return (code, err) - - -- on success these curl invocations produces an output like "200" - -- and on failure it has the server error response first - parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) - parseResponse verbosity uri resp headers = - let codeerr = - case reverse (lines resp) of - (codeLine:rerrLines) -> - case readMaybe (trim codeLine) of - Just i -> let errstr = mkErrstr rerrLines - in Just (i, errstr) - Nothing -> Nothing - [] -> Nothing - - mkErrstr = unlines . reverse . dropWhile (all isSpace) - - mb_etag :: Maybe ETag - mb_etag = listToMaybe $ reverse - [ etag - | ["ETag:", etag] <- map words (lines headers) ] - - in case codeerr of - Just (i, err) -> return (i, err, mb_etag) - _ -> statusParseFail verbosity uri resp - - -wgetTransport :: ConfiguredProgram -> HttpTransport -wgetTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False - where - gethttp verbosity uri etag destPath reqHeaders = do - resp <- runWGet verbosity uri args - - -- wget doesn't support range requests. - -- so, we not only ignore range request headers, - -- but we also dispay a warning message when we see them. - let hasRangeHeader = any isRangeHeader reqHeaders - warningMsg = "the 'wget' transport currently doesn't support" - ++ " range requests, which wastes network bandwidth." - ++ " To fix this, set 'http-transport' to 'curl' or" - ++ " 'plain-http' in '~/.cabal/config'." - ++ " Note that the 'plain-http' transport doesn't" - ++ " support HTTPS.\n" - - when (hasRangeHeader) $ warn verbosity warningMsg - (code, etag') <- parseOutput verbosity uri resp - return (code, etag') - where - args = [ "--output-document=" ++ destPath - , "--user-agent=" ++ userAgent - , "--tries=5" - , "--timeout=15" - , "--server-response" ] - ++ concat - [ ["--header", "If-None-Match: " ++ t] - | t <- maybeToList etag ] - ++ [ "--header=" ++ show name ++ ": " ++ value - | hdr@(Header name value) <- reqHeaders - , (not (isRangeHeader hdr)) ] - - -- wget doesn't support range requests. - -- so, we ignore range request headers, lest we get errors. - isRangeHeader :: Header -> Bool - isRangeHeader (Header HdrRange _) = True - isRangeHeader _ = False - - posthttp = noPostYet - - posthttpfile verbosity uri path auth = - withTempFile (takeDirectory path) - (takeFileName path) $ \tmpFile tmpHandle -> - withTempFile (takeDirectory path) "response" $ - \responseFile responseHandle -> do - hClose responseHandle - (body, boundary) <- generateMultipartBody path - LBS.hPut tmpHandle body - hClose tmpHandle - let args = [ "--post-file=" ++ tmpFile - , "--user-agent=" ++ userAgent - , "--server-response" - , "--output-document=" ++ responseFile - , "--header=Accept: text/plain" - , "--header=Content-type: multipart/form-data; " ++ - "boundary=" ++ boundary ] - out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput verbosity uri out - withFile responseFile ReadMode $ \hnd -> do - resp <- hGetContents hnd - evaluate $ force (code, resp) - - puthttpfile verbosity uri path auth headers = - withTempFile (takeDirectory path) "response" $ - \responseFile responseHandle -> do - hClose responseHandle - let args = [ "--method=PUT", "--body-file="++path - , "--user-agent=" ++ userAgent - , "--server-response" - , "--output-document=" ++ responseFile - , "--header=Accept: text/plain" ] - ++ [ "--header=" ++ show name ++ ": " ++ value - | Header name value <- headers ] - - out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput verbosity uri out - withFile responseFile ReadMode $ \hnd -> do - resp <- hGetContents hnd - evaluate $ force (code, resp) - - addUriAuth Nothing uri = uri - addUriAuth (Just (user, pass)) uri = uri - { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" } - } - where - a = fromMaybe (URIAuth "" "" "") (uriAuthority uri) - - runWGet verbosity uri args = do - -- We pass the URI via STDIN because it contains the users' credentials - -- and sensitive data should not be passed via command line arguments. - let - invocation = (programInvocation prog ("--input-file=-" : args)) - { progInvokeInput = Just $ IODataText $ uriToString id uri "" - } - - -- wget returns its output on stderr rather than stdout - (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity - invocation - -- wget returns exit code 8 for server "errors" like "304 not modified" - if exitCode == ExitSuccess || exitCode == ExitFailure 8 - then return resp - else die' verbosity $ "'" ++ programPath prog - ++ "' exited with an error:\n" ++ resp - - -- With the --server-response flag, wget produces output with the full - -- http server response with all headers, we want to find a line like - -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple - -- requests due to redirects. - parseOutput verbosity uri resp = - let parsedCode = listToMaybe - [ code - | (protocol:codestr:_err) <- map words (reverse (lines resp)) - , "HTTP/" `isPrefixOf` protocol - , code <- maybeToList (readMaybe codestr) ] - mb_etag :: Maybe ETag - mb_etag = listToMaybe - [ etag - | ["ETag:", etag] <- map words (reverse (lines resp)) ] - in case parsedCode of - Just i -> return (i, mb_etag) - _ -> statusParseFail verbosity uri resp - - -powershellTransport :: ConfiguredProgram -> HttpTransport -powershellTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False - where - gethttp verbosity uri etag destPath reqHeaders = do - resp <- runPowershellScript verbosity $ - webclientScript - (escape (show uri)) - (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create") - :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))) - [ "$response = $request.GetResponse()" - , "$responseStream = $response.GetResponseStream()" - , "$buffer = new-object byte[] 10KB" - , "$count = $responseStream.Read($buffer, 0, $buffer.length)" - , "while ($count -gt 0)" - , "{" - , " $targetStream.Write($buffer, 0, $count)" - , " $count = $responseStream.Read($buffer, 0, $buffer.length)" - , "}" - , "Write-Host ($response.StatusCode -as [int]);" - , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')" - ] - [ "$targetStream.Flush()" - , "$targetStream.Close()" - , "$targetStream.Dispose()" - , "$responseStream.Dispose()" - ] - parseResponse resp - where - parseResponse :: String -> IO (HttpCode, Maybe ETag) - parseResponse x = - case lines $ trim x of - (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x - (code: _) -> fmap (\c -> (c, Nothing )) $ parseCode code x - _ -> statusParseFail verbosity uri x - parseCode :: String -> String -> IO HttpCode - parseCode code x = case readMaybe code of - Just i -> return i - Nothing -> statusParseFail verbosity uri x - etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] - - posthttp = noPostYet - - posthttpfile verbosity uri path auth = - withTempFile (takeDirectory path) - (takeFileName path) $ \tmpFile tmpHandle -> do - (body, boundary) <- generateMultipartBody path - LBS.hPut tmpHandle body - hClose tmpHandle - fullPath <- canonicalizePath tmpFile - - let contentHeader = Header HdrContentType - ("multipart/form-data; boundary=" ++ boundary) - resp <- runPowershellScript verbosity $ webclientScript - (escape (show uri)) - (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) - (uploadFileAction "POST" uri fullPath) - uploadFileCleanup - parseUploadResponse verbosity uri resp - - puthttpfile verbosity uri path auth headers = do - fullPath <- canonicalizePath path - resp <- runPowershellScript verbosity $ webclientScript - (escape (show uri)) - (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) - (uploadFileAction "PUT" uri fullPath) - uploadFileCleanup - parseUploadResponse verbosity uri resp - - runPowershellScript verbosity script = do - let args = - [ "-InputFormat", "None" - -- the default execution policy doesn't allow running - -- unsigned scripts, so we need to tell powershell to bypass it - , "-ExecutionPolicy", "bypass" - , "-NoProfile", "-NonInteractive" - , "-Command", "-" - ] - debug verbosity script - getProgramInvocationOutput verbosity (programInvocation prog args) - { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);" - } - - escape = show - - useragentHeader = Header HdrUserAgent userAgent - extraHeaders = [Header HdrAccept "text/plain", useragentHeader] - - setupHeaders headers = - [ "$request." ++ addHeader name value - | Header name value <- headers - ] - where - addHeader header value - = case header of - HdrAccept -> "Accept = " ++ escape value - HdrUserAgent -> "UserAgent = " ++ escape value - HdrConnection -> "Connection = " ++ escape value - HdrContentLength -> "ContentLength = " ++ escape value - HdrContentType -> "ContentType = " ++ escape value - HdrDate -> "Date = " ++ escape value - HdrExpect -> "Expect = " ++ escape value - HdrHost -> "Host = " ++ escape value - HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value - HdrReferer -> "Referer = " ++ escape value - HdrTransferEncoding -> "TransferEncoding = " ++ escape value - HdrRange -> let (start, end) = - if "bytes=" `isPrefixOf` value - then case break (== '-') value' of - (start', '-':end') -> (start', end') - _ -> error $ "Could not decode range: " ++ value - else error $ "Could not decode range: " ++ value - value' = drop 6 value - in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");" - name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");" - - setupAuth auth = - [ "$request.Credentials = new-object System.Net.NetworkCredential(" - ++ escape uname ++ "," ++ escape passwd ++ ",\"\");" - | (uname,passwd) <- maybeToList auth - ] - - uploadFileAction method _uri fullPath = - [ "$request.Method = " ++ show method - , "$requestStream = $request.GetRequestStream()" - , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")" - , "$bufSize=10000" - , "$chunk = New-Object byte[] $bufSize" - , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )" - , "{" - , " $requestStream.write($chunk, 0, $bytesRead)" - , " $requestStream.Flush()" - , "}" - , "" - , "$responseStream = $request.getresponse()" - , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()" - , "$code = $response.StatusCode -as [int]" - , "if ($code -eq 0) {" - , " $code = 200;" - , "}" - , "Write-Host $code" - , "Write-Host $responseReader.ReadToEnd()" - ] - - uploadFileCleanup = - [ "$fileStream.Close()" - , "$requestStream.Close()" - , "$responseStream.Close()" - ] - - parseUploadResponse verbosity uri resp = case lines (trim resp) of - (codeStr : message) - | Just code <- readMaybe codeStr -> return (code, unlines message) - _ -> statusParseFail verbosity uri resp - - webclientScript uri setup action cleanup = unlines - [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\"" - , "$uri = New-Object \"System.Uri\" " ++ uri - , "$request = [System.Net.HttpWebRequest]::Create($uri)" - , unlines setup - , "Try {" - , unlines (map (" " ++) action) - , "} Catch [System.Net.WebException] {" - , " $exception = $_.Exception;" - , " If ($exception.Status -eq " - ++ "[System.Net.WebExceptionStatus]::ProtocolError) {" - , " $response = $exception.Response -as [System.Net.HttpWebResponse];" - , " $reader = new-object " - ++ "System.IO.StreamReader($response.GetResponseStream());" - , " Write-Host ($response.StatusCode -as [int]);" - , " Write-Host $reader.ReadToEnd();" - , " } Else {" - , " Write-Host $exception.Message;" - , " }" - , "} Catch {" - , " Write-Host $_.Exception.Message;" - , "} finally {" - , unlines (map (" " ++) cleanup) - , "}" - ] - - ------------------------------------------------------------------------------- --- The builtin plain HttpTransport --- - -plainHttpTransport :: HttpTransport -plainHttpTransport = - HttpTransport gethttp posthttp posthttpfile puthttpfile False False - where - gethttp verbosity uri etag destPath reqHeaders = do - let req = Request{ - rqURI = uri, - rqMethod = GET, - rqHeaders = [ Header HdrIfNoneMatch t - | t <- maybeToList etag ] - ++ reqHeaders, - rqBody = LBS.empty - } - (_, resp) <- cabalBrowse verbosity Nothing (request req) - let code = convertRspCode (rspCode resp) - etag' = lookupHeader HdrETag (rspHeaders resp) - -- 206 Partial Content is a normal response to a range request; see #3385. - when (code==200 || code==206) $ - writeFileAtomic destPath $ rspBody resp - return (code, etag') - - posthttp = noPostYet - - posthttpfile verbosity uri path auth = do - (body, boundary) <- generateMultipartBody path - let headers = [ Header HdrContentType - ("multipart/form-data; boundary="++boundary) - , Header HdrContentLength (show (LBS8.length body)) - , Header HdrAccept ("text/plain") - ] - req = Request { - rqURI = uri, - rqMethod = POST, - rqHeaders = headers, - rqBody = body - } - (_, resp) <- cabalBrowse verbosity auth (request req) - return (convertRspCode (rspCode resp), rspErrorString resp) - - puthttpfile verbosity uri path auth headers = do - body <- LBS8.readFile path - let req = Request { - rqURI = uri, - rqMethod = PUT, - rqHeaders = Header HdrContentLength (show (LBS8.length body)) - : Header HdrAccept "text/plain" - : headers, - rqBody = body - } - (_, resp) <- cabalBrowse verbosity auth (request req) - return (convertRspCode (rspCode resp), rspErrorString resp) - - convertRspCode (a,b,c) = a*100 + b*10 + c - - rspErrorString resp = - case lookupHeader HdrContentType (rspHeaders resp) of - Just contenttype - | takeWhile (/= ';') contenttype == "text/plain" - -> LBS8.unpack (rspBody resp) - _ -> rspReason resp - - cabalBrowse verbosity auth act = do - p <- fixupEmptyProxy <$> fetchProxy True - Exception.handleJust - (guard . isDoesNotExistError) - (const . die' verbosity $ "Couldn't establish HTTP connection. " - ++ "Possible cause: HTTP proxy server is down.") $ - browse $ do - setProxy p - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - setUserAgent userAgent - setAllowBasicAuth False - setAuthorityGen (\_ _ -> return auth) - act - - fixupEmptyProxy (Proxy uri _) | null uri = NoProxy - fixupEmptyProxy p = p - - ------------------------------------------------------------------------------- --- Common stuff used by multiple transport impls --- - -userAgent :: String -userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion - , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")" - ] - -statusParseFail :: Verbosity -> URI -> String -> IO a -statusParseFail verbosity uri r = - die' verbosity $ "Failed to download " ++ show uri ++ " : " - ++ "No Status Code could be parsed from response: " ++ r - --- Trim -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace - - ------------------------------------------------------------------------------- --- Multipart stuff partially taken from cgi package. --- - -generateMultipartBody :: FilePath -> IO (LBS.ByteString, String) -generateMultipartBody path = do - content <- LBS.readFile path - boundary <- genBoundary - let !body = formatBody content (LBS8.pack boundary) - return (body, boundary) - where - formatBody content boundary = - LBS8.concat $ - [ crlf, dd, boundary, crlf ] - ++ [ LBS8.pack (show header) | header <- headers ] - ++ [ crlf - , content - , crlf, dd, boundary, dd, crlf ] - - headers = - [ Header (HdrCustom "Content-disposition") - ("form-data; name=package; " ++ - "filename=\"" ++ takeFileName path ++ "\"") - , Header HdrContentType "application/x-gzip" - ] - - crlf = LBS8.pack "\r\n" - dd = LBS8.pack "--" - -genBoundary :: IO String -genBoundary = do - i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer - return $ showHex i "" diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs deleted file mode 100644 --- a/Distribution/Client/IndexUtils.hs +++ /dev/null @@ -1,1180 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.IndexUtils --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- Stability : provisional --- Portability : portable --- --- Extra utils related to the package indexes. ------------------------------------------------------------------------------ -module Distribution.Client.IndexUtils ( - getIndexFileAge, - getInstalledPackages, - indexBaseName, - Configure.getInstalledPackagesMonitorFiles, - getSourcePackages, - getSourcePackagesMonitorFiles, - - TotalIndexState, - getSourcePackagesAtIndexState, - ActiveRepos, - filterSkippedActiveRepos, - - Index(..), - RepoIndexState (..), - PackageEntry(..), - parsePackageIndex, - updateRepoIndexCache, - updatePackageIndexCacheFile, - writeIndexTimestamp, - currentIndexTimestamp, - - BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Archive.Tar.Index as Tar -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.IndexUtils.ActiveRepos -import Distribution.Client.IndexUtils.IndexState -import Distribution.Client.IndexUtils.Timestamp -import Distribution.Client.Types -import Distribution.Verbosity -import Distribution.Parsec (simpleParsecBS) - -import Distribution.Package - ( PackageId, PackageIdentifier(..), mkPackageName - , Package(..), packageVersion, packageName ) -import Distribution.Types.Dependency -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription - ( GenericPackageDescription(..) - , PackageDescription(..), emptyPackageDescription ) -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program - ( ProgramDb ) -import qualified Distribution.Simple.Configure as Configure - ( getInstalledPackages, getInstalledPackagesMonitorFiles ) -import Distribution.Types.PackageName (PackageName) -import Distribution.Version - ( Version, VersionRange, mkVersion, intersectVersionRanges ) -import Distribution.Simple.Utils - ( die', warn, info, createDirectoryIfMissingVerbose ) -import Distribution.Client.Setup - ( RepoContext(..) ) - -import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe ) -import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse - -import Distribution.Solver.Types.PackageIndex (PackageIndex) -import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage - -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Exception -import Data.List (stripPrefix) -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import qualified Data.ByteString.Char8 as BSS -import Data.ByteString.Lazy (ByteString) -import Distribution.Client.GZipUtils (maybeDecompress) -import Distribution.Client.Utils ( byteStringToFilePath - , tryFindAddSourcePackageDesc ) -import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail) -import Distribution.Compat.Time (getFileAge, getModTime) -import System.Directory (doesFileExist, doesDirectoryExist) -import System.FilePath - ( (), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory ) -import qualified System.FilePath.Posix as FilePath.Posix -import System.IO -import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO.Error (isDoesNotExistError) -import Distribution.Compat.Directory (listDirectory) -import Distribution.Utils.Generic (fstOf3) - -import qualified Codec.Compression.GZip as GZip - -import qualified Hackage.Security.Client as Sec -import qualified Hackage.Security.Util.Some as Sec - --- | Reduced-verbosity version of 'Configure.getInstalledPackages' -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packageDbs progdb = - Configure.getInstalledPackages verbosity' comp packageDbs progdb - where - verbosity' = lessVerbose verbosity - - --- | Get filename base (i.e. without file extension) for index-related files --- --- /Secure/ cabal repositories use a new extended & incremental --- @01-index.tar@. In order to avoid issues resulting from clobbering --- new/old-style index data, we save them locally to different names. --- --- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the --- @00-index.tar.gz@/@01-index.tar.gz@ file. -indexBaseName :: Repo -> FilePath -indexBaseName repo = repoLocalDir repo fn - where - fn = case repo of - RepoSecure {} -> "01-index" - RepoRemote {} -> "00-index" - RepoLocalNoIndex {} -> "noindex" - ------------------------------------------------------------------------- --- Reading the source package index --- - --- Note: 'data IndexState' is defined in --- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles - --- | 'IndexStateInfo' contains meta-information about the resulting --- filtered 'Cache' 'after applying 'filterCache' according to a --- requested 'IndexState'. -data IndexStateInfo = IndexStateInfo - { isiMaxTime :: !Timestamp - -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current - -- filtered view of the cache. - -- - -- The following property holds - -- - -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi) - -- - - , isiHeadTime :: !Timestamp - -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest - -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to - -- 'isiMaxTime'. - } - -emptyStateInfo :: IndexStateInfo -emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp - --- | Filters a 'Cache' according to an 'IndexState' --- specification. Also returns 'IndexStateInfo' describing the --- resulting index cache. --- --- Note: 'filterCache' is idempotent in the 'Cache' value -filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo) -filterCache IndexStateHead cache = (cache, IndexStateInfo{..}) - where - isiMaxTime = cacheHeadTs cache - isiHeadTime = cacheHeadTs cache -filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..}) - where - cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime } - isiHeadTime = cacheHeadTs cache0 - isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents) - ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0) - --- | Read a repository index from disk, from the local files specified by --- a list of 'Repo's. --- --- All the 'SourcePackage's are marked as having come from the appropriate --- 'Repo'. --- --- This is a higher level wrapper used internally in cabal-install. -getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb -getSourcePackages verbosity repoCtxt = - fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing - --- | Variant of 'getSourcePackages' which allows getting the source --- packages at a particular 'IndexState'. --- --- Current choices are either the latest (aka HEAD), or the index as --- it was at a particular time. --- --- Returns also the total index where repositories' --- RepoIndexState's are not HEAD. This is used in v2-freeze. --- -getSourcePackagesAtIndexState - :: Verbosity - -> RepoContext - -> Maybe TotalIndexState - -> Maybe ActiveRepos - -> IO (SourcePackageDb, TotalIndexState, ActiveRepos) -getSourcePackagesAtIndexState verbosity repoCtxt _ _ - | null (repoContextRepos repoCtxt) = do - -- In the test suite, we routinely don't have any remote package - -- servers, so don't bleat about it - warn (verboseUnmarkOutput verbosity) $ - "No remote package servers have been specified. Usually " ++ - "you would have one specified in the config file." - return (SourcePackageDb { - packageIndex = mempty, - packagePreferences = mempty - }, headTotalIndexState, ActiveRepos []) -getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do - let describeState IndexStateHead = "most recent state" - describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time - - pkgss <- for (repoContextRepos repoCtxt) $ \r -> do - let rname :: RepoName - rname = repoName r - - info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...") - - idxState <- case mb_idxState of - Just totalIdxState -> do - let idxState = lookupIndexState rname totalIdxState - info verbosity $ "Using " ++ describeState idxState ++ - " as explicitly requested (via command line / project configuration)" - return idxState - Nothing -> do - mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r) - case mb_idxState' of - Nothing -> do - info verbosity "Using most recent state (could not read timestamp file)" - return IndexStateHead - Just idxState -> do - info verbosity $ "Using " ++ describeState idxState ++ - " specified from most recent cabal update" - return idxState - - unless (idxState == IndexStateHead) $ - case r of - RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" - RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')") - RepoSecure {} -> pure () - - let idxState' = case r of - RepoSecure {} -> idxState - _ -> IndexStateHead - - (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState' - - case idxState' of - IndexStateHead -> do - info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi)) - return () - IndexStateTime ts0 -> do - when (isiMaxTime isi /= ts0) $ - if ts0 > isiMaxTime isi - then warn verbosity $ - "Requested index-state " ++ prettyShow ts0 - ++ " is newer than '" ++ unRepoName rname ++ "'!" - ++ " Falling back to older state (" - ++ prettyShow (isiMaxTime isi) ++ ")." - else info verbosity $ - "Requested index-state " ++ prettyShow ts0 - ++ " does not exist in '"++ unRepoName rname ++"'!" - ++ " Falling back to older state (" - ++ prettyShow (isiMaxTime isi) ++ ")." - info verbosity ("index-state("++ unRepoName rname ++") = " ++ - prettyShow (isiMaxTime isi) ++ " (HEAD = " ++ - prettyShow (isiHeadTime isi) ++ ")") - - pure RepoData - { rdRepoName = rname - , rdTimeStamp = isiMaxTime isi - , rdIndex = pis - , rdPreferences = deps - } - - let activeRepos :: ActiveRepos - activeRepos = fromMaybe defaultActiveRepos mb_activeRepos - - pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of - Right x -> return x - Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss) - - let activeRepos' :: ActiveRepos - activeRepos' = ActiveRepos - [ ActiveRepo (rdRepoName rd) strategy - | (rd, strategy) <- pkgss' - ] - - let totalIndexState :: TotalIndexState - totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList - [ (n, IndexStateTime ts) - | (RepoData n ts _idx _prefs, _strategy) <- pkgss' - -- e.g. file+noindex have nullTimestamp as their timestamp - , ts /= nullTimestamp - ] - - let addIndex - :: PackageIndex UnresolvedSourcePackage - -> (RepoData, CombineStrategy) - -> PackageIndex UnresolvedSourcePackage - addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc - addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx - addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx - - let pkgs :: PackageIndex UnresolvedSourcePackage - pkgs = foldl' addIndex mempty pkgss' - - -- Note: preferences combined without using CombineStrategy - let prefs :: Map PackageName VersionRange - prefs = Map.fromListWith intersectVersionRanges - [ (name, range) - | (RepoData _n _ts _idx prefs', _strategy) <- pkgss' - , Dependency name range _ <- prefs' - ] - - _ <- evaluate pkgs - _ <- evaluate prefs - _ <- evaluate totalIndexState - return (SourcePackageDb { - packageIndex = pkgs, - packagePreferences = prefs - }, totalIndexState, activeRepos') - --- auxiliary data used in getSourcePackagesAtIndexState -data RepoData = RepoData - { rdRepoName :: RepoName - , rdTimeStamp :: Timestamp - , rdIndex :: PackageIndex UnresolvedSourcePackage - , rdPreferences :: [Dependency] - } - --- | Read a repository index from disk, from the local file specified by --- the 'Repo'. --- --- All the 'SourcePackage's are marked as having come from the given 'Repo'. --- --- This is a higher level wrapper used internally in cabal-install. --- -readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState - -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) -readRepoIndex verbosity repoCtxt repo idxState = - handleNotFound $ do - when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) - readPackageIndexCacheFile verbosity mkAvailablePackage - (RepoIndex repoCtxt repo) - idxState - - where - mkAvailablePackage pkgEntry = SourcePackage - { srcpkgPackageId = pkgid - , srcpkgDescription = pkgdesc - , srcpkgSource = case pkgEntry of - NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing - BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path - , srcpkgDescrOverride = case pkgEntry of - NormalPackage _ _ pkgtxt _ -> Just pkgtxt - _ -> Nothing - } - where - pkgdesc = packageDesc pkgEntry - pkgid = packageId pkgEntry - - handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e - then do - case repo of - RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote - RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote - RepoLocalNoIndex local _ -> warn verbosity $ - "Error during construction of local+noindex " - ++ unRepoName (localRepoName local) ++ " repository index: " - ++ show e - return (mempty,mempty,emptyStateInfo) - else ioError e - - isOldThreshold = 15 --days - warnIfIndexIsOld dt = do - when (dt >= isOldThreshold) $ case repo of - RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt - RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt - RepoLocalNoIndex {} -> return () - - errMissingPackageList repoRemote = - "The package list for '" ++ unRepoName (remoteRepoName repoRemote) - ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote - errOutdatedPackageList repoRemote dt = - "The package list for '" ++ unRepoName (remoteRepoName repoRemote) - ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun " - ++ "'cabal update' to get the latest list of available packages." - --- | Return the age of the index file in days (as a Double). -getIndexFileAge :: Repo -> IO Double -getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar" - --- | A set of files (or directories) that can be monitored to detect when --- there might have been a change in the source packages. --- -getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] -getSourcePackagesMonitorFiles repos = - concat [ [ indexBaseName repo <.> "cache" - , indexBaseName repo <.> "timestamp" ] - | repo <- repos ] - --- | It is not necessary to call this, as the cache will be updated when the --- index is read normally. However you can do the work earlier if you like. --- -updateRepoIndexCache :: Verbosity -> Index -> IO () -updateRepoIndexCache verbosity index = - whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index - -whenCacheOutOfDate :: Index -> IO () -> IO () -whenCacheOutOfDate index action = do - exists <- doesFileExist $ cacheFile index - if not exists - then action - else if localNoIndex index - then return () -- TODO: don't update cache for local+noindex repositories - else do - indexTime <- getModTime $ indexFile index - cacheTime <- getModTime $ cacheFile index - when (indexTime > cacheTime) action - -localNoIndex :: Index -> Bool -localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True -localNoIndex _ = False - ------------------------------------------------------------------------- --- Reading the index file --- - --- | An index entry is either a normal package, or a local build tree reference. -data PackageEntry - = NormalPackage PackageId GenericPackageDescription ByteString BlockNo - | BuildTreeRef BuildTreeRefType - PackageId GenericPackageDescription FilePath BlockNo - --- | A build tree reference is either a link or a snapshot. -data BuildTreeRefType = SnapshotRef | LinkRef - deriving (Eq,Show,Generic) - -instance Binary BuildTreeRefType -instance Structured BuildTreeRefType - -refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType -refTypeFromTypeCode t - | t == Tar.buildTreeRefTypeCode = LinkRef - | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef - | otherwise = - error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code" - -typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode -typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode -typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode - -instance Package PackageEntry where - packageId (NormalPackage pkgid _ _ _) = pkgid - packageId (BuildTreeRef _ pkgid _ _ _) = pkgid - -packageDesc :: PackageEntry -> GenericPackageDescription -packageDesc (NormalPackage _ descr _ _) = descr -packageDesc (BuildTreeRef _ _ descr _ _) = descr - --- | Parse an uncompressed \"00-index.tar\" repository index file represented --- as a 'ByteString'. --- - -data PackageOrDep = Pkg PackageEntry | Dep Dependency - --- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files --- --- We read the index using 'Tar.read', which gives us a lazily constructed --- 'TarEntries'. We translate it to a list of entries using 'tarEntriesList', --- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a --- function over this to translate it to a list of IO actions returning --- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of --- 'PackageOrDep's, still maintaining the lazy nature of the original tar read. -parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)] -parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read - where - extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)] - extract blockNo entry = tryExtractPkg ++ tryExtractPrefs - where - tryExtractPkg = do - mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo - return $ fmap (fmap Pkg) mkPkgEntry - - tryExtractPrefs = do - prefs' <- maybeToList $ extractPrefs entry - fmap (return . Just . Dep) prefs' - --- | Turn the 'Entries' data structure from the @tar@ package into a list, --- and pair each entry with its block number. --- --- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read --- as far as the list is evaluated. -tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)] -tarEntriesList = go 0 - where - go !_ Tar.Done = [] - go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) - go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' - -extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) -extractPkg verbosity entry blockNo = case Tar.entryContent entry of - Tar.NormalFile content _ - | takeExtension fileName == ".cabal" - -> case splitDirectories (normalise fileName) of - [pkgname,vers,_] -> case simpleParsec vers of - Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) - where - pkgid = PackageIdentifier (mkPackageName pkgname) ver - parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) - descr = case parsed of - Just d -> d - Nothing -> error $ "Couldn't read cabal file " - ++ show fileName - _ -> Nothing - _ -> Nothing - - Tar.OtherEntryType typeCode content _ - | Tar.isBuildTreeRefTypeCode typeCode -> - Just $ do - let path = byteStringToFilePath content - dirExists <- doesDirectoryExist path - result <- if not dirExists then return Nothing - else do - cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." - descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile - return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) - descr path blockNo - return result - - _ -> Nothing - - where - fileName = Tar.entryPath entry - -extractPrefs :: Tar.Entry -> Maybe [Dependency] -extractPrefs entry = case Tar.entryContent entry of - Tar.NormalFile content _ - | FilePath.Posix.takeFileName entrypath == "preferred-versions" - -> Just prefs - where - entrypath = Tar.entryPath entry - prefs = parsePreferredVersions content - _ -> Nothing - -parsePreferredVersions :: ByteString -> [Dependency] -parsePreferredVersions = mapMaybe simpleParsec - . filter (not . isPrefixOf "--") - . lines - . BS.Char8.unpack -- TODO: Are we sure no unicode? - ------------------------------------------------------------------------- --- Reading and updating the index cache --- - --- | Variation on 'sequence' which evaluates the actions lazily --- --- Pattern matching on the result list will execute just the first action; --- more generally pattern matching on the first @n@ '(:)' nodes will execute --- the first @n@ actions. -lazySequence :: [IO a] -> IO [a] -lazySequence = unsafeInterleaveIO . go - where - go [] = return [] - go (x:xs) = do x' <- x - xs' <- lazySequence xs - return (x' : xs') - --- | A lazy unfolder for lookup operations which return the current --- value and (possibly) the next key -lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)] -lazyUnfold step = goLazy . Just - where - goLazy s = unsafeInterleaveIO (go s) - - go Nothing = return [] - go (Just k) = do - (v, mk') <- step k - vs' <- goLazy mk' - return ((k,v):vs') - --- | Which index do we mean? -data Index = - -- | The main index for the specified repository - RepoIndex RepoContext Repo - - -- | A sandbox-local repository - -- Argument is the location of the index file - | SandboxIndex FilePath - -indexFile :: Index -> FilePath -indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar" -indexFile (SandboxIndex index) = index - -cacheFile :: Index -> FilePath -cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" -cacheFile (SandboxIndex index) = index `replaceExtension` "cache" - -timestampFile :: Index -> FilePath -timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp" -timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp" - --- | Return 'True' if 'Index' uses 01-index format (aka secure repo) -is01Index :: Index -> Bool -is01Index (RepoIndex _ repo) = case repo of - RepoSecure {} -> True - RepoRemote {} -> False - RepoLocalNoIndex {} -> True -is01Index (SandboxIndex _) = False - - -updatePackageIndexCacheFile :: Verbosity -> Index -> IO () -updatePackageIndexCacheFile verbosity index = do - info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") - withIndexEntries verbosity index callback callbackNoIndex - where - callback entries = do - let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) - cache = Cache { cacheHeadTs = maxTs - , cacheEntries = entries - } - writeIndexCache index cache - info verbosity ("Index cache updated to index-state " - ++ prettyShow (cacheHeadTs cache)) - - callbackNoIndex entries = do - writeNoIndexCache verbosity index $ NoIndexCache entries - info verbosity "Index cache updated" - --- | Read the index (for the purpose of building a cache) --- --- The callback is provided with list of cache entries, which is guaranteed to --- be lazily constructed. This list must ONLY be used in the scope of the --- callback; when the callback is terminated the file handle to the index will --- be closed and further attempts to read from the list will result in (pure) --- I/O exceptions. --- --- In the construction of the index for a secure repo we take advantage of the --- index built by the @hackage-security@ library to avoid reading the @.tar@ --- file as much as possible (we need to read it only to extract preferred --- versions). This helps performance, but is also required for correctness: --- the new @01-index.tar.gz@ may have multiple versions of preferred-versions --- files, and 'parsePackageIndex' does not correctly deal with that (see #2956); --- by reading the already-built cache from the security library we will be sure --- to only read the latest versions of all files. --- --- TODO: It would be nicer if we actually incrementally updated @cabal@'s --- cache, rather than reconstruct it from zero on each update. However, this --- would require a change in the cache format. -withIndexEntries - :: Verbosity -> Index - -> ([IndexCacheEntry] -> IO a) - -> ([NoIndexCacheEntry] -> IO a) - -> IO a -withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ = - repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> - Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do - -- Incrementally (lazily) read all the entries in the tar file in order, - -- including all revisions, not just the last revision of each file - indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory) - callback [ cacheEntry - | (dirEntry, indexEntry) <- indexEntries - , cacheEntry <- toCacheEntries dirEntry indexEntry ] - where - toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry - -> [IndexCacheEntry] - toCacheEntries dirEntry (Sec.Some sie) = - case Sec.indexEntryPathParsed sie of - Nothing -> [] -- skip unrecognized file - Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata - Just (Sec.IndexPkgCabal pkgId) -> force - [CachePackageId pkgId blockNo timestamp] - Just (Sec.IndexPkgPrefs _pkgName) -> force - [ CachePreference dep blockNo timestamp - | dep <- parsePreferredVersions (Sec.indexEntryContent sie) - ] - where - blockNo = Sec.directoryEntryBlockNo dirEntry - timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ - epochTimeToTimestamp $ Sec.indexEntryTime sie - -withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do - dirContents <- listDirectory localDir - let contentSet = Set.fromList dirContents - - entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do - case isTarGz file of - Nothing -> do - unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $ - info verbosity $ "Skipping " ++ file - return Nothing - Just pkgid | cabalPath `Set.member` contentSet -> do - contents <- BSS.readFile (localDir cabalPath) - for (parseGenericPackageDescriptionMaybe contents) $ \gpd -> - return (CacheGPD gpd contents) - where - cabalPath = prettyShow pkgid ++ ".cabal" - Just pkgId -> do - -- check for the right named .cabal file in the compressed tarball - tarGz <- BS.readFile (localDir file) - let tar = GZip.decompress tarGz - entries = Tar.read tar - - case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of - Just ce -> return (Just ce) - Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file - - info verbosity $ "Entries in file+noindex repository " ++ unRepoName name - for_ entries $ \(CacheGPD gpd _) -> - info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd) - - callback entries - where - handler :: IOException -> IO a - handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e - - isTarGz :: FilePath -> Maybe PackageIdentifier - isTarGz fp = do - pfx <- stripSuffix ".tar.gz" fp - simpleParsec pfx - - stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str)) - - -- look for /.cabal inside the tarball - readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry - readCabalEntry pkgId entry Nothing - | filename == Tar.entryPath entry - , Tar.NormalFile contents _ <- Tar.entryContent entry - = let bs = BS.toStrict contents - in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs - where - filename = prettyShow pkgId FilePath.Posix. prettyShow (packageName pkgId) ++ ".cabal" - readCabalEntry _ _ x = x - -withIndexEntries verbosity index callback _ = do -- non-secure repositories - withFile (indexFile index) ReadMode $ \h -> do - bs <- maybeDecompress `fmap` BS.hGetContents h - pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs - callback $ map toCache (catMaybes pkgsOrPrefs) - where - toCache :: PackageOrDep -> IndexCacheEntry - toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp - toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo - toCache (Dep d) = CachePreference d 0 nullTimestamp - -readPackageIndexCacheFile :: Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> Index - -> RepoIndexState - -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) -readPackageIndexCacheFile verbosity mkPkg index idxState - | localNoIndex index = do - cache0 <- readNoIndexCache verbosity index - pkgs <- packageNoIndexFromCache verbosity mkPkg cache0 - pure (pkgs, [], emptyStateInfo) - - | otherwise = do - cache0 <- readIndexCache verbosity index - indexHnd <- openFile (indexFile index) ReadMode - let (cache,isi) = filterCache idxState cache0 - (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache - pure (pkgs,deps,isi) - -packageIndexFromCache :: Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> Handle - -> Cache - -> IO (PackageIndex pkg, [Dependency]) -packageIndexFromCache verbosity mkPkg hnd cache = do - (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache - pkgIndex <- evaluate $ PackageIndex.fromList pkgs - return (pkgIndex, prefs) - -packageNoIndexFromCache - :: forall pkg. Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> NoIndexCache - -> IO (PackageIndex pkg) -packageNoIndexFromCache _verbosity mkPkg cache = - evaluate $ PackageIndex.fromList pkgs - where - pkgs = - [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0 - | CacheGPD gpd bs <- noIndexCacheEntries cache - , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd - ] - --- | Read package list --- --- The result package releases and preference entries are guaranteed --- to be unique. --- --- Note: 01-index.tar is an append-only index and therefore contains --- all .cabal edits and preference-updates. The masking happens --- here, i.e. the semantics that later entries in a tar file mask --- earlier ones is resolved in this function. -packageListFromCache :: Verbosity - -> (PackageEntry -> pkg) - -> Handle - -> Cache - -> IO ([pkg], [Dependency]) -packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries - where - accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) - - accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do - -- Given the cache entry, make a package index entry. - -- The magic here is that we use lazy IO to read the .cabal file - -- from the index tarball if it turns out that we need it. - -- Most of the time we only need the package id. - ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do - pkgtxt <- getEntryContent blockno - pkg <- readPackageDescription pkgid pkgtxt - return (pkg, pkgtxt) - - let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) - accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries - - accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do - -- We have to read the .cabal file eagerly here because we can't cache the - -- package id for build tree references - the user might edit the .cabal - -- file after the reference was added to the index. - path <- liftM byteStringToFilePath . getEntryContent $ blockno - pkg <- do let err = "Error reading package index from cache." - file <- tryFindAddSourcePackageDesc verbosity path err - PackageDesc.Parse.readGenericPackageDescription normal file - let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) - accum srcpkgs (srcpkg:btrs) prefs entries - - accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) = - accum srcpkgs btrs (Map.insert pn pref prefs) entries - - getEntryContent :: BlockNo -> IO ByteString - getEntryContent blockno = do - entry <- Tar.hReadEntry hnd blockno - case Tar.entryContent entry of - Tar.NormalFile content _size -> return content - Tar.OtherEntryType typecode content _size - | Tar.isBuildTreeRefTypeCode typecode - -> return content - _ -> interror "unexpected tar entry type" - - readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription - readPackageDescription pkgid content = - case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of - Right gpd -> return gpd - Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer) - Left _ -> interror "failed to parse .cabal file" - where - dummyPackageDescription :: Version -> GenericPackageDescription - dummyPackageDescription specVer = GenericPackageDescription - { packageDescription = emptyPackageDescription - { package = pkgid - , synopsis = dummySynopsis - } - , gpdScannedVersion = Just specVer -- tells index scanner to skip this file. - , genPackageFlags = [] - , condLibrary = Nothing - , condSubLibraries = [] - , condForeignLibs = [] - , condExecutables = [] - , condTestSuites = [] - , condBenchmarks = [] - } - - dummySynopsis = "" - - interror :: String -> IO a - interror msg = die' verbosity $ "internal error when reading package index: " ++ msg - ++ "The package index or index cache is probably " - ++ "corrupt. Running cabal update might fix it." - - - ------------------------------------------------------------------------- --- Index cache data structure -- - --- | Read the 'Index' cache from the filesystem --- --- If a corrupted index cache is detected this function regenerates --- the index cache and then reattempt to read the index once (and --- 'die's if it fails again). -readIndexCache :: Verbosity -> Index -> IO Cache -readIndexCache verbosity index = do - cacheOrFail <- readIndexCache' index - case cacheOrFail of - Left msg -> do - warn verbosity $ concat - [ "Parsing the index cache failed (", msg, "). " - , "Trying to regenerate the index cache..." - ] - - updatePackageIndexCacheFile verbosity index - - either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index - - Right res -> return (hashConsCache res) - -readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache -readNoIndexCache verbosity index = do - cacheOrFail <- readNoIndexCache' index - case cacheOrFail of - Left msg -> do - warn verbosity $ concat - [ "Parsing the index cache failed (", msg, "). " - , "Trying to regenerate the index cache..." - ] - - updatePackageIndexCacheFile verbosity index - - either (die' verbosity) return =<< readNoIndexCache' index - - -- we don't hash cons local repository cache, they are hopefully small - Right res -> return res - --- | Read the 'Index' cache from the filesystem without attempting to --- regenerate on parsing failures. -readIndexCache' :: Index -> IO (Either String Cache) -readIndexCache' index - | is01Index index = structuredDecodeFileOrFail (cacheFile index) - | otherwise = liftM (Right .read00IndexCache) $ - BSS.readFile (cacheFile index) - -readNoIndexCache' :: Index -> IO (Either String NoIndexCache) -readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index) - --- | Write the 'Index' cache to the filesystem -writeIndexCache :: Index -> Cache -> IO () -writeIndexCache index cache - | is01Index index = structuredEncodeFile (cacheFile index) cache - | otherwise = writeFile (cacheFile index) (show00IndexCache cache) - -writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO () -writeNoIndexCache verbosity index cache = do - let path = cacheFile index - createDirectoryIfMissingVerbose verbosity True (takeDirectory path) - structuredEncodeFile path cache - --- | Write the 'IndexState' to the filesystem -writeIndexTimestamp :: Index -> RepoIndexState -> IO () -writeIndexTimestamp index st - = writeFile (timestampFile index) (prettyShow st) - --- | Read out the "current" index timestamp, i.e., what --- timestamp you would use to revert to this version -currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp -currentIndexTimestamp verbosity repoCtxt r = do - mb_is <- readIndexTimestamp (RepoIndex repoCtxt r) - case mb_is of - Just (IndexStateTime ts) -> return ts - _ -> do - (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead - return (isiHeadTime isi) - --- | Read the 'IndexState' from the filesystem -readIndexTimestamp :: Index -> IO (Maybe RepoIndexState) -readIndexTimestamp index - = fmap simpleParsec (readFile (timestampFile index)) - `catchIO` \e -> - if isDoesNotExistError e - then return Nothing - else ioError e - --- | Optimise sharing of equal values inside 'Cache' --- --- c.f. https://en.wikipedia.org/wiki/Hash_consing -hashConsCache :: Cache -> Cache -hashConsCache cache0 - = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) } - where - -- TODO/NOTE: - -- - -- If/when we redo the binary serialisation via e.g. CBOR and we - -- are able to use incremental decoding, we may want to move the - -- hash-consing into the incremental deserialisation, or - -- alterantively even do something like - -- http://cbor.schmorp.de/value-sharing - -- - go _ _ [] = [] - -- for now we only optimise only CachePackageIds since those - -- represent the vast majority - go !pns !pvs (CachePackageId pid bno ts : rest) - = CachePackageId pid' bno ts : go pns' pvs' rest - where - !pid' = PackageIdentifier pn' pv' - (!pn',!pns') = mapIntern pn pns - (!pv',!pvs') = mapIntern pv pvs - PackageIdentifier pn pv = pid - - go pns pvs (x:xs) = x : go pns pvs xs - - mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k) - mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m) - --- | Cabal caches various information about the Hackage index -data Cache = Cache - { cacheHeadTs :: Timestamp - -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the - -- invariant of 'cacheEntries' being in chronological order is - -- violated, this corresponds to the last (seen) 'Timestamp' in - -- 'cacheEntries' - , cacheEntries :: [IndexCacheEntry] - } - deriving (Show, Generic) - -instance NFData Cache where - rnf = rnf . cacheEntries - --- | Cache format for 'file+noindex' repositories -newtype NoIndexCache = NoIndexCache - { noIndexCacheEntries :: [NoIndexCacheEntry] - } - deriving (Show, Generic) - -instance NFData NoIndexCache where - rnf = rnf . noIndexCacheEntries - --- | Tar files are block structured with 512 byte blocks. Every header and file --- content starts on a block boundary. --- -type BlockNo = Word32 -- Tar.TarEntryOffset - -data IndexCacheEntry - = CachePackageId PackageId !BlockNo !Timestamp - | CachePreference Dependency !BlockNo !Timestamp - | CacheBuildTreeRef !BuildTreeRefType !BlockNo - -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build - deriving (Eq,Show,Generic) - -data NoIndexCacheEntry - = CacheGPD GenericPackageDescription !BSS.ByteString - deriving (Eq,Show,Generic) - -instance NFData IndexCacheEntry where - rnf (CachePackageId pkgid _ _) = rnf pkgid - rnf (CachePreference dep _ _) = rnf dep - rnf (CacheBuildTreeRef _ _) = () - -instance NFData NoIndexCacheEntry where - rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs - -cacheEntryTimestamp :: IndexCacheEntry -> Timestamp -cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp -cacheEntryTimestamp (CachePreference _ _ ts) = ts -cacheEntryTimestamp (CachePackageId _ _ ts) = ts - ----------------------------------------------------------------------------- --- new binary 01-index.cache format - -instance Binary Cache -instance Binary IndexCacheEntry -instance Binary NoIndexCache - -instance Structured Cache -instance Structured IndexCacheEntry -instance Structured NoIndexCache - --- | We need to save only .cabal file contents -instance Binary NoIndexCacheEntry where - put (CacheGPD _ bs) = put bs - - get = do - bs <- get - case parseGenericPackageDescriptionMaybe bs of - Just gpd -> return (CacheGPD gpd bs) - Nothing -> fail "Failed to parse GPD" - -instance Structured NoIndexCacheEntry where - structure = nominalStructure - ----------------------------------------------------------------------------- --- legacy 00-index.cache format - -packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String -packageKey = "pkg:" -blocknoKey = "b#" -buildTreeRefKey = "build-tree-ref:" -preferredVersionKey = "pref-ver:" - --- legacy 00-index.cache format -read00IndexCache :: BSS.ByteString -> Cache -read00IndexCache bs = Cache - { cacheHeadTs = nullTimestamp - , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs - } - -read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry -read00IndexCacheEntry = \line -> - case BSS.words line of - [key, pkgnamestr, pkgverstr, sep, blocknostr] - | key == BSS.pack packageKey && sep == BSS.pack blocknoKey -> - case (parseName pkgnamestr, parseVer pkgverstr [], - parseBlockNo blocknostr) of - (Just pkgname, Just pkgver, Just blockno) - -> Just (CachePackageId (PackageIdentifier pkgname pkgver) - blockno nullTimestamp) - _ -> Nothing - [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey -> - case (parseRefType typecodestr, parseBlockNo blocknostr) of - (Just refType, Just blockno) - -> Just (CacheBuildTreeRef refType blockno) - _ -> Nothing - - (key: remainder) | key == BSS.pack preferredVersionKey -> do - pref <- simpleParsecBS (BSS.unwords remainder) - return $ CachePreference pref 0 nullTimestamp - - _ -> Nothing - where - parseName str - | BSS.all (\c -> isAlphaNum c || c == '-') str - = Just (mkPackageName (BSS.unpack str)) - | otherwise = Nothing - - parseVer str vs = - case BSS.readInt str of - Nothing -> Nothing - Just (v, str') -> case BSS.uncons str' of - Just ('.', str'') -> parseVer str'' (v:vs) - Just _ -> Nothing - Nothing -> Just (mkVersion (reverse (v:vs))) - - parseBlockNo str = - case BSS.readInt str of - Just (blockno, remainder) - | BSS.null remainder -> Just (fromIntegral blockno) - _ -> Nothing - - parseRefType str = - case BSS.uncons str of - Just (typeCode, remainder) - | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode - -> Just (refTypeFromTypeCode typeCode) - _ -> Nothing - --- legacy 00-index.cache format -show00IndexCache :: Cache -> String -show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries - -show00IndexCacheEntry :: IndexCacheEntry -> String -show00IndexCacheEntry entry = unwords $ case entry of - CachePackageId pkgid b _ -> - [ packageKey - , prettyShow (packageName pkgid) - , prettyShow (packageVersion pkgid) - , blocknoKey - , show b - ] - CacheBuildTreeRef tr b -> - [ buildTreeRefKey - , [typeCodeFromRefType tr] - , show b - ] - CachePreference dep _ _ -> - [ preferredVersionKey - , prettyShow dep - ] diff --git a/Distribution/Client/IndexUtils/ActiveRepos.hs b/Distribution/Client/IndexUtils/ActiveRepos.hs deleted file mode 100644 --- a/Distribution/Client/IndexUtils/ActiveRepos.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Client.IndexUtils.ActiveRepos ( - ActiveRepos (..), - defaultActiveRepos, - filterSkippedActiveRepos, - ActiveRepoEntry (..), - CombineStrategy (..), - organizeByRepos, -) where - -import Distribution.Client.Compat.Prelude -import Distribution.Client.Types.RepoName (RepoName (..)) -import Prelude () - -import Distribution.Parsec (parsecLeadingCommaNonEmpty) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- $setup --- >>> import Distribution.Parsec - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - --- | Ordered list of active repositories. -newtype ActiveRepos = ActiveRepos [ActiveRepoEntry] - deriving (Eq, Show, Generic) - -defaultActiveRepos :: ActiveRepos -defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ] - --- | Note, this does nothing if 'ActiveRepoRest' is present. -filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos -filterSkippedActiveRepos repos@(ActiveRepos entries) - | any isActiveRepoRest entries = repos - | otherwise = ActiveRepos (filter notSkipped entries) - where - isActiveRepoRest (ActiveRepoRest _) = True - isActiveRepoRest _ = False - - notSkipped (ActiveRepo _ CombineStrategySkip) = False - notSkipped _ = True - -instance Binary ActiveRepos -instance Structured ActiveRepos -instance NFData ActiveRepos - -instance Pretty ActiveRepos where - pretty (ActiveRepos []) - = Disp.text ":none" - pretty (ActiveRepos repos) - = Disp.hsep - $ Disp.punctuate Disp.comma - $ map pretty repos - --- | Note: empty string is not valid 'ActiveRepos'. --- --- >>> simpleParsec "" :: Maybe ActiveRepos --- Nothing --- --- >>> simpleParsec ":none" :: Maybe ActiveRepos --- Just (ActiveRepos []) --- --- >>> simpleParsec ":rest" :: Maybe ActiveRepos --- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) --- --- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos --- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride]) --- -instance Parsec ActiveRepos where - parsec = ActiveRepos [] <$ P.try (P.string ":none") - <|> do - repos <- parsecLeadingCommaNonEmpty parsec - return (ActiveRepos (toList repos)) - -data ActiveRepoEntry - = ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo' - | ActiveRepo RepoName CombineStrategy -- ^ explicit repository name - deriving (Eq, Show, Generic) - -instance Binary ActiveRepoEntry -instance Structured ActiveRepoEntry -instance NFData ActiveRepoEntry - -instance Pretty ActiveRepoEntry where - pretty (ActiveRepoRest s) = - Disp.text ":rest" <<>> Disp.colon <<>> pretty s - pretty (ActiveRepo r s) = - pretty r <<>> Disp.colon <<>> pretty s - -instance Parsec ActiveRepoEntry where - parsec = leadColon <|> leadRepo where - leadColon = do - _ <- P.char ':' - token <- P.munch1 isAlpha - case token of - "rest" -> ActiveRepoRest <$> strategyP - "repo" -> P.char ':' *> leadRepo - _ -> P.unexpected $ "Unknown active repository entry type: " ++ token - - leadRepo = do - r <- parsec - s <- strategyP - return (ActiveRepo r s) - - strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec) - -data CombineStrategy - = CombineStrategySkip -- ^ skip this repository - | CombineStrategyMerge -- ^ merge existing versions - | CombineStrategyOverride -- ^ if later repository specifies a package, - -- all package versions are replaced - deriving (Eq, Show, Enum, Bounded, Generic) - -instance Binary CombineStrategy -instance Structured CombineStrategy -instance NFData CombineStrategy - -instance Pretty CombineStrategy where - pretty CombineStrategySkip = Disp.text "skip" - pretty CombineStrategyMerge = Disp.text "merge" - pretty CombineStrategyOverride = Disp.text "override" - -instance Parsec CombineStrategy where - parsec = P.choice - [ CombineStrategySkip <$ P.string "skip" - , CombineStrategyMerge <$ P.string "merge" - , CombineStrategyOverride <$ P.string "override" - ] - -------------------------------------------------------------------------------- --- Organisation -------------------------------------------------------------------------------- - --- | Sort values 'RepoName' according to 'ActiveRepos' list. --- --- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"] --- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos --- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] --- --- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos --- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] --- --- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos --- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)] --- --- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos --- Left "no repository provided d" --- --- Note: currently if 'ActiveRepoRest' is provided more than once, --- rest-repositories will be multiple times in the output. --- -organizeByRepos - :: forall a. ActiveRepos - -> (a -> RepoName) - -> [a] - -> Either String [(a, CombineStrategy)] -organizeByRepos (ActiveRepos xs0) sel ys0 = - -- here we use lazyness to do only one traversal - let (rest, result) = case go rest xs0 ys0 of - Right (rest', result') -> (rest', Right result') - Left err -> ([], Left err) - in result - where - go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)]) - go _rest [] ys = Right (ys, []) - go rest (ActiveRepoRest s : xs) ys = - go rest xs ys <&> \(rest', result) -> - (rest', map (\x -> (x, s)) rest ++ result) - go rest (ActiveRepo r s : xs) ys = do - (z, zs) <- extract r ys - go rest xs zs <&> \(rest', result) -> - (rest', (z, s) : result) - - extract :: RepoName -> [a] -> Either String (a, [a]) - extract r = loop id where - loop _acc [] = Left $ "no repository provided " ++ prettyShow r - loop acc (x:xs) - | sel x == r = Right (x, acc xs) - | otherwise = loop (acc . (x :)) xs - - (<&>) - :: Either err ([s], b) - -> (([s], b) -> ([s], c)) - -> Either err ([s], c) - (<&>) = flip fmap diff --git a/Distribution/Client/IndexUtils/IndexState.hs b/Distribution/Client/IndexUtils/IndexState.hs deleted file mode 100644 --- a/Distribution/Client/IndexUtils/IndexState.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.IndexUtils.IndexUtils --- Copyright : (c) 2016 Herbert Valerio Riedel --- License : BSD3 --- --- Package repositories index state. --- -module Distribution.Client.IndexUtils.IndexState ( - RepoIndexState(..), - TotalIndexState, - headTotalIndexState, - makeTotalIndexState, - lookupIndexState, - insertIndexState, -) where - -import Distribution.Client.Compat.Prelude -import Distribution.Client.IndexUtils.Timestamp (Timestamp) -import Distribution.Client.Types.RepoName (RepoName (..)) - -import Distribution.Parsec (parsecLeadingCommaNonEmpty) - -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- $setup --- >>> import Distribution.Parsec - -------------------------------------------------------------------------------- --- Total index state -------------------------------------------------------------------------------- - --- | Index state of multiple repositories -data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState) - deriving (Eq, Show, Generic) - -instance Binary TotalIndexState -instance Structured TotalIndexState -instance NFData TotalIndexState - -instance Pretty TotalIndexState where - pretty (TIS IndexStateHead m) - | not (Map.null m) - = Disp.hsep $ Disp.punctuate Disp.comma - [ pretty rn Disp.<+> pretty idx - | (rn, idx) <- Map.toList m - ] - pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where - go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx - --- | --- --- >>> simpleParsec "HEAD" :: Maybe TotalIndexState --- Just (TIS IndexStateHead (fromList [])) --- --- >>> simpleParsec "" :: Maybe TotalIndexState --- Nothing --- --- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState --- Just (TIS IndexStateHead (fromList [])) --- --- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState --- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)])) --- --- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState --- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))])) --- -instance Parsec TotalIndexState where - parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where - single0 = startsWithRepoName <|> TokTimestamp <$> parsec - startsWithRepoName = do - reponame <- parsec - -- the "HEAD" is technically a valid reponame... - if reponame == RepoName "HEAD" - then return TokHead - else do - P.spaces - TokRepo reponame <$> parsec - - add :: TotalIndexState -> Tok -> TotalIndexState - add _ TokHead = headTotalIndexState - add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty - add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m) - --- used in Parsec TotalIndexState implementation -data Tok - = TokRepo RepoName RepoIndexState - | TokTimestamp Timestamp - | TokHead - --- | Remove non-default values from 'TotalIndexState'. -normalise :: TotalIndexState -> TotalIndexState -normalise (TIS def m) = TIS def (Map.filter (/= def) m) - --- | 'TotalIndexState' where all repositories are at @HEAD@ index state. -headTotalIndexState :: TotalIndexState -headTotalIndexState = TIS IndexStateHead Map.empty - --- | Create 'TotalIndexState'. -makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState -makeTotalIndexState def m = normalise (TIS def m) - --- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'. -lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState -lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m - --- | Insert a 'RepoIndexState' to 'TotalIndexState'. -insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState -insertIndexState rn idx (TIS def m) - | idx == def = TIS def (Map.delete rn m) - | otherwise = TIS def (Map.insert rn idx m) - -------------------------------------------------------------------------------- --- Repository index state -------------------------------------------------------------------------------- - --- | Specification of the state of a specific repo package index -data RepoIndexState - = IndexStateHead -- ^ Use all available entries - | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time - deriving (Eq,Generic,Show) - -instance Binary RepoIndexState -instance Structured RepoIndexState -instance NFData RepoIndexState - -instance Pretty RepoIndexState where - pretty IndexStateHead = Disp.text "HEAD" - pretty (IndexStateTime ts) = pretty ts - -instance Parsec RepoIndexState where - parsec = parseHead <|> parseTime where - parseHead = IndexStateHead <$ P.string "HEAD" - parseTime = IndexStateTime <$> parsec diff --git a/Distribution/Client/IndexUtils/Timestamp.hs b/Distribution/Client/IndexUtils/Timestamp.hs deleted file mode 100644 --- a/Distribution/Client/IndexUtils/Timestamp.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.IndexUtils.Timestamp --- Copyright : (c) 2016 Herbert Valerio Riedel --- License : BSD3 --- --- Timestamp type used in package indexes - -module Distribution.Client.IndexUtils.Timestamp - ( Timestamp - , nullTimestamp - , epochTimeToTimestamp - , timestampToUTCTime - , utcTimeToTimestamp - , maximumTimestamp - ) where - -import Distribution.Client.Compat.Prelude - --- read is needed for Text instance -import Prelude (read) - -import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) - -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). -newtype Timestamp = TS Int64 -- Tar.EpochTime - deriving (Eq,Ord,Enum,NFData,Show,Generic) - -epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp -epochTimeToTimestamp et - | ts == nullTimestamp = Nothing - | otherwise = Just ts - where - ts = TS et - -timestampToUTCTime :: Timestamp -> Maybe UTCTime -timestampToUTCTime (TS t) - | t == minBound = Nothing - | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t) - -utcTimeToTimestamp :: UTCTime -> Maybe Timestamp -utcTimeToTimestamp utct - | minTime <= t, t <= maxTime = Just (TS (fromIntegral t)) - | otherwise = Nothing - where - maxTime = toInteger (maxBound :: Int64) - minTime = toInteger (succ minBound :: Int64) - t :: Integer - t = round . utcTimeToPOSIXSeconds $ utct - --- | Compute the maximum 'Timestamp' value --- --- Returns 'nullTimestamp' for the empty list. Also note that --- 'nullTimestamp' compares as smaller to all non-'nullTimestamp' --- values. -maximumTimestamp :: [Timestamp] -> Timestamp -maximumTimestamp [] = nullTimestamp -maximumTimestamp xs@(_:_) = maximum xs - --- returns 'Nothing' if not representable as 'Timestamp' -posixSecondsToTimestamp :: Integer -> Maybe Timestamp -posixSecondsToTimestamp pt - | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt)) - | otherwise = Nothing - where - maxTs = toInteger (maxBound :: Int64) - minTs = toInteger (succ minBound :: Int64) - --- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format --- (e.g. @"2017-12-31T23:59:59Z"@) --- --- Returns empty string for 'nullTimestamp' in order for --- --- > null (display nullTimestamp) == True --- --- to hold. -showTimestamp :: Timestamp -> String -showTimestamp ts = case timestampToUTCTime ts of - Nothing -> "" - -- Note: we don't use 'formatTime' here to avoid incurring a - -- dependency on 'old-locale' for older `time` libs - Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z" - where - showTOD = show . timeToTimeOfDay - -instance Binary Timestamp -instance Structured Timestamp - -instance Pretty Timestamp where - pretty = Disp.text . showTimestamp - -instance Parsec Timestamp where - parsec = parsePosix <|> parseUTC - where - -- | Parses unix timestamps, e.g. @"\@1474626019"@ - parsePosix = do - _ <- P.char '@' - t <- P.integral -- note, no negative timestamps - maybe (fail (show t ++ " is not representable as timestamp")) return $ - posixSecondsToTimestamp t - - -- | Parses ISO8601/RFC3339-style UTC timestamps, - -- e.g. @"2017-12-31T23:59:59Z"@ - -- - -- TODO: support numeric tz offsets; allow to leave off seconds - parseUTC = do - -- Note: we don't use 'Data.Time.Format.parseTime' here since - -- we want more control over the accepted formats. - - ye <- parseYear - _ <- P.char '-' - mo <- parseTwoDigits - _ <- P.char '-' - da <- parseTwoDigits - _ <- P.char 'T' - - utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $ - fromGregorianValid ye mo da - - ho <- parseTwoDigits - _ <- P.char ':' - mi <- parseTwoDigits - _ <- P.char ':' - se <- parseTwoDigits - _ <- P.char 'Z' - - utctDayTime <- maybe (fail (show (ho,mi,se) ++ " is not valid time of day")) (return . timeOfDayToTime) $ - makeTimeOfDayValid ho mi (realToFrac (se::Int)) - - let utc = UTCTime {..} - - maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc - - parseTwoDigits = do - d1 <- P.satisfy isDigit - d2 <- P.satisfy isDigit - return (read [d1,d2]) - - -- A year must have at least 4 digits; e.g. "0097" is fine, - -- while "97" is not c.f. RFC3339 which - -- deprecates 2-digit years - parseYear = do - sign <- P.option ' ' (P.char '-') - ds <- P.munch1 isDigit - when (length ds < 4) $ fail "Year should have at least 4 digits" - return (read (sign:ds)) - --- | Special timestamp value to be used when 'timestamp' is --- missing/unknown/invalid -nullTimestamp :: Timestamp -nullTimestamp = TS minBound diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs deleted file mode 100644 --- a/Distribution/Client/Init.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Implementation of the 'cabal init' command, which creates an initial .cabal --- file for a project. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init ( - - -- * Commands - initCabal - , incVersion - - ) where - -import Distribution.Client.Init.Command - ( initCabal, incVersion ) diff --git a/Distribution/Client/Init/Command.hs b/Distribution/Client/Init/Command.hs deleted file mode 100644 --- a/Distribution/Client/Init/Command.hs +++ /dev/null @@ -1,730 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Command --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Implementation of the 'cabal init' command, which creates an initial .cabal --- file for a project. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Command ( - - -- * Commands - initCabal - , incVersion - - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) - -import System.IO - ( hSetBuffering, stdout, BufferMode(..) ) -import System.Directory - ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents ) -import System.FilePath - ( (), takeBaseName, equalFilePath ) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import Control.Monad - ( (>=>) ) -import Control.Arrow - ( (&&&), (***) ) - -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..), showCabalSpecVersion ) -import Distribution.Version - ( Version, mkVersion, alterVersion, majorBoundVersion - , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) -import Distribution.ModuleName - ( ModuleName ) -- And for the Text instance -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, exposed ) -import qualified Distribution.Package as P -import qualified Distribution.SPDX as SPDX -import Language.Haskell.Extension ( Language(..) ) - -import Distribution.Client.Init.Defaults - ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir ) -import Distribution.Client.Init.FileCreators - ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs - , createTestSuiteIfEligible, writeCabalFile ) -import Distribution.Client.Init.Prompt - ( prompt, promptYesNo, promptStr, promptList, maybePrompt - , promptListOptional ) -import Distribution.Client.Init.Utils - ( eligibleForTestSuite, message ) -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), Category(..) - , displayPackageType ) -import Distribution.Client.Init.Heuristics - ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, - SourceFileEntry(..), - scanForModules, neededBuildPrograms ) - -import Distribution.Simple.Flag - ( maybeToFlag ) -import Distribution.Simple.Setup - ( Flag(..), flagToMaybe ) -import Distribution.Simple.Configure - ( getInstalledPackages ) -import Distribution.Simple.Compiler - ( PackageDBStack, Compiler ) -import Distribution.Simple.Program - ( ProgramDb ) -import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, moduleNameIndex ) - -import Distribution.Solver.Types.PackageIndex - ( elemByPackageName ) - -import Distribution.Client.IndexUtils - ( getSourcePackages ) -import Distribution.Client.Types - ( SourcePackageDb(..) ) -import Distribution.Client.Setup - ( RepoContext(..) ) - -initCabal :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> ProgramDb - -> InitFlags - -> IO () -initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - - hSetBuffering stdout NoBuffering - - initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags - - case license initFlags' of - Flag SPDX.NONE -> return () - _ -> writeLicense initFlags' - writeChangeLog initFlags' - createDirectories (sourceDirs initFlags') - createLibHs initFlags' - createDirectories (applicationDirs initFlags') - createMainHs initFlags' - createTestSuiteIfEligible initFlags' - success <- writeCabalFile initFlags' - - when success $ generateWarnings initFlags' - ---------------------------------------------------------------------------- --- Flag acquisition ----------------------------------------------------- ---------------------------------------------------------------------------- - --- | Fill in more details in InitFlags by guessing, discovering, or prompting --- the user. -extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags -extendFlags pkgIx sourcePkgDb = - getSimpleProject - >=> getLibOrExec - >=> getCabalVersion - >=> getPackageName sourcePkgDb - >=> getVersion - >=> getLicense - >=> getAuthorInfo - >=> getHomepage - >=> getSynopsis - >=> getCategory - >=> getExtraSourceFiles - >=> getAppDir - >=> getSrcDir - >=> getGenTests - >=> getTestDir - >=> getLanguage - >=> getGenComments - >=> getModulesBuildToolsAndDeps pkgIx - --- | Combine two actions which may return a value, preferring the first. That --- is, run the second action only if the first doesn't return a value. -infixr 1 ?>> -(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) -f ?>> g = do - ma <- f - if isJust ma - then return ma - else g - --- | Ask if a simple project with sensible defaults should be created. -getSimpleProject :: InitFlags -> IO InitFlags -getSimpleProject flags = do - simpleProj <- return (flagToMaybe $ simpleProject flags) - ?>> maybePrompt flags - (promptYesNo - "Should I generate a simple project with sensible defaults" - (Just True)) - return $ case maybeToFlag simpleProj of - Flag True -> - flags { interactive = Flag False - , simpleProject = Flag True - , packageType = Flag LibraryAndExecutable - , cabalVersion = Flag defaultCabalVersion - } - simpleProjFlag@_ -> - flags { simpleProject = simpleProjFlag } - - --- | Get the version of the cabal spec to use. --- --- The spec version can be specified by the InitFlags cabalVersion field. If --- none is specified then the user is prompted to pick from a list of --- supported versions (see code below). -getCabalVersion :: InitFlags -> IO InitFlags -getCabalVersion flags = do - cabVer <- return (flagToMaybe $ cabalVersion flags) - ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap` - promptList "Please choose version of the Cabal specification to use" - [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0] - (Just defaultCabalVersion) displayCabalVersion False) - ?>> return (Just defaultCabalVersion) - - return $ flags { cabalVersion = maybeToFlag cabVer } - - where - displayCabalVersion :: CabalSpecVersion -> String - displayCabalVersion v = case v of - CabalSpecV1_10 -> "1.10 (legacy)" - CabalSpecV2_0 -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" - CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" - CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" - CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" - _ -> showCabalSpecVersion v - - - --- | Get the package name: use the package directory (supplied, or the current --- directory by default) as a guess. It looks at the SourcePackageDb to avoid --- using an existing package name. -getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags -getPackageName sourcePkgDb flags = do - guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) - ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) - - let guess' | isPkgRegistered guess = Nothing - | otherwise = guess - - pkgName' <- return (flagToMaybe $ packageName flags) - ?>> maybePrompt flags (prompt "Package name" guess') - ?>> return guess' - - chooseAgain <- if isPkgRegistered pkgName' - then promptYesNo promptOtherNameMsg (Just True) - else return False - - if chooseAgain - then getPackageName sourcePkgDb flags - else return $ flags { packageName = maybeToFlag pkgName' } - - where - isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg - isPkgRegistered Nothing = False - - promptOtherNameMsg = "This package name is already used by another " ++ - "package on hackage. Do you want to choose a " ++ - "different name" - --- | Package version: use 0.1.0.0 as a last resort, but try prompting the user --- if possible. -getVersion :: InitFlags -> IO InitFlags -getVersion flags = do - let v = Just $ mkVersion [0,1,0,0] - v' <- return (flagToMaybe $ version flags) - ?>> maybePrompt flags (prompt "Package version" v) - ?>> return v - return $ flags { version = maybeToFlag v' } - --- | Choose a license for the package. --- --- The license can come from Initflags (license field), if it is not present --- then prompt the user from a predefined list of licenses. -getLicense :: InitFlags -> IO InitFlags -getLicense flags = do - elic <- return (fmap Right $ flagToMaybe $ license flags) - ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True) - - case elic of - Nothing -> return flags { license = NoFlag } - Just (Right lic) -> return flags { license = Flag lic } - Just (Left str) -> case eitherParsec str of - Right lic -> return flags { license = Flag lic } - -- on error, loop - Left err -> do - putStrLn "The license must be a valid SPDX expression." - putStrLn err - getLicense flags - where - -- perfectly we'll have this and writeLicense (in FileCreators) - -- in a single file - listedLicenses = - SPDX.NONE : - map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) - [ SPDX.BSD_2_Clause - , SPDX.BSD_3_Clause - , SPDX.Apache_2_0 - , SPDX.MIT - , SPDX.MPL_2_0 - , SPDX.ISC - - , SPDX.GPL_2_0_only - , SPDX.GPL_3_0_only - , SPDX.LGPL_2_1_only - , SPDX.LGPL_3_0_only - , SPDX.AGPL_3_0_only - - , SPDX.GPL_2_0_or_later - , SPDX.GPL_3_0_or_later - , SPDX.LGPL_2_1_or_later - , SPDX.LGPL_3_0_or_later - , SPDX.AGPL_3_0_or_later - ] - --- | The author's name and email. Prompt, or try to guess from an existing --- darcs repo. -getAuthorInfo :: InitFlags -> IO InitFlags -getAuthorInfo flags = do - (authorName, authorEmail) <- - (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail - authorName' <- return (flagToMaybe $ author flags) - ?>> maybePrompt flags (promptStr "Author name" authorName) - ?>> return authorName - - authorEmail' <- return (flagToMaybe $ email flags) - ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) - ?>> return authorEmail - - return $ flags { author = maybeToFlag authorName' - , email = maybeToFlag authorEmail' - } - --- | Prompt for a homepage URL for the package. -getHomepage :: InitFlags -> IO InitFlags -getHomepage flags = do - hp <- queryHomepage - hp' <- return (flagToMaybe $ homepage flags) - ?>> maybePrompt flags (promptStr "Project homepage URL" hp) - ?>> return hp - - return $ flags { homepage = maybeToFlag hp' } - --- | Right now this does nothing, but it could be changed to do some --- intelligent guessing. -queryHomepage :: IO (Maybe String) -queryHomepage = return Nothing -- get default remote darcs repo? - --- | Prompt for a project synopsis. -getSynopsis :: InitFlags -> IO InitFlags -getSynopsis flags = do - syn <- return (flagToMaybe $ synopsis flags) - ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) - - return $ flags { synopsis = maybeToFlag syn } - --- | Prompt for a package category. --- Note that it should be possible to do some smarter guessing here too, i.e. --- look at the name of the top level source directory. -getCategory :: InitFlags -> IO InitFlags -getCategory flags = do - cat <- return (flagToMaybe $ category flags) - ?>> fmap join (maybePrompt flags - (promptListOptional "Project category" [Codec ..])) - return $ flags { category = maybeToFlag cat } - --- | Try to guess extra source files (don't prompt the user). -getExtraSourceFiles :: InitFlags -> IO InitFlags -getExtraSourceFiles flags = do - extraSrcFiles <- return (extraSrc flags) - ?>> Just `fmap` guessExtraSourceFiles flags - - return $ flags { extraSrc = extraSrcFiles } - -defaultChangeLog :: FilePath -defaultChangeLog = "CHANGELOG.md" - --- | Try to guess things to include in the extra-source-files field. --- For now, we just look for things in the root directory named --- 'readme', 'changes', or 'changelog', with any sort of --- capitalization and any extension. -guessExtraSourceFiles :: InitFlags -> IO [FilePath] -guessExtraSourceFiles flags = do - dir <- - maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - files <- getDirectoryContents dir - let extraFiles = filter isExtra files - if any isLikeChangeLog extraFiles - then return extraFiles - else return (defaultChangeLog : extraFiles) - - where - isExtra = likeFileNameBase ("README" : changeLogLikeBases) - isLikeChangeLog = likeFileNameBase changeLogLikeBases - likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName - changeLogLikeBases = ["CHANGES", "CHANGELOG"] - --- | Ask whether the project builds a library or executable. -getLibOrExec :: InitFlags -> IO InitFlags -getLibOrExec flags = do - pkgType <- return (flagToMaybe $ packageType flags) - ?>> maybePrompt flags (either (const Executable) id `fmap` - promptList "What does the package build" - [Executable, Library, LibraryAndExecutable] - Nothing displayPackageType False) - ?>> return (Just Executable) - - -- If this package contains an executable, get the main file name. - mainFile <- if pkgType == Just Library then return Nothing else - getMainFile flags - - return $ flags { packageType = maybeToFlag pkgType - , mainIs = maybeToFlag mainFile - } - - --- | Try to guess the main file of the executable, and prompt the user to choose --- one of them. Top-level modules including the word 'Main' in the file name --- will be candidates, and shorter filenames will be preferred. -getMainFile :: InitFlags -> IO (Maybe FilePath) -getMainFile flags = - return (flagToMaybe $ mainIs flags) - ?>> do - candidates <- guessMainFileCandidates flags - let showCandidate = either (++" (does not yet exist, but will be created)") id - defaultFile = listToMaybe candidates - maybePrompt flags (either id (either id id) `fmap` - promptList "What is the main module of the executable" - candidates - defaultFile showCandidate True) - ?>> return (fmap (either id id) defaultFile) - --- | Ask if a test suite should be generated for the library. -getGenTests :: InitFlags -> IO InitFlags -getGenTests flags = do - genTests <- return (flagToMaybe $ initializeTestSuite flags) - -- Only generate a test suite if the package contains a library. - ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing - ?>> maybePrompt flags - (promptYesNo - "Should I generate a test suite for the library" - (Just True)) - return $ flags { initializeTestSuite = maybeToFlag genTests } - --- | Ask for the test suite root directory. -getTestDir :: InitFlags -> IO InitFlags -getTestDir flags = do - dirs <- return (testDirs flags) - -- Only need testDirs when test suite generation is enabled. - ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing - ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt - flags - (promptList "Test directory" ["test"] (Just "test") id True)) - - return $ flags { testDirs = dirs } - --- | Ask for the Haskell base language of the package. -getLanguage :: InitFlags -> IO InitFlags -getLanguage flags = do - lang <- return (flagToMaybe $ language flags) - ?>> maybePrompt flags - (either UnknownLanguage id `fmap` - promptList "What base language is the package written in" - [Haskell2010, Haskell98] - (Just Haskell2010) prettyShow True) - ?>> return (Just Haskell2010) - - if invalidLanguage lang - then putStrLn invalidOtherLanguageMsg >> getLanguage flags - else return $ flags { language = maybeToFlag lang } - - where - invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t - invalidLanguage _ = False - - invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++ - "Please enter a different language." - --- | Ask whether to generate explanatory comments. -getGenComments :: InitFlags -> IO InitFlags -getGenComments flags = do - genComments <- return (not <$> flagToMaybe (noComments flags)) - ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) - ?>> return (Just False) - return $ flags { noComments = maybeToFlag (fmap not genComments) } - where - promptMsg = "Add informative comments to each field in the cabal file (y/n)" - --- | Ask for the application root directory. -getAppDir :: InitFlags -> IO InitFlags -getAppDir flags = do - appDirs <- - return (applicationDirs flags) - ?>> noAppDirIfLibraryOnly - ?>> guessAppDir flags - ?>> promptUserForApplicationDir - ?>> setDefault - return $ flags { applicationDirs = appDirs } - - where - -- If the packageType==Library, then there is no application dir. - noAppDirIfLibraryOnly :: IO (Maybe [String]) - noAppDirIfLibraryOnly = - if (packageType flags) == Flag Library - then return (Just []) - else return Nothing - - -- Set the default application directory. - setDefault :: IO (Maybe [String]) - setDefault = pure (Just [defaultApplicationDir]) - - -- Prompt the user for the application directory (defaulting to "app"). - -- Returns 'Nothing' if in non-interactive mode, otherwise will always - -- return a 'Just' value ('Just []' if no separate application directory). - promptUserForApplicationDir :: IO (Maybe [String]) - promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt - flags - (promptList - ("Application " ++ mainFile ++ "directory") - [[defaultApplicationDir], ["src-exe"], []] - (Just [defaultApplicationDir]) - showOption True) - - showOption :: [String] -> String - showOption [] = "(none)" - showOption (x:_) = x - - -- The name - mainFile :: String - mainFile = case mainIs flags of - Flag mainPath -> "(" ++ mainPath ++ ") " - _ -> "" - --- | Try to guess app directory. Could try harder; for the --- moment just looks to see whether there is a directory called 'app'. -guessAppDir :: InitFlags -> IO (Maybe [String]) -guessAppDir flags = do - dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - appIsDir <- doesDirectoryExist (dir "app") - return $ if appIsDir - then Just ["app"] - else Nothing - --- | Ask for the source (library) root directory. -getSrcDir :: InitFlags -> IO InitFlags -getSrcDir flags = do - srcDirs <- - return (sourceDirs flags) - ?>> noSourceDirIfExecutableOnly - ?>> guessSourceDir flags - ?>> promptUserForSourceDir - ?>> setDefault - - return $ flags { sourceDirs = srcDirs } - - where - -- If the packageType==Executable, then there is no source dir. - noSourceDirIfExecutableOnly :: IO (Maybe [String]) - noSourceDirIfExecutableOnly = - if (packageType flags) == Flag Executable - then return (Just []) - else return Nothing - - -- Set the default source directory. - setDefault :: IO (Maybe [String]) - setDefault = pure (Just [defaultSourceDir]) - - -- Prompt the user for the source directory (defaulting to "app"). - -- Returns 'Nothing' if in non-interactive mode, otherwise will always - -- return a 'Just' value ('Just []' if no separate application directory). - promptUserForSourceDir :: IO (Maybe [String]) - promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt - flags - (promptList - ("Library source directory") - [[defaultSourceDir], ["lib"], ["src-lib"], []] - (Just [defaultSourceDir]) - showOption True) - - showOption :: [String] -> String - showOption [] = "(none)" - showOption (x:_) = x - - --- | Try to guess source directory. Could try harder; for the --- moment just looks to see whether there is a directory called 'src'. -guessSourceDir :: InitFlags -> IO (Maybe [String]) -guessSourceDir flags = do - dir <- - maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - srcIsDir <- doesDirectoryExist (dir "src") - return $ if srcIsDir - then Just ["src"] - else Nothing - --- | Check whether a potential source file is located in one of the --- source directories. -isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool -isSourceFile Nothing sf = isSourceFile (Just ["."]) sf -isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs - --- | Get the list of exposed modules and extra tools needed to build them. -getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags -getModulesBuildToolsAndDeps pkgIx flags = do - dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - - sourceFiles0 <- scanForModules dir - - let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0 - - Just mods <- return (exposedModules flags) - ?>> (return . Just . map moduleName $ sourceFiles) - - tools <- return (buildTools flags) - ?>> (return . Just . neededBuildPrograms $ sourceFiles) - - deps <- return (dependencies flags) - ?>> Just <$> importsToDeps flags - (fromString "Prelude" : -- to ensure we get base as a dep - ( nub -- only need to consider each imported package once - . filter (`notElem` mods) -- don't consider modules from - -- this package itself - . concatMap imports - $ sourceFiles - ) - ) - pkgIx - - exts <- return (otherExts flags) - ?>> (return . Just . nub . concatMap extensions $ sourceFiles) - - -- If we're initializing a library and there were no modules discovered - -- then create an empty 'MyLib' module. - -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because - -- then the executable needs to set 'other-modules: MyLib' or else the build - -- fails. - let (finalModsList, otherMods) = case (packageType flags, mods) of - - -- For an executable leave things as they are. - (Flag Executable, _) -> (mods, otherModules flags) - - -- If a non-empty module list exists don't change anything. - (_, (_:_)) -> (mods, otherModules flags) - - -- Library only: 'MyLib' in 'other-modules' only. - (Flag Library, _) -> ([myLibModule], Nothing) - - -- For a 'LibraryAndExecutable' we need to have special handling. - -- If we don't have a module list (Nothing or empty), then create a Lib. - (_, []) -> - if sourceDirs flags == applicationDirs flags - then ([myLibModule], Just [myLibModule]) - else ([myLibModule], Nothing) - - return $ flags { exposedModules = Just finalModsList - , otherModules = otherMods - , buildTools = tools - , dependencies = deps - , otherExts = exts - } - --- | Given a list of imported modules, retrieve the list of dependencies that --- provide those modules. -importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency] -importsToDeps flags mods pkgIx = do - - let modMap :: M.Map ModuleName [InstalledPackageInfo] - modMap = M.map (filter exposed) $ moduleNameIndex pkgIx - - modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])] - modDeps = map (id &&& flip M.lookup modMap) mods - - message flags "\nGuessing dependencies..." - nub . catMaybes <$> traverse (chooseDep flags) modDeps - --- Given a module and a list of installed packages providing it, --- choose a dependency (i.e. package + version range) to use for that --- module. -chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo]) - -> IO (Maybe P.Dependency) - -chooseDep flags (m, Nothing) - = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") - >> return Nothing - -chooseDep flags (m, Just []) - = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") - >> return Nothing - - -- We found some packages: group them by name. -chooseDep flags (m, Just ps) - = case pkgGroups of - -- if there's only one group, i.e. multiple versions of a single package, - -- we make it into a dependency, choosing the latest-ish version (see toDep). - [grp] -> Just <$> toDep grp - -- otherwise, we refuse to choose between different packages and make the user - -- do it. - grps -> do message flags ("\nWarning: multiple packages found providing " - ++ prettyShow m - ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps)) - message flags "You will need to pick one and manually add it to the Build-depends: field." - return Nothing - where - pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) - - desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags) - - -- Given a list of available versions of the same package, pick a dependency. - toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency - - -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* - toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries - - -- Otherwise, choose the latest version and issue a warning. - toDep pids = do - message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.") - return $ P.Dependency (P.pkgName . NE.head $ pids) - (pvpize desugar . maximum . fmap P.pkgVersion $ pids) - P.mainLibSet --TODO take into account sublibraries - --- | Given a version, return an API-compatible (according to PVP) version range. --- --- If the boolean argument denotes whether to use a desugared --- representation (if 'True') or the new-style @^>=@-form (if --- 'False'). --- --- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the --- same as @0.4.*@). -pvpize :: Bool -> Version -> VersionRange -pvpize False v = majorBoundVersion v -pvpize True v = orLaterVersion v' - `intersectVersionRanges` - earlierVersion (incVersion 1 v') - where v' = alterVersion (take 2) v - --- | Increment the nth version component (counting from 0). -incVersion :: Int -> Version -> Version -incVersion n = alterVersion (incVersion' n) - where - incVersion' 0 [] = [1] - incVersion' 0 (v:_) = [v+1] - incVersion' m [] = replicate m 0 ++ [1] - incVersion' m (v:vs) = v : incVersion' (m-1) vs - --- | Generate warnings for missing fields etc. -generateWarnings :: InitFlags -> IO () -generateWarnings flags = do - message flags "" - when (synopsis flags `elem` [NoFlag, Flag ""]) - (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") - - message flags "You may want to edit the .cabal file and add a Description field." diff --git a/Distribution/Client/Init/Defaults.hs b/Distribution/Client/Init/Defaults.hs deleted file mode 100644 --- a/Distribution/Client/Init/Defaults.hs +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Defaults --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Default values to use in cabal init (if not specified in config/flags). --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Defaults ( - defaultApplicationDir - , defaultSourceDir - , defaultCabalVersion - , myLibModule - ) where - -import Prelude (String) - -import Distribution.ModuleName - ( ModuleName ) -- And for the Text instance -import qualified Distribution.ModuleName as ModuleName - ( fromString ) -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..)) - -defaultApplicationDir :: String -defaultApplicationDir = "app" - -defaultSourceDir :: String -defaultSourceDir = "src" - -defaultCabalVersion :: CabalSpecVersion -defaultCabalVersion = CabalSpecV2_4 - -myLibModule :: ModuleName -myLibModule = ModuleName.fromString "MyLib" diff --git a/Distribution/Client/Init/FileCreators.hs b/Distribution/Client/Init/FileCreators.hs deleted file mode 100644 --- a/Distribution/Client/Init/FileCreators.hs +++ /dev/null @@ -1,650 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.FileCreators --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Functions to create files during 'cabal init'. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.FileCreators ( - - -- * Commands - writeLicense - , writeChangeLog - , createDirectories - , createLibHs - , createMainHs - , createTestSuiteIfEligible - , writeCabalFile - - -- * For testing - , generateCabalFile - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) - -import System.FilePath - ( (), (<.>), takeExtension ) - -import Distribution.Types.Dependency -import Distribution.Types.VersionRange - -import Data.Time - ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) -import System.Directory - ( getCurrentDirectory, doesFileExist, copyFile - , createDirectoryIfMissing ) - -import Text.PrettyPrint hiding ((<>), mode, cat) - -import Distribution.Client.Init.Defaults - ( defaultCabalVersion, myLibModule ) -import Distribution.Client.Init.Licenses - ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) -import Distribution.Client.Init.Utils - ( eligibleForTestSuite, message ) -import Distribution.Client.Init.Types - ( InitFlags(..), BuildType(..), PackageType(..) ) - -import Distribution.CabalSpecVersion -import Distribution.Compat.Newtype - ( Newtype ) -import Distribution.Fields.Field - ( FieldName ) -import Distribution.License - ( licenseFromSPDX ) -import qualified Distribution.ModuleName as ModuleName - ( toFilePath ) -import Distribution.FieldGrammar.Newtypes - ( SpecVersion(..) ) -import Distribution.PackageDescription.FieldGrammar - ( formatDependencyList, formatExposedModules, formatHsSourceDirs, - formatOtherExtensions, formatOtherModules, formatExtraSourceFiles ) -import Distribution.Simple.Flag - ( maybeToFlag ) -import Distribution.Simple.Setup - ( Flag(..), flagToMaybe ) -import Distribution.Simple.Utils - ( toUTF8BS ) -import Distribution.Fields.Pretty - ( PrettyField(..), showFields' ) - -import qualified Distribution.SPDX as SPDX - - ---------------------------------------------------------------------------- --- File generation ------------------------------------------------------ ---------------------------------------------------------------------------- - --- | Write the LICENSE file, as specified in the InitFlags license field. --- --- For licences that contain the author's name(s), the values are taken --- from the 'authors' field of 'InitFlags', and if not specified will --- be the string "???". --- --- If the license type is unknown no license file will be created and --- a warning will be raised. -writeLicense :: InitFlags -> IO () -writeLicense flags = do - message flags "\nGenerating LICENSE..." - year <- show <$> getCurrentYear - let authors = fromMaybe "???" . flagToMaybe . author $ flags - let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId - isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid - isSimpleLicense _ = Nothing - let licenseFile = - case flagToMaybe (license flags) >>= isSimpleLicense of - Just SPDX.BSD_2_Clause -> Just $ bsd2 authors year - Just SPDX.BSD_3_Clause -> Just $ bsd3 authors year - Just SPDX.Apache_2_0 -> Just apache20 - Just SPDX.MIT -> Just $ mit authors year - Just SPDX.MPL_2_0 -> Just mpl20 - Just SPDX.ISC -> Just $ isc authors year - - -- GNU license come in "only" and "or-later" flavours - -- license file used are the same. - Just SPDX.GPL_2_0_only -> Just gplv2 - Just SPDX.GPL_3_0_only -> Just gplv3 - Just SPDX.LGPL_2_1_only -> Just lgpl21 - Just SPDX.LGPL_3_0_only -> Just lgpl3 - Just SPDX.AGPL_3_0_only -> Just agplv3 - - Just SPDX.GPL_2_0_or_later -> Just gplv2 - Just SPDX.GPL_3_0_or_later -> Just gplv3 - Just SPDX.LGPL_2_1_or_later -> Just lgpl21 - Just SPDX.LGPL_3_0_or_later -> Just lgpl3 - Just SPDX.AGPL_3_0_or_later -> Just agplv3 - - _ -> Nothing - - case licenseFile of - Just licenseText -> writeFileSafe flags "LICENSE" licenseText - Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." - --- | Returns the current calendar year. -getCurrentYear :: IO Integer -getCurrentYear = do - u <- getCurrentTime - z <- getCurrentTimeZone - let l = utcToLocalTime z u - (y, _, _) = toGregorian $ localDay l - return y - -defaultChangeLog :: FilePath -defaultChangeLog = "CHANGELOG.md" - --- | Writes the changelog to the current directory. -writeChangeLog :: InitFlags -> IO () -writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do - message flags ("Generating "++ defaultChangeLog ++"...") - writeFileSafe flags defaultChangeLog changeLog - where - changeLog = unlines - [ "# Revision history for " ++ pname - , "" - , "## " ++ pver ++ " -- YYYY-mm-dd" - , "" - , "* First version. Released on an unsuspecting world." - ] - pname = maybe "" prettyShow $ flagToMaybe $ packageName flags - pver = maybe "" prettyShow $ flagToMaybe $ version flags - --- | Creates and writes the initialized .cabal file. --- --- Returns @False@ if no package name is specified, @True@ otherwise. -writeCabalFile :: InitFlags -> IO Bool -writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do - message flags "Error: no package name provided." - return False -writeCabalFile flags@(InitFlags{packageName = Flag p}) = do - let cabalFileName = prettyShow p ++ ".cabal" - message flags $ "Generating " ++ cabalFileName ++ "..." - writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags) - return True - --- | Write a file \"safely\", backing up any existing version (unless --- the overwrite flag is set). -writeFileSafe :: InitFlags -> FilePath -> String -> IO () -writeFileSafe flags fileName content = do - moveExistingFile flags fileName - writeFile fileName content - --- | Create directories, if they were given, and don't already exist. -createDirectories :: Maybe [String] -> IO () -createDirectories mdirs = case mdirs of - Just dirs -> for_ dirs (createDirectoryIfMissing True) - Nothing -> return () - --- | Create MyLib.hs file, if its the only module in the liste. -createLibHs :: InitFlags -> IO () -createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do - let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs" - case sourceDirs flags of - Just (srcPath:_) -> writeLibHs flags (srcPath modFilePath) - _ -> writeLibHs flags modFilePath - --- | Write a MyLib.hs file if it doesn't already exist. -writeLibHs :: InitFlags -> FilePath -> IO () -writeLibHs flags libPath = do - dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - let libFullPath = dir libPath - exists <- doesFileExist libFullPath - unless exists $ do - message flags $ "Generating " ++ libPath ++ "..." - writeFileSafe flags libFullPath myLibHs - --- | Default MyLib.hs file. Used when no Lib.hs exists. -myLibHs :: String -myLibHs = unlines - [ "module MyLib (someFunc) where" - , "" - , "someFunc :: IO ()" - , "someFunc = putStrLn \"someFunc\"" - ] - --- | Create Main.hs, but only if we are init'ing an executable and --- the mainIs flag has been provided. -createMainHs :: InitFlags -> IO () -createMainHs flags = - if hasMainHs flags then - case applicationDirs flags of - Just (appPath:_) -> writeMainHs flags (appPath mainFile) - _ -> writeMainHs flags mainFile - else return () - where - mainFile = case mainIs flags of - Flag x -> x - NoFlag -> error "createMainHs: no mainIs" - --- | Write a main file if it doesn't already exist. -writeMainHs :: InitFlags -> FilePath -> IO () -writeMainHs flags mainPath = do - dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - let mainFullPath = dir mainPath - exists <- doesFileExist mainFullPath - unless exists $ do - message flags $ "Generating " ++ mainPath ++ "..." - writeFileSafe flags mainFullPath (mainHs flags) - --- | Returns true if a main file exists. -hasMainHs :: InitFlags -> Bool -hasMainHs flags = case mainIs flags of - Flag _ -> (packageType flags == Flag Executable - || packageType flags == Flag LibraryAndExecutable) - _ -> False - --- | Default Main.(l)hs file. Used when no Main.(l)hs exists. --- --- If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'. -mainHs :: InitFlags -> String -mainHs flags = (unlines . map prependPrefix) $ case packageType flags of - Flag LibraryAndExecutable -> - [ "module Main where" - , "" - , "import qualified MyLib (someFunc)" - , "" - , "main :: IO ()" - , "main = do" - , " putStrLn \"Hello, Haskell!\"" - , " MyLib.someFunc" - ] - _ -> - [ "module Main where" - , "" - , "main :: IO ()" - , "main = putStrLn \"Hello, Haskell!\"" - ] - where - prependPrefix :: String -> String - prependPrefix "" = "" - prependPrefix line - | isLiterate = "> " ++ line - | otherwise = line - isLiterate = case mainIs flags of - Flag mainPath -> takeExtension mainPath == ".lhs" - _ -> False - --- | Create a test suite for the package if eligible. -createTestSuiteIfEligible :: InitFlags -> IO () -createTestSuiteIfEligible flags = - when (eligibleForTestSuite flags) $ do - createDirectories (testDirs flags) - createTestHs flags - --- | The name of the test file to generate (if --tests is specified). -testFile :: String -testFile = "MyLibTest.hs" - --- | Create MyLibTest.hs, but only if we are init'ing a library and --- the initializeTestSuite flag has been set. --- --- It is up to the caller to verify that the package is eligible --- for test suite initialization (see eligibleForTestSuite). -createTestHs :: InitFlags -> IO () -createTestHs flags = - case testDirs flags of - Just (testPath:_) -> writeTestHs flags (testPath testFile) - _ -> writeMainHs flags testFile - --- | Write a test file. -writeTestHs :: InitFlags -> FilePath -> IO () -writeTestHs flags testPath = do - dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - let testFullPath = dir testPath - exists <- doesFileExist testFullPath - unless exists $ do - message flags $ "Generating " ++ testPath ++ "..." - writeFileSafe flags testFullPath testHs - --- | Default MyLibTest.hs file. -testHs :: String -testHs = unlines - [ "module Main (main) where" - , "" - , "main :: IO ()" - , "main = putStrLn \"Test suite not yet implemented.\"" - ] - - --- | Move an existing file, if there is one, and the overwrite flag is --- not set. -moveExistingFile :: InitFlags -> FilePath -> IO () -moveExistingFile flags fileName = - unless (overwrite flags == Flag True) $ do - e <- doesFileExist fileName - when e $ do - newName <- findNewName fileName - message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName - copyFile fileName newName - - --- | Given a file path find a new name for the file that does not --- already exist. -findNewName :: FilePath -> IO FilePath -findNewName oldName = findNewName' 0 - where - findNewName' :: Integer -> IO FilePath - findNewName' n = do - let newName = oldName <.> ("save" ++ show n) - e <- doesFileExist newName - if e then findNewName' (n+1) else return newName - - --- | Generate a .cabal file from an InitFlags structure. -generateCabalFile :: String -> InitFlags -> String -generateCabalFile fileName c = - showFields' annCommentLines postProcessFieldLines 4 $ catMaybes - [ fieldP "cabal-version" (Flag . SpecVersion $ specVer) - [] - False - - , field "name" (packageName c) - ["Initial package description '" ++ fileName ++ "' generated by", - "'cabal init'. For further documentation, see:", - " http://haskell.org/cabal/users-guide/", - "", - "The name of the package."] - True - - , field "version" (version c) - ["The package version.", - "See the Haskell package versioning policy (PVP) for standards", - "guiding when and how versions should be incremented.", - "https://pvp.haskell.org", - "PVP summary: +-+------- breaking API changes", - " | | +----- non-breaking API additions", - " | | | +--- code changes with no API change"] - True - - , fieldS "synopsis" (synopsis c) - ["A short (one-line) description of the package."] - True - - , fieldS "description" NoFlag - ["A longer description of the package."] - True - - , fieldS "homepage" (homepage c) - ["URL for the project homepage or repository."] - False - - , fieldS "bug-reports" NoFlag - ["A URL where users can report bugs."] - True - - , fieldS "license" licenseStr - ["The license under which the package is released."] - True - - , case license c of - NoFlag -> Nothing - Flag SPDX.NONE -> Nothing - _ -> fieldS "license-file" (Flag "LICENSE") - ["The file containing the license text."] - True - - , fieldS "author" (author c) - ["The package author(s)."] - True - - , fieldS "maintainer" (email c) - ["An email address to which users can send suggestions, bug reports, and patches."] - True - - , fieldS "copyright" NoFlag - ["A copyright notice."] - True - - , fieldS "category" (either id prettyShow `fmap` category c) - [] - True - - , fieldS "build-type" (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple") - [] - False - - , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c)) - ["Extra files to be distributed with the package, such as examples or a README."] - True - ] - ++ - (case packageType c of - Flag Executable -> [executableStanza] - Flag Library -> [libraryStanza] - Flag LibraryAndExecutable -> [libraryStanza, executableStanza] - _ -> []) - ++ - if eligibleForTestSuite c then [testSuiteStanza] else [] - - where - specVer :: CabalSpecVersion - specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c) - - licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c - | otherwise = prettyShow <$> license c - - generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation] - generateBuildInfo buildType c' = catMaybes - [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods) - [ case buildType of - LibBuild -> "Modules included in this library but not exported." - ExecBuild -> "Modules included in this executable, other than Main."] - True - - , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c)) - ["LANGUAGE extensions used by modules in this package."] - True - - , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies) - ["Other library packages from which modules are imported."] - True - - , fieldPAla "hs-source-dirs" formatHsSourceDirs - (maybeToFlag (case buildType of - LibBuild -> sourceDirs c - ExecBuild -> applicationDirs c)) - ["Directories containing source files."] - True - - , fieldS "build-tools" (listFieldS $ buildTools c) - ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] - False - - , field "default-language" (language c) - ["Base language which the package is written in."] - True - ] - -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?). - where - buildDependencies :: Maybe [Dependency] - buildDependencies = (++ myLibDep) <$> dependencies c' - - myLibDep :: [Dependency] - myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild - then case packageName c' of - Flag pkgName -> - [mkDependency pkgName anyVersion mainLibSet] - _ -> [] - else [] - - -- Only include 'MyLib' in 'other-modules' of the executable. - otherModsFromFlag = otherModules c' - otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule] - then Nothing - else otherModsFromFlag - - listFieldS :: Maybe [String] -> Flag String - listFieldS Nothing = NoFlag - listFieldS (Just []) = NoFlag - listFieldS (Just xs) = Flag . intercalate ", " $ xs - - -- | Construct a 'PrettyField' from a field that can be automatically - -- converted to a 'Doc' via 'display'. - field :: Pretty t - => FieldName - -> Flag t - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag) - - -- | Construct a 'PrettyField' from a 'String' field. - fieldS :: FieldName -- ^ Name of the field - -> Flag String -- ^ Field contents - -> [String] -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> Maybe (PrettyField FieldAnnotation) - fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag) - - -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied. - fieldP :: Pretty a - => FieldName - -> Flag a - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldP fieldName fieldContentsFlag fieldComments includeField = - fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField - - -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper. - fieldPAla - :: (Pretty b, Newtype a b) - => FieldName - -> (a -> b) - -> Flag a - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField = - fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField - - -- | Construct a 'PrettyField' from a 'Doc' Flag. - fieldD :: FieldName -- ^ Name of the field - -> Flag Doc -- ^ Field contents - -> [String] -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> Maybe (PrettyField FieldAnnotation) - fieldD fieldName fieldContentsFlag fieldComments includeField = - case fieldContentsFlag of - NoFlag -> - -- If there is no content, optionally produce a commented out field. - fieldSEmptyContents fieldName fieldComments includeField - - Flag fieldContents -> - if isEmpty fieldContents - then - -- If the doc is empty, optionally produce a commented out field. - fieldSEmptyContents fieldName fieldComments includeField - else - -- If the doc is not empty, produce a field. - Just $ case (noComments c, minimal c) of - -- If the "--no-comments" flag is set, strip comments. - (Flag True, _) -> - fieldSWithContents fieldName fieldContents [] - -- If the "--minimal" flag is set, strip comments. - (_, Flag True) -> - fieldSWithContents fieldName fieldContents [] - -- Otherwise, include comments. - (_, _) -> - fieldSWithContents fieldName fieldContents fieldComments - - -- | Optionally produce a field with no content (depending on flags). - fieldSEmptyContents :: FieldName - -> [String] - -> Bool - -> Maybe (PrettyField FieldAnnotation) - fieldSEmptyContents fieldName fieldComments includeField - | not includeField || (minimal c == Flag True) = - Nothing - | otherwise = - Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty) - - -- | Produce a field with content. - fieldSWithContents :: FieldName - -> Doc - -> [String] - -> PrettyField FieldAnnotation - fieldSWithContents fieldName fieldContents fieldComments = - PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents - - executableStanza :: PrettyField FieldAnnotation - executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes - [ fieldS "main-is" (mainIs c) - [".hs or .lhs file containing the Main module."] - True - ] - ++ - generateBuildInfo ExecBuild c - where - exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c) - - libraryStanza :: PrettyField FieldAnnotation - libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes - [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c)) - ["Modules exported by the library."] - True - ] - ++ - generateBuildInfo LibBuild c - - - testSuiteStanza :: PrettyField FieldAnnotation - testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes - [ field "default-language" (language c) - ["Base language which the package is written in."] - True - - , fieldS "type" (Flag "exitcode-stdio-1.0") - ["The interface type and version of the test suite."] - True - - , fieldPAla "hs-source-dirs" formatHsSourceDirs - (maybeToFlag (testDirs c)) - ["Directories containing source files."] - True - - , fieldS "main-is" (Flag testFile) - ["The entrypoint to the test suite."] - True - - , fieldPAla "build-depends" formatDependencyList (maybeToFlag (dependencies c)) - ["Test dependencies."] - True - ] - where - testSuiteName = - text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c) - --- | Annotations for cabal file PrettyField. -data FieldAnnotation = FieldAnnotation - { annCommentedOut :: Bool - -- ^ True iif the field and its contents should be commented out. - , annCommentLines :: [String] - -- ^ Comment lines to place before the field or section. - } - --- | A field annotation instructing the pretty printer to comment out the field --- and any contents, with no comments. -commentedOutWithComments :: [String] -> FieldAnnotation -commentedOutWithComments = FieldAnnotation True . map ("-- " ++) - --- | A field annotation with the specified comment lines. -withComments :: [String] -> FieldAnnotation -withComments = FieldAnnotation False - --- | A field annotation with no comments. -annNoComments :: FieldAnnotation -annNoComments = FieldAnnotation False [] - -postProcessFieldLines :: FieldAnnotation -> [String] -> [String] -postProcessFieldLines ann - | annCommentedOut ann = map ("-- " ++) - | otherwise = id diff --git a/Distribution/Client/Init/Heuristics.hs b/Distribution/Client/Init/Heuristics.hs deleted file mode 100644 --- a/Distribution/Client/Init/Heuristics.hs +++ /dev/null @@ -1,392 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Heuristics --- Copyright : (c) Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Heuristics for creating initial cabal files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Heuristics ( - guessPackageName, - scanForModules, SourceFileEntry(..), - neededBuildPrograms, - guessMainFileCandidates, - guessAuthorNameMail, - knownCategories, -) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic (safeHead, safeTail, safeLast) - -import Distribution.Simple.Setup (Flag(..), flagToMaybe) -import Distribution.ModuleName - ( ModuleName, toFilePath ) -import qualified Distribution.Package as P -import qualified Distribution.PackageDescription as PD - ( category, packageDescription ) -import Distribution.Client.Utils - ( tryCanonicalizePath ) -import Language.Haskell.Extension ( Extension ) - -import Distribution.Solver.Types.PackageIndex - ( allPackagesByName ) -import Distribution.Solver.Types.SourcePackage - ( srcpkgDescription ) - -import Distribution.Client.Types ( SourcePackageDb(..) ) -import Data.Char ( isLower ) -import Data.List ( isInfixOf ) -import qualified Data.Set as Set ( fromList, toList ) -import System.Directory ( getCurrentDirectory, getDirectoryContents, - doesDirectoryExist, doesFileExist, getHomeDirectory, ) -import Distribution.Compat.Environment ( getEnvironment ) -import System.FilePath ( takeExtension, takeBaseName, dropExtension, - (), (<.>), splitDirectories, makeRelative ) - -import Distribution.Client.Init.Types ( InitFlags(..) ) -import Distribution.Client.Compat.Process ( readProcessWithExitCode ) - -import qualified Distribution.Utils.ShortText as ShortText - --- | Return a list of candidate main files for this executable: top-level --- modules including the word 'Main' in the file name. The list is sorted in --- order of preference, shorter file names are preferred. 'Right's are existing --- candidates and 'Left's are those that do not yet exist. -guessMainFileCandidates :: InitFlags -> IO [Either FilePath FilePath] -guessMainFileCandidates flags = do - dir <- - maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) - files <- getDirectoryContents dir - let existingCandidates = filter isMain files - -- We always want to give the user at least one default choice. If either - -- Main.hs or Main.lhs has already been created, then we don't want to - -- suggest the other; however, if neither has been created, then we - -- suggest both. - newCandidates = - if any (`elem` existingCandidates) ["Main.hs", "Main.lhs"] - then [] - else ["Main.hs", "Main.lhs"] - candidates = - sortBy (\x y -> comparing (length . either id id) x y - `mappend` compare x y) - (map Left newCandidates ++ map Right existingCandidates) - return candidates - - where - isMain f = (isInfixOf "Main" f || isInfixOf "main" f) - && (isSuffixOf ".hs" f || isSuffixOf ".lhs" f) - --- | Guess the package name based on the given root directory. -guessPackageName :: FilePath -> IO P.PackageName -guessPackageName = liftM (P.mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) - . tryCanonicalizePath - where - -- Treat each span of non-alphanumeric characters as a hyphen. Each - -- hyphenated component of a package name must contain at least one - -- alphabetic character. An arbitrary character ('x') will be prepended if - -- this is not the case for the first component, and subsequent components - -- will simply be run together. For example, "1+2_foo-3" will become - -- "x12-foo3". - repair = repair' ('x' :) id - repair' invalid valid x = case dropWhile (not . isAlphaNum) x of - "" -> repairComponent "" - x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x' - in c ++ repairRest r - where - repairComponent c | all isDigit c = invalid c - | otherwise = valid c - repairRest = repair' id ('-' :) - --- |Data type of source files found in the working directory -data SourceFileEntry = SourceFileEntry - { relativeSourcePath :: FilePath - , moduleName :: ModuleName - , fileExtension :: String - , imports :: [ModuleName] - , extensions :: [Extension] - } deriving Show - -sfToFileName :: FilePath -> SourceFileEntry -> FilePath -sfToFileName projectRoot (SourceFileEntry relPath m ext _ _) - = projectRoot relPath toFilePath m <.> ext - --- |Search for source files in the given directory --- and return pairs of guessed Haskell source path and --- module names. -scanForModules :: FilePath -> IO [SourceFileEntry] -scanForModules rootDir = scanForModulesIn rootDir rootDir - -scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] -scanForModulesIn projectRoot srcRoot = scan srcRoot [] - where - scan dir hierarchy = do - entries <- getDirectoryContents (projectRoot dir) - (files, dirs) <- liftM partitionEithers (traverse (tagIsDir dir) entries) - let modules = catMaybes [ guessModuleName hierarchy file - | file <- files - , maybe False isUpper (safeHead file) ] - modules' <- traverse (findImportsAndExts projectRoot) modules - recMods <- traverse (scanRecursive dir hierarchy) dirs - return $ concat (modules' : recMods) - tagIsDir parent entry = do - isDir <- doesDirectoryExist (parent entry) - return $ (if isDir then Right else Left) entry - guessModuleName hierarchy entry - | takeBaseName entry == "Setup" = Nothing - | ext `elem` sourceExtensions = - SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure [] - | otherwise = Nothing - where - relRoot = makeRelative projectRoot srcRoot - unqualModName = dropExtension entry - modName = simpleParsec - $ intercalate "." . reverse $ (unqualModName : hierarchy) - ext = case takeExtension entry of '.':e -> e; e -> e - scanRecursive parent hierarchy entry - | maybe False isUpper (safeHead entry) = scan (parent entry) (entry : hierarchy) - | maybe False isLower (safeHead entry) && not (ignoreDir entry) = - scanForModulesIn projectRoot $ foldl () srcRoot (reverse (entry : hierarchy)) - | otherwise = return [] - ignoreDir ('.':_) = True - ignoreDir dir = dir `elem` ["dist", "_darcs"] - -findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry -findImportsAndExts projectRoot sf = do - s <- readFile (sfToFileName projectRoot sf) - - let modules = mapMaybe - ( getModName - . drop 1 - . filter (not . null) - . dropWhile (/= "import") - . words - ) - . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering - . lines - $ s - - -- TODO: We should probably make a better attempt at parsing - -- comments above. Unfortunately we can't use a full-fledged - -- Haskell parser since cabal's dependencies must be kept at a - -- minimum. - - -- A poor man's LANGUAGE pragma parser. - exts = mapMaybe simpleParsec - . concatMap getPragmas - . filter isLANGUAGEPragma - . map fst - . drop 1 - . takeWhile (not . null . snd) - . iterate (takeBraces . snd) - $ ("",s) - - takeBraces = break (== '}') . dropWhile (/= '{') - - isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`) - - getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13 - - splitCommas "" = [] - splitCommas xs = x : splitCommas (drop 1 y) - where (x,y) = break (==',') xs - - return sf { imports = modules - , extensions = exts - } - - where getModName :: [String] -> Maybe ModuleName - getModName [] = Nothing - getModName ("qualified":ws) = getModName ws - getModName (ms:_) = simpleParsec ms - - - --- Unfortunately we cannot use the version exported by Distribution.Simple.Program -knownSuffixHandlers :: [(String,String)] -knownSuffixHandlers = - [ ("gc", "greencard") - , ("chs", "chs") - , ("hsc", "hsc2hs") - , ("x", "alex") - , ("y", "happy") - , ("ly", "happy") - , ("cpphs", "cpp") - ] - -sourceExtensions :: [String] -sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers - -neededBuildPrograms :: [SourceFileEntry] -> [String] -neededBuildPrograms entries = - [ handler - | ext <- nubSet (map fileExtension entries) - , handler <- maybeToList (lookup ext knownSuffixHandlers) - ] - --- | Guess author and email using darcs and git configuration options. Use --- the following in decreasing order of preference: --- --- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*) --- 2. Local repo configs --- 3. Global vcs configs --- 4. The generic $EMAIL --- --- Name and email are processed separately, so the guess might end up being --- a name from DARCS_EMAIL and an email from git config. --- --- Darcs has preference, for tradition's sake. -guessAuthorNameMail :: IO (Flag String, Flag String) -guessAuthorNameMail = fmap authorGuessPure authorGuessIO - --- Ordered in increasing preference, since Flag-as-monoid is identical to --- Last. -authorGuessPure :: AuthorGuessIO -> AuthorGuess -authorGuessPure (AuthorGuessIO { authorGuessEnv = env - , authorGuessLocalDarcs = darcsLocalF - , authorGuessGlobalDarcs = darcsGlobalF - , authorGuessLocalGit = gitLocal - , authorGuessGlobalGit = gitGlobal }) - = mconcat - [ emailEnv env - , gitGlobal - , darcsCfg darcsGlobalF - , gitLocal - , darcsCfg darcsLocalF - , gitEnv env - , darcsEnv env - ] - -authorGuessIO :: IO AuthorGuessIO -authorGuessIO = AuthorGuessIO - <$> getEnvironment - <*> (maybeReadFile $ "_darcs" "prefs" "author") - <*> (maybeReadFile =<< liftM ( (".darcs" "author")) getHomeDirectory) - <*> gitCfg Local - <*> gitCfg Global - --- Types and functions used for guessing the author are now defined: - -type AuthorGuess = (Flag String, Flag String) -type Enviro = [(String, String)] -data GitLoc = Local | Global -data AuthorGuessIO = AuthorGuessIO { - authorGuessEnv :: Enviro, -- ^ Environment lookup table - authorGuessLocalDarcs :: (Maybe String), -- ^ Contents of local darcs author info - authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info - authorGuessLocalGit :: AuthorGuess, -- ^ Git config --local - authorGuessGlobalGit :: AuthorGuess -- ^ Git config --global - } - -darcsEnv :: Enviro -> AuthorGuess -darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL" - -gitEnv :: Enviro -> AuthorGuess -gitEnv env = (name, mail) - where - name = maybeFlag "GIT_AUTHOR_NAME" env - mail = maybeFlag "GIT_AUTHOR_EMAIL" env - -darcsCfg :: Maybe String -> AuthorGuess -darcsCfg = maybe mempty nameAndMail - -emailEnv :: Enviro -> AuthorGuess -emailEnv env = (mempty, mail) - where - mail = maybeFlag "EMAIL" env - -gitCfg :: GitLoc -> IO AuthorGuess -gitCfg which = do - name <- gitVar which "user.name" - mail <- gitVar which "user.email" - return (name, mail) - -gitVar :: GitLoc -> String -> IO (Flag String) -gitVar which = fmap happyOutput . gitConfigQuery which - -happyOutput :: (ExitCode, a, t) -> Flag a -happyOutput v = case v of - (ExitSuccess, s, _) -> Flag s - _ -> mempty - -gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String) -gitConfigQuery which key = - fmap trim' $ readProcessWithExitCode "git" ["config", w, key] "" - where - w = case which of - Local -> "--local" - Global -> "--global" - trim' (a, b, c) = (a, trim b, c) - -maybeFlag :: String -> Enviro -> Flag String -maybeFlag k = maybe mempty Flag . lookup k - --- | Read the first non-comment, non-trivial line of a file, if it exists -maybeReadFile :: String -> IO (Maybe String) -maybeReadFile f = do - exists <- doesFileExist f - if exists - then fmap getFirstLine $ readFile f - else return Nothing - where - getFirstLine content = - let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content - in case nontrivialLines of - [] -> Nothing - (l:_) -> Just l - --- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached -knownCategories :: SourcePackageDb -> [String] -knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet - [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex) - , let catList = (PD.category . PD.packageDescription . srcpkgDescription) pkg - , cat <- splitString ',' $ ShortText.fromShortText catList - ] - --- Parse name and email, from darcs pref files or environment variable -nameAndMail :: String -> (Flag String, Flag String) -nameAndMail str - | all isSpace nameOrEmail = mempty - | null erest = (mempty, Flag $ trim nameOrEmail) - | otherwise = (Flag $ trim nameOrEmail, Flag mail) - where - (nameOrEmail,erest) = break (== '<') str - (mail,_) = break (== '>') (safeTail erest) - -trim :: String -> String -trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse - where - removeLeadingSpace = dropWhile isSpace - --- split string at given character, and remove whitespace -splitString :: Char -> String -> [String] -splitString sep str = go str where - go s = if null s' then [] else tok : go rest where - s' = dropWhile (\c -> c == sep || isSpace c) s - (tok,rest) = break (==sep) s' - -nubSet :: (Ord a) => [a] -> [a] -nubSet = Set.toList . Set.fromList - -{- -test db testProjectRoot = do - putStrLn "Guessed package name" - (guessPackageName >=> print) testProjectRoot - putStrLn "Guessed name and email" - guessAuthorNameMail >>= print - - mods <- scanForModules testProjectRoot - - putStrLn "Guessed modules" - mapM_ print mods - putStrLn "Needed build programs" - print (neededBuildPrograms mods) - - putStrLn "List of known categories" - print $ knownCategories db --} diff --git a/Distribution/Client/Init/Licenses.hs b/Distribution/Client/Init/Licenses.hs deleted file mode 100644 --- a/Distribution/Client/Init/Licenses.hs +++ /dev/null @@ -1,3077 +0,0 @@ -{-| -Module : Distribution.Client.Init.Licenses - -Description : Factory functions for producing known license types. - -License : BSD-like -Maintainer : cabal-devel@haskell.org -Stability : provisional -Portability : portable --} -module Distribution.Client.Init.Licenses - ( License - , bsd2 - , bsd3 - , gplv2 - , gplv3 - , lgpl21 - , lgpl3 - , agplv3 - , apache20 - , mit - , mpl20 - , isc - ) where - -import Prelude (String, unlines, (++)) - -type License = String - -bsd2 :: String -> String -> License -bsd2 authors year = unlines - [ "Copyright (c) " ++ year ++ ", " ++ authors - , "All rights reserved." - , "" - , "Redistribution and use in source and binary forms, with or without" - , "modification, are permitted provided that the following conditions are" - , "met:" - , "" - , "1. Redistributions of source code must retain the above copyright" - , " notice, this list of conditions and the following disclaimer." - , "" - , "2. Redistributions in binary form must reproduce the above copyright" - , " notice, this list of conditions and the following disclaimer in the" - , " documentation and/or other materials provided with the" - , " distribution." - , "" - , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" - , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" - , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" - , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" - , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," - , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" - , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," - , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" - , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" - , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" - , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." - ] - -bsd3 :: String -> String -> License -bsd3 authors year = unlines - [ "Copyright (c) " ++ year ++ ", " ++ authors - , "" - , "All rights reserved." - , "" - , "Redistribution and use in source and binary forms, with or without" - , "modification, are permitted provided that the following conditions are met:" - , "" - , " * Redistributions of source code must retain the above copyright" - , " notice, this list of conditions and the following disclaimer." - , "" - , " * Redistributions in binary form must reproduce the above" - , " copyright notice, this list of conditions and the following" - , " disclaimer in the documentation and/or other materials provided" - , " with the distribution." - , "" - , " * Neither the name of " ++ authors ++ " nor the names of other" - , " contributors may be used to endorse or promote products derived" - , " from this software without specific prior written permission." - , "" - , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" - , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" - , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" - , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" - , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," - , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" - , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," - , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" - , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" - , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" - , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." - ] - -gplv2 :: License -gplv2 = unlines - [ " GNU GENERAL PUBLIC LICENSE" - , " Version 2, June 1991" - , "" - , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The licenses for most software are designed to take away your" - , "freedom to share and change it. By contrast, the GNU General Public" - , "License is intended to guarantee your freedom to share and change free" - , "software--to make sure the software is free for all its users. This" - , "General Public License applies to most of the Free Software" - , "Foundation's software and to any other program whose authors commit to" - , "using it. (Some other Free Software Foundation software is covered by" - , "the GNU Lesser General Public License instead.) You can apply it to" - , "your programs, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "this service if you wish), that you receive source code or can get it" - , "if you want it, that you can change the software or use pieces of it" - , "in new free programs; and that you know you can do these things." - , "" - , " To protect your rights, we need to make restrictions that forbid" - , "anyone to deny you these rights or to ask you to surrender the rights." - , "These restrictions translate to certain responsibilities for you if you" - , "distribute copies of the software, or if you modify it." - , "" - , " For example, if you distribute copies of such a program, whether" - , "gratis or for a fee, you must give the recipients all the rights that" - , "you have. You must make sure that they, too, receive or can get the" - , "source code. And you must show them these terms so they know their" - , "rights." - , "" - , " We protect your rights with two steps: (1) copyright the software, and" - , "(2) offer you this license which gives you legal permission to copy," - , "distribute and/or modify the software." - , "" - , " Also, for each author's protection and ours, we want to make certain" - , "that everyone understands that there is no warranty for this free" - , "software. If the software is modified by someone else and passed on, we" - , "want its recipients to know that what they have is not the original, so" - , "that any problems introduced by others will not reflect on the original" - , "authors' reputations." - , "" - , " Finally, any free program is threatened constantly by software" - , "patents. We wish to avoid the danger that redistributors of a free" - , "program will individually obtain patent licenses, in effect making the" - , "program proprietary. To prevent this, we have made it clear that any" - , "patent must be licensed for everyone's free use or not licensed at all." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " GNU GENERAL PUBLIC LICENSE" - , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" - , "" - , " 0. This License applies to any program or other work which contains" - , "a notice placed by the copyright holder saying it may be distributed" - , "under the terms of this General Public License. The \"Program\", below," - , "refers to any such program or work, and a \"work based on the Program\"" - , "means either the Program or any derivative work under copyright law:" - , "that is to say, a work containing the Program or a portion of it," - , "either verbatim or with modifications and/or translated into another" - , "language. (Hereinafter, translation is included without limitation in" - , "the term \"modification\".) Each licensee is addressed as \"you\"." - , "" - , "Activities other than copying, distribution and modification are not" - , "covered by this License; they are outside its scope. The act of" - , "running the Program is not restricted, and the output from the Program" - , "is covered only if its contents constitute a work based on the" - , "Program (independent of having been made by running the Program)." - , "Whether that is true depends on what the Program does." - , "" - , " 1. You may copy and distribute verbatim copies of the Program's" - , "source code as you receive it, in any medium, provided that you" - , "conspicuously and appropriately publish on each copy an appropriate" - , "copyright notice and disclaimer of warranty; keep intact all the" - , "notices that refer to this License and to the absence of any warranty;" - , "and give any other recipients of the Program a copy of this License" - , "along with the Program." - , "" - , "You may charge a fee for the physical act of transferring a copy, and" - , "you may at your option offer warranty protection in exchange for a fee." - , "" - , " 2. You may modify your copy or copies of the Program or any portion" - , "of it, thus forming a work based on the Program, and copy and" - , "distribute such modifications or work under the terms of Section 1" - , "above, provided that you also meet all of these conditions:" - , "" - , " a) You must cause the modified files to carry prominent notices" - , " stating that you changed the files and the date of any change." - , "" - , " b) You must cause any work that you distribute or publish, that in" - , " whole or in part contains or is derived from the Program or any" - , " part thereof, to be licensed as a whole at no charge to all third" - , " parties under the terms of this License." - , "" - , " c) If the modified program normally reads commands interactively" - , " when run, you must cause it, when started running for such" - , " interactive use in the most ordinary way, to print or display an" - , " announcement including an appropriate copyright notice and a" - , " notice that there is no warranty (or else, saying that you provide" - , " a warranty) and that users may redistribute the program under" - , " these conditions, and telling the user how to view a copy of this" - , " License. (Exception: if the Program itself is interactive but" - , " does not normally print such an announcement, your work based on" - , " the Program is not required to print an announcement.)" - , "" - , "These requirements apply to the modified work as a whole. If" - , "identifiable sections of that work are not derived from the Program," - , "and can be reasonably considered independent and separate works in" - , "themselves, then this License, and its terms, do not apply to those" - , "sections when you distribute them as separate works. But when you" - , "distribute the same sections as part of a whole which is a work based" - , "on the Program, the distribution of the whole must be on the terms of" - , "this License, whose permissions for other licensees extend to the" - , "entire whole, and thus to each and every part regardless of who wrote it." - , "" - , "Thus, it is not the intent of this section to claim rights or contest" - , "your rights to work written entirely by you; rather, the intent is to" - , "exercise the right to control the distribution of derivative or" - , "collective works based on the Program." - , "" - , "In addition, mere aggregation of another work not based on the Program" - , "with the Program (or with a work based on the Program) on a volume of" - , "a storage or distribution medium does not bring the other work under" - , "the scope of this License." - , "" - , " 3. You may copy and distribute the Program (or a work based on it," - , "under Section 2) in object code or executable form under the terms of" - , "Sections 1 and 2 above provided that you also do one of the following:" - , "" - , " a) Accompany it with the complete corresponding machine-readable" - , " source code, which must be distributed under the terms of Sections" - , " 1 and 2 above on a medium customarily used for software interchange; or," - , "" - , " b) Accompany it with a written offer, valid for at least three" - , " years, to give any third party, for a charge no more than your" - , " cost of physically performing source distribution, a complete" - , " machine-readable copy of the corresponding source code, to be" - , " distributed under the terms of Sections 1 and 2 above on a medium" - , " customarily used for software interchange; or," - , "" - , " c) Accompany it with the information you received as to the offer" - , " to distribute corresponding source code. (This alternative is" - , " allowed only for noncommercial distribution and only if you" - , " received the program in object code or executable form with such" - , " an offer, in accord with Subsection b above.)" - , "" - , "The source code for a work means the preferred form of the work for" - , "making modifications to it. For an executable work, complete source" - , "code means all the source code for all modules it contains, plus any" - , "associated interface definition files, plus the scripts used to" - , "control compilation and installation of the executable. However, as a" - , "special exception, the source code distributed need not include" - , "anything that is normally distributed (in either source or binary" - , "form) with the major components (compiler, kernel, and so on) of the" - , "operating system on which the executable runs, unless that component" - , "itself accompanies the executable." - , "" - , "If distribution of executable or object code is made by offering" - , "access to copy from a designated place, then offering equivalent" - , "access to copy the source code from the same place counts as" - , "distribution of the source code, even though third parties are not" - , "compelled to copy the source along with the object code." - , "" - , " 4. You may not copy, modify, sublicense, or distribute the Program" - , "except as expressly provided under this License. Any attempt" - , "otherwise to copy, modify, sublicense or distribute the Program is" - , "void, and will automatically terminate your rights under this License." - , "However, parties who have received copies, or rights, from you under" - , "this License will not have their licenses terminated so long as such" - , "parties remain in full compliance." - , "" - , " 5. You are not required to accept this License, since you have not" - , "signed it. However, nothing else grants you permission to modify or" - , "distribute the Program or its derivative works. These actions are" - , "prohibited by law if you do not accept this License. Therefore, by" - , "modifying or distributing the Program (or any work based on the" - , "Program), you indicate your acceptance of this License to do so, and" - , "all its terms and conditions for copying, distributing or modifying" - , "the Program or works based on it." - , "" - , " 6. Each time you redistribute the Program (or any work based on the" - , "Program), the recipient automatically receives a license from the" - , "original licensor to copy, distribute or modify the Program subject to" - , "these terms and conditions. You may not impose any further" - , "restrictions on the recipients' exercise of the rights granted herein." - , "You are not responsible for enforcing compliance by third parties to" - , "this License." - , "" - , " 7. If, as a consequence of a court judgment or allegation of patent" - , "infringement or for any other reason (not limited to patent issues)," - , "conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot" - , "distribute so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you" - , "may not distribute the Program at all. For example, if a patent" - , "license would not permit royalty-free redistribution of the Program by" - , "all those who receive copies directly or indirectly through you, then" - , "the only way you could satisfy both it and this License would be to" - , "refrain entirely from distribution of the Program." - , "" - , "If any portion of this section is held invalid or unenforceable under" - , "any particular circumstance, the balance of the section is intended to" - , "apply and the section as a whole is intended to apply in other" - , "circumstances." - , "" - , "It is not the purpose of this section to induce you to infringe any" - , "patents or other property right claims or to contest validity of any" - , "such claims; this section has the sole purpose of protecting the" - , "integrity of the free software distribution system, which is" - , "implemented by public license practices. Many people have made" - , "generous contributions to the wide range of software distributed" - , "through that system in reliance on consistent application of that" - , "system; it is up to the author/donor to decide if he or she is willing" - , "to distribute software through any other system and a licensee cannot" - , "impose that choice." - , "" - , "This section is intended to make thoroughly clear what is believed to" - , "be a consequence of the rest of this License." - , "" - , " 8. If the distribution and/or use of the Program is restricted in" - , "certain countries either by patents or by copyrighted interfaces, the" - , "original copyright holder who places the Program under this License" - , "may add an explicit geographical distribution limitation excluding" - , "those countries, so that distribution is permitted only in or among" - , "countries not thus excluded. In such case, this License incorporates" - , "the limitation as if written in the body of this License." - , "" - , " 9. The Free Software Foundation may publish revised and/or new versions" - , "of the General Public License from time to time. Such new versions will" - , "be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , "Each version is given a distinguishing version number. If the Program" - , "specifies a version number of this License which applies to it and \"any" - , "later version\", you have the option of following the terms and conditions" - , "either of that version or of any later version published by the Free" - , "Software Foundation. If the Program does not specify a version number of" - , "this License, you may choose any version ever published by the Free Software" - , "Foundation." - , "" - , " 10. If you wish to incorporate parts of the Program into other free" - , "programs whose distribution conditions are different, write to the author" - , "to ask for permission. For software which is copyrighted by the Free" - , "Software Foundation, write to the Free Software Foundation; we sometimes" - , "make exceptions for this. Our decision will be guided by the two goals" - , "of preserving the free status of all derivatives of our free software and" - , "of promoting the sharing and reuse of software generally." - , "" - , " NO WARRANTY" - , "" - , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" - , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" - , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" - , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" - , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" - , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" - , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" - , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," - , "REPAIR OR CORRECTION." - , "" - , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" - , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," - , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" - , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" - , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" - , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" - , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" - , "POSSIBILITY OF SUCH DAMAGES." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "convey the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software; you can redistribute it and/or modify" - , " it under the terms of the GNU General Public License as published by" - , " the Free Software Foundation; either version 2 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU General Public License for more details." - , "" - , " You should have received a copy of the GNU General Public License along" - , " with this program; if not, write to the Free Software Foundation, Inc.," - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , "If the program is interactive, make it output a short notice like this" - , "when it starts in an interactive mode:" - , "" - , " Gnomovision version 69, Copyright (C) year name of author" - , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." - , " This is free software, and you are welcome to redistribute it" - , " under certain conditions; type `show c' for details." - , "" - , "The hypothetical commands `show w' and `show c' should show the appropriate" - , "parts of the General Public License. Of course, the commands you use may" - , "be called something other than `show w' and `show c'; they could even be" - , "mouse-clicks or menu items--whatever suits your program." - , "" - , "You should also get your employer (if you work as a programmer) or your" - , "school, if any, to sign a \"copyright disclaimer\" for the program, if" - , "necessary. Here is a sample; alter the names:" - , "" - , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" - , " `Gnomovision' (which makes passes at compilers) written by James Hacker." - , "" - , " , 1 April 1989" - , " Ty Coon, President of Vice" - , "" - , "This General Public License does not permit incorporating your program into" - , "proprietary programs. If your program is a subroutine library, you may" - , "consider it more useful to permit linking proprietary applications with the" - , "library. If this is what you want to do, use the GNU Lesser General" - , "Public License instead of this License." - ] - -gplv3 :: License -gplv3 = unlines - [ " GNU GENERAL PUBLIC LICENSE" - , " Version 3, 29 June 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The GNU General Public License is a free, copyleft license for" - , "software and other kinds of works." - , "" - , " The licenses for most software and other practical works are designed" - , "to take away your freedom to share and change the works. By contrast," - , "the GNU General Public License is intended to guarantee your freedom to" - , "share and change all versions of a program--to make sure it remains free" - , "software for all its users. We, the Free Software Foundation, use the" - , "GNU General Public License for most of our software; it applies also to" - , "any other work released this way by its authors. You can apply it to" - , "your programs, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "them if you wish), that you receive source code or can get it if you" - , "want it, that you can change the software or use pieces of it in new" - , "free programs, and that you know you can do these things." - , "" - , " To protect your rights, we need to prevent others from denying you" - , "these rights or asking you to surrender the rights. Therefore, you have" - , "certain responsibilities if you distribute copies of the software, or if" - , "you modify it: responsibilities to respect the freedom of others." - , "" - , " For example, if you distribute copies of such a program, whether" - , "gratis or for a fee, you must pass on to the recipients the same" - , "freedoms that you received. You must make sure that they, too, receive" - , "or can get the source code. And you must show them these terms so they" - , "know their rights." - , "" - , " Developers that use the GNU GPL protect your rights with two steps:" - , "(1) assert copyright on the software, and (2) offer you this License" - , "giving you legal permission to copy, distribute and/or modify it." - , "" - , " For the developers' and authors' protection, the GPL clearly explains" - , "that there is no warranty for this free software. For both users' and" - , "authors' sake, the GPL requires that modified versions be marked as" - , "changed, so that their problems will not be attributed erroneously to" - , "authors of previous versions." - , "" - , " Some devices are designed to deny users access to install or run" - , "modified versions of the software inside them, although the manufacturer" - , "can do so. This is fundamentally incompatible with the aim of" - , "protecting users' freedom to change the software. The systematic" - , "pattern of such abuse occurs in the area of products for individuals to" - , "use, which is precisely where it is most unacceptable. Therefore, we" - , "have designed this version of the GPL to prohibit the practice for those" - , "products. If such problems arise substantially in other domains, we" - , "stand ready to extend this provision to those domains in future versions" - , "of the GPL, as needed to protect the freedom of users." - , "" - , " Finally, every program is threatened constantly by software patents." - , "States should not allow patents to restrict development and use of" - , "software on general-purpose computers, but in those that do, we wish to" - , "avoid the special danger that patents applied to a free program could" - , "make it effectively proprietary. To prevent this, the GPL assures that" - , "patents cannot be used to render the program non-free." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " TERMS AND CONDITIONS" - , "" - , " 0. Definitions." - , "" - , " \"This License\" refers to version 3 of the GNU General Public License." - , "" - , " \"Copyright\" also means copyright-like laws that apply to other kinds of" - , "works, such as semiconductor masks." - , "" - , " \"The Program\" refers to any copyrightable work licensed under this" - , "License. Each licensee is addressed as \"you\". \"Licensees\" and" - , "\"recipients\" may be individuals or organizations." - , "" - , " To \"modify\" a work means to copy from or adapt all or part of the work" - , "in a fashion requiring copyright permission, other than the making of an" - , "exact copy. The resulting work is called a \"modified version\" of the" - , "earlier work or a work \"based on\" the earlier work." - , "" - , " A \"covered work\" means either the unmodified Program or a work based" - , "on the Program." - , "" - , " To \"propagate\" a work means to do anything with it that, without" - , "permission, would make you directly or secondarily liable for" - , "infringement under applicable copyright law, except executing it on a" - , "computer or modifying a private copy. Propagation includes copying," - , "distribution (with or without modification), making available to the" - , "public, and in some countries other activities as well." - , "" - , " To \"convey\" a work means any kind of propagation that enables other" - , "parties to make or receive copies. Mere interaction with a user through" - , "a computer network, with no transfer of a copy, is not conveying." - , "" - , " An interactive user interface displays \"Appropriate Legal Notices\"" - , "to the extent that it includes a convenient and prominently visible" - , "feature that (1) displays an appropriate copyright notice, and (2)" - , "tells the user that there is no warranty for the work (except to the" - , "extent that warranties are provided), that licensees may convey the" - , "work under this License, and how to view a copy of this License. If" - , "the interface presents a list of user commands or options, such as a" - , "menu, a prominent item in the list meets this criterion." - , "" - , " 1. Source Code." - , "" - , " The \"source code\" for a work means the preferred form of the work" - , "for making modifications to it. \"Object code\" means any non-source" - , "form of a work." - , "" - , " A \"Standard Interface\" means an interface that either is an official" - , "standard defined by a recognized standards body, or, in the case of" - , "interfaces specified for a particular programming language, one that" - , "is widely used among developers working in that language." - , "" - , " The \"System Libraries\" of an executable work include anything, other" - , "than the work as a whole, that (a) is included in the normal form of" - , "packaging a Major Component, but which is not part of that Major" - , "Component, and (b) serves only to enable use of the work with that" - , "Major Component, or to implement a Standard Interface for which an" - , "implementation is available to the public in source code form. A" - , "\"Major Component\", in this context, means a major essential component" - , "(kernel, window system, and so on) of the specific operating system" - , "(if any) on which the executable work runs, or a compiler used to" - , "produce the work, or an object code interpreter used to run it." - , "" - , " The \"Corresponding Source\" for a work in object code form means all" - , "the source code needed to generate, install, and (for an executable" - , "work) run the object code and to modify the work, including scripts to" - , "control those activities. However, it does not include the work's" - , "System Libraries, or general-purpose tools or generally available free" - , "programs which are used unmodified in performing those activities but" - , "which are not part of the work. For example, Corresponding Source" - , "includes interface definition files associated with source files for" - , "the work, and the source code for shared libraries and dynamically" - , "linked subprograms that the work is specifically designed to require," - , "such as by intimate data communication or control flow between those" - , "subprograms and other parts of the work." - , "" - , " The Corresponding Source need not include anything that users" - , "can regenerate automatically from other parts of the Corresponding" - , "Source." - , "" - , " The Corresponding Source for a work in source code form is that" - , "same work." - , "" - , " 2. Basic Permissions." - , "" - , " All rights granted under this License are granted for the term of" - , "copyright on the Program, and are irrevocable provided the stated" - , "conditions are met. This License explicitly affirms your unlimited" - , "permission to run the unmodified Program. The output from running a" - , "covered work is covered by this License only if the output, given its" - , "content, constitutes a covered work. This License acknowledges your" - , "rights of fair use or other equivalent, as provided by copyright law." - , "" - , " You may make, run and propagate covered works that you do not" - , "convey, without conditions so long as your license otherwise remains" - , "in force. You may convey covered works to others for the sole purpose" - , "of having them make modifications exclusively for you, or provide you" - , "with facilities for running those works, provided that you comply with" - , "the terms of this License in conveying all material for which you do" - , "not control copyright. Those thus making or running the covered works" - , "for you must do so exclusively on your behalf, under your direction" - , "and control, on terms that prohibit them from making any copies of" - , "your copyrighted material outside their relationship with you." - , "" - , " Conveying under any other circumstances is permitted solely under" - , "the conditions stated below. Sublicensing is not allowed; section 10" - , "makes it unnecessary." - , "" - , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." - , "" - , " No covered work shall be deemed part of an effective technological" - , "measure under any applicable law fulfilling obligations under article" - , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" - , "similar laws prohibiting or restricting circumvention of such" - , "measures." - , "" - , " When you convey a covered work, you waive any legal power to forbid" - , "circumvention of technological measures to the extent such circumvention" - , "is effected by exercising rights under this License with respect to" - , "the covered work, and you disclaim any intention to limit operation or" - , "modification of the work as a means of enforcing, against the work's" - , "users, your or third parties' legal rights to forbid circumvention of" - , "technological measures." - , "" - , " 4. Conveying Verbatim Copies." - , "" - , " You may convey verbatim copies of the Program's source code as you" - , "receive it, in any medium, provided that you conspicuously and" - , "appropriately publish on each copy an appropriate copyright notice;" - , "keep intact all notices stating that this License and any" - , "non-permissive terms added in accord with section 7 apply to the code;" - , "keep intact all notices of the absence of any warranty; and give all" - , "recipients a copy of this License along with the Program." - , "" - , " You may charge any price or no price for each copy that you convey," - , "and you may offer support or warranty protection for a fee." - , "" - , " 5. Conveying Modified Source Versions." - , "" - , " You may convey a work based on the Program, or the modifications to" - , "produce it from the Program, in the form of source code under the" - , "terms of section 4, provided that you also meet all of these conditions:" - , "" - , " a) The work must carry prominent notices stating that you modified" - , " it, and giving a relevant date." - , "" - , " b) The work must carry prominent notices stating that it is" - , " released under this License and any conditions added under section" - , " 7. This requirement modifies the requirement in section 4 to" - , " \"keep intact all notices\"." - , "" - , " c) You must license the entire work, as a whole, under this" - , " License to anyone who comes into possession of a copy. This" - , " License will therefore apply, along with any applicable section 7" - , " additional terms, to the whole of the work, and all its parts," - , " regardless of how they are packaged. This License gives no" - , " permission to license the work in any other way, but it does not" - , " invalidate such permission if you have separately received it." - , "" - , " d) If the work has interactive user interfaces, each must display" - , " Appropriate Legal Notices; however, if the Program has interactive" - , " interfaces that do not display Appropriate Legal Notices, your" - , " work need not make them do so." - , "" - , " A compilation of a covered work with other separate and independent" - , "works, which are not by their nature extensions of the covered work," - , "and which are not combined with it such as to form a larger program," - , "in or on a volume of a storage or distribution medium, is called an" - , "\"aggregate\" if the compilation and its resulting copyright are not" - , "used to limit the access or legal rights of the compilation's users" - , "beyond what the individual works permit. Inclusion of a covered work" - , "in an aggregate does not cause this License to apply to the other" - , "parts of the aggregate." - , "" - , " 6. Conveying Non-Source Forms." - , "" - , " You may convey a covered work in object code form under the terms" - , "of sections 4 and 5, provided that you also convey the" - , "machine-readable Corresponding Source under the terms of this License," - , "in one of these ways:" - , "" - , " a) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by the" - , " Corresponding Source fixed on a durable physical medium" - , " customarily used for software interchange." - , "" - , " b) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by a" - , " written offer, valid for at least three years and valid for as" - , " long as you offer spare parts or customer support for that product" - , " model, to give anyone who possesses the object code either (1) a" - , " copy of the Corresponding Source for all the software in the" - , " product that is covered by this License, on a durable physical" - , " medium customarily used for software interchange, for a price no" - , " more than your reasonable cost of physically performing this" - , " conveying of source, or (2) access to copy the" - , " Corresponding Source from a network server at no charge." - , "" - , " c) Convey individual copies of the object code with a copy of the" - , " written offer to provide the Corresponding Source. This" - , " alternative is allowed only occasionally and noncommercially, and" - , " only if you received the object code with such an offer, in accord" - , " with subsection 6b." - , "" - , " d) Convey the object code by offering access from a designated" - , " place (gratis or for a charge), and offer equivalent access to the" - , " Corresponding Source in the same way through the same place at no" - , " further charge. You need not require recipients to copy the" - , " Corresponding Source along with the object code. If the place to" - , " copy the object code is a network server, the Corresponding Source" - , " may be on a different server (operated by you or a third party)" - , " that supports equivalent copying facilities, provided you maintain" - , " clear directions next to the object code saying where to find the" - , " Corresponding Source. Regardless of what server hosts the" - , " Corresponding Source, you remain obligated to ensure that it is" - , " available for as long as needed to satisfy these requirements." - , "" - , " e) Convey the object code using peer-to-peer transmission, provided" - , " you inform other peers where the object code and Corresponding" - , " Source of the work are being offered to the general public at no" - , " charge under subsection 6d." - , "" - , " A separable portion of the object code, whose source code is excluded" - , "from the Corresponding Source as a System Library, need not be" - , "included in conveying the object code work." - , "" - , " A \"User Product\" is either (1) a \"consumer product\", which means any" - , "tangible personal property which is normally used for personal, family," - , "or household purposes, or (2) anything designed or sold for incorporation" - , "into a dwelling. In determining whether a product is a consumer product," - , "doubtful cases shall be resolved in favor of coverage. For a particular" - , "product received by a particular user, \"normally used\" refers to a" - , "typical or common use of that class of product, regardless of the status" - , "of the particular user or of the way in which the particular user" - , "actually uses, or expects or is expected to use, the product. A product" - , "is a consumer product regardless of whether the product has substantial" - , "commercial, industrial or non-consumer uses, unless such uses represent" - , "the only significant mode of use of the product." - , "" - , " \"Installation Information\" for a User Product means any methods," - , "procedures, authorization keys, or other information required to install" - , "and execute modified versions of a covered work in that User Product from" - , "a modified version of its Corresponding Source. The information must" - , "suffice to ensure that the continued functioning of the modified object" - , "code is in no case prevented or interfered with solely because" - , "modification has been made." - , "" - , " If you convey an object code work under this section in, or with, or" - , "specifically for use in, a User Product, and the conveying occurs as" - , "part of a transaction in which the right of possession and use of the" - , "User Product is transferred to the recipient in perpetuity or for a" - , "fixed term (regardless of how the transaction is characterized), the" - , "Corresponding Source conveyed under this section must be accompanied" - , "by the Installation Information. But this requirement does not apply" - , "if neither you nor any third party retains the ability to install" - , "modified object code on the User Product (for example, the work has" - , "been installed in ROM)." - , "" - , " The requirement to provide Installation Information does not include a" - , "requirement to continue to provide support service, warranty, or updates" - , "for a work that has been modified or installed by the recipient, or for" - , "the User Product in which it has been modified or installed. Access to a" - , "network may be denied when the modification itself materially and" - , "adversely affects the operation of the network or violates the rules and" - , "protocols for communication across the network." - , "" - , " Corresponding Source conveyed, and Installation Information provided," - , "in accord with this section must be in a format that is publicly" - , "documented (and with an implementation available to the public in" - , "source code form), and must require no special password or key for" - , "unpacking, reading or copying." - , "" - , " 7. Additional Terms." - , "" - , " \"Additional permissions\" are terms that supplement the terms of this" - , "License by making exceptions from one or more of its conditions." - , "Additional permissions that are applicable to the entire Program shall" - , "be treated as though they were included in this License, to the extent" - , "that they are valid under applicable law. If additional permissions" - , "apply only to part of the Program, that part may be used separately" - , "under those permissions, but the entire Program remains governed by" - , "this License without regard to the additional permissions." - , "" - , " When you convey a copy of a covered work, you may at your option" - , "remove any additional permissions from that copy, or from any part of" - , "it. (Additional permissions may be written to require their own" - , "removal in certain cases when you modify the work.) You may place" - , "additional permissions on material, added by you to a covered work," - , "for which you have or can give appropriate copyright permission." - , "" - , " Notwithstanding any other provision of this License, for material you" - , "add to a covered work, you may (if authorized by the copyright holders of" - , "that material) supplement the terms of this License with terms:" - , "" - , " a) Disclaiming warranty or limiting liability differently from the" - , " terms of sections 15 and 16 of this License; or" - , "" - , " b) Requiring preservation of specified reasonable legal notices or" - , " author attributions in that material or in the Appropriate Legal" - , " Notices displayed by works containing it; or" - , "" - , " c) Prohibiting misrepresentation of the origin of that material, or" - , " requiring that modified versions of such material be marked in" - , " reasonable ways as different from the original version; or" - , "" - , " d) Limiting the use for publicity purposes of names of licensors or" - , " authors of the material; or" - , "" - , " e) Declining to grant rights under trademark law for use of some" - , " trade names, trademarks, or service marks; or" - , "" - , " f) Requiring indemnification of licensors and authors of that" - , " material by anyone who conveys the material (or modified versions of" - , " it) with contractual assumptions of liability to the recipient, for" - , " any liability that these contractual assumptions directly impose on" - , " those licensors and authors." - , "" - , " All other non-permissive additional terms are considered \"further" - , "restrictions\" within the meaning of section 10. If the Program as you" - , "received it, or any part of it, contains a notice stating that it is" - , "governed by this License along with a term that is a further" - , "restriction, you may remove that term. If a license document contains" - , "a further restriction but permits relicensing or conveying under this" - , "License, you may add to a covered work material governed by the terms" - , "of that license document, provided that the further restriction does" - , "not survive such relicensing or conveying." - , "" - , " If you add terms to a covered work in accord with this section, you" - , "must place, in the relevant source files, a statement of the" - , "additional terms that apply to those files, or a notice indicating" - , "where to find the applicable terms." - , "" - , " Additional terms, permissive or non-permissive, may be stated in the" - , "form of a separately written license, or stated as exceptions;" - , "the above requirements apply either way." - , "" - , " 8. Termination." - , "" - , " You may not propagate or modify a covered work except as expressly" - , "provided under this License. Any attempt otherwise to propagate or" - , "modify it is void, and will automatically terminate your rights under" - , "this License (including any patent licenses granted under the third" - , "paragraph of section 11)." - , "" - , " However, if you cease all violation of this License, then your" - , "license from a particular copyright holder is reinstated (a)" - , "provisionally, unless and until the copyright holder explicitly and" - , "finally terminates your license, and (b) permanently, if the copyright" - , "holder fails to notify you of the violation by some reasonable means" - , "prior to 60 days after the cessation." - , "" - , " Moreover, your license from a particular copyright holder is" - , "reinstated permanently if the copyright holder notifies you of the" - , "violation by some reasonable means, this is the first time you have" - , "received notice of violation of this License (for any work) from that" - , "copyright holder, and you cure the violation prior to 30 days after" - , "your receipt of the notice." - , "" - , " Termination of your rights under this section does not terminate the" - , "licenses of parties who have received copies or rights from you under" - , "this License. If your rights have been terminated and not permanently" - , "reinstated, you do not qualify to receive new licenses for the same" - , "material under section 10." - , "" - , " 9. Acceptance Not Required for Having Copies." - , "" - , " You are not required to accept this License in order to receive or" - , "run a copy of the Program. Ancillary propagation of a covered work" - , "occurring solely as a consequence of using peer-to-peer transmission" - , "to receive a copy likewise does not require acceptance. However," - , "nothing other than this License grants you permission to propagate or" - , "modify any covered work. These actions infringe copyright if you do" - , "not accept this License. Therefore, by modifying or propagating a" - , "covered work, you indicate your acceptance of this License to do so." - , "" - , " 10. Automatic Licensing of Downstream Recipients." - , "" - , " Each time you convey a covered work, the recipient automatically" - , "receives a license from the original licensors, to run, modify and" - , "propagate that work, subject to this License. You are not responsible" - , "for enforcing compliance by third parties with this License." - , "" - , " An \"entity transaction\" is a transaction transferring control of an" - , "organization, or substantially all assets of one, or subdividing an" - , "organization, or merging organizations. If propagation of a covered" - , "work results from an entity transaction, each party to that" - , "transaction who receives a copy of the work also receives whatever" - , "licenses to the work the party's predecessor in interest had or could" - , "give under the previous paragraph, plus a right to possession of the" - , "Corresponding Source of the work from the predecessor in interest, if" - , "the predecessor has it or can get it with reasonable efforts." - , "" - , " You may not impose any further restrictions on the exercise of the" - , "rights granted or affirmed under this License. For example, you may" - , "not impose a license fee, royalty, or other charge for exercise of" - , "rights granted under this License, and you may not initiate litigation" - , "(including a cross-claim or counterclaim in a lawsuit) alleging that" - , "any patent claim is infringed by making, using, selling, offering for" - , "sale, or importing the Program or any portion of it." - , "" - , " 11. Patents." - , "" - , " A \"contributor\" is a copyright holder who authorizes use under this" - , "License of the Program or a work on which the Program is based. The" - , "work thus licensed is called the contributor's \"contributor version\"." - , "" - , " A contributor's \"essential patent claims\" are all patent claims" - , "owned or controlled by the contributor, whether already acquired or" - , "hereafter acquired, that would be infringed by some manner, permitted" - , "by this License, of making, using, or selling its contributor version," - , "but do not include claims that would be infringed only as a" - , "consequence of further modification of the contributor version. For" - , "purposes of this definition, \"control\" includes the right to grant" - , "patent sublicenses in a manner consistent with the requirements of" - , "this License." - , "" - , " Each contributor grants you a non-exclusive, worldwide, royalty-free" - , "patent license under the contributor's essential patent claims, to" - , "make, use, sell, offer for sale, import and otherwise run, modify and" - , "propagate the contents of its contributor version." - , "" - , " In the following three paragraphs, a \"patent license\" is any express" - , "agreement or commitment, however denominated, not to enforce a patent" - , "(such as an express permission to practice a patent or covenant not to" - , "sue for patent infringement). To \"grant\" such a patent license to a" - , "party means to make such an agreement or commitment not to enforce a" - , "patent against the party." - , "" - , " If you convey a covered work, knowingly relying on a patent license," - , "and the Corresponding Source of the work is not available for anyone" - , "to copy, free of charge and under the terms of this License, through a" - , "publicly available network server or other readily accessible means," - , "then you must either (1) cause the Corresponding Source to be so" - , "available, or (2) arrange to deprive yourself of the benefit of the" - , "patent license for this particular work, or (3) arrange, in a manner" - , "consistent with the requirements of this License, to extend the patent" - , "license to downstream recipients. \"Knowingly relying\" means you have" - , "actual knowledge that, but for the patent license, your conveying the" - , "covered work in a country, or your recipient's use of the covered work" - , "in a country, would infringe one or more identifiable patents in that" - , "country that you have reason to believe are valid." - , "" - , " If, pursuant to or in connection with a single transaction or" - , "arrangement, you convey, or propagate by procuring conveyance of, a" - , "covered work, and grant a patent license to some of the parties" - , "receiving the covered work authorizing them to use, propagate, modify" - , "or convey a specific copy of the covered work, then the patent license" - , "you grant is automatically extended to all recipients of the covered" - , "work and works based on it." - , "" - , " A patent license is \"discriminatory\" if it does not include within" - , "the scope of its coverage, prohibits the exercise of, or is" - , "conditioned on the non-exercise of one or more of the rights that are" - , "specifically granted under this License. You may not convey a covered" - , "work if you are a party to an arrangement with a third party that is" - , "in the business of distributing software, under which you make payment" - , "to the third party based on the extent of your activity of conveying" - , "the work, and under which the third party grants, to any of the" - , "parties who would receive the covered work from you, a discriminatory" - , "patent license (a) in connection with copies of the covered work" - , "conveyed by you (or copies made from those copies), or (b) primarily" - , "for and in connection with specific products or compilations that" - , "contain the covered work, unless you entered into that arrangement," - , "or that patent license was granted, prior to 28 March 2007." - , "" - , " Nothing in this License shall be construed as excluding or limiting" - , "any implied license or other defenses to infringement that may" - , "otherwise be available to you under applicable patent law." - , "" - , " 12. No Surrender of Others' Freedom." - , "" - , " If conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot convey a" - , "covered work so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you may" - , "not convey it at all. For example, if you agree to terms that obligate you" - , "to collect a royalty for further conveying from those to whom you convey" - , "the Program, the only way you could satisfy both those terms and this" - , "License would be to refrain entirely from conveying the Program." - , "" - , " 13. Use with the GNU Affero General Public License." - , "" - , " Notwithstanding any other provision of this License, you have" - , "permission to link or combine any covered work with a work licensed" - , "under version 3 of the GNU Affero General Public License into a single" - , "combined work, and to convey the resulting work. The terms of this" - , "License will continue to apply to the part which is the covered work," - , "but the special requirements of the GNU Affero General Public License," - , "section 13, concerning interaction through a network will apply to the" - , "combination as such." - , "" - , " 14. Revised Versions of this License." - , "" - , " The Free Software Foundation may publish revised and/or new versions of" - , "the GNU General Public License from time to time. Such new versions will" - , "be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Program specifies that a certain numbered version of the GNU General" - , "Public License \"or any later version\" applies to it, you have the" - , "option of following the terms and conditions either of that numbered" - , "version or of any later version published by the Free Software" - , "Foundation. If the Program does not specify a version number of the" - , "GNU General Public License, you may choose any version ever published" - , "by the Free Software Foundation." - , "" - , " If the Program specifies that a proxy can decide which future" - , "versions of the GNU General Public License can be used, that proxy's" - , "public statement of acceptance of a version permanently authorizes you" - , "to choose that version for the Program." - , "" - , " Later license versions may give you additional or different" - , "permissions. However, no additional obligations are imposed on any" - , "author or copyright holder as a result of your choosing to follow a" - , "later version." - , "" - , " 15. Disclaimer of Warranty." - , "" - , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" - , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" - , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" - , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," - , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" - , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" - , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. Limitation of Liability." - , "" - , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" - , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" - , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" - , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" - , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" - , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," - , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" - , "SUCH DAMAGES." - , "" - , " 17. Interpretation of Sections 15 and 16." - , "" - , " If the disclaimer of warranty and limitation of liability provided" - , "above cannot be given local legal effect according to their terms," - , "reviewing courts shall apply local law that most closely approximates" - , "an absolute waiver of all civil liability in connection with the" - , "Program, unless a warranty or assumption of liability accompanies a" - , "copy of the Program in return for a fee." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "state the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software: you can redistribute it and/or modify" - , " it under the terms of the GNU General Public License as published by" - , " the Free Software Foundation, either version 3 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU General Public License for more details." - , "" - , " You should have received a copy of the GNU General Public License" - , " along with this program. If not, see ." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , " If the program does terminal interaction, make it output a short" - , "notice like this when it starts in an interactive mode:" - , "" - , " Copyright (C) " - , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." - , " This is free software, and you are welcome to redistribute it" - , " under certain conditions; type `show c' for details." - , "" - , "The hypothetical commands `show w' and `show c' should show the appropriate" - , "parts of the General Public License. Of course, your program's commands" - , "might be different; for a GUI interface, you would use an \"about box\"." - , "" - , " You should also get your employer (if you work as a programmer) or school," - , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." - , "For more information on this, and how to apply and follow the GNU GPL, see" - , "." - , "" - , " The GNU General Public License does not permit incorporating your program" - , "into proprietary programs. If your program is a subroutine library, you" - , "may consider it more useful to permit linking proprietary applications with" - , "the library. If this is what you want to do, use the GNU Lesser General" - , "Public License instead of this License. But first, please read" - , "." - ] - -agplv3 :: License -agplv3 = unlines - [ " GNU AFFERO GENERAL PUBLIC LICENSE" - , " Version 3, 19 November 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The GNU Affero General Public License is a free, copyleft license for" - , "software and other kinds of works, specifically designed to ensure" - , "cooperation with the community in the case of network server software." - , "" - , " The licenses for most software and other practical works are designed" - , "to take away your freedom to share and change the works. By contrast," - , "our General Public Licenses are intended to guarantee your freedom to" - , "share and change all versions of a program--to make sure it remains free" - , "software for all its users." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "them if you wish), that you receive source code or can get it if you" - , "want it, that you can change the software or use pieces of it in new" - , "free programs, and that you know you can do these things." - , "" - , " Developers that use our General Public Licenses protect your rights" - , "with two steps: (1) assert copyright on the software, and (2) offer" - , "you this License which gives you legal permission to copy, distribute" - , "and/or modify the software." - , "" - , " A secondary benefit of defending all users' freedom is that" - , "improvements made in alternate versions of the program, if they" - , "receive widespread use, become available for other developers to" - , "incorporate. Many developers of free software are heartened and" - , "encouraged by the resulting cooperation. However, in the case of" - , "software used on network servers, this result may fail to come about." - , "The GNU General Public License permits making a modified version and" - , "letting the public access it on a server without ever releasing its" - , "source code to the public." - , "" - , " The GNU Affero General Public License is designed specifically to" - , "ensure that, in such cases, the modified source code becomes available" - , "to the community. It requires the operator of a network server to" - , "provide the source code of the modified version running there to the" - , "users of that server. Therefore, public use of a modified version, on" - , "a publicly accessible server, gives the public access to the source" - , "code of the modified version." - , "" - , " An older license, called the Affero General Public License and" - , "published by Affero, was designed to accomplish similar goals. This is" - , "a different license, not a version of the Affero GPL, but Affero has" - , "released a new version of the Affero GPL which permits relicensing under" - , "this license." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " TERMS AND CONDITIONS" - , "" - , " 0. Definitions." - , "" - , " \"This License\" refers to version 3 of the GNU Affero General Public License." - , "" - , " \"Copyright\" also means copyright-like laws that apply to other kinds of" - , "works, such as semiconductor masks." - , "" - , " \"The Program\" refers to any copyrightable work licensed under this" - , "License. Each licensee is addressed as \"you\". \"Licensees\" and" - , "\"recipients\" may be individuals or organizations." - , "" - , " To \"modify\" a work means to copy from or adapt all or part of the work" - , "in a fashion requiring copyright permission, other than the making of an" - , "exact copy. The resulting work is called a \"modified version\" of the" - , "earlier work or a work \"based on\" the earlier work." - , "" - , " A \"covered work\" means either the unmodified Program or a work based" - , "on the Program." - , "" - , " To \"propagate\" a work means to do anything with it that, without" - , "permission, would make you directly or secondarily liable for" - , "infringement under applicable copyright law, except executing it on a" - , "computer or modifying a private copy. Propagation includes copying," - , "distribution (with or without modification), making available to the" - , "public, and in some countries other activities as well." - , "" - , " To \"convey\" a work means any kind of propagation that enables other" - , "parties to make or receive copies. Mere interaction with a user through" - , "a computer network, with no transfer of a copy, is not conveying." - , "" - , " An interactive user interface displays \"Appropriate Legal Notices\"" - , "to the extent that it includes a convenient and prominently visible" - , "feature that (1) displays an appropriate copyright notice, and (2)" - , "tells the user that there is no warranty for the work (except to the" - , "extent that warranties are provided), that licensees may convey the" - , "work under this License, and how to view a copy of this License. If" - , "the interface presents a list of user commands or options, such as a" - , "menu, a prominent item in the list meets this criterion." - , "" - , " 1. Source Code." - , "" - , " The \"source code\" for a work means the preferred form of the work" - , "for making modifications to it. \"Object code\" means any non-source" - , "form of a work." - , "" - , " A \"Standard Interface\" means an interface that either is an official" - , "standard defined by a recognized standards body, or, in the case of" - , "interfaces specified for a particular programming language, one that" - , "is widely used among developers working in that language." - , "" - , " The \"System Libraries\" of an executable work include anything, other" - , "than the work as a whole, that (a) is included in the normal form of" - , "packaging a Major Component, but which is not part of that Major" - , "Component, and (b) serves only to enable use of the work with that" - , "Major Component, or to implement a Standard Interface for which an" - , "implementation is available to the public in source code form. A" - , "\"Major Component\", in this context, means a major essential component" - , "(kernel, window system, and so on) of the specific operating system" - , "(if any) on which the executable work runs, or a compiler used to" - , "produce the work, or an object code interpreter used to run it." - , "" - , " The \"Corresponding Source\" for a work in object code form means all" - , "the source code needed to generate, install, and (for an executable" - , "work) run the object code and to modify the work, including scripts to" - , "control those activities. However, it does not include the work's" - , "System Libraries, or general-purpose tools or generally available free" - , "programs which are used unmodified in performing those activities but" - , "which are not part of the work. For example, Corresponding Source" - , "includes interface definition files associated with source files for" - , "the work, and the source code for shared libraries and dynamically" - , "linked subprograms that the work is specifically designed to require," - , "such as by intimate data communication or control flow between those" - , "subprograms and other parts of the work." - , "" - , " The Corresponding Source need not include anything that users" - , "can regenerate automatically from other parts of the Corresponding" - , "Source." - , "" - , " The Corresponding Source for a work in source code form is that" - , "same work." - , "" - , " 2. Basic Permissions." - , "" - , " All rights granted under this License are granted for the term of" - , "copyright on the Program, and are irrevocable provided the stated" - , "conditions are met. This License explicitly affirms your unlimited" - , "permission to run the unmodified Program. The output from running a" - , "covered work is covered by this License only if the output, given its" - , "content, constitutes a covered work. This License acknowledges your" - , "rights of fair use or other equivalent, as provided by copyright law." - , "" - , " You may make, run and propagate covered works that you do not" - , "convey, without conditions so long as your license otherwise remains" - , "in force. You may convey covered works to others for the sole purpose" - , "of having them make modifications exclusively for you, or provide you" - , "with facilities for running those works, provided that you comply with" - , "the terms of this License in conveying all material for which you do" - , "not control copyright. Those thus making or running the covered works" - , "for you must do so exclusively on your behalf, under your direction" - , "and control, on terms that prohibit them from making any copies of" - , "your copyrighted material outside their relationship with you." - , "" - , " Conveying under any other circumstances is permitted solely under" - , "the conditions stated below. Sublicensing is not allowed; section 10" - , "makes it unnecessary." - , "" - , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." - , "" - , " No covered work shall be deemed part of an effective technological" - , "measure under any applicable law fulfilling obligations under article" - , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" - , "similar laws prohibiting or restricting circumvention of such" - , "measures." - , "" - , " When you convey a covered work, you waive any legal power to forbid" - , "circumvention of technological measures to the extent such circumvention" - , "is effected by exercising rights under this License with respect to" - , "the covered work, and you disclaim any intention to limit operation or" - , "modification of the work as a means of enforcing, against the work's" - , "users, your or third parties' legal rights to forbid circumvention of" - , "technological measures." - , "" - , " 4. Conveying Verbatim Copies." - , "" - , " You may convey verbatim copies of the Program's source code as you" - , "receive it, in any medium, provided that you conspicuously and" - , "appropriately publish on each copy an appropriate copyright notice;" - , "keep intact all notices stating that this License and any" - , "non-permissive terms added in accord with section 7 apply to the code;" - , "keep intact all notices of the absence of any warranty; and give all" - , "recipients a copy of this License along with the Program." - , "" - , " You may charge any price or no price for each copy that you convey," - , "and you may offer support or warranty protection for a fee." - , "" - , " 5. Conveying Modified Source Versions." - , "" - , " You may convey a work based on the Program, or the modifications to" - , "produce it from the Program, in the form of source code under the" - , "terms of section 4, provided that you also meet all of these conditions:" - , "" - , " a) The work must carry prominent notices stating that you modified" - , " it, and giving a relevant date." - , "" - , " b) The work must carry prominent notices stating that it is" - , " released under this License and any conditions added under section" - , " 7. This requirement modifies the requirement in section 4 to" - , " \"keep intact all notices\"." - , "" - , " c) You must license the entire work, as a whole, under this" - , " License to anyone who comes into possession of a copy. This" - , " License will therefore apply, along with any applicable section 7" - , " additional terms, to the whole of the work, and all its parts," - , " regardless of how they are packaged. This License gives no" - , " permission to license the work in any other way, but it does not" - , " invalidate such permission if you have separately received it." - , "" - , " d) If the work has interactive user interfaces, each must display" - , " Appropriate Legal Notices; however, if the Program has interactive" - , " interfaces that do not display Appropriate Legal Notices, your" - , " work need not make them do so." - , "" - , " A compilation of a covered work with other separate and independent" - , "works, which are not by their nature extensions of the covered work," - , "and which are not combined with it such as to form a larger program," - , "in or on a volume of a storage or distribution medium, is called an" - , "\"aggregate\" if the compilation and its resulting copyright are not" - , "used to limit the access or legal rights of the compilation's users" - , "beyond what the individual works permit. Inclusion of a covered work" - , "in an aggregate does not cause this License to apply to the other" - , "parts of the aggregate." - , "" - , " 6. Conveying Non-Source Forms." - , "" - , " You may convey a covered work in object code form under the terms" - , "of sections 4 and 5, provided that you also convey the" - , "machine-readable Corresponding Source under the terms of this License," - , "in one of these ways:" - , "" - , " a) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by the" - , " Corresponding Source fixed on a durable physical medium" - , " customarily used for software interchange." - , "" - , " b) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by a" - , " written offer, valid for at least three years and valid for as" - , " long as you offer spare parts or customer support for that product" - , " model, to give anyone who possesses the object code either (1) a" - , " copy of the Corresponding Source for all the software in the" - , " product that is covered by this License, on a durable physical" - , " medium customarily used for software interchange, for a price no" - , " more than your reasonable cost of physically performing this" - , " conveying of source, or (2) access to copy the" - , " Corresponding Source from a network server at no charge." - , "" - , " c) Convey individual copies of the object code with a copy of the" - , " written offer to provide the Corresponding Source. This" - , " alternative is allowed only occasionally and noncommercially, and" - , " only if you received the object code with such an offer, in accord" - , " with subsection 6b." - , "" - , " d) Convey the object code by offering access from a designated" - , " place (gratis or for a charge), and offer equivalent access to the" - , " Corresponding Source in the same way through the same place at no" - , " further charge. You need not require recipients to copy the" - , " Corresponding Source along with the object code. If the place to" - , " copy the object code is a network server, the Corresponding Source" - , " may be on a different server (operated by you or a third party)" - , " that supports equivalent copying facilities, provided you maintain" - , " clear directions next to the object code saying where to find the" - , " Corresponding Source. Regardless of what server hosts the" - , " Corresponding Source, you remain obligated to ensure that it is" - , " available for as long as needed to satisfy these requirements." - , "" - , " e) Convey the object code using peer-to-peer transmission, provided" - , " you inform other peers where the object code and Corresponding" - , " Source of the work are being offered to the general public at no" - , " charge under subsection 6d." - , "" - , " A separable portion of the object code, whose source code is excluded" - , "from the Corresponding Source as a System Library, need not be" - , "included in conveying the object code work." - , "" - , " A \"User Product\" is either (1) a \"consumer product\", which means any" - , "tangible personal property which is normally used for personal, family," - , "or household purposes, or (2) anything designed or sold for incorporation" - , "into a dwelling. In determining whether a product is a consumer product," - , "doubtful cases shall be resolved in favor of coverage. For a particular" - , "product received by a particular user, \"normally used\" refers to a" - , "typical or common use of that class of product, regardless of the status" - , "of the particular user or of the way in which the particular user" - , "actually uses, or expects or is expected to use, the product. A product" - , "is a consumer product regardless of whether the product has substantial" - , "commercial, industrial or non-consumer uses, unless such uses represent" - , "the only significant mode of use of the product." - , "" - , " \"Installation Information\" for a User Product means any methods," - , "procedures, authorization keys, or other information required to install" - , "and execute modified versions of a covered work in that User Product from" - , "a modified version of its Corresponding Source. The information must" - , "suffice to ensure that the continued functioning of the modified object" - , "code is in no case prevented or interfered with solely because" - , "modification has been made." - , "" - , " If you convey an object code work under this section in, or with, or" - , "specifically for use in, a User Product, and the conveying occurs as" - , "part of a transaction in which the right of possession and use of the" - , "User Product is transferred to the recipient in perpetuity or for a" - , "fixed term (regardless of how the transaction is characterized), the" - , "Corresponding Source conveyed under this section must be accompanied" - , "by the Installation Information. But this requirement does not apply" - , "if neither you nor any third party retains the ability to install" - , "modified object code on the User Product (for example, the work has" - , "been installed in ROM)." - , "" - , " The requirement to provide Installation Information does not include a" - , "requirement to continue to provide support service, warranty, or updates" - , "for a work that has been modified or installed by the recipient, or for" - , "the User Product in which it has been modified or installed. Access to a" - , "network may be denied when the modification itself materially and" - , "adversely affects the operation of the network or violates the rules and" - , "protocols for communication across the network." - , "" - , " Corresponding Source conveyed, and Installation Information provided," - , "in accord with this section must be in a format that is publicly" - , "documented (and with an implementation available to the public in" - , "source code form), and must require no special password or key for" - , "unpacking, reading or copying." - , "" - , " 7. Additional Terms." - , "" - , " \"Additional permissions\" are terms that supplement the terms of this" - , "License by making exceptions from one or more of its conditions." - , "Additional permissions that are applicable to the entire Program shall" - , "be treated as though they were included in this License, to the extent" - , "that they are valid under applicable law. If additional permissions" - , "apply only to part of the Program, that part may be used separately" - , "under those permissions, but the entire Program remains governed by" - , "this License without regard to the additional permissions." - , "" - , " When you convey a copy of a covered work, you may at your option" - , "remove any additional permissions from that copy, or from any part of" - , "it. (Additional permissions may be written to require their own" - , "removal in certain cases when you modify the work.) You may place" - , "additional permissions on material, added by you to a covered work," - , "for which you have or can give appropriate copyright permission." - , "" - , " Notwithstanding any other provision of this License, for material you" - , "add to a covered work, you may (if authorized by the copyright holders of" - , "that material) supplement the terms of this License with terms:" - , "" - , " a) Disclaiming warranty or limiting liability differently from the" - , " terms of sections 15 and 16 of this License; or" - , "" - , " b) Requiring preservation of specified reasonable legal notices or" - , " author attributions in that material or in the Appropriate Legal" - , " Notices displayed by works containing it; or" - , "" - , " c) Prohibiting misrepresentation of the origin of that material, or" - , " requiring that modified versions of such material be marked in" - , " reasonable ways as different from the original version; or" - , "" - , " d) Limiting the use for publicity purposes of names of licensors or" - , " authors of the material; or" - , "" - , " e) Declining to grant rights under trademark law for use of some" - , " trade names, trademarks, or service marks; or" - , "" - , " f) Requiring indemnification of licensors and authors of that" - , " material by anyone who conveys the material (or modified versions of" - , " it) with contractual assumptions of liability to the recipient, for" - , " any liability that these contractual assumptions directly impose on" - , " those licensors and authors." - , "" - , " All other non-permissive additional terms are considered \"further" - , "restrictions\" within the meaning of section 10. If the Program as you" - , "received it, or any part of it, contains a notice stating that it is" - , "governed by this License along with a term that is a further" - , "restriction, you may remove that term. If a license document contains" - , "a further restriction but permits relicensing or conveying under this" - , "License, you may add to a covered work material governed by the terms" - , "of that license document, provided that the further restriction does" - , "not survive such relicensing or conveying." - , "" - , " If you add terms to a covered work in accord with this section, you" - , "must place, in the relevant source files, a statement of the" - , "additional terms that apply to those files, or a notice indicating" - , "where to find the applicable terms." - , "" - , " Additional terms, permissive or non-permissive, may be stated in the" - , "form of a separately written license, or stated as exceptions;" - , "the above requirements apply either way." - , "" - , " 8. Termination." - , "" - , " You may not propagate or modify a covered work except as expressly" - , "provided under this License. Any attempt otherwise to propagate or" - , "modify it is void, and will automatically terminate your rights under" - , "this License (including any patent licenses granted under the third" - , "paragraph of section 11)." - , "" - , " However, if you cease all violation of this License, then your" - , "license from a particular copyright holder is reinstated (a)" - , "provisionally, unless and until the copyright holder explicitly and" - , "finally terminates your license, and (b) permanently, if the copyright" - , "holder fails to notify you of the violation by some reasonable means" - , "prior to 60 days after the cessation." - , "" - , " Moreover, your license from a particular copyright holder is" - , "reinstated permanently if the copyright holder notifies you of the" - , "violation by some reasonable means, this is the first time you have" - , "received notice of violation of this License (for any work) from that" - , "copyright holder, and you cure the violation prior to 30 days after" - , "your receipt of the notice." - , "" - , " Termination of your rights under this section does not terminate the" - , "licenses of parties who have received copies or rights from you under" - , "this License. If your rights have been terminated and not permanently" - , "reinstated, you do not qualify to receive new licenses for the same" - , "material under section 10." - , "" - , " 9. Acceptance Not Required for Having Copies." - , "" - , " You are not required to accept this License in order to receive or" - , "run a copy of the Program. Ancillary propagation of a covered work" - , "occurring solely as a consequence of using peer-to-peer transmission" - , "to receive a copy likewise does not require acceptance. However," - , "nothing other than this License grants you permission to propagate or" - , "modify any covered work. These actions infringe copyright if you do" - , "not accept this License. Therefore, by modifying or propagating a" - , "covered work, you indicate your acceptance of this License to do so." - , "" - , " 10. Automatic Licensing of Downstream Recipients." - , "" - , " Each time you convey a covered work, the recipient automatically" - , "receives a license from the original licensors, to run, modify and" - , "propagate that work, subject to this License. You are not responsible" - , "for enforcing compliance by third parties with this License." - , "" - , " An \"entity transaction\" is a transaction transferring control of an" - , "organization, or substantially all assets of one, or subdividing an" - , "organization, or merging organizations. If propagation of a covered" - , "work results from an entity transaction, each party to that" - , "transaction who receives a copy of the work also receives whatever" - , "licenses to the work the party's predecessor in interest had or could" - , "give under the previous paragraph, plus a right to possession of the" - , "Corresponding Source of the work from the predecessor in interest, if" - , "the predecessor has it or can get it with reasonable efforts." - , "" - , " You may not impose any further restrictions on the exercise of the" - , "rights granted or affirmed under this License. For example, you may" - , "not impose a license fee, royalty, or other charge for exercise of" - , "rights granted under this License, and you may not initiate litigation" - , "(including a cross-claim or counterclaim in a lawsuit) alleging that" - , "any patent claim is infringed by making, using, selling, offering for" - , "sale, or importing the Program or any portion of it." - , "" - , " 11. Patents." - , "" - , " A \"contributor\" is a copyright holder who authorizes use under this" - , "License of the Program or a work on which the Program is based. The" - , "work thus licensed is called the contributor's \"contributor version\"." - , "" - , " A contributor's \"essential patent claims\" are all patent claims" - , "owned or controlled by the contributor, whether already acquired or" - , "hereafter acquired, that would be infringed by some manner, permitted" - , "by this License, of making, using, or selling its contributor version," - , "but do not include claims that would be infringed only as a" - , "consequence of further modification of the contributor version. For" - , "purposes of this definition, \"control\" includes the right to grant" - , "patent sublicenses in a manner consistent with the requirements of" - , "this License." - , "" - , " Each contributor grants you a non-exclusive, worldwide, royalty-free" - , "patent license under the contributor's essential patent claims, to" - , "make, use, sell, offer for sale, import and otherwise run, modify and" - , "propagate the contents of its contributor version." - , "" - , " In the following three paragraphs, a \"patent license\" is any express" - , "agreement or commitment, however denominated, not to enforce a patent" - , "(such as an express permission to practice a patent or covenant not to" - , "sue for patent infringement). To \"grant\" such a patent license to a" - , "party means to make such an agreement or commitment not to enforce a" - , "patent against the party." - , "" - , " If you convey a covered work, knowingly relying on a patent license," - , "and the Corresponding Source of the work is not available for anyone" - , "to copy, free of charge and under the terms of this License, through a" - , "publicly available network server or other readily accessible means," - , "then you must either (1) cause the Corresponding Source to be so" - , "available, or (2) arrange to deprive yourself of the benefit of the" - , "patent license for this particular work, or (3) arrange, in a manner" - , "consistent with the requirements of this License, to extend the patent" - , "license to downstream recipients. \"Knowingly relying\" means you have" - , "actual knowledge that, but for the patent license, your conveying the" - , "covered work in a country, or your recipient's use of the covered work" - , "in a country, would infringe one or more identifiable patents in that" - , "country that you have reason to believe are valid." - , "" - , " If, pursuant to or in connection with a single transaction or" - , "arrangement, you convey, or propagate by procuring conveyance of, a" - , "covered work, and grant a patent license to some of the parties" - , "receiving the covered work authorizing them to use, propagate, modify" - , "or convey a specific copy of the covered work, then the patent license" - , "you grant is automatically extended to all recipients of the covered" - , "work and works based on it." - , "" - , " A patent license is \"discriminatory\" if it does not include within" - , "the scope of its coverage, prohibits the exercise of, or is" - , "conditioned on the non-exercise of one or more of the rights that are" - , "specifically granted under this License. You may not convey a covered" - , "work if you are a party to an arrangement with a third party that is" - , "in the business of distributing software, under which you make payment" - , "to the third party based on the extent of your activity of conveying" - , "the work, and under which the third party grants, to any of the" - , "parties who would receive the covered work from you, a discriminatory" - , "patent license (a) in connection with copies of the covered work" - , "conveyed by you (or copies made from those copies), or (b) primarily" - , "for and in connection with specific products or compilations that" - , "contain the covered work, unless you entered into that arrangement," - , "or that patent license was granted, prior to 28 March 2007." - , "" - , " Nothing in this License shall be construed as excluding or limiting" - , "any implied license or other defenses to infringement that may" - , "otherwise be available to you under applicable patent law." - , "" - , " 12. No Surrender of Others' Freedom." - , "" - , " If conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot convey a" - , "covered work so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you may" - , "not convey it at all. For example, if you agree to terms that obligate you" - , "to collect a royalty for further conveying from those to whom you convey" - , "the Program, the only way you could satisfy both those terms and this" - , "License would be to refrain entirely from conveying the Program." - , "" - , " 13. Remote Network Interaction; Use with the GNU General Public License." - , "" - , " Notwithstanding any other provision of this License, if you modify the" - , "Program, your modified version must prominently offer all users" - , "interacting with it remotely through a computer network (if your version" - , "supports such interaction) an opportunity to receive the Corresponding" - , "Source of your version by providing access to the Corresponding Source" - , "from a network server at no charge, through some standard or customary" - , "means of facilitating copying of software. This Corresponding Source" - , "shall include the Corresponding Source for any work covered by version 3" - , "of the GNU General Public License that is incorporated pursuant to the" - , "following paragraph." - , "" - , " Notwithstanding any other provision of this License, you have" - , "permission to link or combine any covered work with a work licensed" - , "under version 3 of the GNU General Public License into a single" - , "combined work, and to convey the resulting work. The terms of this" - , "License will continue to apply to the part which is the covered work," - , "but the work with which it is combined will remain governed by version" - , "3 of the GNU General Public License." - , "" - , " 14. Revised Versions of this License." - , "" - , " The Free Software Foundation may publish revised and/or new versions of" - , "the GNU Affero General Public License from time to time. Such new versions" - , "will be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Program specifies that a certain numbered version of the GNU Affero General" - , "Public License \"or any later version\" applies to it, you have the" - , "option of following the terms and conditions either of that numbered" - , "version or of any later version published by the Free Software" - , "Foundation. If the Program does not specify a version number of the" - , "GNU Affero General Public License, you may choose any version ever published" - , "by the Free Software Foundation." - , "" - , " If the Program specifies that a proxy can decide which future" - , "versions of the GNU Affero General Public License can be used, that proxy's" - , "public statement of acceptance of a version permanently authorizes you" - , "to choose that version for the Program." - , "" - , " Later license versions may give you additional or different" - , "permissions. However, no additional obligations are imposed on any" - , "author or copyright holder as a result of your choosing to follow a" - , "later version." - , "" - , " 15. Disclaimer of Warranty." - , "" - , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" - , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" - , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" - , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," - , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" - , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" - , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. Limitation of Liability." - , "" - , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" - , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" - , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" - , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" - , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" - , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," - , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" - , "SUCH DAMAGES." - , "" - , " 17. Interpretation of Sections 15 and 16." - , "" - , " If the disclaimer of warranty and limitation of liability provided" - , "above cannot be given local legal effect according to their terms," - , "reviewing courts shall apply local law that most closely approximates" - , "an absolute waiver of all civil liability in connection with the" - , "Program, unless a warranty or assumption of liability accompanies a" - , "copy of the Program in return for a fee." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "state the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software: you can redistribute it and/or modify" - , " it under the terms of the GNU Affero General Public License as published by" - , " the Free Software Foundation, either version 3 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU Affero General Public License for more details." - , "" - , " You should have received a copy of the GNU Affero General Public License" - , " along with this program. If not, see ." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , " If your software can interact with users remotely through a computer" - , "network, you should also make sure that it provides a way for users to" - , "get its source. For example, if your program is a web application, its" - , "interface could display a \"Source\" link that leads users to an archive" - , "of the code. There are many ways you could offer source, and different" - , "solutions will be better for different programs; see section 13 for the" - , "specific requirements." - , "" - , " You should also get your employer (if you work as a programmer) or school," - , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." - , "For more information on this, and how to apply and follow the GNU AGPL, see" - , "." - ] - -lgpl21 :: License -lgpl21 = unlines - [ " GNU LESSER GENERAL PUBLIC LICENSE" - , " Version 2.1, February 1999" - , "" - , " Copyright (C) 1991, 1999 Free Software Foundation, Inc." - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , "[This is the first released version of the Lesser GPL. It also counts" - , " as the successor of the GNU Library Public License, version 2, hence" - , " the version number 2.1.]" - , "" - , " Preamble" - , "" - , " The licenses for most software are designed to take away your" - , "freedom to share and change it. By contrast, the GNU General Public" - , "Licenses are intended to guarantee your freedom to share and change" - , "free software--to make sure the software is free for all its users." - , "" - , " This license, the Lesser General Public License, applies to some" - , "specially designated software packages--typically libraries--of the" - , "Free Software Foundation and other authors who decide to use it. You" - , "can use it too, but we suggest you first think carefully about whether" - , "this license or the ordinary General Public License is the better" - , "strategy to use in any particular case, based on the explanations below." - , "" - , " When we speak of free software, we are referring to freedom of use," - , "not price. Our General Public Licenses are designed to make sure that" - , "you have the freedom to distribute copies of free software (and charge" - , "for this service if you wish); that you receive source code or can get" - , "it if you want it; that you can change the software and use pieces of" - , "it in new free programs; and that you are informed that you can do" - , "these things." - , "" - , " To protect your rights, we need to make restrictions that forbid" - , "distributors to deny you these rights or to ask you to surrender these" - , "rights. These restrictions translate to certain responsibilities for" - , "you if you distribute copies of the library or if you modify it." - , "" - , " For example, if you distribute copies of the library, whether gratis" - , "or for a fee, you must give the recipients all the rights that we gave" - , "you. You must make sure that they, too, receive or can get the source" - , "code. If you link other code with the library, you must provide" - , "complete object files to the recipients, so that they can relink them" - , "with the library after making changes to the library and recompiling" - , "it. And you must show them these terms so they know their rights." - , "" - , " We protect your rights with a two-step method: (1) we copyright the" - , "library, and (2) we offer you this license, which gives you legal" - , "permission to copy, distribute and/or modify the library." - , "" - , " To protect each distributor, we want to make it very clear that" - , "there is no warranty for the free library. Also, if the library is" - , "modified by someone else and passed on, the recipients should know" - , "that what they have is not the original version, so that the original" - , "author's reputation will not be affected by problems that might be" - , "introduced by others." - , "" - , " Finally, software patents pose a constant threat to the existence of" - , "any free program. We wish to make sure that a company cannot" - , "effectively restrict the users of a free program by obtaining a" - , "restrictive license from a patent holder. Therefore, we insist that" - , "any patent license obtained for a version of the library must be" - , "consistent with the full freedom of use specified in this license." - , "" - , " Most GNU software, including some libraries, is covered by the" - , "ordinary GNU General Public License. This license, the GNU Lesser" - , "General Public License, applies to certain designated libraries, and" - , "is quite different from the ordinary General Public License. We use" - , "this license for certain libraries in order to permit linking those" - , "libraries into non-free programs." - , "" - , " When a program is linked with a library, whether statically or using" - , "a shared library, the combination of the two is legally speaking a" - , "combined work, a derivative of the original library. The ordinary" - , "General Public License therefore permits such linking only if the" - , "entire combination fits its criteria of freedom. The Lesser General" - , "Public License permits more lax criteria for linking other code with" - , "the library." - , "" - , " We call this license the \"Lesser\" General Public License because it" - , "does Less to protect the user's freedom than the ordinary General" - , "Public License. It also provides other free software developers Less" - , "of an advantage over competing non-free programs. These disadvantages" - , "are the reason we use the ordinary General Public License for many" - , "libraries. However, the Lesser license provides advantages in certain" - , "special circumstances." - , "" - , " For example, on rare occasions, there may be a special need to" - , "encourage the widest possible use of a certain library, so that it becomes" - , "a de-facto standard. To achieve this, non-free programs must be" - , "allowed to use the library. A more frequent case is that a free" - , "library does the same job as widely used non-free libraries. In this" - , "case, there is little to gain by limiting the free library to free" - , "software only, so we use the Lesser General Public License." - , "" - , " In other cases, permission to use a particular library in non-free" - , "programs enables a greater number of people to use a large body of" - , "free software. For example, permission to use the GNU C Library in" - , "non-free programs enables many more people to use the whole GNU" - , "operating system, as well as its variant, the GNU/Linux operating" - , "system." - , "" - , " Although the Lesser General Public License is Less protective of the" - , "users' freedom, it does ensure that the user of a program that is" - , "linked with the Library has the freedom and the wherewithal to run" - , "that program using a modified version of the Library." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow. Pay close attention to the difference between a" - , "\"work based on the library\" and a \"work that uses the library\". The" - , "former contains code derived from the library, whereas the latter must" - , "be combined with the library in order to run." - , "" - , " GNU LESSER GENERAL PUBLIC LICENSE" - , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" - , "" - , " 0. This License Agreement applies to any software library or other" - , "program which contains a notice placed by the copyright holder or" - , "other authorized party saying it may be distributed under the terms of" - , "this Lesser General Public License (also called \"this License\")." - , "Each licensee is addressed as \"you\"." - , "" - , " A \"library\" means a collection of software functions and/or data" - , "prepared so as to be conveniently linked with application programs" - , "(which use some of those functions and data) to form executables." - , "" - , " The \"Library\", below, refers to any such software library or work" - , "which has been distributed under these terms. A \"work based on the" - , "Library\" means either the Library or any derivative work under" - , "copyright law: that is to say, a work containing the Library or a" - , "portion of it, either verbatim or with modifications and/or translated" - , "straightforwardly into another language. (Hereinafter, translation is" - , "included without limitation in the term \"modification\".)" - , "" - , " \"Source code\" for a work means the preferred form of the work for" - , "making modifications to it. For a library, complete source code means" - , "all the source code for all modules it contains, plus any associated" - , "interface definition files, plus the scripts used to control compilation" - , "and installation of the library." - , "" - , " Activities other than copying, distribution and modification are not" - , "covered by this License; they are outside its scope. The act of" - , "running a program using the Library is not restricted, and output from" - , "such a program is covered only if its contents constitute a work based" - , "on the Library (independent of the use of the Library in a tool for" - , "writing it). Whether that is true depends on what the Library does" - , "and what the program that uses the Library does." - , "" - , " 1. You may copy and distribute verbatim copies of the Library's" - , "complete source code as you receive it, in any medium, provided that" - , "you conspicuously and appropriately publish on each copy an" - , "appropriate copyright notice and disclaimer of warranty; keep intact" - , "all the notices that refer to this License and to the absence of any" - , "warranty; and distribute a copy of this License along with the" - , "Library." - , "" - , " You may charge a fee for the physical act of transferring a copy," - , "and you may at your option offer warranty protection in exchange for a" - , "fee." - , "" - , " 2. You may modify your copy or copies of the Library or any portion" - , "of it, thus forming a work based on the Library, and copy and" - , "distribute such modifications or work under the terms of Section 1" - , "above, provided that you also meet all of these conditions:" - , "" - , " a) The modified work must itself be a software library." - , "" - , " b) You must cause the files modified to carry prominent notices" - , " stating that you changed the files and the date of any change." - , "" - , " c) You must cause the whole of the work to be licensed at no" - , " charge to all third parties under the terms of this License." - , "" - , " d) If a facility in the modified Library refers to a function or a" - , " table of data to be supplied by an application program that uses" - , " the facility, other than as an argument passed when the facility" - , " is invoked, then you must make a good faith effort to ensure that," - , " in the event an application does not supply such function or" - , " table, the facility still operates, and performs whatever part of" - , " its purpose remains meaningful." - , "" - , " (For example, a function in a library to compute square roots has" - , " a purpose that is entirely well-defined independent of the" - , " application. Therefore, Subsection 2d requires that any" - , " application-supplied function or table used by this function must" - , " be optional: if the application does not supply it, the square" - , " root function must still compute square roots.)" - , "" - , "These requirements apply to the modified work as a whole. If" - , "identifiable sections of that work are not derived from the Library," - , "and can be reasonably considered independent and separate works in" - , "themselves, then this License, and its terms, do not apply to those" - , "sections when you distribute them as separate works. But when you" - , "distribute the same sections as part of a whole which is a work based" - , "on the Library, the distribution of the whole must be on the terms of" - , "this License, whose permissions for other licensees extend to the" - , "entire whole, and thus to each and every part regardless of who wrote" - , "it." - , "" - , "Thus, it is not the intent of this section to claim rights or contest" - , "your rights to work written entirely by you; rather, the intent is to" - , "exercise the right to control the distribution of derivative or" - , "collective works based on the Library." - , "" - , "In addition, mere aggregation of another work not based on the Library" - , "with the Library (or with a work based on the Library) on a volume of" - , "a storage or distribution medium does not bring the other work under" - , "the scope of this License." - , "" - , " 3. You may opt to apply the terms of the ordinary GNU General Public" - , "License instead of this License to a given copy of the Library. To do" - , "this, you must alter all the notices that refer to this License, so" - , "that they refer to the ordinary GNU General Public License, version 2," - , "instead of to this License. (If a newer version than version 2 of the" - , "ordinary GNU General Public License has appeared, then you can specify" - , "that version instead if you wish.) Do not make any other change in" - , "these notices." - , "" - , " Once this change is made in a given copy, it is irreversible for" - , "that copy, so the ordinary GNU General Public License applies to all" - , "subsequent copies and derivative works made from that copy." - , "" - , " This option is useful when you wish to copy part of the code of" - , "the Library into a program that is not a library." - , "" - , " 4. You may copy and distribute the Library (or a portion or" - , "derivative of it, under Section 2) in object code or executable form" - , "under the terms of Sections 1 and 2 above provided that you accompany" - , "it with the complete corresponding machine-readable source code, which" - , "must be distributed under the terms of Sections 1 and 2 above on a" - , "medium customarily used for software interchange." - , "" - , " If distribution of object code is made by offering access to copy" - , "from a designated place, then offering equivalent access to copy the" - , "source code from the same place satisfies the requirement to" - , "distribute the source code, even though third parties are not" - , "compelled to copy the source along with the object code." - , "" - , " 5. A program that contains no derivative of any portion of the" - , "Library, but is designed to work with the Library by being compiled or" - , "linked with it, is called a \"work that uses the Library\". Such a" - , "work, in isolation, is not a derivative work of the Library, and" - , "therefore falls outside the scope of this License." - , "" - , " However, linking a \"work that uses the Library\" with the Library" - , "creates an executable that is a derivative of the Library (because it" - , "contains portions of the Library), rather than a \"work that uses the" - , "library\". The executable is therefore covered by this License." - , "Section 6 states terms for distribution of such executables." - , "" - , " When a \"work that uses the Library\" uses material from a header file" - , "that is part of the Library, the object code for the work may be a" - , "derivative work of the Library even though the source code is not." - , "Whether this is true is especially significant if the work can be" - , "linked without the Library, or if the work is itself a library. The" - , "threshold for this to be true is not precisely defined by law." - , "" - , " If such an object file uses only numerical parameters, data" - , "structure layouts and accessors, and small macros and small inline" - , "functions (ten lines or less in length), then the use of the object" - , "file is unrestricted, regardless of whether it is legally a derivative" - , "work. (Executables containing this object code plus portions of the" - , "Library will still fall under Section 6.)" - , "" - , " Otherwise, if the work is a derivative of the Library, you may" - , "distribute the object code for the work under the terms of Section 6." - , "Any executables containing that work also fall under Section 6," - , "whether or not they are linked directly with the Library itself." - , "" - , " 6. As an exception to the Sections above, you may also combine or" - , "link a \"work that uses the Library\" with the Library to produce a" - , "work containing portions of the Library, and distribute that work" - , "under terms of your choice, provided that the terms permit" - , "modification of the work for the customer's own use and reverse" - , "engineering for debugging such modifications." - , "" - , " You must give prominent notice with each copy of the work that the" - , "Library is used in it and that the Library and its use are covered by" - , "this License. You must supply a copy of this License. If the work" - , "during execution displays copyright notices, you must include the" - , "copyright notice for the Library among them, as well as a reference" - , "directing the user to the copy of this License. Also, you must do one" - , "of these things:" - , "" - , " a) Accompany the work with the complete corresponding" - , " machine-readable source code for the Library including whatever" - , " changes were used in the work (which must be distributed under" - , " Sections 1 and 2 above); and, if the work is an executable linked" - , " with the Library, with the complete machine-readable \"work that" - , " uses the Library\", as object code and/or source code, so that the" - , " user can modify the Library and then relink to produce a modified" - , " executable containing the modified Library. (It is understood" - , " that the user who changes the contents of definitions files in the" - , " Library will not necessarily be able to recompile the application" - , " to use the modified definitions.)" - , "" - , " b) Use a suitable shared library mechanism for linking with the" - , " Library. A suitable mechanism is one that (1) uses at run time a" - , " copy of the library already present on the user's computer system," - , " rather than copying library functions into the executable, and (2)" - , " will operate properly with a modified version of the library, if" - , " the user installs one, as long as the modified version is" - , " interface-compatible with the version that the work was made with." - , "" - , " c) Accompany the work with a written offer, valid for at" - , " least three years, to give the same user the materials" - , " specified in Subsection 6a, above, for a charge no more" - , " than the cost of performing this distribution." - , "" - , " d) If distribution of the work is made by offering access to copy" - , " from a designated place, offer equivalent access to copy the above" - , " specified materials from the same place." - , "" - , " e) Verify that the user has already received a copy of these" - , " materials or that you have already sent this user a copy." - , "" - , " For an executable, the required form of the \"work that uses the" - , "Library\" must include any data and utility programs needed for" - , "reproducing the executable from it. However, as a special exception," - , "the materials to be distributed need not include anything that is" - , "normally distributed (in either source or binary form) with the major" - , "components (compiler, kernel, and so on) of the operating system on" - , "which the executable runs, unless that component itself accompanies" - , "the executable." - , "" - , " It may happen that this requirement contradicts the license" - , "restrictions of other proprietary libraries that do not normally" - , "accompany the operating system. Such a contradiction means you cannot" - , "use both them and the Library together in an executable that you" - , "distribute." - , "" - , " 7. You may place library facilities that are a work based on the" - , "Library side-by-side in a single library together with other library" - , "facilities not covered by this License, and distribute such a combined" - , "library, provided that the separate distribution of the work based on" - , "the Library and of the other library facilities is otherwise" - , "permitted, and provided that you do these two things:" - , "" - , " a) Accompany the combined library with a copy of the same work" - , " based on the Library, uncombined with any other library" - , " facilities. This must be distributed under the terms of the" - , " Sections above." - , "" - , " b) Give prominent notice with the combined library of the fact" - , " that part of it is a work based on the Library, and explaining" - , " where to find the accompanying uncombined form of the same work." - , "" - , " 8. You may not copy, modify, sublicense, link with, or distribute" - , "the Library except as expressly provided under this License. Any" - , "attempt otherwise to copy, modify, sublicense, link with, or" - , "distribute the Library is void, and will automatically terminate your" - , "rights under this License. However, parties who have received copies," - , "or rights, from you under this License will not have their licenses" - , "terminated so long as such parties remain in full compliance." - , "" - , " 9. You are not required to accept this License, since you have not" - , "signed it. However, nothing else grants you permission to modify or" - , "distribute the Library or its derivative works. These actions are" - , "prohibited by law if you do not accept this License. Therefore, by" - , "modifying or distributing the Library (or any work based on the" - , "Library), you indicate your acceptance of this License to do so, and" - , "all its terms and conditions for copying, distributing or modifying" - , "the Library or works based on it." - , "" - , " 10. Each time you redistribute the Library (or any work based on the" - , "Library), the recipient automatically receives a license from the" - , "original licensor to copy, distribute, link with or modify the Library" - , "subject to these terms and conditions. You may not impose any further" - , "restrictions on the recipients' exercise of the rights granted herein." - , "You are not responsible for enforcing compliance by third parties with" - , "this License." - , "" - , " 11. If, as a consequence of a court judgment or allegation of patent" - , "infringement or for any other reason (not limited to patent issues)," - , "conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot" - , "distribute so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you" - , "may not distribute the Library at all. For example, if a patent" - , "license would not permit royalty-free redistribution of the Library by" - , "all those who receive copies directly or indirectly through you, then" - , "the only way you could satisfy both it and this License would be to" - , "refrain entirely from distribution of the Library." - , "" - , "If any portion of this section is held invalid or unenforceable under any" - , "particular circumstance, the balance of the section is intended to apply," - , "and the section as a whole is intended to apply in other circumstances." - , "" - , "It is not the purpose of this section to induce you to infringe any" - , "patents or other property right claims or to contest validity of any" - , "such claims; this section has the sole purpose of protecting the" - , "integrity of the free software distribution system which is" - , "implemented by public license practices. Many people have made" - , "generous contributions to the wide range of software distributed" - , "through that system in reliance on consistent application of that" - , "system; it is up to the author/donor to decide if he or she is willing" - , "to distribute software through any other system and a licensee cannot" - , "impose that choice." - , "" - , "This section is intended to make thoroughly clear what is believed to" - , "be a consequence of the rest of this License." - , "" - , " 12. If the distribution and/or use of the Library is restricted in" - , "certain countries either by patents or by copyrighted interfaces, the" - , "original copyright holder who places the Library under this License may add" - , "an explicit geographical distribution limitation excluding those countries," - , "so that distribution is permitted only in or among countries not thus" - , "excluded. In such case, this License incorporates the limitation as if" - , "written in the body of this License." - , "" - , " 13. The Free Software Foundation may publish revised and/or new" - , "versions of the Lesser General Public License from time to time." - , "Such new versions will be similar in spirit to the present version," - , "but may differ in detail to address new problems or concerns." - , "" - , "Each version is given a distinguishing version number. If the Library" - , "specifies a version number of this License which applies to it and" - , "\"any later version\", you have the option of following the terms and" - , "conditions either of that version or of any later version published by" - , "the Free Software Foundation. If the Library does not specify a" - , "license version number, you may choose any version ever published by" - , "the Free Software Foundation." - , "" - , " 14. If you wish to incorporate parts of the Library into other free" - , "programs whose distribution conditions are incompatible with these," - , "write to the author to ask for permission. For software which is" - , "copyrighted by the Free Software Foundation, write to the Free" - , "Software Foundation; we sometimes make exceptions for this. Our" - , "decision will be guided by the two goals of preserving the free status" - , "of all derivatives of our free software and of promoting the sharing" - , "and reuse of software generally." - , "" - , " NO WARRANTY" - , "" - , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" - , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." - , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" - , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" - , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" - , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" - , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" - , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" - , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" - , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" - , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" - , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" - , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" - , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" - , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" - , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" - , "DAMAGES." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Libraries" - , "" - , " If you develop a new library, and you want it to be of the greatest" - , "possible use to the public, we recommend making it free software that" - , "everyone can redistribute and change. You can do so by permitting" - , "redistribution under these terms (or, alternatively, under the terms of the" - , "ordinary General Public License)." - , "" - , " To apply these terms, attach the following notices to the library. It is" - , "safest to attach them to the start of each source file to most effectively" - , "convey the exclusion of warranty; and each file should have at least the" - , "\"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This library is free software; you can redistribute it and/or" - , " modify it under the terms of the GNU Lesser General Public" - , " License as published by the Free Software Foundation; either" - , " version 2.1 of the License, or (at your option) any later version." - , "" - , " This library is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" - , " Lesser General Public License for more details." - , "" - , " You should have received a copy of the GNU Lesser General Public" - , " License along with this library; if not, write to the Free Software" - , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , "You should also get your employer (if you work as a programmer) or your" - , "school, if any, to sign a \"copyright disclaimer\" for the library, if" - , "necessary. Here is a sample; alter the names:" - , "" - , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" - , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." - , "" - , " , 1 April 1990" - , " Ty Coon, President of Vice" - , "" - , "That's all there is to it!" - ] - -lgpl3 :: License -lgpl3 = unlines - [ " GNU LESSER GENERAL PUBLIC LICENSE" - , " Version 3, 29 June 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , "" - , " This version of the GNU Lesser General Public License incorporates" - , "the terms and conditions of version 3 of the GNU General Public" - , "License, supplemented by the additional permissions listed below." - , "" - , " 0. Additional Definitions." - , "" - , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" - , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" - , "General Public License." - , "" - , " \"The Library\" refers to a covered work governed by this License," - , "other than an Application or a Combined Work as defined below." - , "" - , " An \"Application\" is any work that makes use of an interface provided" - , "by the Library, but which is not otherwise based on the Library." - , "Defining a subclass of a class defined by the Library is deemed a mode" - , "of using an interface provided by the Library." - , "" - , " A \"Combined Work\" is a work produced by combining or linking an" - , "Application with the Library. The particular version of the Library" - , "with which the Combined Work was made is also called the \"Linked" - , "Version\"." - , "" - , " The \"Minimal Corresponding Source\" for a Combined Work means the" - , "Corresponding Source for the Combined Work, excluding any source code" - , "for portions of the Combined Work that, considered in isolation, are" - , "based on the Application, and not on the Linked Version." - , "" - , " The \"Corresponding Application Code\" for a Combined Work means the" - , "object code and/or source code for the Application, including any data" - , "and utility programs needed for reproducing the Combined Work from the" - , "Application, but excluding the System Libraries of the Combined Work." - , "" - , " 1. Exception to Section 3 of the GNU GPL." - , "" - , " You may convey a covered work under sections 3 and 4 of this License" - , "without being bound by section 3 of the GNU GPL." - , "" - , " 2. Conveying Modified Versions." - , "" - , " If you modify a copy of the Library, and, in your modifications, a" - , "facility refers to a function or data to be supplied by an Application" - , "that uses the facility (other than as an argument passed when the" - , "facility is invoked), then you may convey a copy of the modified" - , "version:" - , "" - , " a) under this License, provided that you make a good faith effort to" - , " ensure that, in the event an Application does not supply the" - , " function or data, the facility still operates, and performs" - , " whatever part of its purpose remains meaningful, or" - , "" - , " b) under the GNU GPL, with none of the additional permissions of" - , " this License applicable to that copy." - , "" - , " 3. Object Code Incorporating Material from Library Header Files." - , "" - , " The object code form of an Application may incorporate material from" - , "a header file that is part of the Library. You may convey such object" - , "code under terms of your choice, provided that, if the incorporated" - , "material is not limited to numerical parameters, data structure" - , "layouts and accessors, or small macros, inline functions and templates" - , "(ten or fewer lines in length), you do both of the following:" - , "" - , " a) Give prominent notice with each copy of the object code that the" - , " Library is used in it and that the Library and its use are" - , " covered by this License." - , "" - , " b) Accompany the object code with a copy of the GNU GPL and this license" - , " document." - , "" - , " 4. Combined Works." - , "" - , " You may convey a Combined Work under terms of your choice that," - , "taken together, effectively do not restrict modification of the" - , "portions of the Library contained in the Combined Work and reverse" - , "engineering for debugging such modifications, if you also do each of" - , "the following:" - , "" - , " a) Give prominent notice with each copy of the Combined Work that" - , " the Library is used in it and that the Library and its use are" - , " covered by this License." - , "" - , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" - , " document." - , "" - , " c) For a Combined Work that displays copyright notices during" - , " execution, include the copyright notice for the Library among" - , " these notices, as well as a reference directing the user to the" - , " copies of the GNU GPL and this license document." - , "" - , " d) Do one of the following:" - , "" - , " 0) Convey the Minimal Corresponding Source under the terms of this" - , " License, and the Corresponding Application Code in a form" - , " suitable for, and under terms that permit, the user to" - , " recombine or relink the Application with a modified version of" - , " the Linked Version to produce a modified Combined Work, in the" - , " manner specified by section 6 of the GNU GPL for conveying" - , " Corresponding Source." - , "" - , " 1) Use a suitable shared library mechanism for linking with the" - , " Library. A suitable mechanism is one that (a) uses at run time" - , " a copy of the Library already present on the user's computer" - , " system, and (b) will operate properly with a modified version" - , " of the Library that is interface-compatible with the Linked" - , " Version." - , "" - , " e) Provide Installation Information, but only if you would otherwise" - , " be required to provide such information under section 6 of the" - , " GNU GPL, and only to the extent that such information is" - , " necessary to install and execute a modified version of the" - , " Combined Work produced by recombining or relinking the" - , " Application with a modified version of the Linked Version. (If" - , " you use option 4d0, the Installation Information must accompany" - , " the Minimal Corresponding Source and Corresponding Application" - , " Code. If you use option 4d1, you must provide the Installation" - , " Information in the manner specified by section 6 of the GNU GPL" - , " for conveying Corresponding Source.)" - , "" - , " 5. Combined Libraries." - , "" - , " You may place library facilities that are a work based on the" - , "Library side by side in a single library together with other library" - , "facilities that are not Applications and are not covered by this" - , "License, and convey such a combined library under terms of your" - , "choice, if you do both of the following:" - , "" - , " a) Accompany the combined library with a copy of the same work based" - , " on the Library, uncombined with any other library facilities," - , " conveyed under the terms of this License." - , "" - , " b) Give prominent notice with the combined library that part of it" - , " is a work based on the Library, and explaining where to find the" - , " accompanying uncombined form of the same work." - , "" - , " 6. Revised Versions of the GNU Lesser General Public License." - , "" - , " The Free Software Foundation may publish revised and/or new versions" - , "of the GNU Lesser General Public License from time to time. Such new" - , "versions will be similar in spirit to the present version, but may" - , "differ in detail to address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Library as you received it specifies that a certain numbered version" - , "of the GNU Lesser General Public License \"or any later version\"" - , "applies to it, you have the option of following the terms and" - , "conditions either of that published version or of any later version" - , "published by the Free Software Foundation. If the Library as you" - , "received it does not specify a version number of the GNU Lesser" - , "General Public License, you may choose any version of the GNU Lesser" - , "General Public License ever published by the Free Software Foundation." - , "" - , " If the Library as you received it specifies that a proxy can decide" - , "whether future versions of the GNU Lesser General Public License shall" - , "apply, that proxy's public statement of acceptance of any version is" - , "permanent authorization for you to choose that version for the" - , "Library." - ] - -apache20 :: License -apache20 = unlines - [ "" - , " Apache License" - , " Version 2.0, January 2004" - , " http://www.apache.org/licenses/" - , "" - , " TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION" - , "" - , " 1. Definitions." - , "" - , " \"License\" shall mean the terms and conditions for use, reproduction," - , " and distribution as defined by Sections 1 through 9 of this document." - , "" - , " \"Licensor\" shall mean the copyright owner or entity authorized by" - , " the copyright owner that is granting the License." - , "" - , " \"Legal Entity\" shall mean the union of the acting entity and all" - , " other entities that control, are controlled by, or are under common" - , " control with that entity. For the purposes of this definition," - , " \"control\" means (i) the power, direct or indirect, to cause the" - , " direction or management of such entity, whether by contract or" - , " otherwise, or (ii) ownership of fifty percent (50%) or more of the" - , " outstanding shares, or (iii) beneficial ownership of such entity." - , "" - , " \"You\" (or \"Your\") shall mean an individual or Legal Entity" - , " exercising permissions granted by this License." - , "" - , " \"Source\" form shall mean the preferred form for making modifications," - , " including but not limited to software source code, documentation" - , " source, and configuration files." - , "" - , " \"Object\" form shall mean any form resulting from mechanical" - , " transformation or translation of a Source form, including but" - , " not limited to compiled object code, generated documentation," - , " and conversions to other media types." - , "" - , " \"Work\" shall mean the work of authorship, whether in Source or" - , " Object form, made available under the License, as indicated by a" - , " copyright notice that is included in or attached to the work" - , " (an example is provided in the Appendix below)." - , "" - , " \"Derivative Works\" shall mean any work, whether in Source or Object" - , " form, that is based on (or derived from) the Work and for which the" - , " editorial revisions, annotations, elaborations, or other modifications" - , " represent, as a whole, an original work of authorship. For the purposes" - , " of this License, Derivative Works shall not include works that remain" - , " separable from, or merely link (or bind by name) to the interfaces of," - , " the Work and Derivative Works thereof." - , "" - , " \"Contribution\" shall mean any work of authorship, including" - , " the original version of the Work and any modifications or additions" - , " to that Work or Derivative Works thereof, that is intentionally" - , " submitted to Licensor for inclusion in the Work by the copyright owner" - , " or by an individual or Legal Entity authorized to submit on behalf of" - , " the copyright owner. For the purposes of this definition, \"submitted\"" - , " means any form of electronic, verbal, or written communication sent" - , " to the Licensor or its representatives, including but not limited to" - , " communication on electronic mailing lists, source code control systems," - , " and issue tracking systems that are managed by, or on behalf of, the" - , " Licensor for the purpose of discussing and improving the Work, but" - , " excluding communication that is conspicuously marked or otherwise" - , " designated in writing by the copyright owner as \"Not a Contribution.\"" - , "" - , " \"Contributor\" shall mean Licensor and any individual or Legal Entity" - , " on behalf of whom a Contribution has been received by Licensor and" - , " subsequently incorporated within the Work." - , "" - , " 2. Grant of Copyright License. Subject to the terms and conditions of" - , " this License, each Contributor hereby grants to You a perpetual," - , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" - , " copyright license to reproduce, prepare Derivative Works of," - , " publicly display, publicly perform, sublicense, and distribute the" - , " Work and such Derivative Works in Source or Object form." - , "" - , " 3. Grant of Patent License. Subject to the terms and conditions of" - , " this License, each Contributor hereby grants to You a perpetual," - , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" - , " (except as stated in this section) patent license to make, have made," - , " use, offer to sell, sell, import, and otherwise transfer the Work," - , " where such license applies only to those patent claims licensable" - , " by such Contributor that are necessarily infringed by their" - , " Contribution(s) alone or by combination of their Contribution(s)" - , " with the Work to which such Contribution(s) was submitted. If You" - , " institute patent litigation against any entity (including a" - , " cross-claim or counterclaim in a lawsuit) alleging that the Work" - , " or a Contribution incorporated within the Work constitutes direct" - , " or contributory patent infringement, then any patent licenses" - , " granted to You under this License for that Work shall terminate" - , " as of the date such litigation is filed." - , "" - , " 4. Redistribution. You may reproduce and distribute copies of the" - , " Work or Derivative Works thereof in any medium, with or without" - , " modifications, and in Source or Object form, provided that You" - , " meet the following conditions:" - , "" - , " (a) You must give any other recipients of the Work or" - , " Derivative Works a copy of this License; and" - , "" - , " (b) You must cause any modified files to carry prominent notices" - , " stating that You changed the files; and" - , "" - , " (c) You must retain, in the Source form of any Derivative Works" - , " that You distribute, all copyright, patent, trademark, and" - , " attribution notices from the Source form of the Work," - , " excluding those notices that do not pertain to any part of" - , " the Derivative Works; and" - , "" - , " (d) If the Work includes a \"NOTICE\" text file as part of its" - , " distribution, then any Derivative Works that You distribute must" - , " include a readable copy of the attribution notices contained" - , " within such NOTICE file, excluding those notices that do not" - , " pertain to any part of the Derivative Works, in at least one" - , " of the following places: within a NOTICE text file distributed" - , " as part of the Derivative Works; within the Source form or" - , " documentation, if provided along with the Derivative Works; or," - , " within a display generated by the Derivative Works, if and" - , " wherever such third-party notices normally appear. The contents" - , " of the NOTICE file are for informational purposes only and" - , " do not modify the License. You may add Your own attribution" - , " notices within Derivative Works that You distribute, alongside" - , " or as an addendum to the NOTICE text from the Work, provided" - , " that such additional attribution notices cannot be construed" - , " as modifying the License." - , "" - , " You may add Your own copyright statement to Your modifications and" - , " may provide additional or different license terms and conditions" - , " for use, reproduction, or distribution of Your modifications, or" - , " for any such Derivative Works as a whole, provided Your use," - , " reproduction, and distribution of the Work otherwise complies with" - , " the conditions stated in this License." - , "" - , " 5. Submission of Contributions. Unless You explicitly state otherwise," - , " any Contribution intentionally submitted for inclusion in the Work" - , " by You to the Licensor shall be under the terms and conditions of" - , " this License, without any additional terms or conditions." - , " Notwithstanding the above, nothing herein shall supersede or modify" - , " the terms of any separate license agreement you may have executed" - , " with Licensor regarding such Contributions." - , "" - , " 6. Trademarks. This License does not grant permission to use the trade" - , " names, trademarks, service marks, or product names of the Licensor," - , " except as required for reasonable and customary use in describing the" - , " origin of the Work and reproducing the content of the NOTICE file." - , "" - , " 7. Disclaimer of Warranty. Unless required by applicable law or" - , " agreed to in writing, Licensor provides the Work (and each" - , " Contributor provides its Contributions) on an \"AS IS\" BASIS," - , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or" - , " implied, including, without limitation, any warranties or conditions" - , " of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A" - , " PARTICULAR PURPOSE. You are solely responsible for determining the" - , " appropriateness of using or redistributing the Work and assume any" - , " risks associated with Your exercise of permissions under this License." - , "" - , " 8. Limitation of Liability. In no event and under no legal theory," - , " whether in tort (including negligence), contract, or otherwise," - , " unless required by applicable law (such as deliberate and grossly" - , " negligent acts) or agreed to in writing, shall any Contributor be" - , " liable to You for damages, including any direct, indirect, special," - , " incidental, or consequential damages of any character arising as a" - , " result of this License or out of the use or inability to use the" - , " Work (including but not limited to damages for loss of goodwill," - , " work stoppage, computer failure or malfunction, or any and all" - , " other commercial damages or losses), even if such Contributor" - , " has been advised of the possibility of such damages." - , "" - , " 9. Accepting Warranty or Additional Liability. While redistributing" - , " the Work or Derivative Works thereof, You may choose to offer," - , " and charge a fee for, acceptance of support, warranty, indemnity," - , " or other liability obligations and/or rights consistent with this" - , " License. However, in accepting such obligations, You may act only" - , " on Your own behalf and on Your sole responsibility, not on behalf" - , " of any other Contributor, and only if You agree to indemnify," - , " defend, and hold each Contributor harmless for any liability" - , " incurred by, or claims asserted against, such Contributor by reason" - , " of your accepting any such warranty or additional liability." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " APPENDIX: How to apply the Apache License to your work." - , "" - , " To apply the Apache License to your work, attach the following" - , " boilerplate notice, with the fields enclosed by brackets \"[]\"" - , " replaced with your own identifying information. (Don't include" - , " the brackets!) The text should be enclosed in the appropriate" - , " comment syntax for the file format. We also recommend that a" - , " file or class name and description of purpose be included on the" - , " same \"printed page\" as the copyright notice for easier" - , " identification within third-party archives." - , "" - , " Copyright [yyyy] [name of copyright owner]" - , "" - , " Licensed under the Apache License, Version 2.0 (the \"License\");" - , " you may not use this file except in compliance with the License." - , " You may obtain a copy of the License at" - , "" - , " http://www.apache.org/licenses/LICENSE-2.0" - , "" - , " Unless required by applicable law or agreed to in writing, software" - , " distributed under the License is distributed on an \"AS IS\" BASIS," - , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied." - , " See the License for the specific language governing permissions and" - , " limitations under the License." - ] - -mit :: String -> String -> License -mit authors year = unlines - [ "Copyright (c) " ++ year ++ " " ++ authors - , "" - , "Permission is hereby granted, free of charge, to any person obtaining" - , "a copy of this software and associated documentation files (the" - , "\"Software\"), to deal in the Software without restriction, including" - , "without limitation the rights to use, copy, modify, merge, publish," - , "distribute, sublicense, and/or sell copies of the Software, and to" - , "permit persons to whom the Software is furnished to do so, subject to" - , "the following conditions:" - , "" - , "The above copyright notice and this permission notice shall be included" - , "in all copies or substantial portions of the Software." - , "" - , "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND," - , "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF" - , "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT." - , "IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY" - , "CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT," - , "TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE" - , "SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE." - ] - -mpl20 :: License -mpl20 = unlines - [ "Mozilla Public License Version 2.0" - , "==================================" - , "" - , "1. Definitions" - , "--------------" - , "" - , "1.1. \"Contributor\"" - , " means each individual or legal entity that creates, contributes to" - , " the creation of, or owns Covered Software." - , "" - , "1.2. \"Contributor Version\"" - , " means the combination of the Contributions of others (if any) used" - , " by a Contributor and that particular Contributor's Contribution." - , "" - , "1.3. \"Contribution\"" - , " means Covered Software of a particular Contributor." - , "" - , "1.4. \"Covered Software\"" - , " means Source Code Form to which the initial Contributor has attached" - , " the notice in Exhibit A, the Executable Form of such Source Code" - , " Form, and Modifications of such Source Code Form, in each case" - , " including portions thereof." - , "" - , "1.5. \"Incompatible With Secondary Licenses\"" - , " means" - , "" - , " (a) that the initial Contributor has attached the notice described" - , " in Exhibit B to the Covered Software; or" - , "" - , " (b) that the Covered Software was made available under the terms of" - , " version 1.1 or earlier of the License, but not also under the" - , " terms of a Secondary License." - , "" - , "1.6. \"Executable Form\"" - , " means any form of the work other than Source Code Form." - , "" - , "1.7. \"Larger Work\"" - , " means a work that combines Covered Software with other material, in" - , " a separate file or files, that is not Covered Software." - , "" - , "1.8. \"License\"" - , " means this document." - , "" - , "1.9. \"Licensable\"" - , " means having the right to grant, to the maximum extent possible," - , " whether at the time of the initial grant or subsequently, any and" - , " all of the rights conveyed by this License." - , "" - , "1.10. \"Modifications\"" - , " means any of the following:" - , "" - , " (a) any file in Source Code Form that results from an addition to," - , " deletion from, or modification of the contents of Covered" - , " Software; or" - , "" - , " (b) any new file in Source Code Form that contains any Covered" - , " Software." - , "" - , "1.11. \"Patent Claims\" of a Contributor" - , " means any patent claim(s), including without limitation, method," - , " process, and apparatus claims, in any patent Licensable by such" - , " Contributor that would be infringed, but for the grant of the" - , " License, by the making, using, selling, offering for sale, having" - , " made, import, or transfer of either its Contributions or its" - , " Contributor Version." - , "" - , "1.12. \"Secondary License\"" - , " means either the GNU General Public License, Version 2.0, the GNU" - , " Lesser General Public License, Version 2.1, the GNU Affero General" - , " Public License, Version 3.0, or any later versions of those" - , " licenses." - , "" - , "1.13. \"Source Code Form\"" - , " means the form of the work preferred for making modifications." - , "" - , "1.14. \"You\" (or \"Your\")" - , " means an individual or a legal entity exercising rights under this" - , " License. For legal entities, \"You\" includes any entity that" - , " controls, is controlled by, or is under common control with You. For" - , " purposes of this definition, \"control\" means (a) the power, direct" - , " or indirect, to cause the direction or management of such entity," - , " whether by contract or otherwise, or (b) ownership of more than" - , " fifty percent (50%) of the outstanding shares or beneficial" - , " ownership of such entity." - , "" - , "2. License Grants and Conditions" - , "--------------------------------" - , "" - , "2.1. Grants" - , "" - , "Each Contributor hereby grants You a world-wide, royalty-free," - , "non-exclusive license:" - , "" - , "(a) under intellectual property rights (other than patent or trademark)" - , " Licensable by such Contributor to use, reproduce, make available," - , " modify, display, perform, distribute, and otherwise exploit its" - , " Contributions, either on an unmodified basis, with Modifications, or" - , " as part of a Larger Work; and" - , "" - , "(b) under Patent Claims of such Contributor to make, use, sell, offer" - , " for sale, have made, import, and otherwise transfer either its" - , " Contributions or its Contributor Version." - , "" - , "2.2. Effective Date" - , "" - , "The licenses granted in Section 2.1 with respect to any Contribution" - , "become effective for each Contribution on the date the Contributor first" - , "distributes such Contribution." - , "" - , "2.3. Limitations on Grant Scope" - , "" - , "The licenses granted in this Section 2 are the only rights granted under" - , "this License. No additional rights or licenses will be implied from the" - , "distribution or licensing of Covered Software under this License." - , "Notwithstanding Section 2.1(b) above, no patent license is granted by a" - , "Contributor:" - , "" - , "(a) for any code that a Contributor has removed from Covered Software;" - , " or" - , "" - , "(b) for infringements caused by: (i) Your and any other third party's" - , " modifications of Covered Software, or (ii) the combination of its" - , " Contributions with other software (except as part of its Contributor" - , " Version); or" - , "" - , "(c) under Patent Claims infringed by Covered Software in the absence of" - , " its Contributions." - , "" - , "This License does not grant any rights in the trademarks, service marks," - , "or logos of any Contributor (except as may be necessary to comply with" - , "the notice requirements in Section 3.4)." - , "" - , "2.4. Subsequent Licenses" - , "" - , "No Contributor makes additional grants as a result of Your choice to" - , "distribute the Covered Software under a subsequent version of this" - , "License (see Section 10.2) or under the terms of a Secondary License (if" - , "permitted under the terms of Section 3.3)." - , "" - , "2.5. Representation" - , "" - , "Each Contributor represents that the Contributor believes its" - , "Contributions are its original creation(s) or it has sufficient rights" - , "to grant the rights to its Contributions conveyed by this License." - , "" - , "2.6. Fair Use" - , "" - , "This License is not intended to limit any rights You have under" - , "applicable copyright doctrines of fair use, fair dealing, or other" - , "equivalents." - , "" - , "2.7. Conditions" - , "" - , "Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted" - , "in Section 2.1." - , "" - , "3. Responsibilities" - , "-------------------" - , "" - , "3.1. Distribution of Source Form" - , "" - , "All distribution of Covered Software in Source Code Form, including any" - , "Modifications that You create or to which You contribute, must be under" - , "the terms of this License. You must inform recipients that the Source" - , "Code Form of the Covered Software is governed by the terms of this" - , "License, and how they can obtain a copy of this License. You may not" - , "attempt to alter or restrict the recipients' rights in the Source Code" - , "Form." - , "" - , "3.2. Distribution of Executable Form" - , "" - , "If You distribute Covered Software in Executable Form then:" - , "" - , "(a) such Covered Software must also be made available in Source Code" - , " Form, as described in Section 3.1, and You must inform recipients of" - , " the Executable Form how they can obtain a copy of such Source Code" - , " Form by reasonable means in a timely manner, at a charge no more" - , " than the cost of distribution to the recipient; and" - , "" - , "(b) You may distribute such Executable Form under the terms of this" - , " License, or sublicense it under different terms, provided that the" - , " license for the Executable Form does not attempt to limit or alter" - , " the recipients' rights in the Source Code Form under this License." - , "" - , "3.3. Distribution of a Larger Work" - , "" - , "You may create and distribute a Larger Work under terms of Your choice," - , "provided that You also comply with the requirements of this License for" - , "the Covered Software. If the Larger Work is a combination of Covered" - , "Software with a work governed by one or more Secondary Licenses, and the" - , "Covered Software is not Incompatible With Secondary Licenses, this" - , "License permits You to additionally distribute such Covered Software" - , "under the terms of such Secondary License(s), so that the recipient of" - , "the Larger Work may, at their option, further distribute the Covered" - , "Software under the terms of either this License or such Secondary" - , "License(s)." - , "" - , "3.4. Notices" - , "" - , "You may not remove or alter the substance of any license notices" - , "(including copyright notices, patent notices, disclaimers of warranty," - , "or limitations of liability) contained within the Source Code Form of" - , "the Covered Software, except that You may alter any license notices to" - , "the extent required to remedy known factual inaccuracies." - , "" - , "3.5. Application of Additional Terms" - , "" - , "You may choose to offer, and to charge a fee for, warranty, support," - , "indemnity or liability obligations to one or more recipients of Covered" - , "Software. However, You may do so only on Your own behalf, and not on" - , "behalf of any Contributor. You must make it absolutely clear that any" - , "such warranty, support, indemnity, or liability obligation is offered by" - , "You alone, and You hereby agree to indemnify every Contributor for any" - , "liability incurred by such Contributor as a result of warranty, support," - , "indemnity or liability terms You offer. You may include additional" - , "disclaimers of warranty and limitations of liability specific to any" - , "jurisdiction." - , "" - , "4. Inability to Comply Due to Statute or Regulation" - , "---------------------------------------------------" - , "" - , "If it is impossible for You to comply with any of the terms of this" - , "License with respect to some or all of the Covered Software due to" - , "statute, judicial order, or regulation then You must: (a) comply with" - , "the terms of this License to the maximum extent possible; and (b)" - , "describe the limitations and the code they affect. Such description must" - , "be placed in a text file included with all distributions of the Covered" - , "Software under this License. Except to the extent prohibited by statute" - , "or regulation, such description must be sufficiently detailed for a" - , "recipient of ordinary skill to be able to understand it." - , "" - , "5. Termination" - , "--------------" - , "" - , "5.1. The rights granted under this License will terminate automatically" - , "if You fail to comply with any of its terms. However, if You become" - , "compliant, then the rights granted under this License from a particular" - , "Contributor are reinstated (a) provisionally, unless and until such" - , "Contributor explicitly and finally terminates Your grants, and (b) on an" - , "ongoing basis, if such Contributor fails to notify You of the" - , "non-compliance by some reasonable means prior to 60 days after You have" - , "come back into compliance. Moreover, Your grants from a particular" - , "Contributor are reinstated on an ongoing basis if such Contributor" - , "notifies You of the non-compliance by some reasonable means, this is the" - , "first time You have received notice of non-compliance with this License" - , "from such Contributor, and You become compliant prior to 30 days after" - , "Your receipt of the notice." - , "" - , "5.2. If You initiate litigation against any entity by asserting a patent" - , "infringement claim (excluding declaratory judgment actions," - , "counter-claims, and cross-claims) alleging that a Contributor Version" - , "directly or indirectly infringes any patent, then the rights granted to" - , "You by any and all Contributors for the Covered Software under Section" - , "2.1 of this License shall terminate." - , "" - , "5.3. In the event of termination under Sections 5.1 or 5.2 above, all" - , "end user license agreements (excluding distributors and resellers) which" - , "have been validly granted by You or Your distributors under this License" - , "prior to termination shall survive termination." - , "" - , "************************************************************************" - , "* *" - , "* 6. Disclaimer of Warranty *" - , "* ------------------------- *" - , "* *" - , "* Covered Software is provided under this License on an \"as is\" *" - , "* basis, without warranty of any kind, either expressed, implied, or *" - , "* statutory, including, without limitation, warranties that the *" - , "* Covered Software is free of defects, merchantable, fit for a *" - , "* particular purpose or non-infringing. The entire risk as to the *" - , "* quality and performance of the Covered Software is with You. *" - , "* Should any Covered Software prove defective in any respect, You *" - , "* (not any Contributor) assume the cost of any necessary servicing, *" - , "* repair, or correction. This disclaimer of warranty constitutes an *" - , "* essential part of this License. No use of any Covered Software is *" - , "* authorized under this License except under this disclaimer. *" - , "* *" - , "************************************************************************" - , "" - , "************************************************************************" - , "* *" - , "* 7. Limitation of Liability *" - , "* -------------------------- *" - , "* *" - , "* Under no circumstances and under no legal theory, whether tort *" - , "* (including negligence), contract, or otherwise, shall any *" - , "* Contributor, or anyone who distributes Covered Software as *" - , "* permitted above, be liable to You for any direct, indirect, *" - , "* special, incidental, or consequential damages of any character *" - , "* including, without limitation, damages for lost profits, loss of *" - , "* goodwill, work stoppage, computer failure or malfunction, or any *" - , "* and all other commercial damages or losses, even if such party *" - , "* shall have been informed of the possibility of such damages. This *" - , "* limitation of liability shall not apply to liability for death or *" - , "* personal injury resulting from such party's negligence to the *" - , "* extent applicable law prohibits such limitation. Some *" - , "* jurisdictions do not allow the exclusion or limitation of *" - , "* incidental or consequential damages, so this exclusion and *" - , "* limitation may not apply to You. *" - , "* *" - , "************************************************************************" - , "" - , "8. Litigation" - , "-------------" - , "" - , "Any litigation relating to this License may be brought only in the" - , "courts of a jurisdiction where the defendant maintains its principal" - , "place of business and such litigation shall be governed by laws of that" - , "jurisdiction, without reference to its conflict-of-law provisions." - , "Nothing in this Section shall prevent a party's ability to bring" - , "cross-claims or counter-claims." - , "" - , "9. Miscellaneous" - , "----------------" - , "" - , "This License represents the complete agreement concerning the subject" - , "matter hereof. If any provision of this License is held to be" - , "unenforceable, such provision shall be reformed only to the extent" - , "necessary to make it enforceable. Any law or regulation which provides" - , "that the language of a contract shall be construed against the drafter" - , "shall not be used to construe this License against a Contributor." - , "" - , "10. Versions of the License" - , "---------------------------" - , "" - , "10.1. New Versions" - , "" - , "Mozilla Foundation is the license steward. Except as provided in Section" - , "10.3, no one other than the license steward has the right to modify or" - , "publish new versions of this License. Each version will be given a" - , "distinguishing version number." - , "" - , "10.2. Effect of New Versions" - , "" - , "You may distribute the Covered Software under the terms of the version" - , "of the License under which You originally received the Covered Software," - , "or under the terms of any subsequent version published by the license" - , "steward." - , "" - , "10.3. Modified Versions" - , "" - , "If you create software not governed by this License, and you want to" - , "create a new license for such software, you may create and use a" - , "modified version of this License if you rename the license and remove" - , "any references to the name of the license steward (except to note that" - , "such modified license differs from this License)." - , "" - , "10.4. Distributing Source Code Form that is Incompatible With Secondary" - , "Licenses" - , "" - , "If You choose to distribute Source Code Form that is Incompatible With" - , "Secondary Licenses under the terms of this version of the License, the" - , "notice described in Exhibit B of this License must be attached." - , "" - , "Exhibit A - Source Code Form License Notice" - , "-------------------------------------------" - , "" - , " This Source Code Form is subject to the terms of the Mozilla Public" - , " License, v. 2.0. If a copy of the MPL was not distributed with this" - , " file, You can obtain one at http://mozilla.org/MPL/2.0/." - , "" - , "If it is not possible or desirable to put the notice in a particular" - , "file, then You may include the notice in a location (such as a LICENSE" - , "file in a relevant directory) where a recipient would be likely to look" - , "for such a notice." - , "" - , "You may add additional accurate notices of copyright ownership." - , "" - , "Exhibit B - \"Incompatible With Secondary Licenses\" Notice" - , "---------------------------------------------------------" - , "" - , " This Source Code Form is \"Incompatible With Secondary Licenses\", as" - , " defined by the Mozilla Public License, v. 2.0." - ] - -isc :: String -> String -> License -isc authors year = unlines - [ "Copyright (c) " ++ year ++ " " ++ authors - , "" - , "Permission to use, copy, modify, and/or distribute this software for any purpose" - , "with or without fee is hereby granted, provided that the above copyright notice" - , "and this permission notice appear in all copies." - , "" - , "THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH" - , "REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND" - , "FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT," - , "INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS" - , "OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER" - , "TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF" - , "THIS SOFTWARE." - ] diff --git a/Distribution/Client/Init/Prompt.hs b/Distribution/Client/Init/Prompt.hs deleted file mode 100644 --- a/Distribution/Client/Init/Prompt.hs +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Prompt --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- User prompt utility functions for use by the 'cabal init' command. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Prompt ( - - -- * Commands - prompt - , promptYesNo - , promptStr - , promptList - , promptListOptional - , maybePrompt - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (empty) - -import Distribution.Client.Init.Types - ( InitFlags(..) ) -import Distribution.Simple.Setup - ( Flag(..) ) - - --- | Run a prompt or not based on the interactive flag of the --- InitFlags structure. -maybePrompt :: InitFlags -> IO t -> IO (Maybe t) -maybePrompt flags p = - case interactive flags of - Flag True -> Just `fmap` p - _ -> return Nothing - --- | Create a prompt with optional default value that returns a --- String. -promptStr :: String -> Maybe String -> IO String -promptStr = promptDefault' Just id - --- | Create a yes/no prompt with optional default value. -promptYesNo :: String -- ^ prompt message - -> Maybe Bool -- ^ optional default value - -> IO Bool -promptYesNo = - promptDefault' recogniseYesNo showYesNo - where - recogniseYesNo s | s == "y" || s == "Y" = Just True - | s == "n" || s == "N" = Just False - | otherwise = Nothing - showYesNo True = "y" - showYesNo False = "n" - --- | Create a prompt with optional default value that returns a value --- of some Text instance. -prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t -prompt = promptDefault' simpleParsec prettyShow - --- | Create a prompt with an optional default value. -promptDefault' :: (String -> Maybe t) -- ^ parser - -> (t -> String) -- ^ pretty-printer - -> String -- ^ prompt message - -> Maybe t -- ^ optional default value - -> IO t -promptDefault' parser ppr pr def = do - putStr $ mkDefPrompt pr (ppr `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return d - _ -> case parser inp of - Just t -> return t - Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" - promptDefault' parser ppr pr def - --- | Create a prompt from a prompt string and a String representation --- of an optional default value. -mkDefPrompt :: String -> Maybe String -> String -mkDefPrompt pr def = pr ++ "?" ++ defStr def - where defStr Nothing = " " - defStr (Just s) = " [default: " ++ s ++ "] " - --- | Create a prompt from a list of items, where no selected items is --- valid and will be represented as a return value of 'Nothing'. -promptListOptional :: (Pretty t, Eq t) - => String -- ^ prompt - -> [t] -- ^ choices - -> IO (Maybe (Either String t)) -promptListOptional pr choices = promptListOptional' pr choices prettyShow - -promptListOptional' :: Eq t - => String -- ^ prompt - -> [t] -- ^ choices - -> (t -> String) -- ^ show an item - -> IO (Maybe (Either String t)) -promptListOptional' pr choices displayItem = - fmap rearrange - $ promptList pr (Nothing : map Just choices) (Just Nothing) - (maybe "(none)" displayItem) True - where - rearrange = either (Just . Left) (fmap Right) - --- | Create a prompt from a list of items. -promptList :: Eq t - => String -- ^ prompt - -> [t] -- ^ choices - -> Maybe t -- ^ optional default value - -> (t -> String) -- ^ show an item - -> Bool -- ^ whether to allow an 'other' option - -> IO (Either String t) -promptList pr choices def displayItem other = do - putStrLn $ pr ++ ":" - let options1 = map (\c -> (Just c == def, displayItem c)) choices - options2 = zip ([1..]::[Int]) - (options1 ++ [(False, "Other (specify)") | other]) - traverse_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 - promptList' displayItem (length options2) choices def other - where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest - | otherwise = " " ++ star i ++ rest - where rest = show n ++ ") " - star True = "*" - star False = " " - -promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t) -promptList' displayItem numChoices choices def other = do - putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return $ Right d - _ -> case readMaybe inp of - Nothing -> invalidChoice inp - Just n -> getChoice n - where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." - promptList' displayItem numChoices choices def other - getChoice n | n < 1 || n > numChoices = invalidChoice (show n) - | n < numChoices || - (n == numChoices && not other) - = return . Right $ choices !! (n-1) - | otherwise = Left `fmap` promptStr "Please specify" Nothing diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs deleted file mode 100644 --- a/Distribution/Client/Init/Types.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Types --- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Some types used by the 'cabal init' command. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Types where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Simple.Setup (Flag(..), toFlag ) - -import Distribution.Types.Dependency as P -import Distribution.Version -import Distribution.Verbosity -import qualified Distribution.Package as P -import Distribution.SPDX.License (License) -import Distribution.ModuleName -import Distribution.CabalSpecVersion -import Language.Haskell.Extension ( Language(..), Extension ) - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P -import qualified Data.Map as Map - --- | InitFlags is really just a simple type to represent certain --- portions of a .cabal file. Rather than have a flag for EVERY --- possible field, we just have one for each field that the user is --- likely to want and/or that we are likely to be able to --- intelligently guess. -data InitFlags = - InitFlags { interactive :: Flag Bool - , quiet :: Flag Bool - , packageDir :: Flag FilePath - , noComments :: Flag Bool - , minimal :: Flag Bool - , simpleProject :: Flag Bool - - , packageName :: Flag P.PackageName - , version :: Flag Version - , cabalVersion :: Flag CabalSpecVersion - , license :: Flag License - , author :: Flag String - , email :: Flag String - , homepage :: Flag String - - , synopsis :: Flag String - , category :: Flag (Either String Category) - , extraSrc :: Maybe [String] - - , packageType :: Flag PackageType - , mainIs :: Flag FilePath - , language :: Flag Language - - , exposedModules :: Maybe [ModuleName] - , otherModules :: Maybe [ModuleName] - , otherExts :: Maybe [Extension] - - , dependencies :: Maybe [P.Dependency] - , applicationDirs :: Maybe [String] - , sourceDirs :: Maybe [String] - , buildTools :: Maybe [String] - - , initializeTestSuite :: Flag Bool - , testDirs :: Maybe [String] - - , initHcPath :: Flag FilePath - - , initVerbosity :: Flag Verbosity - , overwrite :: Flag Bool - } - deriving (Show, Generic) - - -- the Monoid instance for Flag has later values override earlier - -- ones, which is why we want Maybe [foo] for collecting foo values, - -- not Flag [foo]. - -data BuildType = LibBuild | ExecBuild - deriving Eq - --- The type of package to initialize. -data PackageType = Library | Executable | LibraryAndExecutable - deriving (Show, Read, Eq) - -displayPackageType :: PackageType -> String -displayPackageType LibraryAndExecutable = "Library and Executable" -displayPackageType pkgtype = show pkgtype - -instance Monoid InitFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InitFlags where - (<>) = gmappend - -defaultInitFlags :: InitFlags -defaultInitFlags = mempty - { initVerbosity = toFlag normal - } - --- | Some common package categories (non-exhaustive list). -data Category - = Codec - | Concurrency - | Control - | Data - | Database - | Development - | Distribution - | Game - | Graphics - | Language - | Math - | Network - | Sound - | System - | Testing - | Text - | Web - deriving (Read, Show, Eq, Ord, Bounded, Enum) - -instance Pretty Category where - pretty = Disp.text . show - -instance Parsec Category where - parsec = do - name <- P.munch1 isAlpha - case Map.lookup name names of - Just cat -> pure cat - _ -> P.unexpected $ "Category: " ++ name - where - names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ] diff --git a/Distribution/Client/Init/Utils.hs b/Distribution/Client/Init/Utils.hs deleted file mode 100644 --- a/Distribution/Client/Init/Utils.hs +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Utils --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Shared utilities used by multiple cabal init modules. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init.Utils ( - eligibleForTestSuite - , message - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..) ) - --- | Returns true if this package is eligible for test suite initialization. -eligibleForTestSuite :: InitFlags -> Bool -eligibleForTestSuite flags = - Flag True == initializeTestSuite flags - && Flag Executable /= packageType flags - --- | Possibly generate a message to stdout, taking into account the --- --quiet flag. -message :: InitFlags -> String -> IO () -message (InitFlags{quiet = Flag True}) _ = return () -message _ s = putStrLn s diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs deleted file mode 100644 --- a/Distribution/Client/Install.hs +++ /dev/null @@ -1,1587 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Install --- Copyright : (c) 2005 David Himmelstrup --- 2007 Bjorn Bringert --- 2007-2010 Duncan Coutts --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- High level interface to package installation. ------------------------------------------------------------------------------ -module Distribution.Client.Install ( - -- * High-level interface - install, - - -- * Lower-level interface that allows to manipulate the install plan - makeInstallContext, - makeInstallPlan, - processInstallPlan, - InstallArgs, - InstallContext, - - -- * Prune certain packages from the install plan - pruneInstallPlan - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic(safeLast) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import Control.Exception as Exception - ( bracket, catches, Handler(Handler), handleJust ) -import System.Directory - ( getTemporaryDirectory, doesDirectoryExist, doesFileExist, - createDirectoryIfMissing, removeFile, renameDirectory, - getDirectoryContents ) -import System.FilePath - ( (), (<.>), equalFilePath, takeDirectory ) -import System.IO - ( openFile, IOMode(AppendMode), hClose ) -import System.IO.Error - ( isDoesNotExistError, ioeGetFileName ) - -import Distribution.Client.Targets -import Distribution.Client.Configure - ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types - ( Solver(..) ) -import Distribution.Client.FetchUtils -import Distribution.Client.HttpUtils - ( HttpTransport (..) ) -import Distribution.Solver.Types.PackageFixedDeps -import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackagesAtIndexState, getInstalledPackages ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) -import Distribution.Client.Setup - ( GlobalFlags(..), RepoContext(..) - , ConfigFlags(..), configureCommand, filterConfigureFlags - , ConfigExFlags(..), InstallFlags(..) - , filterTestFlags ) -import Distribution.Client.Config - ( getCabalDir, defaultUserInstall ) -import Distribution.Client.Tar (extractTarGzFile) -import Distribution.Client.Types as Source -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.BuildReports.Anonymous (showBuildReport) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReports -import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) -import qualified Distribution.Client.InstallSymlink as InstallSymlink - ( symlinkBinaries ) -import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) -import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade -import qualified Distribution.Client.World as World -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Client.JobControl - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex -import Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb, readPkgConfigDb ) -import Distribution.Solver.Types.SourcePackage as SourcePackage - -import Distribution.Utils.NubList -import Distribution.Simple.Compiler - ( CompilerId(..), Compiler(compilerId), compilerFlavor - , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Setup - ( haddockCommand, HaddockFlags(..) - , buildCommand, BuildFlags(..), emptyBuildFlags - , TestFlags, BenchmarkFlags - , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) -import qualified Distribution.Simple.Setup as Cabal - ( Flag(..) - , copyCommand, CopyFlags(..), emptyCopyFlags - , registerCommand, RegisterFlags(..), emptyRegisterFlags - , testCommand, TestFlags(..) ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, writeFileAtomic ) -import Distribution.Simple.InstallDirs as InstallDirs - ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate - , initialPathTemplateEnv, installDirsTemplateEnv ) -import Distribution.Simple.Configure (interpretPackageDbFlags) -import Distribution.Simple.Register (registerPackage, defaultRegisterOptions) -import Distribution.Package - ( PackageIdentifier(..), PackageId, packageName, packageVersion - , Package(..), HasMungedPackageId(..), HasUnitId(..) - , UnitId ) -import Distribution.Types.Dependency - ( Dependency (..), mainLibSet ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..), thisPackageVersionConstraint ) -import Distribution.Types.MungedPackageId -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription, GenericPackageDescription(..) ) -import Distribution.Types.Flag - ( PackageFlag(..), FlagAssignment, mkFlagAssignment - , showFlagAssignment, diffFlagAssignment, nullFlagAssignment ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Version - ( Version, VersionRange, foldVersionRange ) -import Distribution.Simple.Utils as Utils - ( notice, info, warn, debug, debugNoWrap, die' - , withTempDirectory ) -import Distribution.Client.Utils - ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) - , ProgressPhase(..), progressMessage ) -import Distribution.System - ( Platform, OS(Windows), buildOS, buildPlatform ) -import Distribution.Verbosity as Verbosity - ( modifyVerbosity, normal, verbose ) -import Distribution.Simple.BuildPaths ( exeExtension ) - -import qualified Data.ByteString as BS - ---TODO: --- * assign flags to packages individually --- * complain about flags that do not apply to any package given as target --- so flags do not apply to dependencies, only listed, can use flag --- constraints for dependencies --- * only record applicable flags in world file --- * allow flag constraints --- * allow installed constraints --- * allow flag and installed preferences --- * change world file to use cabal section syntax --- * allow persistent configure flags for each package individually - --- ------------------------------------------------------------ --- * Top level user actions --- ------------------------------------------------------------ - --- | Installs the packages needed to satisfy a list of dependencies. --- -install - :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> HaddockFlags - -> TestFlags - -> BenchmarkFlags - -> [UserTarget] - -> IO () -install verbosity packageDBs repos comp platform progdb - globalFlags configFlags configExFlags installFlags - haddockFlags testFlags benchmarkFlags userTargets0 = do - - unless (installRootCmd installFlags == Cabal.NoFlag) $ - warn verbosity $ "--root-cmd is no longer supported, " - ++ "see https://github.com/haskell/cabal/issues/3353" - ++ " (if you didn't type --root-cmd, comment out root-cmd" - ++ " in your ~/.cabal/config file)" - let userOrSandbox = fromFlag (configUserInstall configFlags) - unless userOrSandbox $ - warn verbosity $ "the --global flag is deprecated -- " - ++ "it is generally considered a bad idea to install packages " - ++ "into the global store" - - installContext <- makeInstallContext verbosity args (Just userTargets0) - planResult <- foldProgress logMsg (return . Left) (return . Right) =<< - makeInstallPlan verbosity args installContext - - case planResult of - Left message -> do - reportPlanningFailure verbosity args installContext message - die'' message - Right installPlan -> - processInstallPlan verbosity args installContext installPlan - where - args :: InstallArgs - args = (packageDBs, repos, comp, platform, progdb, - globalFlags, configFlags, configExFlags, - installFlags, haddockFlags, testFlags, benchmarkFlags) - - die'' = die' verbosity - - logMsg message rest = debugNoWrap verbosity message >> rest - --- TODO: Make InstallContext a proper data type with documented fields. --- | Common context for makeInstallPlan and processInstallPlan. -type InstallContext = ( InstalledPackageIndex, SourcePackageDb - , PkgConfigDb - , [UserTarget], [PackageSpecifier UnresolvedSourcePackage] - , HttpTransport ) - --- TODO: Make InstallArgs a proper data type with documented fields or just get --- rid of it completely. --- | Initial arguments given to 'install' or 'makeInstallContext'. -type InstallArgs = ( PackageDBStack - , RepoContext - , Compiler - , Platform - , ProgramDb - , GlobalFlags - , ConfigFlags - , ConfigExFlags - , InstallFlags - , HaddockFlags - , TestFlags - , BenchmarkFlags ) - --- | Make an install context given install arguments. -makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] - -> IO InstallContext -makeInstallContext verbosity - (packageDBs, repoCtxt, comp, _, progdb, - globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do - - let idxState = flagToMaybe (installIndexState installFlags) - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing - pkgConfigDb <- readPkgConfigDb verbosity progdb - - checkConfigExFlags verbosity installedPkgIndex - (packageIndex sourcePkgDb) configExFlags - transport <- repoContextGetTransport repoCtxt - - (userTargets, pkgSpecifiers) <- case mUserTargets of - Nothing -> - -- We want to distinguish between the case where the user has given an - -- empty list of targets on the command-line and the case where we - -- specifically want to have an empty list of targets. - return ([], []) - Just userTargets0 -> do - -- For install, if no target is given it means we use the current - -- directory as the single target. - let userTargets | null userTargets0 = [UserTargetLocalDir "."] - | otherwise = userTargets0 - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - userTargets - return (userTargets, pkgSpecifiers) - - return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets - ,pkgSpecifiers, transport) - --- | Make an install plan given install context and install arguments. -makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext - -> IO (Progress String String SolverInstallPlan) -makeInstallPlan verbosity - (_, _, comp, platform,_, - _, configFlags, configExFlags, installFlags, - _, _, _) - (installedPkgIndex, sourcePkgDb, pkgConfigDb, - _, pkgSpecifiers, _) = do - - solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) - (compilerInfo comp) - notice verbosity "Resolving dependencies..." - return $ planPackages verbosity comp platform solver - configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - --- | Given an install plan, perform the actual installations. -processInstallPlan :: Verbosity -> InstallArgs -> InstallContext - -> SolverInstallPlan - -> IO () -processInstallPlan verbosity - args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _) - (installedPkgIndex, sourcePkgDb, _, - userTargets, pkgSpecifiers, _) installPlan0 = do - - checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb - installFlags pkgSpecifiers - - unless (dryRun || nothingToInstall) $ do - buildOutcomes <- performInstallations verbosity - args installedPkgIndex installPlan - postInstallActions verbosity args userTargets installPlan buildOutcomes - where - installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 - dryRun = fromFlag (installDryRun installFlags) - nothingToInstall = null (fst (InstallPlan.ready installPlan)) - --- ------------------------------------------------------------ --- * Installation planning --- ------------------------------------------------------------ - -planPackages :: Verbosity - -> Compiler - -> Platform - -> Solver - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> Progress String String SolverInstallPlan -planPackages verbosity comp platform solver - configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = - - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return - - where - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setAvoidReinstalls avoidReinstalls - - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . setPreferenceDefault (if upgradeDeps then PreferAllLatest - else PreferLatestForSelected) - - . removeLowerBounds allowOlder - . removeUpperBounds allowNewer - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- configPreferences configExFlags ] - - . addConstraints - -- version constraints from the config file or command line - [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- configExConstraints configExFlags ] - - . addConstraints - --FIXME: this just applies all flags to all targets which - -- is silly. We should check if the flags are appropriate - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyFlags flags) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | let flags = configConfigurationsFlags configFlags - , not (nullFlagAssignment flags) - , pkgSpecifier <- pkgSpecifiers ] - - . addConstraints - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | pkgSpecifier <- pkgSpecifiers ] - - . (if reinstall then reinstallTargets else id) - - -- Don't solve for executables, the legacy install codepath - -- doesn't understand how to install them - . setSolveExecutables (SolveExecutables False) - - $ standardInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ configTests configFlags - benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags - - reinstall = fromFlag (installOverrideReinstall installFlags) || - fromFlag (installReinstall installFlags) - reorderGoals = fromFlag (installReorderGoals installFlags) - countConflicts = fromFlag (installCountConflicts installFlags) - fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) - minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) - independentGoals = fromFlag (installIndependentGoals installFlags) - avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) - shadowPkgs = fromFlag (installShadowPkgs installFlags) - strongFlags = fromFlag (installStrongFlags installFlags) - maxBackjumps = fromFlag (installMaxBackjumps installFlags) - allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) - onlyConstrained = fromFlag (installOnlyConstrained installFlags) - upgradeDeps = fromFlag (installUpgradeDeps installFlags) - onlyDeps = fromFlag (installOnlyDeps installFlags) - - allowOlder = fromMaybe (AllowOlder mempty) - (configAllowOlder configExFlags) - allowNewer = fromMaybe (AllowNewer mempty) - (configAllowNewer configExFlags) - --- | Remove the provided targets from the install plan. -pruneInstallPlan :: Package targetpkg - => [PackageSpecifier targetpkg] - -> SolverInstallPlan - -> Progress String String SolverInstallPlan -pruneInstallPlan pkgSpecifiers = - -- TODO: this is a general feature and should be moved to D.C.Dependency - -- Also, the InstallPlan.remove should return info more precise to the - -- problem, rather than the very general PlanProblem type. - either (Fail . explain) Done - . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) - where - explain :: [SolverInstallPlan.SolverPlanProblem] -> String - explain problems = - "Cannot select only the dependencies (as requested by the " - ++ "'--only-dependencies' flag), " - ++ (case pkgids of - [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " - _ -> "the packages " - ++ intercalate ", " (map prettyShow pkgids) ++ " are ") - ++ "required by a dependency of one of the other targets." - where - pkgids = - nub [ depid - | SolverInstallPlan.PackageMissingDeps _ depids <- problems - , depid <- depids - , packageName depid `elem` targetnames ] - - targetnames = map pkgSpecifierTarget pkgSpecifiers - --- ------------------------------------------------------------ --- * Informational messages --- ------------------------------------------------------------ - --- | Perform post-solver checks of the install plan and print it if --- either requested or needed. -checkPrintPlan :: Verbosity - -> InstalledPackageIndex - -> InstallPlan - -> SourcePackageDb - -> InstallFlags - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO () -checkPrintPlan verbosity installed installPlan sourcePkgDb - installFlags pkgSpecifiers = do - - -- User targets that are already installed. - let preExistingTargets = - [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, - InstallPlan.PreExisting p <- InstallPlan.toList installPlan, - packageName p `elem` tgts ] - - -- If there's nothing to install, we print the already existing - -- target packages as an explanation. - when nothingToInstall $ - notice verbosity $ unlines $ - "All the requested packages are already installed:" - : map (prettyShow . packageId) preExistingTargets - ++ ["Use --reinstall if you want to reinstall anyway."] - - let lPlan = - [ (pkg, status) - | pkg <- InstallPlan.executionOrder installPlan - , let status = packageStatus installed pkg ] - -- Are any packages classified as reinstalls? - let reinstalledPkgs = - [ ipkg - | (_pkg, status) <- lPlan - , ipkg <- extractReinstalls status ] - -- Packages that are already broken. - let oldBrokenPkgs = - map Installed.installedUnitId - . PackageIndex.reverseDependencyClosure installed - . map (Installed.installedUnitId . fst) - . PackageIndex.brokenPackages - $ installed - let excluded = reinstalledPkgs ++ oldBrokenPkgs - -- Packages that are reverse dependencies of replaced packages are very - -- likely to be broken. We exclude packages that are already broken. - let newBrokenPkgs = - filter (\ p -> not (Installed.installedUnitId p `elem` excluded)) - (PackageIndex.reverseDependencyClosure installed reinstalledPkgs) - let containsReinstalls = not (null reinstalledPkgs) - let breaksPkgs = not (null newBrokenPkgs) - - let adaptedVerbosity - | containsReinstalls - , not overrideReinstall = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - -- We print the install plan if we are in a dry-run or if we are confronted - -- with a dangerous install plan. - when (dryRun || containsReinstalls && not overrideReinstall) $ - printPlan (dryRun || breaksPkgs && not overrideReinstall) - adaptedVerbosity lPlan sourcePkgDb - - -- If the install plan is dangerous, we print various warning messages. In - -- particular, if we can see that packages are likely to be broken, we even - -- bail out (unless installation has been forced with --force-reinstalls). - when containsReinstalls $ do - if breaksPkgs - then do - (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ - "The following packages are likely to be broken by the reinstalls:" - : map (prettyShow . mungedId) newBrokenPkgs - ++ if overrideReinstall - then if dryRun then [] else - ["Continuing even though " ++ - "the plan contains dangerous reinstalls."] - else - ["Use --force-reinstalls if you want to install anyway."] - else unless dryRun $ warn verbosity - "Note that reinstalls are always dangerous. Continuing anyway..." - - -- If we are explicitly told to not download anything, check that all packages - -- are already fetched. - let offline = fromFlagOrDefault False (installOfflineMode installFlags) - when offline $ do - let pkgs = [ confPkgSource cpkg - | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ] - notFetched <- fmap (map packageId) - . filterM (fmap isNothing . checkFetched . srcpkgSource) - $ pkgs - unless (null notFetched) $ - die' verbosity $ "Can't download packages in offline mode. " - ++ "Must download the following packages to proceed:\n" - ++ intercalate ", " (map prettyShow notFetched) - ++ "\nTry using 'cabal fetch'." - - where - nothingToInstall = null (fst (InstallPlan.ready installPlan)) - - dryRun = fromFlag (installDryRun installFlags) - overrideReinstall = fromFlag (installOverrideReinstall installFlags) - -data PackageStatus = NewPackage - | NewVersion [Version] - | Reinstall [UnitId] [PackageChange] - -type PackageChange = MergeResult MungedPackageId MungedPackageId - -extractReinstalls :: PackageStatus -> [UnitId] -extractReinstalls (Reinstall ipids _) = ipids -extractReinstalls _ = [] - -packageStatus :: InstalledPackageIndex - -> ReadyPackage - -> PackageStatus -packageStatus installedPkgIndex cpkg = - case PackageIndex.lookupPackageName installedPkgIndex - (packageName cpkg) of - [] -> NewPackage - ps -> case filter ((== mungedId cpkg) - . mungedId) (concatMap snd ps) of - [] -> NewVersion (map fst ps) - pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs) - (changes pkg cpkg) - - where - - changes :: Installed.InstalledPackageInfo - -> ReadyPackage - -> [PackageChange] - changes pkg (ReadyPackage pkg') = filter changed $ - mergeBy (comparing mungedName) - -- deps of installed pkg - (resolveInstalledIds $ Installed.depends pkg) - -- deps of configured pkg - (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) - - -- convert to source pkg ids via index - resolveInstalledIds :: [UnitId] -> [MungedPackageId] - resolveInstalledIds = - nub - . sort - . map mungedId - . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex) - - changed (InBoth pkgid pkgid') = pkgid /= pkgid' - changed _ = True - -printPlan :: Bool -- is dry run - -> Verbosity - -> [(ReadyPackage, PackageStatus)] - -> SourcePackageDb - -> IO () -printPlan dryRun verbosity plan sourcePkgDb = case plan of - [] -> return () - pkgs - | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill ++ " be installed:") - : map showPkgAndReason pkgs - | otherwise -> notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill - ++ " be installed (use -v for more details):") - : map showPkg pkgs - where - wouldWill | dryRun = "would" - | otherwise = "will" - - showPkg (pkg, _) = prettyShow (packageId pkg) ++ - showLatest (pkg) - - showPkgAndReason (ReadyPackage pkg', pr) = unwords - [ prettyShow (packageId pkg') - , showLatest pkg' - , showFlagAssignment (nonDefaultFlags pkg') - , showStanzas (confPkgStanzas pkg') - , showDep pkg' - , case pr of - NewPackage -> "(new package)" - NewVersion _ -> "(new version)" - Reinstall _ cs -> "(reinstall)" ++ case cs of - [] -> "" - diff -> "(changes: " ++ intercalate ", " (map change diff) - ++ ")" - ] - - showLatest :: Package srcpkg => srcpkg -> String - showLatest pkg = case mLatestVersion of - Just latestVersion -> - if packageVersion pkg < latestVersion - then ("(latest: " ++ prettyShow latestVersion ++ ")") - else "" - Nothing -> "" - where - mLatestVersion :: Maybe Version - mLatestVersion = fmap packageVersion $ - safeLast $ - SourcePackageIndex.lookupPackageName - (packageIndex sourcePkgDb) - (packageName pkg) - - toFlagAssignment :: [PackageFlag] -> FlagAssignment - toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) - - nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment - nonDefaultFlags cpkg = - let defaultAssignment = - toFlagAssignment - (genPackageFlags (SourcePackage.srcpkgDescription $ - confPkgSource cpkg)) - in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment - - showStanzas :: [OptionalStanza] -> String - showStanzas = unwords . map (("*" ++) . showStanza) - - change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed" - change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> " - ++ prettyShow (mungedVersion pkgid') - change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added" - - showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps - = " (via: " ++ unwords (map prettyShow rdeps) ++ ")" - | otherwise = "" - - revDepGraphEdges :: [(PackageId, PackageId)] - revDepGraphEdges = [ (rpid, packageId cpkg) - | (ReadyPackage cpkg, _) <- plan - , ConfiguredId - rpid - (Just - (PackageDescription.CLibName - PackageDescription.LMainLibName)) - _ - <- CD.flatDeps (confPkgDeps cpkg) ] - - revDeps :: Map.Map PackageId [PackageId] - revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges) - --- ------------------------------------------------------------ --- * Post installation stuff --- ------------------------------------------------------------ - --- | Report a solver failure. This works slightly differently to --- 'postInstallActions', as (by definition) we don't have an install plan. -reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String - -> IO () -reportPlanningFailure verbosity - (_, _, comp, platform, _ - ,_, configFlags, _, installFlags, _, _, _) - (_, sourcePkgDb, _, _, pkgSpecifiers, _) - message = do - - when reportFailure $ do - - -- Only create reports for explicitly named packages - let pkgids = filter - (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $ - mapMaybe theSpecifiedPackage pkgSpecifiers - - buildReports = BuildReports.fromPlanningFailure platform - (compilerId comp) pkgids - (configConfigurationsFlags configFlags) - - unless (null buildReports) $ - info verbosity $ - "Solver failure will be reported for " - ++ intercalate "," (map prettyShow pkgids) - - -- Save reports - BuildReports.storeLocal (compilerInfo comp) - (fromNubList $ installSummaryFile installFlags) - buildReports platform - - -- Save solver log - case logFile of - Nothing -> return () - Just template -> for_ pkgids $ \pkgid -> - let env = initialPathTemplateEnv pkgid dummyIpid - (compilerInfo comp) platform - path = fromPathTemplate $ substPathTemplate env template - in writeFile path message - - where - reportFailure = fromFlag (installReportPlanningFailure installFlags) - logFile = flagToMaybe (installLogFile installFlags) - - -- A IPID is calculated from the transitive closure of - -- dependencies, but when the solver fails we don't have that. - -- So we fail. - dummyIpid = error "reportPlanningFailure: installed package ID not available" - --- | If a 'PackageSpecifier' refers to a single package, return Just that --- package. -theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId -theSpecifiedPackage pkgSpec = - case pkgSpec of - NamedPackage name [PackagePropertyVersion version] - -> PackageIdentifier name <$> trivialRange version - NamedPackage _ _ -> Nothing - SpecificSourcePackage pkg -> Just $ packageId pkg - where - -- | If a range includes only a single version, return Just that version. - trivialRange :: VersionRange -> Maybe Version - trivialRange = foldVersionRange - Nothing - Just -- "== v" - (\_ -> Nothing) - (\_ -> Nothing) - (\_ _ -> Nothing) - (\_ _ -> Nothing) - --- | Various stuff we do after successful or unsuccessfully installing a bunch --- of packages. This includes: --- --- * build reporting, local and remote --- * symlinking binaries --- * updating indexes --- * updating world file --- * error reporting --- -postInstallActions :: Verbosity - -> InstallArgs - -> [UserTarget] - -> InstallPlan - -> BuildOutcomes - -> IO () -postInstallActions verbosity - (packageDBs, _, comp, platform, progdb - ,globalFlags, configFlags, _, installFlags, _, _, _) - targets installPlan buildOutcomes = do - - unless oneShot $ - World.insert verbosity worldFile - --FIXME: does not handle flags - [ World.WorldPkgInfo (Dependency pn vr mainLibSet) mempty - | UserTargetNamed (PackageVersionConstraint pn vr) <- targets ] - - let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) - installPlan buildOutcomes - BuildReports.storeLocal (compilerInfo comp) - (fromNubList $ installSummaryFile installFlags) - buildReports - platform - when (reportingLevel >= AnonymousReports) $ - BuildReports.storeAnonymous buildReports - when (reportingLevel == DetailedReports) $ - storeDetailedBuildReports verbosity logsDir buildReports - - regenerateHaddockIndex verbosity packageDBs comp platform progdb - configFlags installFlags buildOutcomes - - symlinkBinaries verbosity platform comp configFlags installFlags - installPlan buildOutcomes - - printBuildFailures verbosity buildOutcomes - - where - reportingLevel = fromFlag (installBuildReports installFlags) - logsDir = fromFlag (globalLogsDir globalFlags) - oneShot = fromFlag (installOneShot installFlags) - worldFile = fromFlag $ globalWorldFile globalFlags - -storeDetailedBuildReports :: Verbosity -> FilePath - -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () -storeDetailedBuildReports verbosity logsDir reports = sequence_ - [ do dotCabal <- getCabalDir - let logFileName = prettyShow (BuildReports.package report) <.> "log" - logFile = logsDir logFileName - reportsDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) - reportFile = reportsDir logFileName - - handleMissingLogFile $ do - buildLog <- readFile logFile - createDirectoryIfMissing True reportsDir -- FIXME - writeFile reportFile (show (showBuildReport report, buildLog)) - - | (report, Just repo) <- reports - , Just remoteRepo <- [maybeRepoRemote repo] - , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] - - where - isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True - isLikelyToHaveLogFile BuildReports.BuildFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallOk {} = True - isLikelyToHaveLogFile _ = False - - handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> - warn verbosity $ "Missing log file for build report: " - ++ fromMaybe "" (ioeGetFileName ioe) - - missingFile ioe - | isDoesNotExistError ioe = Just ioe - missingFile _ = Nothing - - -regenerateHaddockIndex :: Verbosity - -> [PackageDB] - -> Compiler - -> Platform - -> ProgramDb - -> ConfigFlags - -> InstallFlags - -> BuildOutcomes - -> IO () -regenerateHaddockIndex verbosity packageDBs comp platform progdb - configFlags installFlags buildOutcomes - | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do - - defaultDirs <- InstallDirs.defaultInstallDirs - (compilerFlavor comp) - (fromFlag (configUserInstall configFlags)) - True - let indexFileTemplate = fromFlag (installHaddockIndex installFlags) - indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate - - notice verbosity $ - "Updating documentation index " ++ indexFile - - --TODO: might be nice if the install plan gave us the new InstalledPackageInfo - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile - - | otherwise = return () - where - haddockIndexFileIsRequested = - fromFlag (installDocumentation installFlags) - && isJust (flagToMaybe (installHaddockIndex installFlags)) - - -- We want to regenerate the index if some new documentation was actually - -- installed. Since the index can be only per-user or per-sandbox (see - -- #1337), we don't do it for global installs or special cases where we're - -- installing into a specific db. - shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes - where - someDocsWereInstalled = any installedDocs . Map.elems - installedDocs (Right (BuildResult DocsOk _ _)) = True - installedDocs _ = False - - normalUserInstall = (UserPackageDB `elem` packageDBs) - && all (not . isSpecificPackageDB) packageDBs - isSpecificPackageDB (SpecificPackageDB _) = True - isSpecificPackageDB _ = False - - substHaddockIndexFileName defaultDirs = fromPathTemplate - . substPathTemplate env - where - env = env0 ++ installDirsTemplateEnv absoluteDirs - env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp) - ++ InstallDirs.platformTemplateEnv platform - ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform - absoluteDirs = InstallDirs.substituteInstallDirTemplates - env0 templateDirs - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - - -symlinkBinaries :: Verbosity - -> Platform -> Compiler - -> ConfigFlags - -> InstallFlags - -> InstallPlan - -> BuildOutcomes - -> IO () -symlinkBinaries verbosity platform comp configFlags installFlags - plan buildOutcomes = do - failed <- InstallSymlink.symlinkBinaries platform comp - NeverOverwrite - configFlags installFlags - plan buildOutcomes - case failed of - [] -> return () - [(_, exe, path)] -> - warn verbosity $ - "could not create a symlink in " ++ bindir ++ " for " - ++ prettyShow exe ++ " because the file exists there already but is not " - ++ "managed by cabal. You can create a symlink for this executable " - ++ "manually if you wish. The executable file has been installed at " - ++ path - exes -> - warn verbosity $ - "could not create symlinks in " ++ bindir ++ " for " - ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ] - ++ " because the files exist there already and are not " - ++ "managed by cabal. You can create symlinks for these executables " - ++ "manually if you wish. The executable files have been installed at " - ++ intercalate ", " [ path | (_, _, path) <- exes ] - where - bindir = fromFlag (installSymlinkBinDir installFlags) - - -printBuildFailures :: Verbosity -> BuildOutcomes -> IO () -printBuildFailures verbosity buildOutcomes = - case [ (pkgid, failure) - | (pkgid, Left failure) <- Map.toList buildOutcomes ] of - [] -> return () - failed -> die' verbosity . unlines - $ "Error: some packages failed to install:" - : [ prettyShow pkgid ++ printFailureReason reason - | (pkgid, reason) <- failed ] - where - printFailureReason reason = case reason of - DependentFailed pkgid -> " depends on " ++ prettyShow pkgid - ++ " which failed to install." - DownloadFailed e -> " failed while downloading the package." - ++ showException e - UnpackFailed e -> " failed while unpacking the package." - ++ showException e - ConfigureFailed e -> " failed during the configure step." - ++ showException e - BuildFailed e -> " failed during the building phase." - ++ showException e - TestsFailed e -> " failed during the tests phase." - ++ showException e - InstallFailed e -> " failed during the final install step." - ++ showException e - - -- This will never happen, but we include it for completeness - PlanningFailed -> " failed during the planning phase." - - showException e = " The exception was:\n " ++ show e ++ maybeOOM e -#ifdef mingw32_HOST_OS - maybeOOM _ = "" -#else - maybeOOM e = maybe "" onExitFailure (fromException e) - onExitFailure (ExitFailure n) - | n == 9 || n == -9 = - "\nThis may be due to an out-of-memory condition." - onExitFailure _ = "" -#endif - --- ------------------------------------------------------------ --- * Actually do the installations --- ------------------------------------------------------------ - -data InstallMisc = InstallMisc { - libVersion :: Maybe Version - } - --- | If logging is enabled, contains location of the log file and the verbosity --- level for logging. -type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity) - -performInstallations :: Verbosity - -> InstallArgs - -> InstalledPackageIndex - -> InstallPlan - -> IO BuildOutcomes -performInstallations verbosity - (packageDBs, repoCtxt, comp, platform, progdb, - globalFlags, configFlags, configExFlags, installFlags, - haddockFlags, testFlags, _) - installedPkgIndex installPlan = do - - info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." - - jobControl <- if parallelInstall then newParallelJobControl numJobs - else newSerialJobControl - fetchLimit <- newJobLimit (min numJobs numFetchJobs) - installLock <- newLock -- serialise installation - cacheLock <- newLock -- serialise access to setup exe cache - - executeInstallPlan verbosity jobControl keepGoing useLogFile - installPlan $ \rpkg -> - installReadyPackage platform cinfo configFlags - rpkg $ \configFlags' src pkg pkgoverride -> - fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' -> - installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath -> - installUnpackedPackage verbosity installLock numJobs - (setupScriptOptions installedPkgIndex - cacheLock rpkg) - configFlags' - installFlags haddockFlags testFlags - comp progdb - platform pkg rpkg pkgoverride mpath useLogFile - - where - cinfo = compilerInfo comp - - numJobs = determineNumJobs (installNumJobs installFlags) - numFetchJobs = 2 - parallelInstall = numJobs >= 2 - keepGoing = fromFlag (installKeepGoing installFlags) - distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags) - - setupScriptOptions index lock rpkg = - configureSetupScript - packageDBs - comp - platform - progdb - distPref - (chooseCabalVersion configExFlags (libVersion miscOptions)) - (Just lock) - parallelInstall - index - (Just rpkg) - - reportingLevel = fromFlag (installBuildReports installFlags) - logsDir = fromFlag (globalLogsDir globalFlags) - - -- Should the build output be written to a log file instead of stdout? - useLogFile :: UseLogFile - useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName) - logFileTemplate - where - installLogFile' = flagToMaybe $ installLogFile installFlags - defaultTemplate = toPathTemplate $ - logsDir "$compiler" "$libname" <.> "log" - - -- If the user has specified --remote-build-reporting=detailed, use the - -- default log file location. If the --build-log option is set, use the - -- provided location. Otherwise don't use logging, unless building in - -- parallel (in which case the default location is used). - logFileTemplate :: Maybe PathTemplate - logFileTemplate - | useDefaultTemplate = Just defaultTemplate - | otherwise = installLogFile' - - -- If the user has specified --remote-build-reporting=detailed or - -- --build-log, use more verbose logging. - loggingVerbosity :: Verbosity - loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - useDefaultTemplate :: Bool - useDefaultTemplate - | reportingLevel == DetailedReports = True - | isJust installLogFile' = False - | parallelInstall = True - | otherwise = False - - overrideVerbosity :: Bool - overrideVerbosity - | reportingLevel == DetailedReports = True - | isJust installLogFile' = True - | parallelInstall = False - | otherwise = False - - substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath - substLogFileName template pkg uid = fromPathTemplate - . substPathTemplate env - $ template - where env = initialPathTemplateEnv (packageId pkg) uid - (compilerInfo comp) platform - - miscOptions = InstallMisc { - libVersion = flagToMaybe (configCabalVersion configExFlags) - } - - -executeInstallPlan :: Verbosity - -> JobControl IO (UnitId, BuildOutcome) - -> Bool - -> UseLogFile - -> InstallPlan - -> (ReadyPackage -> IO BuildOutcome) - -> IO BuildOutcomes -executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = - InstallPlan.execute - jobCtl keepGoing depsFailure plan0 $ \pkg -> do - buildOutcome <- installPkg pkg - printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome - return buildOutcome - - where - depsFailure = DependentFailed . packageId - - -- Print build log if something went wrong, and 'Installed $PKGID' - -- otherwise. - printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () - printBuildResult pkgid uid buildOutcome = case buildOutcome of - (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid) - (Left _) -> do - notice verbosity $ "Failed to install " ++ prettyShow pkgid - when (verbosity >= normal) $ - case useLogFile of - Nothing -> return () - Just (mkLogFileName, _) -> do - let logName = mkLogFileName pkgid uid - putStr $ "Build log ( " ++ logName ++ " ):\n" - printFile logName - - printFile :: FilePath -> IO () - printFile path = readFile path >>= putStr - --- | Call an installer for an 'SourcePackage' but override the configure --- flags with the ones given by the 'ReadyPackage'. In particular the --- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly --- versioned package dependencies. So we ignore any previous partial flag --- assignment or dependency constraints and use the new ones. --- --- NB: when updating this function, don't forget to also update --- 'configurePackage' in D.C.Configure. -installReadyPackage :: Platform -> CompilerInfo - -> ConfigFlags - -> ReadyPackage - -> (ConfigFlags -> UnresolvedPkgLoc - -> PackageDescription - -> PackageDescriptionOverride - -> a) - -> a -installReadyPackage platform cinfo configFlags - (ReadyPackage (ConfiguredPackage ipid - (SourcePackage _ gpkg source pkgoverride) - flags stanzas deps)) - installPkg = - installPkg configFlags { - configIPID = toFlag (prettyShow ipid), - configConfigurationsFlags = flags, - -- We generate the legacy constraints as well as the new style precise deps. - -- In the end only one set gets passed to Setup.hs configure, depending on - -- the Cabal version we are talking to. - configConstraints = [ thisPackageVersionConstraint srcid - | ConfiguredId - srcid - (Just - (PackageDescription.CLibName - PackageDescription.LMainLibName)) - _ipid - <- CD.nonSetupDeps deps ], - configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid - | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid - <- CD.nonSetupDeps deps ], - -- Use '--exact-configuration' if supported. - configExactConfiguration = toFlag True, - configBenchmarks = toFlag False, - configTests = toFlag (TestStanzas `elem` stanzas) - } source pkg pkgoverride - where - pkg = case finalizePD flags (enableStanzas stanzas) - (const True) - platform cinfo [] gpkg of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc - -fetchSourcePackage - :: Verbosity - -> RepoContext - -> JobLimit - -> UnresolvedPkgLoc - -> (ResolvedPkgLoc -> IO BuildOutcome) - -> IO BuildOutcome -fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do - fetched <- checkFetched src - case fetched of - Just src' -> installPkg src' - Nothing -> onFailure DownloadFailed $ do - loc <- withJobLimit fetchLimit $ - fetchPackage verbosity repoCtxt src - installPkg loc - - -installLocalPackage - :: Verbosity - -> PackageIdentifier -> ResolvedPkgLoc -> FilePath - -> (Maybe FilePath -> IO BuildOutcome) - -> IO BuildOutcome -installLocalPackage verbosity pkgid location distPref installPkg = - - case location of - - LocalUnpackedPackage dir -> - installPkg (Just dir) - - RemoteSourceRepoPackage _repo dir -> - installPkg (Just dir) - - LocalTarballPackage tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg - - RemoteTarballPackage _ tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg - - RepoTarballPackage _ _ tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg - -installLocalTarballPackage - :: Verbosity - -> PackageIdentifier -> FilePath -> FilePath - -> (Maybe FilePath -> IO BuildOutcome) - -> IO BuildOutcome -installLocalTarballPackage verbosity pkgid - tarballPath distPref installPkg = do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> - onFailure UnpackFailed $ do - let relUnpackedPath = prettyShow pkgid - absUnpackedPath = tmpDirPath relUnpackedPath - descFilePath = absUnpackedPath - prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ "Extracting " ++ tarballPath - ++ " to " ++ tmpDirPath ++ "..." - extractTarGzFile tmpDirPath relUnpackedPath tarballPath - exists <- doesFileExist descFilePath - unless exists $ - die' verbosity $ "Package .cabal file not found: " ++ show descFilePath - maybeRenameDistDir absUnpackedPath - installPkg (Just absUnpackedPath) - - where - -- 'cabal sdist' puts pre-generated files in the 'dist' - -- directory. This fails when a nonstandard build directory name - -- is used (as is the case with sandboxes), so we need to rename - -- the 'dist' dir here. - -- - -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still - -- fails even with this workaround. We probably can live with that. - maybeRenameDistDir :: FilePath -> IO () - maybeRenameDistDir absUnpackedPath = do - let distDirPath = absUnpackedPath defaultDistPref - distDirPathTmp = absUnpackedPath (defaultDistPref ++ "-tmp") - distDirPathNew = absUnpackedPath distPref - distDirExists <- doesDirectoryExist distDirPath - when (distDirExists - && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do - -- NB: we need to handle the case when 'distDirPathNew' is a - -- subdirectory of 'distDirPath' (e.g. the former is - -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist'). - debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '" - ++ distDirPathTmp ++ "'." - renameDirectory distDirPath distDirPathTmp - when (distDirPath `isPrefixOf` distDirPathNew) $ - createDirectoryIfMissingVerbose verbosity False distDirPath - debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '" - ++ distDirPathNew ++ "'." - renameDirectory distDirPathTmp distDirPathNew - -installUnpackedPackage - :: Verbosity - -> Lock - -> Int - -> SetupScriptOptions - -> ConfigFlags - -> InstallFlags - -> HaddockFlags - -> TestFlags - -> Compiler - -> ProgramDb - -> Platform - -> PackageDescription - -> ReadyPackage - -> PackageDescriptionOverride - -> Maybe FilePath -- ^ Directory to change to before starting the installation. - -> UseLogFile -- ^ File to log output to (if any) - -> IO BuildOutcome -installUnpackedPackage verbosity installLock numJobs - scriptOptions - configFlags installFlags haddockFlags testFlags comp progdb - platform pkg rpkg pkgoverride workingDir useLogFile = do - -- Override the .cabal file if necessary - case pkgoverride of - Nothing -> return () - Just pkgtxt -> do - let descFilePath = fromMaybe "." workingDir - prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ - "Updating " ++ prettyShow (packageName pkgid) <.> "cabal" - ++ " with the latest revision from the index." - writeFileAtomic descFilePath pkgtxt - - -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if - -- the setup script was compiled against an old version of the Cabal lib). - configFlags' <- addDefaultInstallDirs configFlags - -- Filter out flags not supported by the old versions of the Cabal lib. - let configureFlags :: Version -> ConfigFlags - configureFlags = filterConfigureFlags configFlags' { - configVerbosity = toFlag verbosity' - } - - -- Path to the optional log file. - mLogPath <- maybeLogPath - - logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do - -- Configure phase - onFailure ConfigureFailed $ do - noticeProgress ProgressStarting - setup configureCommand configureFlags mLogPath - - -- Build phase - onFailure BuildFailed $ do - noticeProgress ProgressBuilding - setup buildCommand' buildFlags mLogPath - - -- Doc generation phase - docsResult <- if shouldHaddock - then (do setup haddockCommand haddockFlags' mLogPath - return DocsOk) - `catchIO` (\_ -> return DocsFailed) - `catchExit` (\_ -> return DocsFailed) - else return DocsNotTried - - -- Tests phase - onFailure TestsFailed $ do - when (testsEnabled && PackageDescription.hasTests pkg) $ - setup Cabal.testCommand testFlags' mLogPath - - let testsResult | testsEnabled = TestsOk - | otherwise = TestsNotTried - - -- Install phase - onFailure InstallFailed $ criticalSection installLock $ do - -- Actual installation - withWin32SelfUpgrade verbosity uid configFlags - cinfo platform pkg $ do - setup Cabal.copyCommand copyFlags mLogPath - - -- Capture installed package configuration file, so that - -- it can be incorporated into the final InstallPlan - ipkgs <- genPkgConfs mLogPath - let ipkgs' = case ipkgs of - [ipkg] -> [ipkg { Installed.installedUnitId = uid }] - _ -> ipkgs - let packageDBs = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags)) - (configPackageDBs configFlags) - for_ ipkgs' $ \ipkg' -> - registerPackage verbosity comp progdb - packageDBs ipkg' - defaultRegisterOptions - - return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs'))) - - where - pkgid = packageId pkg - uid = installedUnitId rpkg - cinfo = compilerInfo comp - buildCommand' = buildCommand progdb - dispname = prettyShow pkgid - isParallelBuild = numJobs >= 2 - - noticeProgress phase = when isParallelBuild $ - progressMessage verbosity phase dispname - - buildFlags _ = emptyBuildFlags { - buildDistPref = configDistPref configFlags, - buildVerbosity = toFlag verbosity' - } - shouldHaddock = fromFlag (installDocumentation installFlags) - haddockFlags' _ = haddockFlags { - haddockVerbosity = toFlag verbosity', - haddockDistPref = configDistPref configFlags - } - testsEnabled = fromFlag (configTests configFlags) - && fromFlagOrDefault False (installRunTests installFlags) - testFlags' = filterTestFlags testFlags { - Cabal.testDistPref = configDistPref configFlags - } - copyFlags _ = Cabal.emptyCopyFlags { - Cabal.copyDistPref = configDistPref configFlags, - Cabal.copyDest = toFlag InstallDirs.NoCopyDest, - Cabal.copyVerbosity = toFlag verbosity' - } - shouldRegister = PackageDescription.hasLibs pkg - registerFlags _ = Cabal.emptyRegisterFlags { - Cabal.regDistPref = configDistPref configFlags, - Cabal.regVerbosity = toFlag verbosity' - } - verbosity' = maybe verbosity snd useLogFile - tempTemplate name = name ++ "-" ++ prettyShow pkgid - - addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags - addDefaultInstallDirs configFlags' = do - defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False - return $ configFlags' { - configInstallDirs = fmap Cabal.Flag . - InstallDirs.substituteInstallDirTemplates env $ - InstallDirs.combineInstallDirs fromFlagOrDefault - defInstallDirs (configInstallDirs configFlags) - } - where - CompilerId flavor _ = compilerInfoId cinfo - env = initialPathTemplateEnv pkgid uid cinfo platform - userInstall = fromFlagOrDefault defaultUserInstall - (configUserInstall configFlags') - - genPkgConfs :: Maybe FilePath - -> IO [Installed.InstalledPackageInfo] - genPkgConfs mLogPath = - if shouldRegister then do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do - let pkgConfDest = dir "pkgConf" - registerFlags' version = (registerFlags version) { - Cabal.regGenPkgConf = toFlag (Just pkgConfDest) - } - setup Cabal.registerCommand registerFlags' mLogPath - is_dir <- doesDirectoryExist pkgConfDest - let notHidden = not . isHidden - isHidden name = "." `isPrefixOf` name - if is_dir - -- Sort so that each prefix of the package - -- configurations is well formed - then traverse (readPkgConf pkgConfDest) . sort . filter notHidden - =<< getDirectoryContents pkgConfDest - else fmap (:[]) $ readPkgConf "." pkgConfDest - else return [] - - readPkgConf :: FilePath -> FilePath - -> IO Installed.InstalledPackageInfo - readPkgConf pkgConfDir pkgConfFile = do - pkgConfText <- BS.readFile (pkgConfDir pkgConfFile) - case Installed.parseInstalledPackageInfo pkgConfText of - Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors - Right (warns, pkgConf) -> do - unless (null warns) $ - warn verbosity $ unlines warns - return pkgConf - - pkgConfParseFailed :: String -> IO a - pkgConfParseFailed perror = - die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" - ++ show perror - - maybeLogPath :: IO (Maybe FilePath) - maybeLogPath = - case useLogFile of - Nothing -> return Nothing - Just (mkLogFileName, _) -> do - let logFileName = mkLogFileName (packageId pkg) uid - logDir = takeDirectory logFileName - unless (null logDir) $ createDirectoryIfMissing True logDir - logFileExists <- doesFileExist logFileName - when logFileExists $ removeFile logFileName - return (Just logFileName) - - setup cmd flags mLogPath = - Exception.bracket - (traverse (\path -> openFile path AppendMode) mLogPath) - (traverse_ hClose) - (\logFileHandle -> - setupWrapper verbosity - scriptOptions { useLoggingHandle = logFileHandle - , useWorkingDir = workingDir } - (Just pkg) - cmd flags (const [])) - - --- helper -onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome -onFailure result action = - action `catches` - [ Handler $ \ioe -> handler (ioe :: IOException) - , Handler $ \exit -> handler (exit :: ExitCode) - ] - where - handler :: Exception e => e -> IO BuildOutcome - handler = return . Left . result . toException - - --- ------------------------------------------------------------ --- * Weird windows hacks --- ------------------------------------------------------------ - -withWin32SelfUpgrade :: Verbosity - -> UnitId - -> ConfigFlags - -> CompilerInfo - -> Platform - -> PackageDescription - -> IO a -> IO a -withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action -withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do - - defaultDirs <- InstallDirs.defaultInstallDirs - compFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - - Win32SelfUpgrade.possibleSelfUpgrade verbosity - (exeInstallPaths defaultDirs) action - - where - pkgid = packageId pkg - (CompilerId compFlavor _) = compilerInfoId cinfo - - exeInstallPaths defaultDirs = - [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension buildPlatform - | exe <- PackageDescription.executables pkg - , PackageDescription.buildable (PackageDescription.buildInfo exe) - , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix - prefix = substTemplate prefixTemplate - suffix = substTemplate suffixTemplate ] - where - fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") - prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) - suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - absoluteDirs = InstallDirs.absoluteInstallDirs - pkgid uid - cinfo InstallDirs.NoCopyDest - platform templateDirs - substTemplate = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid uid - cinfo platform diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs deleted file mode 100644 --- a/Distribution/Client/InstallPlan.hs +++ /dev/null @@ -1,957 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.InstallPlan --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- Stability : provisional --- Portability : portable --- --- Package installation plan --- ------------------------------------------------------------------------------ -module Distribution.Client.InstallPlan ( - InstallPlan, - GenericInstallPlan, - PlanPackage, - GenericPlanPackage(..), - foldPlanPackage, - IsUnit, - - -- * Operations on 'InstallPlan's - new, - toGraph, - toList, - toMap, - keys, - keysSet, - planIndepGoals, - depends, - - fromSolverInstallPlan, - fromSolverInstallPlanWithProgress, - configureInstallPlan, - remove, - installed, - lookup, - directDeps, - revDirectDeps, - - -- * Traversal - executionOrder, - execute, - BuildOutcomes, - lookupBuildOutcome, - -- ** Traversal helpers - -- $traversal - Processing, - ready, - completed, - failed, - - -- * Display - showPlanGraph, - showInstallPlan, - - -- * Graph-like operations - dependencyClosure, - reverseTopologicalOrder, - reverseDependencyClosure, - ) where - -import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail) -import Prelude (tail) -import Distribution.Compat.Stack (WithCallStack) - -import Distribution.Client.Types hiding (BuildOutcomes) -import qualified Distribution.PackageDescription as PD -import qualified Distribution.Simple.Configure as Configure -import qualified Distribution.Simple.Setup as Cabal - -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Package - ( Package(..), HasMungedPackageId(..) - , HasUnitId(..), UnitId ) -import Distribution.Solver.Types.SolverPackage -import Distribution.Client.JobControl -import Distribution.Pretty (defaultStyle) -import Text.PrettyPrint -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.InstSolverPackage - -import Distribution.Utils.LogProgress -import Distribution.Utils.Structured (Structured (..), Structure(Nominal)) - --- TODO: Need this when we compute final UnitIds --- import qualified Distribution.Simple.Configure as Configure - -import qualified Data.Foldable as Foldable (all, toList) -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, IsNode(..)) -import Control.Exception - ( assert ) -import qualified Data.Map as Map -import qualified Data.Set as Set - --- When cabal tries to install a number of packages, including all their --- dependencies it has a non-trivial problem to solve. --- --- The Problem: --- --- In general we start with a set of installed packages and a set of source --- packages. --- --- Installed packages have fixed dependencies. They have already been built and --- we know exactly what packages they were built against, including their exact --- versions. --- --- Source package have somewhat flexible dependencies. They are specified as --- version ranges, though really they're predicates. To make matters worse they --- have conditional flexible dependencies. Configuration flags can affect which --- packages are required and can place additional constraints on their --- versions. --- --- These two sets of package can and usually do overlap. There can be installed --- packages that are also available as source packages which means they could --- be re-installed if required, though there will also be packages which are --- not available as source and cannot be re-installed. Very often there will be --- extra versions available than are installed. Sometimes we may like to prefer --- installed packages over source ones or perhaps always prefer the latest --- available version whether installed or not. --- --- The goal is to calculate an installation plan that is closed, acyclic and --- consistent and where every configured package is valid. --- --- An installation plan is a set of packages that are going to be used --- together. It will consist of a mixture of installed packages and source --- packages along with their exact version dependencies. An installation plan --- is closed if for every package in the set, all of its dependencies are --- also in the set. It is consistent if for every package in the set, all --- dependencies which target that package have the same version. - --- Note that plans do not necessarily compose. You might have a valid plan for --- package A and a valid plan for package B. That does not mean the composition --- is simultaneously valid for A and B. In particular you're most likely to --- have problems with inconsistent dependencies. --- On the other hand it is true that every closed sub plan is valid. - --- | Packages in an install plan --- --- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage' --- intentionally have no 'PackageInstalled' instance. `This is important: --- PackageInstalled returns only library dependencies, but for package that --- aren't yet installed we know many more kinds of dependencies (setup --- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on --- dependencies in cabal-install should consider what to do with these --- dependencies; if we give a 'PackageInstalled' instance it would be too easy --- to get this wrong (and, for instance, call graph traversal functions from --- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'. -data GenericPlanPackage ipkg srcpkg - = PreExisting ipkg - | Configured srcpkg - | Installed srcpkg - deriving (Eq, Show, Generic) - -displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String -displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) - --- | Convenience combinator for destructing 'GenericPlanPackage'. --- This is handy because if you case manually, you have to handle --- 'Configured' and 'Installed' separately (where often you want --- them to be the same.) -foldPlanPackage :: (ipkg -> a) - -> (srcpkg -> a) - -> GenericPlanPackage ipkg srcpkg - -> a -foldPlanPackage f _ (PreExisting ipkg) = f ipkg -foldPlanPackage _ g (Configured srcpkg) = g srcpkg -foldPlanPackage _ g (Installed srcpkg) = g srcpkg - -type IsUnit a = (IsNode a, Key a ~ UnitId) - -depends :: IsUnit a => a -> [UnitId] -depends = nodeNeighbors - --- NB: Expanded constraint synonym here to avoid undecidable --- instance errors in GHC 7.8 and earlier. -instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) - => IsNode (GenericPlanPackage ipkg srcpkg) where - type Key (GenericPlanPackage ipkg srcpkg) = UnitId - nodeKey (PreExisting ipkg) = nodeKey ipkg - nodeKey (Configured spkg) = nodeKey spkg - nodeKey (Installed spkg) = nodeKey spkg - nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg - nodeNeighbors (Configured spkg) = nodeNeighbors spkg - nodeNeighbors (Installed spkg) = nodeNeighbors spkg - -instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) -instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg) - -type PlanPackage = GenericPlanPackage - InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) - -instance (Package ipkg, Package srcpkg) => - Package (GenericPlanPackage ipkg srcpkg) where - packageId (PreExisting ipkg) = packageId ipkg - packageId (Configured spkg) = packageId spkg - packageId (Installed spkg) = packageId spkg - -instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) => - HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where - mungedId (PreExisting ipkg) = mungedId ipkg - mungedId (Configured spkg) = mungedId spkg - mungedId (Installed spkg) = mungedId spkg - -instance (HasUnitId ipkg, HasUnitId srcpkg) => - HasUnitId - (GenericPlanPackage ipkg srcpkg) where - installedUnitId (PreExisting ipkg) = installedUnitId ipkg - installedUnitId (Configured spkg) = installedUnitId spkg - installedUnitId (Installed spkg) = installedUnitId spkg - -instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) => - HasConfiguredId (GenericPlanPackage ipkg srcpkg) where - configuredId (PreExisting ipkg) = configuredId ipkg - configuredId (Configured spkg) = configuredId spkg - configuredId (Installed spkg) = configuredId spkg - -data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { - planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)), - planIndepGoals :: !IndependentGoals - } - deriving (Typeable) - --- | 'GenericInstallPlan' specialised to most commonly used types. -type InstallPlan = GenericInstallPlan - InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) - --- | Smart constructor that deals with caching the 'Graph' representation. --- -mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> IndependentGoals - -> GenericInstallPlan ipkg srcpkg -mkInstallPlan loc graph indepGoals = - assert (valid loc graph) - GenericInstallPlan { - planGraph = graph, - planIndepGoals = indepGoals - } - -internalError :: WithCallStack (String -> String -> a) -internalError loc msg = error $ "internal error in InstallPlan." ++ loc - ++ if null msg then "" else ": " ++ msg - -instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where - structure p = Nominal (typeRep p) 0 "GenericInstallPlan" - [ structure (Proxy :: Proxy ipkg) - , structure (Proxy :: Proxy srcpkg) - ] - -instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, - Binary ipkg, Binary srcpkg) - => Binary (GenericInstallPlan ipkg srcpkg) where - put GenericInstallPlan { - planGraph = graph, - planIndepGoals = indepGoals - } = put graph >> put indepGoals - - get = do - graph <- get - indepGoals <- get - return $! mkInstallPlan "(instance Binary)" graph indepGoals - -showPlanGraph :: (Package ipkg, Package srcpkg, - IsUnit ipkg, IsUnit srcpkg) - => Graph (GenericPlanPackage ipkg srcpkg) -> String -showPlanGraph graph = renderStyle defaultStyle $ - vcat (map dispPlanPackage (Foldable.toList graph)) - where dispPlanPackage p = - hang (hsep [ text (showPlanPackageTag p) - , pretty (packageId p) - , parens (pretty (nodeKey p))]) 2 - (vcat (map pretty (nodeNeighbors p))) - -showInstallPlan :: (Package ipkg, Package srcpkg, - IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg -> String -showInstallPlan = showPlanGraph . planGraph - -showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String -showPlanPackageTag (PreExisting _) = "PreExisting" -showPlanPackageTag (Configured _) = "Configured" -showPlanPackageTag (Installed _) = "Installed" - --- | Build an installation plan from a valid set of resolved packages. --- -new :: (IsUnit ipkg, IsUnit srcpkg) - => IndependentGoals - -> Graph (GenericPlanPackage ipkg srcpkg) - -> GenericInstallPlan ipkg srcpkg -new indepGoals graph = mkInstallPlan "new" graph indepGoals - -toGraph :: GenericInstallPlan ipkg srcpkg - -> Graph (GenericPlanPackage ipkg srcpkg) -toGraph = planGraph - -toList :: GenericInstallPlan ipkg srcpkg - -> [GenericPlanPackage ipkg srcpkg] -toList = Foldable.toList . planGraph - -toMap :: GenericInstallPlan ipkg srcpkg - -> Map UnitId (GenericPlanPackage ipkg srcpkg) -toMap = Graph.toMap . planGraph - -keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] -keys = Graph.keys . planGraph - -keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId -keysSet = Graph.keysSet . planGraph - --- | Remove packages from the install plan. This will result in an --- error if there are remaining packages that depend on any matching --- package. This is primarily useful for obtaining an install plan for --- the dependencies of a package or set of packages without actually --- installing the package itself, as when doing development. --- -remove :: (IsUnit ipkg, IsUnit srcpkg) - => (GenericPlanPackage ipkg srcpkg -> Bool) - -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg -remove shouldRemove plan = - mkInstallPlan "remove" newGraph (planIndepGoals plan) - where - newGraph = Graph.fromDistinctList $ - filter (not . shouldRemove) (toList plan) - --- | Change a number of packages in the 'Configured' state to the 'Installed' --- state. --- --- To preserve invariants, the package must have all of its dependencies --- already installed too (that is 'PreExisting' or 'Installed'). --- -installed :: (IsUnit ipkg, IsUnit srcpkg) - => (srcpkg -> Bool) - -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg -installed shouldBeInstalled installPlan = - foldl' markInstalled installPlan - [ pkg - | Configured pkg <- reverseTopologicalOrder installPlan - , shouldBeInstalled pkg ] - where - markInstalled plan pkg = - assert (all isInstalled (directDeps plan (nodeKey pkg))) $ - plan { - planGraph = Graph.insert (Installed pkg) (planGraph plan) - } - --- | Lookup a package in the plan. --- -lookup :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> UnitId - -> Maybe (GenericPlanPackage ipkg srcpkg) -lookup plan pkgid = Graph.lookup pkgid (planGraph plan) - --- | Find all the direct dependencies of the given package. --- --- Note that the package must exist in the plan or it is an error. --- -directDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId - -> [GenericPlanPackage ipkg srcpkg] -directDeps plan pkgid = - case Graph.neighbors (planGraph plan) pkgid of - Just deps -> deps - Nothing -> internalError "directDeps" "package not in graph" - --- | Find all the direct reverse dependencies of the given package. --- --- Note that the package must exist in the plan or it is an error. --- -revDirectDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId - -> [GenericPlanPackage ipkg srcpkg] -revDirectDeps plan pkgid = - case Graph.revNeighbors (planGraph plan) pkgid of - Just deps -> deps - Nothing -> internalError "revDirectDeps" "package not in graph" - --- | Return all the packages in the 'InstallPlan' in reverse topological order. --- That is, for each package, all dependencies of the package appear first. --- --- Compared to 'executionOrder', this function returns all the installed and --- source packages rather than just the source ones. Also, while both this --- and 'executionOrder' produce reverse topological orderings of the package --- dependency graph, it is not necessarily exactly the same order. --- -reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg - -> [GenericPlanPackage ipkg srcpkg] -reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) - - --- | Return the packages in the plan that are direct or indirect dependencies of --- the given packages. --- -dependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] - -> [GenericPlanPackage ipkg srcpkg] -dependencyClosure plan = fromMaybe [] - . Graph.closure (planGraph plan) - --- | Return the packages in the plan that depend directly or indirectly on the --- given packages. --- -reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] - -> [GenericPlanPackage ipkg srcpkg] -reverseDependencyClosure plan = fromMaybe [] - . Graph.revClosure (planGraph plan) - - --- Alert alert! Why does SolverId map to a LIST of plan packages? --- The sordid story has to do with 'build-depends' on a package --- with libraries and executables. In an ideal world, we would --- ONLY depend on the library in this situation. But c.f. #3661 --- some people rely on the build-depends to ALSO implicitly --- depend on an executable. --- --- I don't want to commit to a strategy yet, so the only possible --- thing you can do in this case is return EVERYTHING and let --- the client filter out what they want (executables? libraries? --- etc). This similarly implies we can't return a 'ConfiguredId' --- because that's not enough information. - -fromSolverInstallPlan :: - (IsUnit ipkg, IsUnit srcpkg) - => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) - -> SolverInstallPlan.SolverPlanPackage - -> [GenericPlanPackage ipkg srcpkg] ) - -> SolverInstallPlan - -> GenericInstallPlan ipkg srcpkg -fromSolverInstallPlan f plan = - mkInstallPlan "fromSolverInstallPlan" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) - where - (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, []) - (SolverInstallPlan.reverseTopologicalOrder plan) - - f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs) - where - pkgs' = f (mapDep pidMap ipiMap) pkg - - (pidMap', ipiMap') - = case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) - - mapDep _ ipiMap (PreExistingId _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) - -- This shouldn't happen, since mapDep should only be called - -- on neighbor SolverId, which must have all been done already - -- by the reverse top-sort (we assume the graph is not broken). - - -fromSolverInstallPlanWithProgress :: - (IsUnit ipkg, IsUnit srcpkg) - => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) - -> SolverInstallPlan.SolverPlanPackage - -> LogProgress [GenericPlanPackage ipkg srcpkg] ) - -> SolverInstallPlan - -> LogProgress (GenericInstallPlan ipkg srcpkg) -fromSolverInstallPlanWithProgress f plan = do - (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) - (SolverInstallPlan.reverseTopologicalOrder plan) - return $ mkInstallPlan "fromSolverInstallPlanWithProgress" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) - where - f' (pidMap, ipiMap, pkgs) pkg = do - pkgs' <- f (mapDep pidMap ipiMap) pkg - let (pidMap', ipiMap') - = case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) - return (pidMap', ipiMap', pkgs' ++ pkgs) - - mapDep _ ipiMap (PreExistingId _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) - -- This shouldn't happen, since mapDep should only be called - -- on neighbor SolverId, which must have all been done already - -- by the reverse top-sort (we assume the graph is not broken). - --- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. --- Similar to 'elaboratedInstallPlan' -configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan -configureInstallPlan configFlags solverPlan = - flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> - [case planpkg of - SolverInstallPlan.PreExisting pkg -> - PreExisting (instSolverPkgIPI pkg) - - SolverInstallPlan.Configured pkg -> - Configured (configureSolverPackage mapDep pkg) - ] - where - configureSolverPackage :: (SolverId -> [PlanPackage]) - -> SolverPackage UnresolvedPkgLoc - -> ConfiguredPackage UnresolvedPkgLoc - configureSolverPackage mapDep spkg = - ConfiguredPackage { - confPkgId = Configure.computeComponentId - (Cabal.fromFlagOrDefault False - (Cabal.configDeterministic configFlags)) - Cabal.NoFlag - Cabal.NoFlag - (packageId spkg) - (PD.CLibName PD.LMainLibName) - (Just (map confInstId (CD.libraryDeps deps), - solverPkgFlags spkg)), - confPkgSource = solverPkgSource spkg, - confPkgFlags = solverPkgFlags spkg, - confPkgStanzas = solverPkgStanzas spkg, - confPkgDeps = deps - -- NB: no support for executable dependencies - } - where - deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg) - - --- ------------------------------------------------------------ --- * Primitives for traversing plans --- ------------------------------------------------------------ - --- $traversal --- --- Algorithms to traverse or execute an 'InstallPlan', especially in parallel, --- may make use of the 'Processing' type and the associated operations --- 'ready', 'completed' and 'failed'. --- --- The 'Processing' type is used to keep track of the state of a traversal and --- includes the set of packages that are in the processing state, e.g. in the --- process of being installed, plus those that have been completed and those --- where processing failed. --- --- Traversal algorithms start with an 'InstallPlan': --- --- * Initially there will be certain packages that can be processed immediately --- (since they are configured source packages and have all their dependencies --- installed already). The function 'ready' returns these packages plus a --- 'Processing' state that marks these same packages as being in the --- processing state. --- --- * The algorithm must now arrange for these packages to be processed --- (possibly in parallel). When a package has completed processing, the --- algorithm needs to know which other packages (if any) are now ready to --- process as a result. The 'completed' function marks a package as completed --- and returns any packages that are newly in the processing state (ie ready --- to process), along with the updated 'Processing' state. --- --- * If failure is possible then when processing a package fails, the algorithm --- needs to know which other packages have also failed as a result. The --- 'failed' function marks the given package as failed as well as all the --- other packages that depend on the failed package. In addition it returns --- the other failed packages. - - --- | The 'Processing' type is used to keep track of the state of a traversal --- and includes the set of packages that are in the processing state, e.g. in --- the process of being installed, plus those that have been completed and --- those where processing failed. --- -data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) - -- processing, completed, failed - --- | The packages in the plan that are initially ready to be installed. --- That is they are in the configured state and have all their dependencies --- installed already. --- --- The result is both the packages that are now ready to be installed and also --- a 'Processing' state containing those same packages. The assumption is that --- all the packages that are ready will now be processed and so we can consider --- them to be in the processing state. --- -ready :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> ([GenericReadyPackage srcpkg], Processing) -ready plan = - assert (processingInvariant plan processing) $ - (readyPackages, processing) - where - !processing = - Processing - (Set.fromList [ nodeKey pkg | pkg <- readyPackages ]) - (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ]) - Set.empty - readyPackages = - [ ReadyPackage pkg - | Configured pkg <- toList plan - , all isInstalled (directDeps plan (nodeKey pkg)) - ] - -isInstalled :: GenericPlanPackage a b -> Bool -isInstalled (PreExisting {}) = True -isInstalled (Installed {}) = True -isInstalled _ = False - --- | Given a package in the processing state, mark the package as completed --- and return any packages that are newly in the processing state (ie ready to --- process), along with the updated 'Processing' state. --- -completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> UnitId - -> ([GenericReadyPackage srcpkg], Processing) -completed plan (Processing processingSet completedSet failedSet) pkgid = - assert (pkgid `Set.member` processingSet) $ - assert (processingInvariant plan processing') $ - - ( map asReadyPackage newlyReady - , processing' ) - where - completedSet' = Set.insert pkgid completedSet - - -- each direct reverse dep where all direct deps are completed - newlyReady = [ dep - | dep <- revDirectDeps plan pkgid - , all ((`Set.member` completedSet') . nodeKey) - (directDeps plan (nodeKey dep)) - ] - - processingSet' = foldl' (flip Set.insert) - (Set.delete pkgid processingSet) - (map nodeKey newlyReady) - processing' = Processing processingSet' completedSet' failedSet - - asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg - asReadyPackage (Configured pkg) = ReadyPackage pkg - asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg - -failed :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> UnitId - -> ([srcpkg], Processing) -failed plan (Processing processingSet completedSet failedSet) pkgid = - assert (pkgid `Set.member` processingSet) $ - assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $ - assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ - -- but note that some newlyFailed may already be in the failed set - -- since one package can depend on two packages that both fail and - -- so would be in the rev-dep closure for both. - assert (processingInvariant plan processing') $ - - ( map asConfiguredPackage (tail newlyFailed) - , processing' ) - where - processingSet' = Set.delete pkgid processingSet - failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds - newlyFailedIds = map nodeKey newlyFailed - newlyFailed = fromMaybe (internalError "failed" "package not in graph") - $ Graph.revClosure (planGraph plan) [pkgid] - processing' = Processing processingSet' completedSet failedSet' - - asConfiguredPackage (Configured pkg) = pkg - asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg - -processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> Bool -processingInvariant plan (Processing processingSet completedSet failedSet) = - - -- All the packages in the three sets are actually in the graph - assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $ - assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $ - assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $ - - -- The processing, completed and failed sets are disjoint from each other - assert (noIntersection processingSet completedSet) $ - assert (noIntersection processingSet failedSet) $ - assert (noIntersection failedSet completedSet) $ - - -- Packages that depend on a package that's still processing cannot be - -- completed - assert (noIntersection (reverseClosure processingSet) completedSet) $ - - -- On the other hand, packages that depend on a package that's still - -- processing /can/ have failed (since they may have depended on multiple - -- packages that were processing, but it only takes one to fail to cause - -- knock-on failures) so it is quite possible to have an - -- intersection (reverseClosure processingSet) failedSet - - -- The failed set is upwards closed, i.e. equal to its own rev dep closure - assert (failedSet == reverseClosure failedSet) $ - - -- All immediate reverse deps of packges that are currently processing - -- are not currently being processed (ie not in the processing set). - assert (and [ rdeppkgid `Set.notMember` processingSet - | pkgid <- Set.toList processingSet - , rdeppkgid <- maybe (internalError "processingInvariant" "") - (map nodeKey) - (Graph.revNeighbors (planGraph plan) pkgid) - ]) $ - - -- Packages from the processing or failed sets are only ever in the - -- configured state. - assert (and [ case Graph.lookup pkgid (planGraph plan) of - Just (Configured _) -> True - Just (PreExisting _) -> False - Just (Installed _) -> False - Nothing -> False - | pkgid <- Set.toList processingSet ++ Set.toList failedSet ]) - - -- We use asserts rather than returning False so that on failure we get - -- better details on which bit of the invariant was violated. - True - where - reverseClosure = Set.fromList - . map nodeKey - . fromMaybe (internalError "processingInvariant" "") - . Graph.revClosure (planGraph plan) - . Set.toList - noIntersection a b = Set.null (Set.intersection a b) - - --- ------------------------------------------------------------ --- * Traversing plans --- ------------------------------------------------------------ - --- | Flatten an 'InstallPlan', producing the sequence of source packages in --- the order in which they would be processed when the plan is executed. This --- can be used for simultations or presenting execution dry-runs. --- --- It is guaranteed to give the same order as using 'execute' (with a serial --- in-order 'JobControl'), which is a reverse topological orderings of the --- source packages in the dependency graph, albeit not necessarily exactly the --- same ordering as that produced by 'reverseTopologicalOrder'. --- -executionOrder :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> [GenericReadyPackage srcpkg] -executionOrder plan = - let (newpkgs, processing) = ready plan - in tryNewTasks processing newpkgs - where - tryNewTasks _processing [] = [] - tryNewTasks processing (p:todo) = waitForTasks processing p todo - - waitForTasks processing p todo = - p : tryNewTasks processing' (todo++nextpkgs) - where - (nextpkgs, processing') = completed plan processing (nodeKey p) - - --- ------------------------------------------------------------ --- * Executing plans --- ------------------------------------------------------------ - --- | The set of results we get from executing an install plan. --- -type BuildOutcomes failure result = Map UnitId (Either failure result) - --- | Lookup the build result for a single package. --- -lookupBuildOutcome :: HasUnitId pkg - => pkg -> BuildOutcomes failure result - -> Maybe (Either failure result) -lookupBuildOutcome = Map.lookup . installedUnitId - --- | Execute an install plan. This traverses the plan in dependency order. --- --- Executing each individual package can fail and if so all dependents fail --- too. The result for each package is collected as a 'BuildOutcomes' map. --- --- Visiting each package happens with optional parallelism, as determined by --- the 'JobControl'. By default, after any failure we stop as soon as possible --- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour --- can be reversed to keep going and build as many packages as possible. --- --- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages --- in the plan. In particular in the default mode where we stop as soon as --- possible after a failure then there may be packages which are skipped and --- these will have no 'BuildOutcome'. --- -execute :: forall m ipkg srcpkg result failure. - (IsUnit ipkg, IsUnit srcpkg, - Monad m) - => JobControl m (UnitId, Either failure result) - -> Bool -- ^ Keep going after failure - -> (srcpkg -> failure) -- ^ Value for dependents of failed packages - -> GenericInstallPlan ipkg srcpkg - -> (GenericReadyPackage srcpkg -> m (Either failure result)) - -> m (BuildOutcomes failure result) -execute jobCtl keepGoing depFailure plan installPkg = - let (newpkgs, processing) = ready plan - in tryNewTasks Map.empty False False processing newpkgs - where - tryNewTasks :: BuildOutcomes failure result - -> Bool -> Bool -> Processing - -> [GenericReadyPackage srcpkg] - -> m (BuildOutcomes failure result) - - tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs - -- we were in the process of cancelling and now we're finished - | tasksFailed && not keepGoing && not tasksRemaining - = return results - - -- we are still in the process of cancelling, wait for remaining tasks - | tasksFailed && not keepGoing && tasksRemaining - = waitForTasks results tasksFailed processing - - -- no new tasks to do and all tasks are done so we're finished - | null newpkgs && not tasksRemaining - = return results - - -- no new tasks to do, remaining tasks to wait for - | null newpkgs - = waitForTasks results tasksFailed processing - - -- new tasks to do, spawn them, then wait for tasks to complete - | otherwise - = do sequence_ [ spawnJob jobCtl $ do - result <- installPkg pkg - return (nodeKey pkg, result) - | pkg <- newpkgs ] - waitForTasks results tasksFailed processing - - waitForTasks :: BuildOutcomes failure result - -> Bool -> Processing - -> m (BuildOutcomes failure result) - waitForTasks !results tasksFailed !processing = do - (pkgid, result) <- collectJob jobCtl - - case result of - - Right _success -> do - tasksRemaining <- remainingJobs jobCtl - tryNewTasks results' tasksFailed tasksRemaining - processing' nextpkgs - where - results' = Map.insert pkgid result results - (nextpkgs, processing') = completed plan processing pkgid - - Left _failure -> do - -- if this is the first failure and we're not trying to keep going - -- then try to cancel as many of the remaining jobs as possible - when (not tasksFailed && not keepGoing) $ - cancelJobs jobCtl - - tasksRemaining <- remainingJobs jobCtl - tryNewTasks results' True tasksRemaining processing' [] - where - (depsfailed, processing') = failed plan processing pkgid - results' = Map.insert pkgid result results `Map.union` depResults - depResults = Map.fromList - [ (nodeKey deppkg, Left (depFailure deppkg)) - | deppkg <- depsfailed ] - --- ------------------------------------------------------------ --- * Checking validity of plans --- ------------------------------------------------------------ - --- | A valid installation plan is a set of packages that is closed, acyclic --- and respects the package state relation. --- --- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: (IsUnit ipkg, IsUnit srcpkg) - => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool -valid loc graph = - case problems graph of - [] -> True - ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) - -data PlanProblem ipkg srcpkg = - PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] - | PackageCycle [GenericPlanPackage ipkg srcpkg] - | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) - (GenericPlanPackage ipkg srcpkg) - -showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg) - => PlanProblem ipkg srcpkg -> String -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " ++ prettyShow (nodeKey pkg) - ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) - -showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup) -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " ++ prettyShow (nodeKey pkg) - ++ " is in the " ++ showPlanPackageTag pkg - ++ " state but it depends on package " ++ prettyShow (nodeKey pkg') - ++ " which is in the " ++ showPlanPackageTag pkg' - ++ " state" - --- | For an invalid plan, produce a detailed list of problems as human readable --- error messages. This is mainly intended for debugging purposes. --- Use 'showPlanProblem' for a human readable explanation. --- -problems :: (IsUnit ipkg, IsUnit srcpkg) - => Graph (GenericPlanPackage ipkg srcpkg) - -> [PlanProblem ipkg srcpkg] -problems graph = - - [ PackageMissingDeps pkg - (mapMaybe - (fmap nodeKey . flip Graph.lookup graph) - missingDeps) - | (pkg, missingDeps) <- Graph.broken graph ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles graph ] -{- - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - dependencyInconsistencies indepGoals graph ] - --TODO: consider re-enabling this one, see SolverInstallPlan --} - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Foldable.toList graph - , Just pkg' <- map (flip Graph.lookup graph) - (nodeNeighbors pkg) - , not (stateDependencyRelation pkg pkg') ] - --- | The states of packages have that depend on each other must respect --- this relation. That is for very case where package @a@ depends on --- package @b@ we require that @stateDependencyRelation a b = True@. --- -stateDependencyRelation :: GenericPlanPackage ipkg srcpkg - -> GenericPlanPackage ipkg srcpkg -> Bool -stateDependencyRelation PreExisting{} PreExisting{} = True - -stateDependencyRelation Installed{} PreExisting{} = True -stateDependencyRelation Installed{} Installed{} = True - -stateDependencyRelation Configured{} PreExisting{} = True -stateDependencyRelation Configured{} Installed{} = True -stateDependencyRelation Configured{} Configured{} = True - -stateDependencyRelation _ _ = False diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs deleted file mode 100644 --- a/Distribution/Client/InstallSymlink.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.InstallSymlink --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Managing installing binaries with symlinks. ------------------------------------------------------------------------------ -module Distribution.Client.InstallSymlink ( - symlinkBinaries, - symlinkBinary, - trySymlink, - ) where - -import Distribution.Client.Compat.Prelude hiding (ioError) -import Prelude () - -import Distribution.Client.Types - ( ConfiguredPackage(..), BuildOutcomes ) -import Distribution.Client.Setup - ( InstallFlags(installSymlinkBinDir) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) - -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.OptionalStanza - -import Distribution.Package - ( PackageIdentifier, Package(packageId), UnitId, installedUnitId ) -import Distribution.Types.UnqualComponentName -import Distribution.Compiler - ( CompilerId(..) ) -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Simple.Setup - ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.Compiler - ( Compiler, compilerInfo, CompilerInfo(..) ) -import Distribution.System - ( Platform ) -import Distribution.Simple.Utils ( info, withTempDirectory ) - -import System.Directory - ( canonicalizePath, getTemporaryDirectory, removeFile ) -import System.FilePath - ( (), splitPath, joinPath, isAbsolute ) - -import System.IO.Error - ( isDoesNotExistError, ioError ) -import Control.Exception - ( assert ) - -import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink ) -import Distribution.Client.Types.OverwritePolicy - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 - --- | We would like by default to install binaries into some location that is on --- the user's PATH. For per-user installations on Unix systems that basically --- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ --- directory will be on the user's PATH. However some people are a bit nervous --- about letting a package manager install programs into @~/bin/@. --- --- A compromise solution is that instead of installing binaries directly into --- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ --- and then create symlinks in @~/bin/@. We can be careful when setting up the --- symlinks that we do not overwrite any binary that the user installed. We can --- check if it was a symlink we made because it would point to the private dir --- where we install our binaries. This means we can install normally without --- worrying and in a later phase set up symlinks, and if that fails then we --- report it to the user, but even in this case the package is still in an OK --- installed state. --- --- This is an optional feature that users can choose to use or not. It is --- controlled from the config file. Of course it only works on POSIX systems --- with symlinks so is not available to Windows users. --- -symlinkBinaries :: Platform -> Compiler - -> OverwritePolicy - -> ConfigFlags - -> InstallFlags - -> InstallPlan - -> BuildOutcomes - -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] -symlinkBinaries platform comp overwritePolicy - configFlags installFlags - plan buildOutcomes = - case flagToMaybe (installSymlinkBinDir installFlags) of - Nothing -> return [] - Just symlinkBinDir - | null exes -> return [] - | otherwise -> do - publicBinDir <- canonicalizePath symlinkBinDir --- TODO: do we want to do this here? : --- createDirectoryIfMissing True publicBinDir - fmap catMaybes $ sequenceA - [ do privateBinDir <- pkgBinDir pkg ipid - ok <- symlinkBinary - overwritePolicy - publicBinDir privateBinDir - (prettyShow publicExeName) privateExeName - if ok - then return Nothing - else return (Just (pkgid, publicExeName, - privateBinDir privateExeName)) - | (rpkg, pkg, exe) <- exes - , let pkgid = packageId pkg - -- This is a bit dodgy; probably won't work for Backpack packages - ipid = installedUnitId rpkg - publicExeName = PackageDescription.exeName exe - privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix - prefix = substTemplate pkgid ipid prefixTemplate - suffix = substTemplate pkgid ipid suffixTemplate ] - where - exes = - [ (cpkg, pkg, exe) - | InstallPlan.Configured cpkg <- InstallPlan.toList plan - , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of - Just (Right _success) -> True - _ -> False - , let pkg :: PackageDescription - pkg = pkgDescription cpkg - , exe <- PackageDescription.executables pkg - , PackageDescription.buildable (PackageDescription.buildInfo exe) ] - - pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _) - flags stanzas _) = - case finalizePD flags (enableStanzas stanzas) - (const True) - platform cinfo [] gpd of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc - - -- This is sadly rather complicated. We're kind of re-doing part of the - -- configuration for the package. :-( - pkgBinDir :: PackageDescription -> UnitId -> IO FilePath - pkgBinDir pkg ipid = do - defaultDirs <- InstallDirs.defaultInstallDirs - compilerFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - absoluteDirs = InstallDirs.absoluteInstallDirs - (packageId pkg) ipid - cinfo InstallDirs.NoCopyDest - platform templateDirs - canonicalizePath (InstallDirs.bindir absoluteDirs) - - substTemplate pkgid ipid = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid ipid - cinfo platform - - fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") - prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) - suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - cinfo = compilerInfo comp - (CompilerId compilerFlavor _) = compilerInfoId cinfo - --- | Symlink binary. --- --- The paths are take in pieces, so we can make relative link when possible. --- -symlinkBinary :: - OverwritePolicy -- ^ Whether to force overwrite an existing file - -> FilePath -- ^ The canonical path of the public bin dir eg - -- @/home/user/bin@ - -> FilePath -- ^ The canonical path of the private bin dir eg - -- @/home/user/.cabal/bin@ - -> FilePath -- ^ The name of the executable to go in the public bin - -- dir, eg @foo@ - -> String -- ^ The name of the executable to in the private bin - -- dir, eg @foo-1.0@ - -> IO Bool -- ^ If creating the symlink was successful. @False@ if - -- there was another file there already that we did - -- not own. Other errors like permission errors just - -- propagate as exceptions. -symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir publicName) - (privateBindir privateName) - case ok of - NotExists -> mkLink >> return True - OkToOverwrite -> rmLink >> mkLink >> return True - NotOurFile -> - case overwritePolicy of - NeverOverwrite -> return False - AlwaysOverwrite -> rmLink >> mkLink >> return True - where - relativeBindir = makeRelative publicBindir privateBindir - mkLink = createFileLink (relativeBindir privateName) (publicBindir publicName) - rmLink = removeFile (publicBindir publicName) - --- | Check a file path of a symlink that we would like to create to see if it --- is OK. For it to be OK to overwrite it must either not already exist yet or --- be a symlink to our target (in which case we can assume ownership). --- -targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private - -- binary that we would like to create - -> FilePath -- ^ The canonical path of the private binary. - -- Use 'canonicalizePath' to make this. - -> IO SymlinkStatus -targetOkToOverwrite symlink target = handleNotExist $ do - isLink <- pathIsSymbolicLink symlink - if not isLink - then return NotOurFile - else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink - -- This partially relies on canonicalizePath handling symlinks - if target == target' - then return OkToOverwrite - else return NotOurFile - - where - handleNotExist action = catchIO action $ \ioexception -> - -- If the target doesn't exist then there's no problem overwriting it! - if isDoesNotExistError ioexception - then return NotExists - else ioError ioexception - -data SymlinkStatus - = NotExists -- ^ The file doesn't exist so we can make a symlink. - | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll - -- have to delete it first before we make a new symlink. - | NotOurFile -- ^ A file already exists and it is not one of our existing - -- symlinks (either because it is not a symlink or because - -- it points somewhere other than our managed space). - deriving Show - --- | Take two canonical paths and produce a relative path to get from the first --- to the second, even if it means adding @..@ path components. --- -makeRelative :: FilePath -> FilePath -> FilePath -makeRelative a b = assert (isAbsolute a && isAbsolute b) $ - let as = splitPath a - bs = splitPath b - commonLen = length $ takeWhile id $ zipWith (==) as bs - in joinPath $ [ ".." | _ <- drop commonLen as ] - ++ drop commonLen bs - --- | Try to make a symlink in a temporary directory. --- --- If this works, we can try to symlink: even on Windows. --- -trySymlink :: Verbosity -> IO Bool -trySymlink verbosity = do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do - let from = tmpDirPath "file.txt" - let to = tmpDirPath "file2.txt" - - -- create a file - BS.writeFile from (BS8.pack "TEST") - - -- create a symbolic link - let create :: IO Bool - create = do - createFileLink from to - info verbosity $ "Symlinking seems to work" - return True - - create `catchIO` \exc -> do - info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc - return False diff --git a/Distribution/Client/JobControl.hs b/Distribution/Client/JobControl.hs deleted file mode 100644 --- a/Distribution/Client/JobControl.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.JobControl --- Copyright : (c) Duncan Coutts 2012 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- A job control concurrency abstraction ------------------------------------------------------------------------------ -module Distribution.Client.JobControl ( - JobControl, - newSerialJobControl, - newParallelJobControl, - spawnJob, - collectJob, - remainingJobs, - cancelJobs, - - JobLimit, - newJobLimit, - withJobLimit, - - Lock, - newLock, - criticalSection - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Control.Monad (forever, replicateM_) -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Control.Concurrent.STM (STM, atomically) -import Control.Concurrent.STM.TVar -import Control.Concurrent.STM.TChan -import Control.Exception (bracket_, try) -import Distribution.Compat.Stack -import Distribution.Client.Compat.Semaphore - - --- | A simple concurrency abstraction. Jobs can be spawned and can complete --- in any order. This allows both serial and parallel implementations. --- -data JobControl m a = JobControl { - -- | Add a new job to the pool of jobs - spawnJob :: m a -> m (), - - -- | Wait until one job is complete - collectJob :: m a, - - -- | Returns True if there are any outstanding jobs - -- (ie spawned but yet to be collected) - remainingJobs :: m Bool, - - -- | Try to cancel any outstanding but not-yet-started jobs. - -- Call 'remainingJobs' after this to find out if any jobs are left - -- (ie could not be cancelled). - cancelJobs :: m () - } - - --- | Make a 'JobControl' that executes all jobs serially and in order. --- It only executes jobs on demand when they are collected, not eagerly. --- --- Cancelling will cancel /all/ jobs that have not been collected yet. --- -newSerialJobControl :: IO (JobControl IO a) -newSerialJobControl = do - qVar <- newTChanIO - return JobControl { - spawnJob = spawn qVar, - collectJob = collect qVar, - remainingJobs = remaining qVar, - cancelJobs = cancel qVar - } - where - spawn :: TChan (IO a) -> IO a -> IO () - spawn qVar job = atomically $ writeTChan qVar job - - collect :: TChan (IO a) -> IO a - collect qVar = - join $ atomically $ readTChan qVar - - remaining :: TChan (IO a) -> IO Bool - remaining qVar = fmap not $ atomically $ isEmptyTChan qVar - - cancel :: TChan (IO a) -> IO () - cancel qVar = do - _ <- atomically $ readAllTChan qVar - return () - --- | Make a 'JobControl' that eagerly executes jobs in parallel, with a given --- maximum degree of parallelism. --- --- Cancelling will cancel jobs that have not yet begun executing, but jobs --- that have already been executed or are currently executing cannot be --- cancelled. --- -newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a)) -newParallelJobControl n | n < 1 || n > 1000 = - error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n -newParallelJobControl maxJobLimit = do - inqVar <- newTChanIO - outqVar <- newTChanIO - countVar <- newTVarIO 0 - replicateM_ maxJobLimit $ - forkIO $ - worker inqVar outqVar - return JobControl { - spawnJob = spawn inqVar countVar, - collectJob = collect outqVar countVar, - remainingJobs = remaining countVar, - cancelJobs = cancel inqVar countVar - } - where - worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO () - worker inqVar outqVar = - forever $ do - job <- atomically $ readTChan inqVar - res <- try job - atomically $ writeTChan outqVar res - - spawn :: TChan (IO a) -> TVar Int -> IO a -> IO () - spawn inqVar countVar job = - atomically $ do - modifyTVar' countVar (+1) - writeTChan inqVar job - - collect :: TChan (Either SomeException a) -> TVar Int -> IO a - collect outqVar countVar = do - res <- atomically $ do - modifyTVar' countVar (subtract 1) - readTChan outqVar - either throwIO return res - - remaining :: TVar Int -> IO Bool - remaining countVar = fmap (/=0) $ atomically $ readTVar countVar - - cancel :: TChan (IO a) -> TVar Int -> IO () - cancel inqVar countVar = - atomically $ do - xs <- readAllTChan inqVar - modifyTVar' countVar (subtract (length xs)) - -readAllTChan :: TChan a -> STM [a] -readAllTChan qvar = go [] - where - go xs = do - mx <- tryReadTChan qvar - case mx of - Nothing -> return (reverse xs) - Just x -> go (x:xs) - -------------------------- --- Job limits and locks --- - -data JobLimit = JobLimit QSem - -newJobLimit :: Int -> IO JobLimit -newJobLimit n = - fmap JobLimit (newQSem n) - -withJobLimit :: JobLimit -> IO a -> IO a -withJobLimit (JobLimit sem) = - bracket_ (waitQSem sem) (signalQSem sem) - -newtype Lock = Lock (MVar ()) - -newLock :: IO Lock -newLock = fmap Lock $ newMVar () - -criticalSection :: Lock -> IO a -> IO a -criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs deleted file mode 100644 --- a/Distribution/Client/List.hs +++ /dev/null @@ -1,629 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.List --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2008-2011 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- --- Search for and print information about packages ------------------------------------------------------------------------------ -module Distribution.Client.List ( - list, info - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Package - ( PackageName, Package(..), packageName - , packageVersion, UnitId ) -import Distribution.Types.Dependency -import Distribution.Types.UnqualComponentName -import Distribution.ModuleName (ModuleName) -import Distribution.License (License) -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.PackageDescription as Source -import qualified Distribution.Types.ModuleReexport as Source -import Distribution.PackageDescription - ( PackageFlag(..), unFlagName ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) - -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) -import Distribution.Simple.Utils - ( equating, die', notice ) -import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import Distribution.Version - ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion - , intersectVersionRanges, simplifyVersionRange ) - -import qualified Distribution.SPDX as SPDX - -import Distribution.Solver.Types.PackageConstraint -import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage - -import Distribution.Client.Types - ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage ) -import Distribution.Client.Targets - ( UserTarget, resolveUserTargets ) -import Distribution.Client.Setup - ( GlobalFlags(..), ListFlags(..), InfoFlags(..) - , RepoContext(..) ) -import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.FetchUtils - ( isFetched ) - -import Data.Bits ((.|.)) -import Data.List - ( maximumBy ) -import Data.List.NonEmpty (groupBy, nonEmpty) -import qualified Data.List as L -import Data.Maybe - ( fromJust ) -import qualified Data.Map as Map -import Data.Tree as Tree -import Control.Exception - ( assert ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint - ( lineLength, ribbonsPerLine, Doc, renderStyle, char - , nest, ($+$), text, vcat, style, parens, fsep) -import System.Directory - ( doesDirectoryExist ) - -import Distribution.Utils.ShortText (ShortText) -import qualified Distribution.Utils.ShortText as ShortText -import qualified Text.Regex.Base as Regex -import qualified Text.Regex.Posix.String as Regex - - --- | Return a list of packages matching given search strings. -getPkgList :: Verbosity - -> PackageDBStack - -> RepoContext - -> Maybe (Compiler, ProgramDb) - -> ListFlags - -> [String] - -> IO [PackageDisplayInfo] -getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do - installedPkgIndex <- for mcompprogdb $ \(comp, progdb) -> - getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - - regexps <- for pats $ \pat -> do - e <- Regex.compile compOption Regex.execBlank pat - case e of - Right r -> return r - Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err - - let sourcePkgIndex = packageIndex sourcePkgDb - prefs name = fromMaybe anyVersion - (Map.lookup name (packagePreferences sourcePkgDb)) - - pkgsInfoMatching :: - [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] - pkgsInfoMatching = - let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex - matchingSource = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex - in mergePackages matchingInstalled matchingSource - - pkgsInfo :: - [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] - pkgsInfo - -- gather info for all packages - | null regexps = mergePackages - (maybe [] InstalledPackageIndex.allPackages installedPkgIndex) - ( PackageIndex.allPackages sourcePkgIndex) - - -- gather info for packages matching search term - | otherwise = pkgsInfoMatching - - matches :: [PackageDisplayInfo] - matches = [ mergePackageInfo pref - installedPkgs sourcePkgs selectedPkg False - | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo - , not onlyInstalled || not (null installedPkgs) - , let pref = prefs pkgname - selectedPkg = latestWithPref pref sourcePkgs ] - return matches - where - onlyInstalled = fromFlagOrDefault False (listInstalled listFlags) - caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags) - - compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase - | otherwise = Regex.compExtended - - matchingPackages search regexps index = - [ pkg - | re <- regexps - , pkg <- search index (Regex.matchTest re) ] - - --- | Show information about packages. -list :: Verbosity - -> PackageDBStack - -> RepoContext - -> Maybe (Compiler, ProgramDb) - -> ListFlags - -> [String] - -> IO () -list verbosity packageDBs repos mcompProgdb listFlags pats = do - matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats - - if simpleOutput - then putStr $ unlines - [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version - | pkg <- matches - , version <- if onlyInstalled - then installedVersions pkg - else nub . sort $ installedVersions pkg - ++ sourceVersions pkg ] - -- Note: this only works because for 'list', one cannot currently - -- specify any version constraints, so listing all installed - -- and source ones works. - else - if null matches - then notice verbosity "No matches found." - else putStr $ unlines (map showPackageSummaryInfo matches) - where - onlyInstalled = fromFlag (listInstalled listFlags) - simpleOutput = fromFlag (listSimpleOutput listFlags) - -info :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> ProgramDb - -> GlobalFlags - -> InfoFlags - -> [UserTarget] - -> IO () -info verbosity _ _ _ _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -info verbosity packageDBs repoCtxt comp progdb - globalFlags _listFlags userTargets = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - let sourcePkgIndex = packageIndex sourcePkgDb - prefs name = fromMaybe anyVersion - (Map.lookup name (packagePreferences sourcePkgDb)) - - -- Users may specify names of packages that are only installed, not - -- just available source packages, so we must resolve targets using - -- the combination of installed and source packages. - let sourcePkgs' = PackageIndex.fromList - $ map packageId - (InstalledPackageIndex.allPackages installedPkgIndex) - ++ map packageId - (PackageIndex.allPackages sourcePkgIndex) - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (fromFlag $ globalWorldFile globalFlags) - sourcePkgs' userTargets - - pkgsinfo <- sequenceA - [ do pkginfo <- either (die' verbosity) return $ - gatherPkgInfo prefs - installedPkgIndex sourcePkgIndex - pkgSpecifier - updateFileSystemPackageDetails pkginfo - | pkgSpecifier <- pkgSpecifiers ] - - putStr $ unlines (map showPackageDetailedInfo pkgsinfo) - - where - gatherPkgInfo :: (PackageName -> VersionRange) -> - InstalledPackageIndex -> - PackageIndex.PackageIndex UnresolvedSourcePackage -> - PackageSpecifier UnresolvedSourcePackage -> - Either String PackageDisplayInfo - gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (NamedPackage name props) - | null (selectedInstalledPkgs) && null (selectedSourcePkgs) - = Left $ "There is no available version of " ++ prettyShow name - ++ " that satisfies " - ++ prettyShow (simplifyVersionRange verConstraint) - - | otherwise - = Right $ mergePackageInfo pref installedPkgs - sourcePkgs selectedSourcePkg' - showPkgVersion - where - (pref, installedPkgs, sourcePkgs) = - sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex - - selectedInstalledPkgs = InstalledPackageIndex.lookupDependency - installedPkgIndex - name verConstraint - selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex - name verConstraint - selectedSourcePkg' = latestWithPref pref selectedSourcePkgs - - -- display a specific package version if the user - -- supplied a non-trivial version constraint - showPkgVersion = not (null verConstraints) - verConstraint = foldr intersectVersionRanges anyVersion verConstraints - verConstraints = [ vr | PackagePropertyVersion vr <- props ] - - gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (SpecificSourcePackage pkg) = - Right $ mergePackageInfo pref installedPkgs sourcePkgs - selectedPkg True - where - name = packageName pkg - selectedPkg = Just pkg - (pref, installedPkgs, sourcePkgs) = - sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex - -sourcePkgsInfo :: - (PackageName -> VersionRange) - -> PackageName - -> InstalledPackageIndex - -> PackageIndex.PackageIndex UnresolvedSourcePackage - -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage]) -sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex = - (pref, installedPkgs, sourcePkgs) - where - pref = prefs name - installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName - installedPkgIndex name) - sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name - - --- | The info that we can display for each package. It is information per --- package name and covers all installed and available versions. --- -data PackageDisplayInfo = PackageDisplayInfo { - pkgName :: PackageName, - selectedVersion :: Maybe Version, - selectedSourcePkg :: Maybe UnresolvedSourcePackage, - installedVersions :: [Version], - sourceVersions :: [Version], - preferredVersions :: VersionRange, - homepage :: ShortText, - bugReports :: ShortText, - sourceRepo :: String, -- TODO - synopsis :: ShortText, - description :: ShortText, - category :: ShortText, - license :: Either SPDX.License License, - author :: ShortText, - maintainer :: ShortText, - dependencies :: [ExtDependency], - flags :: [PackageFlag], - hasLib :: Bool, - hasExe :: Bool, - executables :: [UnqualComponentName], - modules :: [ModuleName], - haddockHtml :: FilePath, - haveTarball :: Bool - } - --- | Covers source dependencies and installed dependencies in --- one type. -data ExtDependency = SourceDependency Dependency - | InstalledDependency UnitId - -showPackageSummaryInfo :: PackageDisplayInfo -> String -showPackageSummaryInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> pretty (pkgName pkginfo) - $+$ - (nest 4 $ vcat [ - maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs - , text "Default available version:" <+> - case selectedSourcePkg pkginfo of - Nothing -> text "[ Not available from any configured repository ]" - Just pkg -> pretty (packageVersion pkg) - , text "Installed versions:" <+> - case installedVersions pkginfo of - [] | hasLib pkginfo -> text "[ Not installed ]" - | otherwise -> text "[ Unknown ]" - versions -> dispTopVersions 4 - (preferredVersions pkginfo) versions - , maybeShowST (homepage pkginfo) "Homepage:" text - , text "License: " <+> either pretty pretty (license pkginfo) - ]) - $+$ text "" - where - maybeShowST l s f - | ShortText.null l = Disp.empty - | otherwise = text s <+> f (ShortText.fromShortText l) - -showPackageDetailedInfo :: PackageDisplayInfo -> String -showPackageDetailedInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> pretty (pkgName pkginfo) - <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo) - <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ') - <<>> parens pkgkind - $+$ - (nest 4 $ vcat [ - entryST "Synopsis" synopsis hideIfNull reflowParagraphs - , entry "Versions available" sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry "Versions installed" installedVersions - (altText null (if hasLib pkginfo then "[ Not installed ]" - else "[ Unknown ]")) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entryST "Homepage" homepage orNotSpecified text - , entryST "Bug reports" bugReports orNotSpecified text - , entryST "Description" description hideIfNull reflowParagraphs - , entryST "Category" category hideIfNull text - , entry "License" license alwaysShow (either pretty pretty) - , entryST "Author" author hideIfNull reflowLines - , entryST "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep pretty) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) then mempty else - text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo)) - ]) - $+$ text "" - where - entry fname field cond format = case cond (field pkginfo) of - Nothing -> label <+> format (field pkginfo) - Just Nothing -> mempty - Just (Just other) -> label <+> text other - where - label = text fname Disp.<> char ':' Disp.<> padding - padding = text (replicate (13 - length fname ) ' ') - - entryST fname field = entry fname (ShortText.fromShortText . field) - - normal = Nothing - hide = Just Nothing - replace msg = Just (Just msg) - - alwaysShow = const normal - hideIfNull v = if null v then hide else normal - showIfInstalled v - | not isInstalled = hide - | null v = replace "[ Not installed ]" - | otherwise = normal - altText nul msg v = if nul v then replace msg else normal - orNotSpecified = altText null "[ Not specified ]" - - commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f - dispFlag = text . unFlagName . flagName - dispYesNo True = text "Yes" - dispYesNo False = text "No" - - dispExtDep (SourceDependency dep) = pretty dep - dispExtDep (InstalledDependency dep) = pretty dep - - isInstalled = not (null (installedVersions pkginfo)) - hasExes = length (executables pkginfo) >= 2 - --TODO: exclude non-buildable exes - pkgkind | hasLib pkginfo && hasExes = text "programs and library" - | hasLib pkginfo && hasExe pkginfo = text "program and library" - | hasLib pkginfo = text "library" - | hasExes = text "programs" - | hasExe pkginfo = text "program" - | otherwise = mempty - - -reflowParagraphs :: String -> Doc -reflowParagraphs = - vcat - . intersperse (text "") -- re-insert blank lines - . map (fsep . map text . concatMap words) -- reflow paragraphs - . filter (/= [""]) - . L.groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines - . lines - -reflowLines :: String -> Doc -reflowLines = vcat . map text . lines - --- | We get the 'PackageDisplayInfo' by combining the info for the installed --- and available versions of a package. --- --- * We're building info about a various versions of a single named package so --- the input package info records are all supposed to refer to the same --- package name. --- -mergePackageInfo :: VersionRange - -> [Installed.InstalledPackageInfo] - -> [UnresolvedSourcePackage] - -> Maybe UnresolvedSourcePackage - -> Bool - -> PackageDisplayInfo -mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer = - assert (length installedPkgs + length sourcePkgs > 0) $ - PackageDisplayInfo { - pkgName = combine packageName source - packageName installed, - selectedVersion = if showVer then fmap packageVersion selectedPkg - else Nothing, - selectedSourcePkg = sourceSelected, - installedVersions = map packageVersion installedPkgs, - sourceVersions = map packageVersion sourcePkgs, - preferredVersions = versionPref, - - license = combine Source.licenseRaw source - Installed.license installed, - maintainer = combine Source.maintainer source - Installed.maintainer installed, - author = combine Source.author source - Installed.author installed, - homepage = combine Source.homepage source - Installed.homepage installed, - bugReports = maybe mempty Source.bugReports source, - sourceRepo = fromMaybe mempty . join - . fmap (uncons Nothing Source.repoLocation - . sortBy (comparing Source.repoKind) - . Source.sourceRepos) - $ source, - --TODO: installed package info is missing synopsis - synopsis = maybe mempty Source.synopsis source, - description = combine Source.description source - Installed.description installed, - category = combine Source.category source - Installed.category installed, - flags = maybe [] Source.genPackageFlags sourceGeneric, - hasLib = isJust installed - || maybe False (isJust . Source.condLibrary) sourceGeneric, - hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric, - executables = map fst (maybe [] Source.condExecutables sourceGeneric), - modules = combine (map Installed.exposedName . Installed.exposedModules) - installed - -- NB: only for the PUBLIC library - (concatMap getListOfExposedModules . maybeToList . Source.library) - source, - dependencies = - combine (map (SourceDependency . simplifyDependency) - . Source.allBuildDepends) source - (map InstalledDependency . Installed.depends) installed, - haddockHtml = fromMaybe "" . join - . fmap (listToMaybe . Installed.haddockHTMLs) - $ installed, - haveTarball = False - } - where - combine f x g y = fromJust (fmap f x `mplus` fmap g y) - installed :: Maybe Installed.InstalledPackageInfo - installed = latestWithPref versionPref installedPkgs - - getListOfExposedModules lib = Source.exposedModules lib - ++ map Source.moduleReexportName - (Source.reexportedModules lib) - - sourceSelected - | isJust selectedPkg = selectedPkg - | otherwise = latestWithPref versionPref sourcePkgs - sourceGeneric = fmap srcpkgDescription sourceSelected - source = fmap flattenPackageDescription sourceGeneric - - uncons :: b -> (a -> b) -> [a] -> b - uncons z _ [] = z - uncons _ f (x:_) = f x - - --- | Not all the info is pure. We have to check if the docs really are --- installed, because the registered package info lies. Similarly we have to --- check if the tarball has indeed been fetched. --- -updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo -updateFileSystemPackageDetails pkginfo = do - fetched <- maybe (return False) (isFetched . srcpkgSource) - (selectedSourcePkg pkginfo) - docsExist <- doesDirectoryExist (haddockHtml pkginfo) - return pkginfo { - haveTarball = fetched, - haddockHtml = if docsExist then haddockHtml pkginfo else "" - } - -latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg -latestWithPref _ [] = Nothing -latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs) - where - prefThenVersion pkg = let ver = packageVersion pkg - in (withinRange ver pref, ver) - - --- | Rearrange installed and source packages into groups referring to the --- same package by name. In the result pairs, the lists are guaranteed to not --- both be empty. --- -mergePackages :: [Installed.InstalledPackageInfo] - -> [UnresolvedSourcePackage] - -> [( PackageName - , [Installed.InstalledPackageInfo] - , [UnresolvedSourcePackage] )] -mergePackages installedPkgs sourcePkgs = - map collect - $ mergeBy (\i a -> fst i `compare` fst a) - (groupOn packageName installedPkgs) - (groupOn packageName sourcePkgs) - where - collect (OnlyInLeft (name,is) ) = (name, is, []) - collect ( InBoth (_,is) (name,as)) = (name, is, as) - collect (OnlyInRight (name,as)) = (name, [], as) - -groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] -groupOn key = map (\xs -> (key (head xs), toList xs)) - . groupBy (equating key) - . sortBy (comparing key) - -dispTopVersions :: Int -> VersionRange -> [Version] -> Doc -dispTopVersions n pref vs = - (Disp.fsep . Disp.punctuate (Disp.char ',') - . map (\ver -> if ispref ver then pretty ver else parens (pretty ver)) - . sort . take n . interestingVersions ispref - $ vs) - <+> trailingMessage - - where - ispref ver = withinRange ver pref - extra = length vs - n - trailingMessage - | extra <= 0 = Disp.empty - | otherwise = Disp.parens $ Disp.text "and" - <+> Disp.int (length vs - n) - <+> if extra == 1 then Disp.text "other" - else Disp.text "others" - --- | Reorder a bunch of versions to put the most interesting / significant --- versions first. A preferred version range is taken into account. --- --- This may be used in a user interface to select a small number of versions --- to present to the user, e.g. --- --- > let selectVersions = sort . take 5 . interestingVersions pref --- -interestingVersions :: (Version -> Bool) -> [Version] -> [Version] -interestingVersions pref = - map (mkVersion . fst) . filter snd - . concat . Tree.levels - . swizzleTree - . reorderTree (\(Node (v,_) _) -> pref (mkVersion v)) - . reverseTree - . mkTree - . map (or0 . versionNumbers) - - where - or0 [] = 0 :| [] - or0 (x:xs) = x :| xs - - swizzleTree = unfoldTree (spine []) - where - spine ts' (Node x []) = (x, ts') - spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t - - reorderTree _ (Node x []) = Node x [] - reorderTree p (Node x ts) = Node x (ts' ++ ts'') - where - (ts',ts'') = partition p (map (reorderTree p) ts) - - reverseTree (Node x cs) = Node x (reverse (map reverseTree cs)) - - mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool) - mkTree xs = unfoldTree step (False, [], xs) - where - step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])]) - step (node,ns,vs) = - ( (reverse ns, node) - , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs')) - | (n, vs') <- groups vs - ] - ) - - groups :: [NonEmpty a] -> [(a, NonEmpty [a])] - groups = map (\g -> (head (head g), fmap tail g)) - . groupBy (equating head) diff --git a/Distribution/Client/Manpage.hs b/Distribution/Client/Manpage.hs deleted file mode 100644 --- a/Distribution/Client/Manpage.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Manpage --- Copyright : (c) Maciek Makowski 2015 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Functions for building the manual page. - -module Distribution.Client.Manpage - ( -- * Manual page generation - manpage - , manpageCmd - , ManpageFlags - , defaultManpageFlags - , manpageOptions - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ManpageFlags -import Distribution.Client.Setup (globalCommand) -import Distribution.Compat.Process (createProcess) -import Distribution.Simple.Command -import Distribution.Simple.Flag (fromFlagOrDefault) -import System.IO (hClose, hPutStr) - -import qualified System.Process as Process - -data FileInfo = FileInfo String String -- ^ path, description - -------------------------------------------------------------------------------- --- -------------------------------------------------------------------------------- - --- | A list of files that should be documented in the manual page. -files :: [FileInfo] -files = - [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.") - , (FileInfo "~/.cabal/world" "A list of all packages whose installation has been explicitly requested.") - ] - -manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO () -manpageCmd pname commands flags - | fromFlagOrDefault False (manpageRaw flags) - = putStrLn contents - | otherwise - = do - let cmd = "man" - args = ["-l", "-"] - - (mb_in, _, _, ph) <- createProcess (Process.proc cmd args) - { Process.std_in = Process.CreatePipe - , Process.std_out = Process.Inherit - , Process.std_err = Process.Inherit - } - - -- put contents - for_ mb_in $ \hin -> do - hPutStr hin contents - hClose hin - - -- wait for process to exit, propagate exit code - ec <- Process.waitForProcess ph - exitWith ec - where - contents :: String - contents = manpage pname commands - --- | Produces a manual page with @troff@ markup. -manpage :: String -> [CommandSpec a] -> String -manpage pname commands = unlines $ - [ ".TH " ++ map toUpper pname ++ " 1" - , ".SH NAME" - , pname ++ " \\- a system for building and packaging Haskell libraries and programs" - , ".SH SYNOPSIS" - , ".B " ++ pname - , ".I command" - , ".RI < arguments |[ options ]>..." - , "" - , "Where the" - , ".I commands" - , "are" - , "" - ] ++ - concatMap (commandSynopsisLines pname) commands ++ - [ ".SH DESCRIPTION" - , "Cabal is the standard package system for Haskell software. It helps people to configure, " - , "build and install Haskell software and to distribute it easily to other users and developers." - , "" - , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with " - , "installing existing packages and developing new packages. " - , "It can be used to work with local packages or to install packages from online package archives, " - , "including automatically installing dependencies. By default it is configured to use Hackage, " - , "which is Haskell's central package archive that contains thousands of libraries and applications " - , "in the Cabal package format." - , ".SH OPTIONS" - , "Global options:" - , "" - ] ++ - optionsLines (globalCommand []) ++ - [ ".SH COMMANDS" - ] ++ - concatMap (commandDetailsLines pname) commands ++ - [ ".SH FILES" - ] ++ - concatMap fileLines files ++ - [ ".SH BUGS" - , "To browse the list of known issues or report a new one please see " - , "https://github.com/haskell/cabal/labels/cabal-install." - ] - -commandSynopsisLines :: String -> CommandSpec action -> [String] -commandSynopsisLines pname (CommandSpec ui _ NormalCommand) = - [ ".B " ++ pname ++ " " ++ (commandName ui) - , ".R - " ++ commandSynopsis ui - , ".br" - ] -commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = [] - -commandDetailsLines :: String -> CommandSpec action -> [String] -commandDetailsLines pname (CommandSpec ui _ NormalCommand) = - [ ".B " ++ pname ++ " " ++ (commandName ui) - , "" - , commandUsage ui pname - , "" - ] ++ - optional commandDescription ++ - optional commandNotes ++ - [ "Flags:" - , ".RS" - ] ++ - optionsLines ui ++ - [ ".RE" - , "" - ] - where - optional field = - case field ui of - Just text -> [text pname, ""] - Nothing -> [] -commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = [] - -optionsLines :: CommandUI flags -> [String] -optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs)) - -data ArgumentRequired = Optional | Required -type OptionArg = (ArgumentRequired, ArgPlaceHolder) - -optionLines :: OptDescr flags -> [String] -optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) = - argOptionLines description optionChars optionStrings (Required, placeHolder) -optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) = - argOptionLines description optionChars optionStrings (Optional, placeHolder) -optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) = - optionLinesIfPresent trueChars trueStrings ++ - optionLinesIfPresent falseChars falseStrings ++ - optionDescriptionLines description -optionLines (ChoiceOpt options) = - concatMap choiceLines options - where - choiceLines (description, (optionChars, optionStrings), _, _) = - [ optionsLine optionChars optionStrings ] ++ - optionDescriptionLines description - -argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String] -argOptionLines description optionChars optionStrings arg = - [ optionsLine optionChars optionStrings - , optionArgLine arg - ] ++ - optionDescriptionLines description - -optionLinesIfPresent :: [Char] -> [String] -> [String] -optionLinesIfPresent optionChars optionStrings = - if null optionChars && null optionStrings then [] - else [ optionsLine optionChars optionStrings, ".br" ] - -optionDescriptionLines :: String -> [String] -optionDescriptionLines description = - [ ".RS" - , description - , ".RE" - , "" - ] - -optionsLine :: [Char] -> [String] -> String -optionsLine optionChars optionStrings = - intercalate ", " (shortOptions optionChars ++ longOptions optionStrings) - -shortOptions :: [Char] -> [String] -shortOptions = map (\c -> "\\-" ++ [c]) - -longOptions :: [String] -> [String] -longOptions = map (\s -> "\\-\\-" ++ s) - -optionArgLine :: OptionArg -> String -optionArgLine (Required, placeHolder) = ".I " ++ placeHolder -optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]" - -fileLines :: FileInfo -> [String] -fileLines (FileInfo path description) = - [ path - , ".RS" - , description - , ".RE" - , "" - ] diff --git a/Distribution/Client/ManpageFlags.hs b/Distribution/Client/ManpageFlags.hs deleted file mode 100644 --- a/Distribution/Client/ManpageFlags.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -module Distribution.Client.ManpageFlags -( ManpageFlags (..) -, defaultManpageFlags -, manpageOptions, -) where - -import Distribution.Client.Compat.Prelude - -import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) -import Distribution.Simple.Setup (Flag (..), toFlag, trueArg, optionVerbosity) -import Distribution.Verbosity (normal) - -data ManpageFlags = ManpageFlags - { manpageVerbosity :: Flag Verbosity - , manpageRaw :: Flag Bool - } deriving (Eq, Show, Generic) - -instance Monoid ManpageFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ManpageFlags where - (<>) = gmappend - -defaultManpageFlags :: ManpageFlags -defaultManpageFlags = ManpageFlags - { manpageVerbosity = toFlag normal - , manpageRaw = toFlag False - } - -manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags] -manpageOptions _ = - [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v }) - , option "" ["raw"] - "Output raw troff content" - manpageRaw (\v flags -> flags { manpageRaw = v }) - trueArg - ] diff --git a/Distribution/Client/Nix.hs b/Distribution/Client/Nix.hs deleted file mode 100644 --- a/Distribution/Client/Nix.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} - -module Distribution.Client.Nix - ( findNixExpr - , inNixShell - , nixInstantiate - , nixShell - ) where - -import Distribution.Client.Compat.Prelude - -import Control.Exception (bracket) -import System.Directory - ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist - , doesFileExist, removeDirectoryRecursive, removeFile ) -import System.Environment (getArgs, getExecutablePath) -import System.FilePath - ( (), replaceExtension, takeDirectory, takeFileName ) -import System.IO (IOMode(..), hClose, openFile) -import System.IO.Error (isDoesNotExistError) -import System.Process (showCommandForUser) - -import Distribution.Compat.Environment - ( lookupEnv, setEnv, unsetEnv ) - -import Distribution.Simple.Program - ( Program(..), ProgramDb - , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput - , runDbProgram, simpleProgram ) -import Distribution.Simple.Setup (fromFlagOrDefault) -import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan) - -import Distribution.Client.Config (SavedConfig(..)) -import Distribution.Client.GlobalFlags (GlobalFlags(..)) - - -configureOneProgram :: Verbosity -> Program -> IO ProgramDb -configureOneProgram verb prog = - configureProgram verb prog (addKnownProgram prog emptyProgramDb) - - -touchFile :: FilePath -> IO () -touchFile path = do - catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ())) - createDirectoryIfMissing True (takeDirectory path) - openFile path WriteMode >>= hClose - - -findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath) -findNixExpr globalFlags config = do - -- criteria for deciding to run nix-shell - let nixEnabled = - fromFlagOrDefault False - (globalNix (savedGlobalFlags config) <> globalNix globalFlags) - - if nixEnabled - then do - let exprPaths = [ "shell.nix", "default.nix" ] - filterM doesFileExist exprPaths >>= \case - [] -> return Nothing - (path : _) -> return (Just path) - else return Nothing - - --- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell -inFakeNixShell :: IO a -> IO a -inFakeNixShell f = - bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f) - where - fakeEnv var new = do - old <- lookupEnv var - setEnv var new - return old - resetEnv var = maybe (unsetEnv var) (setEnv var) - - -nixInstantiate - :: Verbosity - -> FilePath - -> Bool - -> GlobalFlags - -> SavedConfig - -> IO () -nixInstantiate verb dist force' globalFlags config = - findNixExpr globalFlags config >>= \case - Nothing -> return () - Just shellNix -> do - alreadyInShell <- inNixShell - shellDrv <- drvPath dist shellNix - instantiated <- doesFileExist shellDrv - -- an extra timestamp file is necessary because the derivation lives in - -- the store so its mtime is always 1. - let timestamp = timestampPath dist shellNix - upToDate <- existsAndIsMoreRecentThan timestamp shellNix - - let ready = alreadyInShell || (instantiated && upToDate && not force') - unless ready $ do - - let prog = simpleProgram "nix-instantiate" - progdb <- configureOneProgram verb prog - - removeGCRoots verb dist - touchFile timestamp - - _ <- inFakeNixShell - (getDbProgramOutput verb prog progdb - [ "--add-root", shellDrv, "--indirect", shellNix ]) - return () - - -nixShell - :: Verbosity - -> FilePath - -> GlobalFlags - -> SavedConfig - -> IO () - -- ^ The action to perform inside a nix-shell. This is also the action - -- that will be performed immediately if Nix is disabled. - -> IO () -nixShell verb dist globalFlags config go = do - - alreadyInShell <- inNixShell - - if alreadyInShell - then go - else do - findNixExpr globalFlags config >>= \case - Nothing -> go - Just shellNix -> do - - let prog = simpleProgram "nix-shell" - progdb <- configureOneProgram verb prog - - cabal <- getExecutablePath - - -- alreadyInShell == True in child process - setEnv "CABAL_IN_NIX_SHELL" "1" - - -- Run cabal with the same arguments inside nix-shell. - -- When the child process reaches the top of nixShell, it will - -- detect that it is running inside the shell and fall back - -- automatically. - shellDrv <- drvPath dist shellNix - args <- getArgs - runDbProgram verb prog progdb - [ "--add-root", gcrootPath dist "result", "--indirect", shellDrv - , "--run", showCommandForUser cabal args - ] - - -drvPath :: FilePath -> FilePath -> IO FilePath -drvPath dist path = do - -- We do not actually care about canonicity, but makeAbsolute is only - -- available in newer versions of directory. - -- We expect the path to be a symlink if it exists, so we do not canonicalize - -- the entire path because that would dereference the symlink. - distNix <- canonicalizePath (dist "nix") - -- Nix garbage collector roots must be absolute paths - return (distNix replaceExtension (takeFileName path) "drv") - - -timestampPath :: FilePath -> FilePath -> FilePath -timestampPath dist path = - dist "nix" replaceExtension (takeFileName path) "drv.timestamp" - - -gcrootPath :: FilePath -> FilePath -gcrootPath dist = dist "nix" "gcroots" - - -inNixShell :: IO Bool -inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL" - - -removeGCRoots :: Verbosity -> FilePath -> IO () -removeGCRoots verb dist = do - let tgt = gcrootPath dist - exists <- doesDirectoryExist tgt - when exists $ do - debug verb ("removing Nix gcroots from " ++ tgt) - removeDirectoryRecursive tgt diff --git a/Distribution/Client/NixStyleOptions.hs b/Distribution/Client/NixStyleOptions.hs deleted file mode 100644 --- a/Distribution/Client/NixStyleOptions.hs +++ /dev/null @@ -1,85 +0,0 @@ --- | Command line options for nix-style / v2 commands. --- --- The commands take a lot of the same options, which affect how install plan --- is constructed. -module Distribution.Client.NixStyleOptions ( - NixStyleFlags (..), - nixStyleOptions, - defaultNixStyleFlags, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs) -import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags) -import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) - -import Distribution.Client.ProjectFlags - (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions) -import Distribution.Client.Setup - (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions, - configureOptions, haddockOptions, installOptions, liftOptions, testOptions) - -data NixStyleFlags a = NixStyleFlags - { configFlags :: ConfigFlags - , configExFlags :: ConfigExFlags - , installFlags :: InstallFlags - , haddockFlags :: HaddockFlags - , testFlags :: TestFlags - , benchmarkFlags :: BenchmarkFlags - , projectFlags :: ProjectFlags - , extraFlags :: a - } - -nixStyleOptions - :: (ShowOrParseArgs -> [OptionField a]) - -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)] -nixStyleOptions commandOptions showOrParseArgs = - liftOptions configFlags set1 - -- Note: [Hidden Flags] - -- hide "constraint", "dependency", and - -- "exact-configuration" from the configure options. - (filter ((`notElem` ["constraint", "dependency" - , "exact-configuration"]) - . optionName) $ configureOptions showOrParseArgs) - ++ liftOptions configExFlags set2 (configureExOptions showOrParseArgs - ConstraintSourceCommandlineFlag) - ++ liftOptions installFlags set3 - -- hide "target-package-db" and "symlink-bindir" flags from the - -- install options. - -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags - (filter ((`notElem` ["target-package-db", "symlink-bindir"]) - . optionName) $ - installOptions showOrParseArgs) - ++ liftOptions haddockFlags set4 - -- hide "verbose" and "builddir" flags from the - -- haddock options. - (filter ((`notElem` ["v", "verbose", "builddir"]) - . optionName) $ - haddockOptions showOrParseArgs) - ++ liftOptions testFlags set5 (testOptions showOrParseArgs) - ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs) - ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs) - ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs) - where - set1 x flags = flags { configFlags = x } - set2 x flags = flags { configExFlags = x } - set3 x flags = flags { installFlags = x } - set4 x flags = flags { haddockFlags = x } - set5 x flags = flags { testFlags = x } - set6 x flags = flags { benchmarkFlags = x } - set7 x flags = flags { projectFlags = x } - set8 x flags = flags { extraFlags = x } - -defaultNixStyleFlags :: a -> NixStyleFlags a -defaultNixStyleFlags x = NixStyleFlags - { configFlags = mempty - , configExFlags = mempty - , installFlags = mempty - , haddockFlags = mempty - , testFlags = mempty - , benchmarkFlags = mempty - , projectFlags = defaultProjectFlags - , extraFlags = x - } diff --git a/Distribution/Client/Outdated.hs b/Distribution/Client/Outdated.hs deleted file mode 100644 --- a/Distribution/Client/Outdated.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Outdated --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Implementation of the 'outdated' command. Checks for outdated --- dependencies in the package description file or freeze file. ------------------------------------------------------------------------------ - -module Distribution.Client.Outdated ( outdated - , ListOutdatedSettings(..), listOutdated ) -where - -import Prelude () -import Distribution.Client.Config -import Distribution.Client.IndexUtils as IndexUtils -import Distribution.Client.Compat.Prelude -import Distribution.Client.ProjectConfig -import Distribution.Client.DistDirLayout -import Distribution.Client.RebuildMonad -import Distribution.Client.Setup hiding (quiet) -import Distribution.Client.Targets -import Distribution.Client.Types -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackageIndex -import Distribution.Client.Sandbox.PackageEnvironment -import Distribution.Utils.Generic - -import Distribution.Package (PackageName, packageVersion) -import Distribution.PackageDescription (allBuildDepends) -import Distribution.PackageDescription.Configuration (finalizePD) -import Distribution.Simple.Compiler (Compiler, compilerInfo) -import Distribution.Simple.Setup - (fromFlagOrDefault, flagToMaybe) -import Distribution.Simple.Utils - (die', notice, debug, tryFindPackageDesc) -import Distribution.System (Platform) -import Distribution.Types.ComponentRequestedSpec - (ComponentRequestedSpec(..)) -import Distribution.Types.Dependency - (Dependency(..)) -import Distribution.Verbosity (silent) -import Distribution.Version - (Version, VersionRange, LowerBound(..), UpperBound(..) - ,asVersionIntervals, majorBoundVersion) -import Distribution.PackageDescription.Parsec - (readGenericPackageDescription) -import Distribution.Types.PackageVersionConstraint - (PackageVersionConstraint (..), simplifyPackageVersionConstraint) - -import qualified Data.Set as S -import System.Directory (getCurrentDirectory) - --- | Entry point for the 'outdated' command. -outdated :: Verbosity -> OutdatedFlags -> RepoContext - -> Compiler -> Platform - -> IO () -outdated verbosity0 outdatedFlags repoContext comp platform = do - let freezeFile = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags) - newFreezeFile = fromFlagOrDefault False - (outdatedNewFreezeFile outdatedFlags) - mprojectFile = flagToMaybe - (outdatedProjectFile outdatedFlags) - simpleOutput = fromFlagOrDefault False - (outdatedSimpleOutput outdatedFlags) - quiet = fromFlagOrDefault False (outdatedQuiet outdatedFlags) - exitCode = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags) - ignorePred = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags) - in \pkgname -> pkgname `S.member` ignoreSet - minorPred = case outdatedMinor outdatedFlags of - Nothing -> const False - Just IgnoreMajorVersionBumpsNone -> const False - Just IgnoreMajorVersionBumpsAll -> const True - Just (IgnoreMajorVersionBumpsSome pkgs) -> - let minorSet = S.fromList pkgs - in \pkgname -> pkgname `S.member` minorSet - verbosity = if quiet then silent else verbosity0 - - when (not newFreezeFile && isJust mprojectFile) $ - die' verbosity $ - "--project-file must only be used with --v2-freeze-file." - - sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext - let pkgIndex = packageIndex sourcePkgDb - deps <- if freezeFile - then depsFromFreezeFile verbosity - else if newFreezeFile - then depsFromNewFreezeFile verbosity mprojectFile - else depsFromPkgDesc verbosity comp platform - debug verbosity $ "Dependencies loaded: " - ++ (intercalate ", " $ map prettyShow deps) - let outdatedDeps = listOutdated deps pkgIndex - (ListOutdatedSettings ignorePred minorPred) - when (not quiet) $ - showResult verbosity outdatedDeps simpleOutput - if (exitCode && (not . null $ outdatedDeps)) - then exitFailure - else return () - --- | Print either the list of all outdated dependencies, or a message --- that there are none. -showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO () -showResult verbosity outdatedDeps simpleOutput = - if (not . null $ outdatedDeps) - then - do when (not simpleOutput) $ - notice verbosity "Outdated dependencies:" - for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) -> - let outdatedDep = if simpleOutput then prettyShow pn - else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")" - in notice verbosity outdatedDep - else notice verbosity "All dependencies are up to date." - --- | Convert a list of 'UserConstraint's to a 'Dependency' list. -userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint] -userConstraintsToDependencies ucnstrs = - mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs - --- | Read the list of dependencies from the freeze file. -depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint] -depsFromFreezeFile verbosity = do - cwd <- getCurrentDirectory - userConfig <- loadUserConfig verbosity cwd Nothing - let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ - userConfig - deps = userConstraintsToDependencies ucnstrs - debug verbosity "Reading the list of dependencies from the freeze file" - return deps - --- | Read the list of dependencies from the new-style freeze file. -depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [PackageVersionConstraint] -depsFromNewFreezeFile verbosity mprojectFile = do - projectRoot <- either throwIO return =<< - findProjectRoot Nothing mprojectFile - let distDirLayout = defaultDistDirLayout projectRoot - {- TODO: Support dist dir override -} Nothing - projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ - readProjectLocalFreezeConfig verbosity distDirLayout - let ucnstrs = map fst . projectConfigConstraints . projectConfigShared - $ projectConfig - deps = userConstraintsToDependencies ucnstrs - debug verbosity $ - "Reading the list of dependencies from the new-style freeze file " ++ distProjectFile distDirLayout "freeze" - return deps - --- | Read the list of dependencies from the package description. -depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint] -depsFromPkgDesc verbosity comp platform = do - cwd <- getCurrentDirectory - path <- tryFindPackageDesc verbosity cwd - gpd <- readGenericPackageDescription verbosity path - let cinfo = compilerInfo comp - epd = finalizePD mempty (ComponentRequestedSpec True True) - (const True) platform cinfo [] gpd - case epd of - Left _ -> die' verbosity "finalizePD failed" - Right (pd, _) -> do - let bd = allBuildDepends pd - debug verbosity - "Reading the list of dependencies from the package description" - return $ map toPVC bd - where - toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr - --- | Various knobs for customising the behaviour of 'listOutdated'. -data ListOutdatedSettings = ListOutdatedSettings { - -- | Should this package be ignored? - listOutdatedIgnorePred :: PackageName -> Bool, - -- | Should major version bumps should be ignored for this package? - listOutdatedMinorPred :: PackageName -> Bool - } - --- | Find all outdated dependencies. -listOutdated :: [PackageVersionConstraint] - -> PackageIndex UnresolvedSourcePackage - -> ListOutdatedSettings - -> [(PackageVersionConstraint, Version)] -listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) = - mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps - where - isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version) - isOutdated dep@(PackageVersionConstraint pname vr) - | ignorePred pname = Nothing - | otherwise = - let this = map packageVersion $ lookupDependency pkgIndex pname vr - latest = lookupLatest dep - in (\v -> (dep, v)) `fmap` isOutdated' this latest - - isOutdated' :: [Version] -> [Version] -> Maybe Version - isOutdated' [] _ = Nothing - isOutdated' _ [] = Nothing - isOutdated' this latest = - let this' = maximum this - latest' = maximum latest - in if this' < latest' then Just latest' else Nothing - - lookupLatest :: PackageVersionConstraint -> [Version] - lookupLatest (PackageVersionConstraint pname vr) - | minorPred pname = - map packageVersion $ lookupDependency pkgIndex pname (relaxMinor vr) - | otherwise = - map packageVersion $ lookupPackageName pkgIndex pname - - relaxMinor :: VersionRange -> VersionRange - relaxMinor vr = - let vis = asVersionIntervals vr - in maybe vr relax (safeLast vis) - where relax (LowerBound v0 _, upper) = - case upper of - NoUpperBound -> vr - UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/Distribution/Client/PackageHash.hs b/Distribution/Client/PackageHash.hs deleted file mode 100644 --- a/Distribution/Client/PackageHash.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} - --- | Functions to calculate nix-style hashes for package ids. --- --- The basic idea is simple, hash the combination of: --- --- * the package tarball --- * the ids of all the direct dependencies --- * other local configuration (flags, profiling, etc) --- -module Distribution.Client.PackageHash ( - -- * Calculating package hashes - PackageHashInputs(..), - PackageHashConfigInputs(..), - PackageSourceHash, - hashedInstalledPackageId, - hashPackageHashInputs, - renderPackageHashInputs, - -- ** Platform-specific variations - hashedInstalledPackageIdLong, - hashedInstalledPackageIdShort, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Package - ( PackageId, PackageIdentifier(..), mkComponentId - , PkgconfigName ) -import Distribution.System - ( Platform, OS(Windows, OSX), buildOS ) -import Distribution.Types.Flag - ( FlagAssignment, showFlagAssignment ) -import Distribution.Simple.Compiler - ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) - , ProfDetailLevel(..), showProfDetailLevel ) -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate ) -import Distribution.Types.PkgconfigVersion (PkgconfigVersion) -import Distribution.Client.HashValue -import Distribution.Client.Types - ( InstalledPackageId ) -import qualified Distribution.Solver.Types.ComponentDeps as CD - -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.Map as Map -import qualified Data.Set as Set - -------------------------------- --- Calculating package hashes --- - --- | Calculate a 'InstalledPackageId' for a package using our nix-style --- inputs hashing method. --- --- Note that due to path length limitations on Windows, this function uses --- a different method on Windows that produces shorted package ids. --- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'. --- -hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageId - | buildOS == Windows = hashedInstalledPackageIdShort - | buildOS == OSX = hashedInstalledPackageIdVeryShort - | otherwise = hashedInstalledPackageIdLong - --- | Calculate a 'InstalledPackageId' for a package using our nix-style --- inputs hashing method. --- --- This produces large ids with big hashes. It is only suitable for systems --- without significant path length limitations (ie not Windows). --- -hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageIdLong - pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent} - = mkComponentId $ - prettyShow pkgHashPkgId -- to be a bit user friendly - ++ maybe "" displayComponent pkgHashComponent - ++ "-" - ++ showHashValue (hashPackageHashInputs pkghashinputs) - where - displayComponent :: CD.Component -> String - displayComponent CD.ComponentLib = "" - displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s - displayComponent (CD.ComponentFLib s) = "-f-" ++ prettyShow s - displayComponent (CD.ComponentExe s) = "-e-" ++ prettyShow s - displayComponent (CD.ComponentTest s) = "-t-" ++ prettyShow s - displayComponent (CD.ComponentBench s) = "-b-" ++ prettyShow s - displayComponent CD.ComponentSetup = "-setup" - --- | On Windows we have serious problems with path lengths. Windows imposes a --- maximum path length of 260 chars, and even if we can use the windows long --- path APIs ourselves, we cannot guarantee that ghc, gcc, ld, ar, etc etc all --- do so too. --- --- So our only choice is to limit the lengths of the paths, and the only real --- way to do that is to limit the size of the 'InstalledPackageId's that we --- generate. We do this by truncating the package names and versions and also --- by truncating the hash sizes. --- --- Truncating the package names and versions is technically ok because they are --- just included for human convenience, the full source package id is included --- in the hash. --- --- Truncating the hash size is disappointing but also technically ok. We --- rely on the hash primarily for collision avoidance not for any security --- properties (at least for now). --- -hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkComponentId $ - intercalate "-" - -- max length now 64 - [ truncateStr 14 (prettyShow name) - , truncateStr 8 (prettyShow version) - , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) - ] - where - PackageIdentifier name version = pkgHashPkgId - - -- Truncate a string, with a visual indication that it is truncated. - truncateStr n s | length s <= n = s - | otherwise = take (n-1) s ++ "_" - --- | On macOS we shorten the name very aggressively. The mach-o linker on --- macOS has a limited load command size, to which the name of the library --- as well as its relative path (\@rpath) entry count. To circumvent this, --- on macOS the libraries are not stored as --- @store//libHS.dylib@ --- where libraryname contains the libraries name, version and abi hash, but in --- @store/lib/libHS.dylib@ --- where the very short library name drops all vowels from the package name, --- and truncates the hash to 4 bytes. --- --- We therefore we only need one \@rpath entry to @store/lib@ instead of one --- \@rpath entry for each library. And the reduced library name saves some --- additional space. --- --- This however has two major drawbacks: --- 1) Packages can collide more easily due to the shortened hash. --- 2) The libraries are *not* prefix relocatable anymore as they all end up --- in the same @store/lib@ folder. --- --- The ultimate solution would have to include generating proxy dynamic --- libraries on macOS, such that the proxy libraries and the linked libraries --- stay under the load command limit, and the recursive linker is still able --- to link all of them. -hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkComponentId $ - intercalate "-" - [ filter (not . flip elem "aeiou") (prettyShow name) - , prettyShow version - , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs)) - ] - where - PackageIdentifier name version = pkgHashPkgId - --- | All the information that contribues to a package's hash, and thus its --- 'InstalledPackageId'. --- -data PackageHashInputs = PackageHashInputs { - pkgHashPkgId :: PackageId, - pkgHashComponent :: Maybe CD.Component, - pkgHashSourceHash :: PackageSourceHash, - pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion), - pkgHashDirectDeps :: Set InstalledPackageId, - pkgHashOtherConfig :: PackageHashConfigInputs - } - -type PackageSourceHash = HashValue - --- | Those parts of the package configuration that contribute to the --- package hash. --- -data PackageHashConfigInputs = PackageHashConfigInputs { - pkgHashCompilerId :: CompilerId, - pkgHashPlatform :: Platform, - pkgHashFlagAssignment :: FlagAssignment, -- complete not partial - pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure - pkgHashVanillaLib :: Bool, - pkgHashSharedLib :: Bool, - pkgHashDynExe :: Bool, - pkgHashFullyStaticExe :: Bool, - pkgHashGHCiLib :: Bool, - pkgHashProfLib :: Bool, - pkgHashProfExe :: Bool, - pkgHashProfLibDetail :: ProfDetailLevel, - pkgHashProfExeDetail :: ProfDetailLevel, - pkgHashCoverage :: Bool, - pkgHashOptimization :: OptimisationLevel, - pkgHashSplitObjs :: Bool, - pkgHashSplitSections :: Bool, - pkgHashStripLibs :: Bool, - pkgHashStripExes :: Bool, - pkgHashDebugInfo :: DebugInfoLevel, - pkgHashProgramArgs :: Map String [String], - pkgHashExtraLibDirs :: [FilePath], - pkgHashExtraFrameworkDirs :: [FilePath], - pkgHashExtraIncludeDirs :: [FilePath], - pkgHashProgPrefix :: Maybe PathTemplate, - pkgHashProgSuffix :: Maybe PathTemplate, - - -- Haddock options - pkgHashDocumentation :: Bool, - pkgHashHaddockHoogle :: Bool, - pkgHashHaddockHtml :: Bool, - pkgHashHaddockHtmlLocation :: Maybe String, - pkgHashHaddockForeignLibs :: Bool, - pkgHashHaddockExecutables :: Bool, - pkgHashHaddockTestSuites :: Bool, - pkgHashHaddockBenchmarks :: Bool, - pkgHashHaddockInternal :: Bool, - pkgHashHaddockCss :: Maybe FilePath, - pkgHashHaddockLinkedSource :: Bool, - pkgHashHaddockQuickJump :: Bool, - pkgHashHaddockContents :: Maybe PathTemplate - --- TODO: [required eventually] pkgHashToolsVersions ? --- TODO: [required eventually] pkgHashToolsExtraOptions ? - } - deriving Show - - --- | Calculate the overall hash to be used for an 'InstalledPackageId'. --- -hashPackageHashInputs :: PackageHashInputs -> HashValue -hashPackageHashInputs = hashValue . renderPackageHashInputs - --- | Render a textual representation of the 'PackageHashInputs'. --- --- The 'hashValue' of this text is the overall package hash. --- -renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString -renderPackageHashInputs PackageHashInputs{ - pkgHashPkgId, - pkgHashComponent, - pkgHashSourceHash, - pkgHashDirectDeps, - pkgHashPkgConfigDeps, - pkgHashOtherConfig = - PackageHashConfigInputs{..} - } = - -- The purpose of this somewhat laboured rendering (e.g. why not just - -- use show?) is so that existing package hashes do not change - -- unnecessarily when new configuration inputs are added into the hash. - - -- In particular, the assumption is that when a new configuration input - -- is included into the hash, that existing packages will typically get - -- the default value for that feature. So if we avoid adding entries with - -- the default value then most of the time adding new features will not - -- change the hashes of existing packages and so fewer packages will need - -- to be rebuilt. - - --TODO: [nice to have] ultimately we probably want to put this config info - -- into the ghc-pkg db. At that point this should probably be changed to - -- use the config file infrastructure so it can be read back in again. - LBS.pack $ unlines $ catMaybes $ - [ entry "pkgid" prettyShow pkgHashPkgId - , mentry "component" show pkgHashComponent - , entry "src" showHashValue pkgHashSourceHash - , entry "pkg-config-deps" - (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++ - case mb_v of - Nothing -> "" - Just v -> " " ++ prettyShow v) - . Set.toList) pkgHashPkgConfigDeps - , entry "deps" (intercalate ", " . map prettyShow - . Set.toList) pkgHashDirectDeps - -- and then all the config - , entry "compilerid" prettyShow pkgHashCompilerId - , entry "platform" prettyShow pkgHashPlatform - , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment - , opt "configure-script" [] unwords pkgHashConfigureScriptArgs - , opt "vanilla-lib" True prettyShow pkgHashVanillaLib - , opt "shared-lib" False prettyShow pkgHashSharedLib - , opt "dynamic-exe" False prettyShow pkgHashDynExe - , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe - , opt "ghci-lib" False prettyShow pkgHashGHCiLib - , opt "prof-lib" False prettyShow pkgHashProfLib - , opt "prof-exe" False prettyShow pkgHashProfExe - , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail - , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail - , opt "hpc" False prettyShow pkgHashCoverage - , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization - , opt "split-objs" False prettyShow pkgHashSplitObjs - , opt "split-sections" False prettyShow pkgHashSplitSections - , opt "stripped-lib" False prettyShow pkgHashStripLibs - , opt "stripped-exe" True prettyShow pkgHashStripExes - , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo - , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs - , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs - , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs - , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix - , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix - - , opt "documentation" False prettyShow pkgHashDocumentation - , opt "haddock-hoogle" False prettyShow pkgHashHaddockHoogle - , opt "haddock-html" False prettyShow pkgHashHaddockHtml - , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation - , opt "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs - , opt "haddock-executables" False prettyShow pkgHashHaddockExecutables - , opt "haddock-tests" False prettyShow pkgHashHaddockTestSuites - , opt "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks - , opt "haddock-internal" False prettyShow pkgHashHaddockInternal - , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss - , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource - , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump - , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents - - ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs - where - entry key format value = Just (key ++ ": " ++ format value) - mentry key format value = fmap (\v -> key ++ ": " ++ format v) value - opt key def format value - | value == def = Nothing - | otherwise = entry key format value diff --git a/Distribution/Client/ParseUtils.hs b/Distribution/Client/ParseUtils.hs deleted file mode 100644 --- a/Distribution/Client/ParseUtils.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.ParseUtils --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Parsing utilities. ------------------------------------------------------------------------------ - -module Distribution.Client.ParseUtils ( - - -- * Fields and field utilities - FieldDescr(..), - liftField, - liftFields, - filterFields, - mapFieldNames, - commandOptionToField, - commandOptionsToFields, - - -- * Sections and utilities - SectionDescr(..), - liftSection, - - -- * FieldGrammar sections - FGSectionDescr(..), - - -- * Parsing and printing flat config - parseFields, - ppFields, - ppSection, - - -- * Parsing and printing config with sections and subsections - parseFieldsAndSections, - ppFieldsAndSections, - - -- ** Top level of config files - parseConfig, - showConfig, - ) - where - -import Distribution.Client.Compat.Prelude hiding (empty, get) -import Prelude () - -import Distribution.Deprecated.ParseUtils - ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo - , Field(..), liftField, readFieldsFlat ) -import Distribution.Deprecated.ViewAsFieldDescr - ( viewAsFieldDescr ) - -import Distribution.Simple.Command - ( OptionField ) - -import Text.PrettyPrint ( ($+$) ) -import qualified Data.Map as Map -import qualified Text.PrettyPrint as Disp - ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) - --- For new parser stuff -import Distribution.CabalSpecVersion (cabalSpecLatest) -import Distribution.FieldGrammar (partitionFields, parseFieldGrammar) -import Distribution.Fields.ParseResult (runParseResult) -import Distribution.Parsec.Error (showPError) -import Distribution.Parsec.Position (Position (..)) -import Distribution.Parsec.Warning (showPWarning) -import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) -import qualified Distribution.Fields as F -import qualified Distribution.FieldGrammar as FG - - -------------------------- --- FieldDescr utilities --- - -liftFields :: (b -> a) - -> (a -> b -> b) - -> [FieldDescr a] - -> [FieldDescr b] -liftFields get set = map (liftField get set) - - --- | Given a collection of field descriptions, keep only a given list of them, --- identified by name. --- -filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a] -filterFields includeFields = filter ((`elem` includeFields) . fieldName) - --- | Apply a name mangling function to the field names of all the field --- descriptions. The typical use case is to apply some prefix. --- -mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a] -mapFieldNames mangleName = - map (\descr -> descr { fieldName = mangleName (fieldName descr) }) - - --- | Reuse a command line 'OptionField' as a config file 'FieldDescr'. --- -commandOptionToField :: OptionField a -> FieldDescr a -commandOptionToField = viewAsFieldDescr - --- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's. --- -commandOptionsToFields :: [OptionField a] -> [FieldDescr a] -commandOptionsToFields = map viewAsFieldDescr - - ------------------------------------------- --- SectionDescr definition and utilities --- - --- | The description of a section in a config file. It can contain both --- fields and optionally further subsections. See also 'FieldDescr'. --- -data SectionDescr a = forall b. SectionDescr { - sectionName :: String, - sectionFields :: [FieldDescr b], - sectionSubsections :: [SectionDescr b], - sectionGet :: a -> [(String, b)], - sectionSet :: LineNo -> String -> b -> a -> ParseResult a, - sectionEmpty :: b - } - --- | 'FieldGrammar' section description -data FGSectionDescr g a = forall s. FGSectionDescr - { fgSectionName :: String - , fgSectionGrammar :: g s s - -- todo: add subsections? - , fgSectionGet :: a -> [(String, s)] - , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a - } - --- | To help construction of config file descriptions in a modular way it is --- useful to define fields and sections on local types and then hoist them --- into the parent types when combining them in bigger descriptions. --- --- This is essentially a lens operation for 'SectionDescr' to help embedding --- one inside another. --- -liftSection :: (b -> a) - -> (a -> b -> b) - -> SectionDescr a - -> SectionDescr b -liftSection get' set' (SectionDescr name fields sections get set empty) = - let sectionGet' = get . get' - sectionSet' lineno param x y = do - x' <- set lineno param x (get' y) - return (set' x' y) - in SectionDescr name fields sections sectionGet' sectionSet' empty - - -------------------------------------- --- Parsing and printing flat config --- - --- | Parse a bunch of semi-parsed 'Field's according to a set of field --- descriptions. It accumulates the result on top of a given initial value. --- --- This only covers the case of flat configuration without subsections. See --- also 'parseFieldsAndSections'. --- -parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a -parseFields fieldDescrs = - foldM setField - where - fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] - - setField accum (F line name value) = - case Map.lookup name fieldMap of - Just (FieldDescr _ _ set) -> set line value accum - Nothing -> do - warning $ "Unrecognized field " ++ name ++ " on line " ++ show line - return accum - - setField accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - --- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils --- that also optionally print default values for empty fields as comments. --- -ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc -ppFields fields def cur = - Disp.vcat [ ppField name (fmap getter def) (getter cur) - | FieldDescr name getter _ <- fields] - -ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc -ppField name mdef cur - | Disp.isEmpty cur = maybe Disp.empty - (\def -> Disp.text "--" <+> Disp.text name - Disp.<> Disp.colon <+> def) mdef - | otherwise = Disp.text name Disp.<> Disp.colon <+> cur - --- | Pretty print a section. --- --- Since 'ppFields' does not cover subsections you can use this to add them. --- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'. --- -ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc -ppSection name arg fields def cur - | Disp.isEmpty fieldsDoc = Disp.empty - | otherwise = Disp.text name <+> argDoc - $+$ (Disp.nest 2 fieldsDoc) - where - fieldsDoc = ppFields fields def cur - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg - - ------------------------------------------ --- Parsing and printing non-flat config --- - --- | Much like 'parseFields' but it also allows subsections. The permitted --- subsections are given by a list of 'SectionDescr's. --- -parseFieldsAndSections - :: [FieldDescr a] -- ^ field - -> [SectionDescr a] -- ^ legacy sections - -> [FGSectionDescr FG.ParsecFieldGrammar a] -- ^ FieldGrammar sections - -> a - -> [Field] -> ParseResult a -parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = - foldM setField - where - fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] - sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ] - fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ] - - setField a (F line name value) = - case Map.lookup name fieldMap of - Just (FieldDescr _ _ set) -> set line value a - Nothing -> do - warning $ "Unrecognized field '" ++ name - ++ "' on line " ++ show line - return a - - setField a (Section line name param fields) = - case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of - Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do - b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields - set line param b a - Just (Right (FGSectionDescr _ grammar _getter setter)) -> do - let fields1 = mapMaybe convertField fields - (fields2, sections) = partitionFields fields1 - -- TODO: recurse into sections - for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) -> - warning $ "Unrecognized section '" ++ fromUTF8BS name' - ++ "' on line " ++ show line' - case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of - (warnings, Right b) -> do - for_ warnings $ \w -> warning $ showPWarning "???" w - setter line param b a - (warnings, Left (_, errs)) -> do - for_ warnings $ \w -> warning $ showPWarning "???" w - case errs of - err :| _errs -> fail $ showPError "???" err - Nothing -> do - warning $ "Unrecognized section '" ++ name - ++ "' on line " ++ show line - return a - - setField accum (block@IfBlock {}) = do - warning $ "Unrecognized stanza on line " ++ show (lineNo block) - return accum - -convertField :: Field -> Maybe (F.Field Position) -convertField (F line name str) = Just $ - F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ] - where - pos = Position line 0 --- arguments omitted -convertField (Section line name _arg fields) = Just $ - F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields) - where - pos = Position line 0 --- silently omitted. -convertField IfBlock {} = Nothing - - --- | Much like 'ppFields' but also pretty prints any subsections. Subsection --- are only shown if they are non-empty. --- --- Note that unlike 'ppFields', at present it does not support printing --- default values. If needed, adding such support would be quite reasonable. --- -ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc -ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val = - ppFields fieldDescrs Nothing val - $+$ - Disp.vcat ( - [ Disp.text "" $+$ sectionDoc - | SectionDescr { - sectionName, sectionGet, - sectionFields, sectionSubsections - } <- sectionDescrs - , (param, x) <- sectionGet val - , let sectionDoc = ppSectionAndSubsections - sectionName param - sectionFields sectionSubsections [] x - , not (Disp.isEmpty sectionDoc) - ] ++ - [ Disp.text "" $+$ sectionDoc - | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs - , (param, x) <- fgSectionGet val - , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x - , not (Disp.isEmpty sectionDoc) - ]) - --- | Unlike 'ppSection' which has to be called directly, this gets used via --- 'ppFieldsAndSections' and so does not need to be exported. --- -ppSectionAndSubsections :: String -> String - -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc -ppSectionAndSubsections name arg fields sections fgSections cur - | Disp.isEmpty fieldsDoc = Disp.empty - | otherwise = Disp.text name <+> argDoc - $+$ (Disp.nest 2 fieldsDoc) - where - fieldsDoc = showConfig fields sections fgSections cur - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg - --- | --- --- TODO: subsections --- TODO: this should simply build 'PrettyField' -ppFgSection - :: String -- ^ section name - -> String -- ^ parameter - -> FG.PrettyFieldGrammar a a - -> a - -> Disp.Doc -ppFgSection secName arg grammar x - | null prettyFields = Disp.empty - | otherwise = - Disp.text secName <+> argDoc - $+$ (Disp.nest 2 fieldsDoc) - where - prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x - - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg - - fieldsDoc = Disp.vcat - [ Disp.text fname' <<>> Disp.colon <<>> doc - | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections - , let fname' = fromUTF8BS fname - ] - - ------------------------------------------------ --- Top level config file parsing and printing --- - --- | Parse a string in the config file syntax into a value, based on a --- description of the configuration file in terms of its fields and sections. --- --- It accumulates the result on top of a given initial (typically empty) value. --- -parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a - -> String -> ParseResult a -parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str = - parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty - =<< readFieldsFlat str - --- | Render a value in the config file syntax, based on a description of the --- configuration file in terms of its fields and sections. --- -showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc -showConfig = ppFieldsAndSections - diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs deleted file mode 100644 --- a/Distribution/Client/ProjectBuilding.hs +++ /dev/null @@ -1,1475 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- -module Distribution.Client.ProjectBuilding ( - -- * Dry run phase - -- | What bits of the plan will we execute? The dry run does not change - -- anything but tells us what will need to be built. - rebuildTargetsDryRun, - improveInstallPlanWithUpToDatePackages, - - -- ** Build status - -- | This is the detailed status information we get from the dry run. - BuildStatusMap, - BuildStatus(..), - BuildStatusRebuild(..), - BuildReason(..), - MonitorChangedReason(..), - buildStatusToString, - - -- * Build phase - -- | Now we actually execute the plan. - rebuildTargets, - -- ** Build outcomes - -- | This is the outcome for each package of executing the plan. - -- For each package, did the build succeed or fail? - BuildOutcomes, - BuildOutcome, - BuildResult(..), - BuildFailure(..), - BuildFailureReason(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.PackageHash (renderPackageHashInputs) -import Distribution.Client.RebuildMonad -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding.Types -import Distribution.Client.Store - -import Distribution.Client.Types - hiding (BuildOutcomes, BuildOutcome, - BuildResult(..), BuildFailure(..)) -import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage, IsUnit ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.DistDirLayout -import Distribution.Client.FileMonitor -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import Distribution.Client.GlobalFlags (RepoContext) -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.Setup - ( filterConfigureFlags, filterHaddockArgs - , filterHaddockFlags, filterTestFlags ) -import Distribution.Client.SourceFiles -import Distribution.Client.SrcDist (allPackageSourceFiles) -import Distribution.Client.Utils - ( ProgressPhase(..), progressMessage, removeExistingFile ) - -import Distribution.Compat.Lens -import Distribution.Package -import qualified Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Simple.BuildPaths (haddockDirName) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Types.BuildType -import Distribution.Types.PackageDescription.Lens (componentModules) -import Distribution.Simple.Program -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Command (CommandUI) -import qualified Distribution.Simple.Register as Cabal -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), LibraryName(..) ) -import Distribution.Simple.Compiler - ( Compiler, compilerId, PackageDB(..) ) - -import Distribution.Simple.Utils -import Distribution.Version -import Distribution.Compat.Graph (IsNode(..)) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS - -import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) -import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) -import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) -import System.IO (IOMode (AppendMode), withFile) - -import Distribution.Compat.Directory (listDirectory) - - ------------------------------------------------------------------------------- --- * Overall building strategy. ------------------------------------------------------------------------------- --- --- We start with an 'ElaboratedInstallPlan' that has already been improved by --- reusing packages from the store, and pruned to include only the targets of --- interest and their dependencies. So the remaining packages in the --- 'InstallPlan.Configured' state are ones we either need to build or rebuild. --- --- First, we do a preliminary dry run phase where we work out which packages --- we really need to (re)build, and for the ones we do need to build which --- build phase to start at. --- --- We use this to improve the 'ElaboratedInstallPlan' again by changing --- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed' --- so that the build phase will skip them. --- --- Then we execute the plan, that is actually build packages. The outcomes of --- trying to build all the packages are collected and returned. --- --- We split things like this (dry run and execute) for a couple reasons. --- Firstly we need to be able to do dry runs anyway, and these need to be --- reasonably accurate in terms of letting users know what (and why) things --- are going to be (re)built. --- --- Given that we need to be able to do dry runs, it would not be great if --- we had to repeat all the same work when we do it for real. Not only is --- it duplicate work, but it's duplicate code which is likely to get out of --- sync. So we do things only once. We preserve info we discover in the dry --- run phase and rely on it later when we build things for real. This also --- somewhat simplifies the build phase. So this way the dry run can't so --- easily drift out of sync with the real thing since we're relying on the --- info it produces. --- --- An additional advantage is that it makes it easier to debug rebuild --- errors (ie rebuilding too much or too little), since all the rebuild --- decisions are made without making any state changes at the same time --- (that would make it harder to reproduce the problem situation). --- --- Finally, we can use the dry run build status and the build outcomes to --- give us some information on the overall status of packages in the project. --- This includes limited information about the status of things that were --- not actually in the subset of the plan that was used for the dry run or --- execution phases. In particular we may know that some packages are now --- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for --- details. - - ------------------------------------------------------------------------------- --- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? ------------------------------------------------------------------------------- - --- Refer to ProjectBuilding.Types for details of these important types: - --- type BuildStatusMap = ... --- data BuildStatus = ... --- data BuildStatusRebuild = ... --- data BuildReason = ... - --- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. --- --- It gives us the 'BuildStatusMap'. This should be used with --- 'improveInstallPlanWithUpToDatePackages' to give an improved version of --- the 'ElaboratedInstallPlan' with packages switched to the --- 'InstallPlan.Installed' state when we find that they're already up to date. --- -rebuildTargetsDryRun :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> IO BuildStatusMap -rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = - -- Do the various checks to work out the 'BuildStatus' of each package - foldMInstallPlanDepOrder dryRunPkg - where - dryRunPkg :: ElaboratedPlanPackage - -> [BuildStatus] - -> IO BuildStatus - dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = - return BuildStatusPreExisting - - dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus = - return BuildStatusInstalled - - dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do - mloc <- checkFetched (elabPkgSourceLocation pkg) - case mloc of - Nothing -> return BuildStatusDownload - - Just (LocalUnpackedPackage srcdir) -> - -- For the case of a user-managed local dir, irrespective of the - -- build style, we build from that directory and put build - -- artifacts under the shared dist directory. - dryRunLocalPkg pkg depsBuildStatus srcdir - - -- The rest cases are all tarball cases are, - -- and handled the same as each other though depending on the build style. - Just (LocalTarballPackage tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - Just (RemoteTarballPackage _ tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - Just (RepoTarballPackage _ _ tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - Just (RemoteSourceRepoPackage _repo tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - - dryRunTarballPkg :: ElaboratedConfiguredPackage - -> [BuildStatus] - -> FilePath - -> IO BuildStatus - dryRunTarballPkg pkg depsBuildStatus tarball = - case elabBuildStyle pkg of - BuildAndInstall -> return (BuildStatusUnpack tarball) - BuildInplaceOnly -> do - -- TODO: [nice to have] use a proper file monitor rather - -- than this dir exists test - exists <- doesDirectoryExist srcdir - if exists - then dryRunLocalPkg pkg depsBuildStatus srcdir - else return (BuildStatusUnpack tarball) - where - srcdir = distUnpackedSrcDirectory (packageId pkg) - - dryRunLocalPkg :: ElaboratedConfiguredPackage - -> [BuildStatus] - -> FilePath - -> IO BuildStatus - dryRunLocalPkg pkg depsBuildStatus srcdir = do - -- Go and do lots of I/O, reading caches and probing files to work out - -- if anything has changed - change <- checkPackageFileMonitorChanged - packageFileMonitor pkg srcdir depsBuildStatus - case change of - -- It did change, giving us 'BuildStatusRebuild' info on why - Left rebuild -> - return (BuildStatusRebuild srcdir rebuild) - - -- No changes, the package is up to date. Use the saved build results. - Right buildResult -> - return (BuildStatusUpToDate buildResult) - where - packageFileMonitor = - newPackageFileMonitor shared distDirLayout - (elabDistDirParams shared pkg) - - --- | A specialised traversal over the packages in an install plan. --- --- The packages are visited in dependency order, starting with packages with no --- dependencies. The result for each package is accumulated into a 'Map' and --- returned as the final result. In addition, when visiting a package, the --- visiting function is passed the results for all the immediate package --- dependencies. This can be used to propagate information from dependencies. --- -foldMInstallPlanDepOrder - :: forall m ipkg srcpkg b. - (Monad m, IsUnit ipkg, IsUnit srcpkg) - => (GenericPlanPackage ipkg srcpkg -> - [b] -> m b) - -> GenericInstallPlan ipkg srcpkg - -> m (Map UnitId b) -foldMInstallPlanDepOrder visit = - go Map.empty . InstallPlan.reverseTopologicalOrder - where - go :: Map UnitId b - -> [GenericPlanPackage ipkg srcpkg] - -> m (Map UnitId b) - go !results [] = return results - - go !results (pkg : pkgs) = do - -- we go in the right order so the results map has entries for all deps - let depresults :: [b] - depresults = - map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results - in result) - (InstallPlan.depends pkg) - result <- visit pkg depresults - let results' = Map.insert (nodeKey pkg) result results - go results' pkgs - -improveInstallPlanWithUpToDatePackages :: BuildStatusMap - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -improveInstallPlanWithUpToDatePackages pkgsBuildStatus = - InstallPlan.installed canPackageBeImproved - where - canPackageBeImproved pkg = - case Map.lookup (installedUnitId pkg) pkgsBuildStatus of - Just BuildStatusUpToDate {} -> True - Just _ -> False - Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " - ++ prettyShow (packageId pkg) ++ " not in status map" - - ------------------------------ --- Package change detection --- - --- | As part of the dry run for local unpacked packages we have to check if the --- package config or files have changed. That is the purpose of --- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. --- --- When a package is (re)built, the monitor must be updated to reflect the new --- state of the package. Because we sometimes build without reconfiguring the --- state updates are split into two, one for package config changes and one --- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' --- and 'updatePackageBuildFileMonitor'. --- -data PackageFileMonitor = PackageFileMonitor { - pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), - pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, - pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) - } - --- | This is all the components of the 'BuildResult' other than the --- @['InstalledPackageInfo']@. --- --- We have to split up the 'BuildResult' components since they get produced --- at different times (or rather, when different things change). --- -type BuildResultMisc = (DocsResult, TestsResult) - -newPackageFileMonitor :: ElaboratedSharedConfig - -> DistDirLayout - -> DistDirParams - -> PackageFileMonitor -newPackageFileMonitor shared - DistDirLayout{distPackageCacheFile} - dparams = - PackageFileMonitor { - pkgFileMonitorConfig = - FileMonitor { - fileMonitorCacheFile = distPackageCacheFile dparams "config", - fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared, - fileMonitorCheckIfOnlyValueChanged = False - }, - - pkgFileMonitorBuild = - FileMonitor { - fileMonitorCacheFile = distPackageCacheFile dparams "build", - fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> - componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, - fileMonitorCheckIfOnlyValueChanged = True - }, - - pkgFileMonitorReg = - newFileMonitor (distPackageCacheFile dparams "registration") - } - --- | Helper function for 'checkPackageFileMonitorChanged', --- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. --- --- It selects the info from a 'ElaboratedConfiguredPackage' that are used by --- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. --- -packageFileMonitorKeyValues :: ElaboratedConfiguredPackage - -> (ElaboratedConfiguredPackage, Set ComponentName) -packageFileMonitorKeyValues elab = - (elab_config, buildComponents) - where - -- The first part is the value used to guard (re)configuring the package. - -- That is, if this value changes then we will reconfigure. - -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of - -- information that affects the (re)configure step. But those parts that - -- do not affect the configure step need to be nulled out. Those parts are - -- the specific targets that we're going to build. - -- - elab_config = - elab { - elabBuildTargets = [], - elabTestTargets = [], - elabBenchTargets = [], - elabReplTarget = Nothing, - elabHaddockTargets = [], - elabBuildHaddocks = False - } - - -- The second part is the value used to guard the build step. So this is - -- more or less the opposite of the first part, as it's just the info about - -- what targets we're going to build. - -- - buildComponents = elabBuildTargetWholeComponents elab - --- | Do all the checks on whether a package has changed and thus needs either --- rebuilding or reconfiguring and rebuilding. --- -checkPackageFileMonitorChanged :: PackageFileMonitor - -> ElaboratedConfiguredPackage - -> FilePath - -> [BuildStatus] - -> IO (Either BuildStatusRebuild BuildResult) -checkPackageFileMonitorChanged PackageFileMonitor{..} - pkg srcdir depsBuildStatus = do - --TODO: [nice to have] some debug-level message about file - --changes, like rerunIfChanged - configChanged <- checkFileMonitorChanged - pkgFileMonitorConfig srcdir pkgconfig - case configChanged of - MonitorChanged monitorReason -> - return (Left (BuildStatusConfigure monitorReason')) - where - monitorReason' = fmap (const ()) monitorReason - - MonitorUnchanged () _ - -- The configChanged here includes the identity of the dependencies, - -- so depsBuildStatus is just needed for the changes in the content - -- of dependencies. - | any buildStatusRequiresBuild depsBuildStatus -> do - regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () - let mreg = changedToMaybe regChanged - return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) - - | otherwise -> do - buildChanged <- checkFileMonitorChanged - pkgFileMonitorBuild srcdir buildComponents - regChanged <- checkFileMonitorChanged - pkgFileMonitorReg srcdir () - let mreg = changedToMaybe regChanged - case (buildChanged, regChanged) of - (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonExtraTargets prevBuildComponents - - (MonitorChanged monitorReason, _) -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - - (MonitorUnchanged _ _, MonitorChanged monitorReason) -> - -- this should only happen if the file is corrupt or been - -- manually deleted. We don't want to bother with another - -- phase just for this, so we'll reregister by doing a build. - return (Left (BuildStatusBuild Nothing buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - - (MonitorUnchanged _ _, MonitorUnchanged _ _) - | pkgHasEphemeralBuildTargets pkg -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonEphemeralTargets - - (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> - return $ Right BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = Nothing - } - where - (docsResult, testsResult) = buildResult - where - (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - changedToMaybe (MonitorChanged _) = Nothing - changedToMaybe (MonitorUnchanged x _) = Just x - - -updatePackageConfigFileMonitor :: PackageFileMonitor - -> FilePath - -> ElaboratedConfiguredPackage - -> IO () -updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig} - srcdir pkg = - updateFileMonitor pkgFileMonitorConfig srcdir Nothing - [] pkgconfig () - where - (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg - -updatePackageBuildFileMonitor :: PackageFileMonitor - -> FilePath - -> MonitorTimestamp - -> ElaboratedConfiguredPackage - -> BuildStatusRebuild - -> [MonitorFilePath] - -> BuildResultMisc - -> IO () -updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} - srcdir timestamp pkg pkgBuildStatus - monitors buildResult = - updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) - monitors buildComponents' buildResult - where - (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - - -- If the only thing that's changed is that we're now building extra - -- components, then we can avoid later unnecessary rebuilds by saving the - -- total set of components that have been built, namely the union of the - -- existing ones plus the new ones. If files also changed this would be - -- the wrong thing to do. Note that we rely on the - -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee - -- that it's /only/ the value that changed not any files that changed. - buildComponents' = - case pkgBuildStatus of - BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) - -> buildComponents `Set.union` prevBuildComponents - _ -> buildComponents - -updatePackageRegFileMonitor :: PackageFileMonitor - -> FilePath - -> Maybe InstalledPackageInfo - -> IO () -updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} - srcdir mipkg = - updateFileMonitor pkgFileMonitorReg srcdir Nothing - [] () mipkg - -invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () -invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = - removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) - - ------------------------------------------------------------------------------- --- * Doing it: executing an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------- - --- Refer to ProjectBuilding.Types for details of these important types: - --- type BuildOutcomes = ... --- type BuildOutcome = ... --- data BuildResult = ... --- data BuildFailure = ... --- data BuildFailureReason = ... - --- | Build things for real. --- --- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. --- -rebuildTargets :: Verbosity - -> DistDirLayout - -> StoreDirLayout - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> BuildStatusMap - -> BuildTimeSettings - -> IO BuildOutcomes -rebuildTargets verbosity - distDirLayout@DistDirLayout{..} - storeDirLayout - installPlan - sharedPackageConfig@ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - pkgsBuildStatus - buildSettings@BuildTimeSettings{ - buildSettingNumJobs, - buildSettingKeepGoing - } = do - - -- Concurrency control: create the job controller and concurrency limits - -- for downloading, building and installing. - jobControl <- if isParallelBuild - then newParallelJobControl buildSettingNumJobs - else newSerialJobControl - registerLock <- newLock -- serialise registration - cacheLock <- newLock -- serialise access to setup exe cache - --TODO: [code cleanup] eliminate setup exe cache - - debug verbosity $ - "Executing install plan " - ++ if isParallelBuild - then " in parallel using " ++ show buildSettingNumJobs ++ " threads." - else " serially." - - createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory - createDirectoryIfMissingVerbose verbosity True distTempDirectory - traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse - - -- Before traversing the install plan, pre-emptively find all packages that - -- will need to be downloaded and start downloading them. - asyncDownloadPackages verbosity withRepoCtx - installPlan pkgsBuildStatus $ \downloadMap -> - - -- For each package in the plan, in dependency order, but in parallel... - InstallPlan.execute jobControl keepGoing - (BuildFailure Nothing . DependentFailed . packageId) - installPlan $ \pkg -> - --TODO: review exception handling - handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ - - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in - - rebuildTarget - verbosity - distDirLayout - storeDirLayout - buildSettings downloadMap - registerLock cacheLock - sharedPackageConfig - installPlan pkg - pkgBuildStatus - where - isParallelBuild = buildSettingNumJobs >= 2 - keepGoing = buildSettingKeepGoing - withRepoCtx = projectConfigWithBuilderRepoContext verbosity - buildSettings - packageDBsToUse = -- all the package dbs we may need to create - (Set.toList . Set.fromList) - [ pkgdb - | InstallPlan.Configured elab <- InstallPlan.toList installPlan - , pkgdb <- concat [ elabBuildPackageDBStack elab - , elabRegisterPackageDBStack elab - , elabSetupPackageDBStack elab ] - ] - - --- | Create a package DB if it does not currently exist. Note that this action --- is /not/ safe to run concurrently. --- -createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb - -> PackageDB -> IO () -createPackageDBIfMissing verbosity compiler progdb - (SpecificPackageDB dbPath) = do - exists <- Cabal.doesPackageDBExist dbPath - unless exists $ do - createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - Cabal.createPackageDB verbosity compiler progdb False dbPath -createPackageDBIfMissing _ _ _ _ = return () - - --- | Given all the context and resources, (re)build an individual package. --- -rebuildTarget :: Verbosity - -> DistDirLayout - -> StoreDirLayout - -> BuildTimeSettings - -> AsyncFetchMap - -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> BuildStatus - -> IO BuildResult -rebuildTarget verbosity - distDirLayout@DistDirLayout{distBuildDirectory} - storeDirLayout - buildSettings downloadMap - registerLock cacheLock - sharedPackageConfig - plan rpkg@(ReadyPackage pkg) - pkgBuildStatus = - - -- We rely on the 'BuildStatus' to decide which phase to start from: - case pkgBuildStatus of - BuildStatusDownload -> downloadPhase - BuildStatusUnpack tarball -> unpackTarballPhase tarball - BuildStatusRebuild srcdir status -> rebuildPhase status srcdir - - -- TODO: perhaps re-nest the types to make these impossible - BuildStatusPreExisting {} -> unexpectedState - BuildStatusInstalled {} -> unexpectedState - BuildStatusUpToDate {} -> unexpectedState - where - unexpectedState = error "rebuildTarget: unexpected package status" - - downloadPhase = do - downsrcloc <- annotateFailureNoLog DownloadFailed $ - waitAsyncPackageDownload verbosity downloadMap pkg - case downsrcloc of - DownloadedTarball tarball -> unpackTarballPhase tarball - --TODO: [nice to have] git/darcs repos etc - - - unpackTarballPhase tarball = - withTarballLocalDirectory - verbosity distDirLayout tarball - (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) - (elabBuildStyle pkg) - (elabPkgDescriptionOverride pkg) $ - - case elabBuildStyle pkg of - BuildAndInstall -> buildAndInstall - BuildInplaceOnly -> buildInplace buildStatus - where - buildStatus = BuildStatusConfigure MonitorFirstRun - - -- Note that this really is rebuild, not build. It can only happen for - -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages - -- would only start from download or unpack phases. - -- - rebuildPhase buildStatus srcdir = - assert (elabBuildStyle pkg == BuildInplaceOnly) $ - - buildInplace buildStatus srcdir builddir - where - builddir = distBuildDirectory - (elabDistDirParams sharedPackageConfig pkg) - - buildAndInstall srcdir builddir = - buildAndInstallUnpackedPackage - verbosity distDirLayout storeDirLayout - buildSettings registerLock cacheLock - sharedPackageConfig - plan rpkg - srcdir builddir' - where - builddir' = makeRelative srcdir builddir - --TODO: [nice to have] ^^ do this relative stuff better - - buildInplace buildStatus srcdir builddir = - --TODO: [nice to have] use a relative build dir rather than absolute - buildInplaceUnpackedPackage - verbosity distDirLayout - buildSettings registerLock cacheLock - sharedPackageConfig - plan rpkg - buildStatus - srcdir builddir - --- TODO: [nice to have] do we need to use a with-style for the temp --- files for downloading http packages, or are we going to cache them --- persistently? - --- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the --- packages we have to download and fork off an async action to download them. --- We download them in dependency order so that the one's we'll need --- first are the ones we will start downloading first. --- --- The body action is passed a map from those packages (identified by their --- location) to a completion var for that package. So the body action should --- lookup the location and use 'waitAsyncPackageDownload' to get the result. --- -asyncDownloadPackages :: Verbosity - -> ((RepoContext -> IO a) -> IO a) - -> ElaboratedInstallPlan - -> BuildStatusMap - -> (AsyncFetchMap -> IO a) - -> IO a -asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body - | null pkgsToDownload = body Map.empty - | otherwise = withRepoCtx $ \repoctx -> - asyncFetchPackages verbosity repoctx - pkgsToDownload body - where - pkgsToDownload = - ordNub $ - [ elabPkgSourceLocation elab - | InstallPlan.Configured elab - <- InstallPlan.reverseTopologicalOrder installPlan - , let uid = installedUnitId elab - pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus - , BuildStatusDownload <- [pkgBuildStatus] - ] - - --- | Check if a package needs downloading, and if so expect to find a download --- in progress in the given 'AsyncFetchMap' and wait on it to finish. --- -waitAsyncPackageDownload :: Verbosity - -> AsyncFetchMap - -> ElaboratedConfiguredPackage - -> IO DownloadedSourceLocation -waitAsyncPackageDownload verbosity downloadMap elab = do - pkgloc <- waitAsyncFetchPackage verbosity downloadMap - (elabPkgSourceLocation elab) - case downloadedSourceLocation pkgloc of - Just loc -> return loc - Nothing -> fail "waitAsyncPackageDownload: unexpected source location" - -data DownloadedSourceLocation = DownloadedTarball FilePath - --TODO: [nice to have] git/darcs repos etc - -downloadedSourceLocation :: PackageLocation FilePath - -> Maybe DownloadedSourceLocation -downloadedSourceLocation pkgloc = - case pkgloc of - RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) - RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) - _ -> Nothing - - - - --- | Ensure that the package is unpacked in an appropriate directory, either --- a temporary one or a persistent one under the shared dist directory. --- -withTarballLocalDirectory - :: Verbosity - -> DistDirLayout - -> FilePath - -> PackageId - -> DistDirParams - -> BuildStyle - -> Maybe CabalFileText - -> (FilePath -> -- Source directory - FilePath -> -- Build directory - IO a) - -> IO a -withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} - tarball pkgid dparams buildstyle pkgTextOverride - buildPkg = - case buildstyle of - -- In this case we make a temp dir (e.g. tmp/src2345/), unpack - -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for - -- compatibility we put the dist dir within it - -- (i.e. tmp/src2345/foo-1.0/dist/). - -- - -- Unfortunately, a few custom Setup.hs scripts do not respect - -- the --builddir flag and always look for it at ./dist/ so - -- this way we avoid breaking those packages - BuildAndInstall -> - let tmpdir = distTempDirectory in - withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do - unpackPackageTarball verbosity tarball unpackdir - pkgid pkgTextOverride - let srcdir = unpackdir prettyShow pkgid - builddir = srcdir "dist" - buildPkg srcdir builddir - - -- In this case we make sure the tarball has been unpacked to the - -- appropriate location under the shared dist dir, and then build it - -- inplace there - BuildInplaceOnly -> do - let srcrootdir = distUnpackedSrcRootDirectory - srcdir = distUnpackedSrcDirectory pkgid - builddir = distBuildDirectory dparams - -- TODO: [nice to have] use a proper file monitor rather - -- than this dir exists test - exists <- doesDirectoryExist srcdir - unless exists $ do - createDirectoryIfMissingVerbose verbosity True srcrootdir - unpackPackageTarball verbosity tarball srcrootdir - pkgid pkgTextOverride - moveTarballShippedDistDirectory verbosity distDirLayout - srcrootdir pkgid dparams - buildPkg srcdir builddir - - -unpackPackageTarball :: Verbosity -> FilePath -> FilePath - -> PackageId -> Maybe CabalFileText - -> IO () -unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = - --TODO: [nice to have] switch to tar package and catch tar exceptions - annotateFailureNoLog UnpackFailed $ do - - -- Unpack the tarball - -- - info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." - Tar.extractTarGzFile parentdir pkgsubdir tarball - - -- Sanity check - -- - exists <- doesFileExist cabalFile - unless exists $ - die' verbosity $ - "Package .cabal file not found in the tarball: " ++ cabalFile - - -- Overwrite the .cabal with the one from the index, when appropriate - -- - case pkgTextOverride of - Nothing -> return () - Just pkgtxt -> do - info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal" - ++ " with the latest revision from the index." - writeFileAtomic cabalFile pkgtxt - - where - cabalFile = parentdir pkgsubdir - prettyShow pkgname <.> "cabal" - pkgsubdir = prettyShow pkgid - pkgname = packageName pkgid - - --- | This is a bit of a hacky workaround. A number of packages ship --- pre-processed .hs files in a dist directory inside the tarball. We don't --- use the standard 'dist' location so unless we move this dist dir to the --- right place then we'll miss the shipped pre-procssed files. This hacky --- approach to shipped pre-procssed files ought to be replaced by a proper --- system, though we'll still need to keep this hack for older packages. --- -moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout - -> FilePath -> PackageId -> DistDirParams - -> IO () -moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} - parentdir pkgid dparams = do - distDirExists <- doesDirectoryExist tarballDistDir - when distDirExists $ do - debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" - ++ targetDistDir ++ "'" - --TODO: [nice to have] or perhaps better to copy, and use a file monitor - renameDirectory tarballDistDir targetDistDir - where - tarballDistDir = parentdir prettyShow pkgid "dist" - targetDistDir = distBuildDirectory dparams - - -buildAndInstallUnpackedPackage :: Verbosity - -> DistDirLayout - -> StoreDirLayout - -> BuildTimeSettings -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> FilePath -> FilePath - -> IO BuildResult -buildAndInstallUnpackedPackage verbosity - distDirLayout@DistDirLayout{distTempDirectory} - storeDirLayout@StoreDirLayout { - storePackageDBStack - } - BuildTimeSettings { - buildSettingNumJobs, - buildSettingLogFile - } - registerLock cacheLock - pkgshared@ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - plan rpkg@(ReadyPackage pkg) - srcdir builddir = do - - createDirectoryIfMissingVerbose verbosity True (srcdir builddir) - initLogFile - - --TODO: [code cleanup] deal consistently with talking to older - -- Setup.hs versions, much like we do for ghc, with a proper - -- options type and rendering step which will also let us - -- call directly into the lib, rather than always going via - -- the lib's command line interface, which would also allow - -- passing data like installed packages, compiler, and - -- program db for a quicker configure. - - --TODO: [required feature] docs and tests - --TODO: [required feature] sudo re-exec - - -- Configure phase - noticeProgress ProgressStarting - - annotateFailure mlogFile ConfigureFailed $ - setup' configureCommand configureFlags configureArgs - - -- Build phase - noticeProgress ProgressBuilding - - annotateFailure mlogFile BuildFailed $ - setup buildCommand buildFlags - - -- Haddock phase - whenHaddock $ do - noticeProgress ProgressHaddock - annotateFailureNoLog HaddocksFailed $ - setup haddockCommand haddockFlags - - -- Install phase - noticeProgress ProgressInstalling - annotateFailure mlogFile InstallFailed $ do - - let copyPkgFiles tmpDir = do - let tmpDirNormalised = normalise tmpDir - setup Cabal.copyCommand (copyFlags tmpDirNormalised) - -- Note that the copy command has put the files into - -- @$tmpDir/$prefix@ so we need to return this dir so - -- the store knows which dir will be the final store entry. - let prefix = normalise $ - dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) - entryDir = tmpDirNormalised prefix - - -- if there weren't anything to build, it might be that directory is not created - -- the @setup Cabal.copyCommand@ above might do nothing. - -- https://github.com/haskell/cabal/issues/4130 - createDirectoryIfMissingVerbose verbosity True entryDir - - LBS.writeFile - (entryDir "cabal-hash.txt") - (renderPackageHashInputs (packageHashInputs pkgshared pkg)) - - -- Ensure that there are no files in `tmpDir`, that are - -- not in `entryDir`. While this breaks the - -- prefix-relocatable property of the libraries, it is - -- necessary on macOS to stay under the load command limit - -- of the macOS mach-o linker. See also - -- @PackageHash.hashedInstalledPackageIdVeryShort@. - -- - -- We also normalise paths to ensure that there are no - -- different representations for the same path. Like / and - -- \\ on windows under msys. - otherFiles <- filter (not . isPrefixOf entryDir) <$> - listFilesRecursive tmpDirNormalised - -- Here's where we could keep track of the installed files - -- ourselves if we wanted to by making a manifest of the - -- files in the tmp dir. - return (entryDir, otherFiles) - where - listFilesRecursive :: FilePath -> IO [FilePath] - listFilesRecursive path = do - files <- fmap (path ) <$> (listDirectory path) - allFiles <- for files $ \file -> do - isDir <- doesDirectoryExist file - if isDir - then listFilesRecursive file - else return [file] - return (concat allFiles) - - registerPkg - | not (elabRequiresRegistration pkg) = - debug verbosity $ - "registerPkg: elab does NOT require registration for " - ++ prettyShow uid - | otherwise = do - -- We register ourselves rather than via Setup.hs. We need to - -- grab and modify the InstalledPackageInfo. We decide what - -- the installed package id is, not the build system. - ipkg0 <- generateInstalledPackageInfo - let ipkg = ipkg0 { Installed.installedUnitId = uid } - assert ( elabRegisterPackageDBStack pkg - == storePackageDBStack compid) (return ()) - criticalSection registerLock $ - Cabal.registerPackage - verbosity compiler progdb - (storePackageDBStack compid) ipkg - Cabal.defaultRegisterOptions { - Cabal.registerMultiInstance = True, - Cabal.registerSuppressFilesCheck = True - } - - - -- Actual installation - void $ newStoreEntry verbosity storeDirLayout - compid uid - copyPkgFiles registerPkg - - --TODO: [nice to have] we currently rely on Setup.hs copy to do the right - -- thing. Although we do copy into an image dir and do the move into the - -- final location ourselves, perhaps we ought to do some sanity checks on - -- the image dir first. - - -- TODO: [required eventually] note that for nix-style - -- installations it is not necessary to do the - -- 'withWin32SelfUpgrade' dance, but it would be necessary for a - -- shared bin dir. - - --TODO: [required feature] docs and test phases - let docsResult = DocsNotTried - testsResult = TestsNotTried - - noticeProgress ProgressCompleted - - return BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = mlogFile - } - - where - pkgid = packageId rpkg - uid = installedUnitId rpkg - compid = compilerId compiler - - dispname = case elabPkgOrComp pkg of - ElabPackage _ -> prettyShow pkgid - ++ " (all, legacy fallback)" - ElabComponent comp -> prettyShow pkgid - ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")" - - noticeProgress phase = when isParallelBuild $ - progressMessage verbosity phase dispname - - isParallelBuild = buildSettingNumJobs >= 2 - - whenHaddock action - | hasValidHaddockTargets pkg = action - | otherwise = return () - - configureCommand = Cabal.configureCommand defaultProgramDb - configureFlags v = flip filterConfigureFlags v $ - setupHsConfigureFlags rpkg pkgshared - verbosity builddir - configureArgs _ = setupHsConfigureArgs pkg - - buildCommand = Cabal.buildCommand defaultProgramDb - buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir - - haddockCommand = Cabal.haddockCommand - haddockFlags _ = setupHsHaddockFlags pkg pkgshared - verbosity builddir - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity distTempDirectory $ \pkgConfDest -> do - let registerFlags _ = setupHsRegisterFlags - pkg pkgshared - verbosity builddir - pkgConfDest - setup Cabal.registerCommand registerFlags - - copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity - builddir destdir - - scriptOptions = setupHsScriptOptions rpkg plan pkgshared - distDirLayout srcdir builddir - isParallelBuild cacheLock - - setup :: CommandUI flags -> (Version -> flags) -> IO () - setup cmd flags = setup' cmd flags (const []) - - setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) - -> IO () - setup' cmd flags args = - withLogging $ \mLogFileHandle -> - setupWrapper - verbosity - scriptOptions - { useLoggingHandle = mLogFileHandle - , useExtraEnvOverrides = dataDirsEnvironmentForPlan - distDirLayout plan } - (Just (elabPkgDescription pkg)) - cmd flags args - - mlogFile :: Maybe FilePath - mlogFile = - case buildSettingLogFile of - Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) - - initLogFile = - case mlogFile of - Nothing -> return () - Just logFile -> do - createDirectoryIfMissing True (takeDirectory logFile) - exists <- doesFileExist logFile - when exists $ removeFile logFile - - withLogging action = - case mlogFile of - Nothing -> action Nothing - Just logFile -> withFile logFile AppendMode (action . Just) - - -hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool -hasValidHaddockTargets ElaboratedConfiguredPackage{..} - | not elabBuildHaddocks = False - | otherwise = any componentHasHaddocks components - where - components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets - ++ maybeToList elabReplTarget ++ elabHaddockTargets - - componentHasHaddocks :: ComponentTarget -> Bool - componentHasHaddocks (ComponentTarget name _) = - case name of - CLibName LMainLibName -> hasHaddocks - CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks - CFLibName _ -> elabHaddockForeignLibs && hasHaddocks - CExeName _ -> elabHaddockExecutables && hasHaddocks - CTestName _ -> elabHaddockTestSuites && hasHaddocks - CBenchName _ -> elabHaddockBenchmarks && hasHaddocks - where - hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) - - -buildInplaceUnpackedPackage :: Verbosity - -> DistDirLayout - -> BuildTimeSettings -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> BuildStatusRebuild - -> FilePath -> FilePath - -> IO BuildResult -buildInplaceUnpackedPackage verbosity - distDirLayout@DistDirLayout { - distTempDirectory, - distPackageCacheDirectory, - distDirectory - } - BuildTimeSettings{buildSettingNumJobs} - registerLock cacheLock - pkgshared@ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - plan - rpkg@(ReadyPackage pkg) - buildStatus - srcdir builddir = do - - --TODO: [code cleanup] there is duplication between the - -- distdirlayout and the builddir here builddir is not - -- enough, we also need the per-package cachedir - createDirectoryIfMissingVerbose verbosity True builddir - createDirectoryIfMissingVerbose verbosity True - (distPackageCacheDirectory dparams) - - -- Configure phase - -- - whenReConfigure $ do - annotateFailureNoLog ConfigureFailed $ - setup configureCommand configureFlags configureArgs - invalidatePackageRegFileMonitor packageFileMonitor - updatePackageConfigFileMonitor packageFileMonitor srcdir pkg - - -- Build phase - -- - let docsResult = DocsNotTried - testsResult = TestsNotTried - - buildResult :: BuildResultMisc - buildResult = (docsResult, testsResult) - - whenRebuild $ do - timestamp <- beginUpdateFileMonitor - annotateFailureNoLog BuildFailed $ - setup buildCommand buildFlags buildArgs - - let listSimple = - execRebuild srcdir (needElaboratedConfiguredPackage pkg) - listSdist = - fmap (map monitorFileHashed) $ - allPackageSourceFiles verbosity srcdir - ifNullThen m m' = do xs <- m - if null xs then m' else return xs - monitors <- case PD.buildType (elabPkgDescription pkg) of - Simple -> listSimple - -- If a Custom setup was used, AND the Cabal is recent - -- enough to have sdist --list-sources, use that to - -- determine the files that we need to track. This can - -- cause unnecessary rebuilding (for example, if README - -- is edited, we will try to rebuild) but there isn't - -- a more accurate Custom interface we can use to get - -- this info. We prefer not to use listSimple here - -- as it can miss extra source files that are considered - -- by the Custom setup. - _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17] - -- However, sometimes sdist --list-sources will fail - -- and return an empty list. In that case, fall - -- back on the (inaccurate) simple tracking. - -> listSdist `ifNullThen` listSimple - | otherwise - -> listSimple - - let dep_monitors = map monitorFileHashed - $ elabInplaceDependencyBuildCacheFiles - distDirLayout pkgshared plan pkg - updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp - pkg buildStatus - (monitors ++ dep_monitors) buildResult - - -- PURPOSELY omitted: no copy! - - whenReRegister $ annotateFailureNoLog InstallFailed $ do - -- Register locally - mipkg <- if elabRequiresRegistration pkg - then do - ipkg0 <- generateInstalledPackageInfo - -- We register ourselves rather than via Setup.hs. We need to - -- grab and modify the InstalledPackageInfo. We decide what - -- the installed package id is, not the build system. - let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } - criticalSection registerLock $ - Cabal.registerPackage verbosity compiler progdb - (elabRegisterPackageDBStack pkg) - ipkg Cabal.defaultRegisterOptions - return (Just ipkg) - - else return Nothing - - updatePackageRegFileMonitor packageFileMonitor srcdir mipkg - - whenTest $ do - annotateFailureNoLog TestsFailed $ - setup testCommand testFlags testArgs - - whenBench $ - annotateFailureNoLog BenchFailed $ - setup benchCommand benchFlags benchArgs - - -- Repl phase - -- - whenRepl $ - annotateFailureNoLog ReplFailed $ - setupInteractive replCommand replFlags replArgs - - -- Haddock phase - whenHaddock $ - annotateFailureNoLog HaddocksFailed $ do - setup haddockCommand haddockFlags haddockArgs - let haddockTarget = elabHaddockForHackage pkg - when (haddockTarget == Cabal.ForHackage) $ do - let dest = distDirectory name <.> "tar.gz" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = distBuildDirectory distDirLayout dparams - "doc" "html" - Tar.createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - - return BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = Nothing - } - - where - ipkgid = installedUnitId pkg - dparams = elabDistDirParams pkgshared pkg - - isParallelBuild = buildSettingNumJobs >= 2 - - packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams - - whenReConfigure action = case buildStatus of - BuildStatusConfigure _ -> action - _ -> return () - - whenRebuild action - | null (elabBuildTargets pkg) - -- NB: we have to build the test/bench suite! - , null (elabTestTargets pkg) - , null (elabBenchTargets pkg) = return () - | otherwise = action - - whenTest action - | null (elabTestTargets pkg) = return () - | otherwise = action - - whenBench action - | null (elabBenchTargets pkg) = return () - | otherwise = action - - whenRepl action - | isNothing (elabReplTarget pkg) = return () - | otherwise = action - - whenHaddock action - | hasValidHaddockTargets pkg = action - | otherwise = return () - - whenReRegister action - = case buildStatus of - -- We registered the package already - BuildStatusBuild (Just _) _ -> - info verbosity "whenReRegister: previously registered" - -- There is nothing to register - _ | null (elabBuildTargets pkg) -> - info verbosity "whenReRegister: nothing to register" - | otherwise -> action - - configureCommand = Cabal.configureCommand defaultProgramDb - configureFlags v = flip filterConfigureFlags v $ - setupHsConfigureFlags rpkg pkgshared - verbosity builddir - configureArgs _ = setupHsConfigureArgs pkg - - buildCommand = Cabal.buildCommand defaultProgramDb - buildFlags _ = setupHsBuildFlags pkg pkgshared - verbosity builddir - buildArgs _ = setupHsBuildArgs pkg - - testCommand = Cabal.testCommand -- defaultProgramDb - testFlags v = flip filterTestFlags v $ - setupHsTestFlags pkg pkgshared - verbosity builddir - testArgs _ = setupHsTestArgs pkg - - benchCommand = Cabal.benchmarkCommand - benchFlags _ = setupHsBenchFlags pkg pkgshared - verbosity builddir - benchArgs _ = setupHsBenchArgs pkg - - replCommand = Cabal.replCommand defaultProgramDb - replFlags _ = setupHsReplFlags pkg pkgshared - verbosity builddir - replArgs _ = setupHsReplArgs pkg - - haddockCommand = Cabal.haddockCommand - haddockFlags v = flip filterHaddockFlags v $ - setupHsHaddockFlags pkg pkgshared - verbosity builddir - haddockArgs v = flip filterHaddockArgs v $ - setupHsHaddockArgs pkg - - scriptOptions = setupHsScriptOptions rpkg plan pkgshared - distDirLayout srcdir builddir - isParallelBuild cacheLock - - setupInteractive :: CommandUI flags - -> (Version -> flags) -> (Version -> [String]) -> IO () - setupInteractive cmd flags args = - setupWrapper verbosity - scriptOptions { isInteractive = True } - (Just (elabPkgDescription pkg)) - cmd flags args - - setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) - -> IO () - setup cmd flags args = - setupWrapper verbosity - scriptOptions - (Just (elabPkgDescription pkg)) - cmd flags args - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity distTempDirectory $ \pkgConfDest -> do - let registerFlags _ = setupHsRegisterFlags - pkg pkgshared - verbosity builddir - pkgConfDest - setup Cabal.registerCommand registerFlags (const []) - -withTempInstalledPackageInfoFile :: Verbosity -> FilePath - -> (FilePath -> IO ()) - -> IO InstalledPackageInfo -withTempInstalledPackageInfoFile verbosity tempdir action = - withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do - -- make absolute since @action@ will often change directory - abs_dir <- canonicalizePath dir - - let pkgConfDest = abs_dir "pkgConf" - action pkgConfDest - - readPkgConf "." pkgConfDest - where - pkgConfParseFailed :: String -> IO a - pkgConfParseFailed perror = - die' verbosity $ - "Couldn't parse the output of 'setup register --gen-pkg-config':" - ++ show perror - - readPkgConf pkgConfDir pkgConfFile = do - pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) - (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of - Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors - Right (warns, ipkg) -> return (warns, ipkg) - - unless (null warns) $ - warn verbosity $ unlines warns - - return ipkg - - ------------------------------------------------------------------------------- --- * Utilities ------------------------------------------------------------------------------- - -annotateFailureNoLog :: (SomeException -> BuildFailureReason) - -> IO a -> IO a -annotateFailureNoLog annotate action = - annotateFailure Nothing annotate action - -annotateFailure :: Maybe FilePath - -> (SomeException -> BuildFailureReason) - -> IO a -> IO a -annotateFailure mlogFile annotate action = - action `catches` - -- It's not just IOException and ExitCode we have to deal with, there's - -- lots, including exceptions from the hackage-security and tar packages. - -- So we take the strategy of catching everything except async exceptions. - [ -#if MIN_VERSION_base(4,7,0) - Handler $ \async -> throwIO (async :: SomeAsyncException) -#else - Handler $ \async -> throwIO (async :: AsyncException) -#endif - , Handler $ \other -> handler (other :: SomeException) - ] - where - handler :: Exception e => e -> IO a - handler = throwIO . BuildFailure mlogFile . annotate . toException diff --git a/Distribution/Client/ProjectBuilding/Types.hs b/Distribution/Client/ProjectBuilding/Types.hs deleted file mode 100644 --- a/Distribution/Client/ProjectBuilding/Types.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | Types for the "Distribution.Client.ProjectBuilding" --- --- Moved out to avoid module cycles. --- -module Distribution.Client.ProjectBuilding.Types ( - -- * Pre-build status - BuildStatusMap, - BuildStatus(..), - buildStatusRequiresBuild, - buildStatusToString, - BuildStatusRebuild(..), - BuildReason(..), - MonitorChangedReason(..), - - -- * Build outcomes - BuildOutcomes, - BuildOutcome, - BuildResult(..), - BuildFailure(..), - BuildFailureReason(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Types (DocsResult, TestsResult) -import Distribution.Client.FileMonitor (MonitorChangedReason(..)) - -import Distribution.Package (UnitId, PackageId) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.LocalBuildInfo (ComponentName) - - ------------------------------------------------------------------------------- --- Pre-build status: result of the dry run --- - --- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. --- --- This is used as the result of the dry-run of building an install plan. --- -type BuildStatusMap = Map UnitId BuildStatus - --- | The build status for an individual package is the state that the --- package is in /prior/ to initiating a (re)build. --- --- This should not be confused with a 'BuildResult' which is the result --- /after/ successfully building a package. --- --- It serves two purposes: --- --- * For dry-run output, it lets us explain to the user if and why a package --- is going to be (re)built. --- --- * It tell us what step to start or resume building from, and carries --- enough information for us to be able to do so. --- -data BuildStatus = - - -- | The package is in the 'InstallPlan.PreExisting' state, so does not - -- need building. - BuildStatusPreExisting - - -- | The package is in the 'InstallPlan.Installed' state, so does not - -- need building. - | BuildStatusInstalled - - -- | The package has not been downloaded yet, so it will have to be - -- downloaded, unpacked and built. - | BuildStatusDownload - - -- | The package has not been unpacked yet, so it will have to be - -- unpacked and built. - | BuildStatusUnpack FilePath - - -- | The package exists in a local dir already, and just needs building - -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style - -- packages. - | BuildStatusRebuild FilePath BuildStatusRebuild - - -- | The package exists in a local dir already, and is fully up to date. - -- So this package can be put into the 'InstallPlan.Installed' state - -- and it does not need to be built. - | BuildStatusUpToDate BuildResult - - --- | Which 'BuildStatus' values indicate we'll have to do some build work of --- some sort. In particular we use this as part of checking if any of a --- package's deps have changed. --- -buildStatusRequiresBuild :: BuildStatus -> Bool -buildStatusRequiresBuild BuildStatusPreExisting = False -buildStatusRequiresBuild BuildStatusInstalled = False -buildStatusRequiresBuild BuildStatusUpToDate {} = False -buildStatusRequiresBuild _ = True - --- | This is primarily here for debugging. It's not actually used anywhere. --- -buildStatusToString :: BuildStatus -> String -buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" -buildStatusToString BuildStatusInstalled = "BuildStatusInstalled" -buildStatusToString BuildStatusDownload = "BuildStatusDownload" -buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp -buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp -buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" - - --- | For a package that is going to be built or rebuilt, the state it's in now. --- --- So again, this tells us why a package needs to be rebuilt and what build --- phases need to be run. The 'MonitorChangedReason' gives us details like --- which file changed, which is mainly for high verbosity debug output. --- -data BuildStatusRebuild = - - -- | The package configuration changed, so the configure and build phases - -- needs to be (re)run. - BuildStatusConfigure (MonitorChangedReason ()) - - -- | The configuration has not changed but the build phase needs to be - -- rerun. We record the reason the (re)build is needed. - -- - -- The optional registration info here tells us if we've registered the - -- package already, or if we still need to do that after building. - -- @Just Nothing@ indicates that we know that no registration is - -- necessary (e.g., executable.) - -- - | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason - -data BuildReason = - -- | The dependencies of this package have been (re)built so the build - -- phase needs to be rerun. - -- - BuildReasonDepsRebuilt - - -- | Changes in files within the package (or first run or corrupt cache) - | BuildReasonFilesChanged (MonitorChangedReason ()) - - -- | An important special case is that no files have changed but the - -- set of components the /user asked to build/ has changed. We track the - -- set of components /we have built/, which of course only grows (until - -- some other change resets it). - -- - -- The @Set 'ComponentName'@ is the set of components we have built - -- previously. When we update the monitor we take the union of the ones - -- we have built previously with the ones the user has asked for this - -- time and save those. See 'updatePackageBuildFileMonitor'. - -- - | BuildReasonExtraTargets (Set ComponentName) - - -- | Although we're not going to build any additional targets as a whole, - -- we're going to build some part of a component or run a repl or any - -- other action that does not result in additional persistent artifacts. - -- - | BuildReasonEphemeralTargets - - ------------------------------------------------------------------------------- --- Build outcomes: result of the build --- - --- | A summary of the outcome for building a whole set of packages. --- -type BuildOutcomes = Map UnitId BuildOutcome - --- | A summary of the outcome for building a single package: either success --- or failure. --- -type BuildOutcome = Either BuildFailure BuildResult - --- | Information arising from successfully building a single package. --- -data BuildResult = BuildResult { - buildResultDocs :: DocsResult, - buildResultTests :: TestsResult, - buildResultLogFile :: Maybe FilePath - } - deriving Show - --- | Information arising from the failure to build a single package. --- -data BuildFailure = BuildFailure { - buildFailureLogFile :: Maybe FilePath, - buildFailureReason :: BuildFailureReason - } - deriving (Show, Typeable) - -instance Exception BuildFailure - --- | Detail on the reason that a package failed to build. --- -data BuildFailureReason = DependentFailed PackageId - | DownloadFailed SomeException - | UnpackFailed SomeException - | ConfigureFailed SomeException - | BuildFailed SomeException - | ReplFailed SomeException - | HaddocksFailed SomeException - | TestsFailed SomeException - | BenchFailed SomeException - | InstallFailed SomeException - deriving Show diff --git a/Distribution/Client/ProjectConfig.hs b/Distribution/Client/ProjectConfig.hs deleted file mode 100644 --- a/Distribution/Client/ProjectConfig.hs +++ /dev/null @@ -1,1464 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - --- | Handling project configuration. --- -module Distribution.Client.ProjectConfig ( - - -- * Types for project config - ProjectConfig(..), - ProjectConfigBuildOnly(..), - ProjectConfigShared(..), - ProjectConfigProvenance(..), - PackageConfig(..), - MapLast(..), - MapMappend(..), - - -- * Project root - findProjectRoot, - ProjectRoot(..), - BadProjectRoot(..), - - -- * Project config files - readProjectConfig, - readGlobalConfig, - readProjectLocalFreezeConfig, - withProjectOrGlobalConfig, - writeProjectLocalExtraConfig, - writeProjectLocalFreezeConfig, - writeProjectConfigFile, - commandLineFlagsToProjectConfig, - - -- * Packages within projects - ProjectPackageLocation(..), - BadPackageLocations(..), - BadPackageLocation(..), - BadPackageLocationMatch(..), - findProjectPackages, - fetchAndReadSourcePackages, - - -- * Resolving configuration - lookupLocalPackageConfig, - projectConfigWithBuilderRepoContext, - projectConfigWithSolverRepoContext, - SolverSettings(..), - resolveSolverSettings, - BuildTimeSettings(..), - resolveBuildTimeSettings, - - -- * Checking configuration - checkBadPerPackageCompilerPaths, - BadPerPackageCompilerPaths(..) - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.ProjectConfig.Types -import Distribution.Client.ProjectConfig.Legacy -import Distribution.Client.RebuildMonad -import Distribution.Client.Glob - ( isTrivialFilePathGlob ) -import Distribution.Client.VCS - ( validateSourceRepos, SourceRepoProblem(..) - , VCS(..), knownVCSs, configureVCS, syncSourceRepos ) - -import Distribution.Client.Types -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) ) -import Distribution.Client.GlobalFlags - ( RepoContext(..), withRepoContext' ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Config - ( loadConfig, getConfigFilePath ) -import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport, transportCheckHttps - , downloadURI ) -import Distribution.Client.Utils.Parsec (renderParseError) - -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) - -import Distribution.Package - ( PackageName, PackageId, UnitId, packageId ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..) ) -import Distribution.System - ( Platform ) -import Distribution.Types.GenericPackageDescription - ( GenericPackageDescription ) -import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription ) -import Distribution.Fields - ( runParseResult, PError, PWarning, showPWarning) -import Distribution.Types.SourceRepo - ( RepoType(..) ) -import Distribution.Client.Types.SourceRepo - ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) -import Distribution.Simple.Compiler - ( Compiler, compilerInfo ) -import Distribution.Simple.Program - ( ConfiguredProgram(..) ) -import Distribution.Simple.Setup - ( Flag(Flag), toFlag, flagToMaybe, flagToList - , fromFlag, fromFlagOrDefault ) -import Distribution.Client.Setup - ( defaultSolver, defaultMaxBackjumps ) -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) -import Distribution.Simple.Utils - ( die', warn, notice, info, createDirectoryIfMissingVerbose ) -import Distribution.Client.Utils - ( determineNumJobs ) -import Distribution.Utils.NubList - ( fromNubList ) -import Distribution.Verbosity - ( modifyVerbosity, verbose ) -import Distribution.Version - ( Version ) -import qualified Distribution.Deprecated.ParseUtils as OldParser - ( ParseResult(..), locatedErrorMsg, showPWarning ) -import Distribution.Client.SrcDist - ( packageDirToSdist ) - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Client.Tar as Tar -import qualified Distribution.Client.GZipUtils as GZipUtils - -import Control.Monad.Trans (liftIO) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set -import qualified Data.Hashable as Hashable -import Numeric (showHex) - -import System.FilePath hiding (combine) -import System.IO - ( withBinaryFile, IOMode(ReadMode) ) -import System.Directory -import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString ) - - ----------------------------------------- --- Resolving configuration to settings --- - --- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific --- 'PackageName'. This returns the configuration that applies to all local --- packages plus any package-specific configuration for this package. --- -lookupLocalPackageConfig - :: (Semigroup a, Monoid a) - => (PackageConfig -> a) -> ProjectConfig -> PackageName - -> a -lookupLocalPackageConfig field ProjectConfig { - projectConfigLocalPackages, - projectConfigSpecificPackage - } pkgname = - field projectConfigLocalPackages - <> maybe mempty field - (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage)) - - --- | Use a 'RepoContext' based on the 'BuildTimeSettings'. --- -projectConfigWithBuilderRepoContext :: Verbosity - -> BuildTimeSettings - -> (RepoContext -> IO a) -> IO a -projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} = - withRepoContext' - verbosity - buildSettingRemoteRepos - buildSettingLocalNoIndexRepos - buildSettingCacheDir - buildSettingHttpTransport - (Just buildSettingIgnoreExpiry) - buildSettingProgPathExtra - - --- | Use a 'RepoContext', but only for the solver. The solver does not use the --- full facilities of the 'RepoContext' so we can get away with making one --- that doesn't have an http transport. And that avoids having to have access --- to the 'BuildTimeSettings' --- -projectConfigWithSolverRepoContext - :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly - -> (RepoContext -> IO a) - -> IO a -projectConfigWithSolverRepoContext verbosity - ProjectConfigShared{..} - ProjectConfigBuildOnly{..} = - withRepoContext' - verbosity - (fromNubList projectConfigRemoteRepos) - (fromNubList projectConfigLocalNoIndexRepos) - (fromFlagOrDefault - (error - "projectConfigWithSolverRepoContext: projectConfigCacheDir") - projectConfigCacheDir) - (flagToMaybe projectConfigHttpTransport) - (flagToMaybe projectConfigIgnoreExpiry) - (fromNubList projectConfigProgPathExtra) - - --- | Resolve the project configuration, with all its optional fields, into --- 'SolverSettings' with no optional fields (by applying defaults). --- -resolveSolverSettings :: ProjectConfig -> SolverSettings -resolveSolverSettings ProjectConfig{ - projectConfigShared, - projectConfigLocalPackages, - projectConfigSpecificPackage - } = - SolverSettings {..} - where - --TODO: [required eventually] some of these settings need validation, e.g. - -- the flag assignments need checking. - solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos - solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - solverSettingConstraints = projectConfigConstraints - solverSettingPreferences = projectConfigPreferences - solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages - solverSettingFlagAssignments = fmap packageConfigFlagAssignment - (getMapMappend projectConfigSpecificPackage) - solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion - solverSettingSolver = fromFlag projectConfigSolver - solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder - solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer - solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of - n | n < 0 -> Nothing - | otherwise -> Just n - solverSettingReorderGoals = fromFlag projectConfigReorderGoals - solverSettingCountConflicts = fromFlag projectConfigCountConflicts - solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts - solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet - solverSettingStrongFlags = fromFlag projectConfigStrongFlags - solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls - solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained - solverSettingIndexState = flagToMaybe projectConfigIndexState - solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos - solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals - --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs - --solverSettingReinstall = fromFlag projectConfigReinstall - --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls - --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall - --solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps - - ProjectConfigShared {..} = defaults <> projectConfigShared - - defaults = mempty { - projectConfigSolver = Flag defaultSolver, - projectConfigAllowOlder = Just (AllowOlder mempty), - projectConfigAllowNewer = Just (AllowNewer mempty), - projectConfigMaxBackjumps = Flag defaultMaxBackjumps, - projectConfigReorderGoals = Flag (ReorderGoals False), - projectConfigCountConflicts = Flag (CountConflicts True), - projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), - projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), - projectConfigStrongFlags = Flag (StrongFlags False), - projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - projectConfigOnlyConstrained = Flag OnlyConstrainedNone, - projectConfigIndependentGoals = Flag (IndependentGoals False) - --projectConfigShadowPkgs = Flag False, - --projectConfigReinstall = Flag False, - --projectConfigAvoidReinstalls = Flag False, - --projectConfigOverrideReinstall = Flag False, - --projectConfigUpgradeDeps = Flag False - } - - --- | Resolve the project configuration, with all its optional fields, into --- 'BuildTimeSettings' with no optional fields (by applying defaults). --- -resolveBuildTimeSettings :: Verbosity - -> CabalDirLayout - -> ProjectConfig - -> BuildTimeSettings -resolveBuildTimeSettings verbosity - CabalDirLayout { - cabalLogsDirectory - } - ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigRemoteRepos, - projectConfigLocalNoIndexRepos, - projectConfigProgPathExtra - }, - projectConfigBuildOnly - } = - BuildTimeSettings {..} - where - buildSettingDryRun = fromFlag projectConfigDryRun - buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps - buildSettingSummaryFile = fromNubList projectConfigSummaryFile - --buildSettingLogFile -- defined below, more complicated - --buildSettingLogVerbosity -- defined below, more complicated - buildSettingBuildReports = fromFlag projectConfigBuildReports - buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir - buildSettingOneShot = fromFlag projectConfigOneShot - buildSettingNumJobs = determineNumJobs projectConfigNumJobs - buildSettingKeepGoing = fromFlag projectConfigKeepGoing - buildSettingOfflineMode = fromFlag projectConfigOfflineMode - buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles - buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos - buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - buildSettingCacheDir = fromFlag projectConfigCacheDir - buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport - buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry - buildSettingReportPlanningFailure - = fromFlag projectConfigReportPlanningFailure - buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra - - ProjectConfigBuildOnly{..} = defaults - <> projectConfigBuildOnly - - defaults = mempty { - projectConfigDryRun = toFlag False, - projectConfigOnlyDeps = toFlag False, - projectConfigBuildReports = toFlag NoReports, - projectConfigReportPlanningFailure = toFlag False, - projectConfigKeepGoing = toFlag False, - projectConfigOneShot = toFlag False, - projectConfigOfflineMode = toFlag False, - projectConfigKeepTempFiles = toFlag False, - projectConfigIgnoreExpiry = toFlag False - } - - -- The logging logic: what log file to use and what verbosity. - -- - -- If the user has specified --remote-build-reporting=detailed, use the - -- default log file location. If the --build-log option is set, use the - -- provided location. Otherwise don't use logging, unless building in - -- parallel (in which case the default location is used). - -- - buildSettingLogFile :: Maybe (Compiler -> Platform - -> PackageId -> UnitId -> FilePath) - buildSettingLogFile - | useDefaultTemplate = Just (substLogFileName defaultTemplate) - | otherwise = fmap substLogFileName givenTemplate - - defaultTemplate = toPathTemplate $ - cabalLogsDirectory - "$compiler" "$libname" <.> "log" - givenTemplate = flagToMaybe projectConfigLogFile - - useDefaultTemplate - | buildSettingBuildReports == DetailedReports = True - | isJust givenTemplate = False - | isParallelBuild = True - | otherwise = False - - isParallelBuild = buildSettingNumJobs >= 2 - - substLogFileName :: PathTemplate - -> Compiler -> Platform - -> PackageId -> UnitId -> FilePath - substLogFileName template compiler platform pkgid uid = - fromPathTemplate (substPathTemplate env template) - where - env = initialPathTemplateEnv - pkgid uid (compilerInfo compiler) platform - - -- If the user has specified --remote-build-reporting=detailed or - -- --build-log, use more verbose logging. - -- - buildSettingLogVerbosity - | overrideVerbosity = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - overrideVerbosity - | buildSettingBuildReports == DetailedReports = True - | isJust givenTemplate = True - | isParallelBuild = False - | otherwise = False - - ---------------------------------------------- --- Reading and writing project config files --- - --- | Find the root of this project. --- --- Searches for an explicit @cabal.project@ file, in the current directory or --- parent directories. If no project file is found then the current dir is the --- project root (and the project will use an implicit config). --- -findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory - -> Maybe FilePath -- ^ @cabal.project@ file name override - -> IO (Either BadProjectRoot ProjectRoot) -findProjectRoot _ (Just projectFile) - | isAbsolute projectFile = do - exists <- doesFileExist projectFile - if exists - then do projectFile' <- canonicalizePath projectFile - let projectRoot = ProjectRootExplicit (takeDirectory projectFile') - (takeFileName projectFile') - return (Right projectRoot) - else return (Left (BadProjectRootExplicitFile projectFile)) - -findProjectRoot mstartdir mprojectFile = do - startdir <- maybe getCurrentDirectory canonicalizePath mstartdir - homedir <- getHomeDirectory - probe startdir homedir - where - projectFileName = fromMaybe "cabal.project" mprojectFile - - -- Search upwards. If we get to the users home dir or the filesystem root, - -- then use the current dir - probe startdir homedir = go startdir - where - go dir | isDrive dir || dir == homedir = - case mprojectFile of - Nothing -> return (Right (ProjectRootImplicit startdir)) - Just file -> return (Left (BadProjectRootExplicitFile file)) - go dir = do - exists <- doesFileExist (dir projectFileName) - if exists - then return (Right (ProjectRootExplicit dir projectFileName)) - else go (takeDirectory dir) - --- | Errors returned by 'findProjectRoot'. --- -data BadProjectRoot = BadProjectRootExplicitFile FilePath -#if MIN_VERSION_base(4,8,0) - deriving (Show, Typeable) -#else - deriving (Typeable) - -instance Show BadProjectRoot where - show = renderBadProjectRoot -#endif - -instance Exception BadProjectRoot where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadProjectRoot -#endif - -renderBadProjectRoot :: BadProjectRoot -> String -renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = - "The given project file '" ++ projectFile ++ "' does not exist." - -withProjectOrGlobalConfig - :: Verbosity -- ^ verbosity - -> Flag Bool -- ^ whether to ignore local project - -> Flag FilePath -- ^ @--cabal-config@ - -> IO a -- ^ with project - -> (ProjectConfig -> IO a) -- ^ without projet - -> IO a -withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf - without globalConfig -withProjectOrGlobalConfig verbosity _ignorePrj gcf with without = - withProjectOrGlobalConfig' verbosity gcf with without - -withProjectOrGlobalConfig' - :: Verbosity - -> Flag FilePath - -> IO a - -> (ProjectConfig -> IO a) - -> IO a -withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag - - let - res' = catch with - $ \case - (BadPackageLocations prov locs) - | prov == Set.singleton Implicit - , let - isGlobErr (BadLocGlobEmptyMatch _) = True - isGlobErr _ = False - , any isGlobErr locs -> - without globalConfig - err -> throwIO err - - catch res' - $ \case - (BadProjectRootExplicitFile "") -> without globalConfig - err -> throwIO err - --- | Read all the config relevant for a project. This includes the project --- file if any, plus other global config. --- -readProjectConfig :: Verbosity - -> Flag FilePath - -> DistDirLayout - -> Rebuild ProjectConfig -readProjectConfig verbosity configFileFlag distDirLayout = do - global <- readGlobalConfig verbosity configFileFlag - local <- readProjectLocalConfigOrDefault verbosity distDirLayout - freeze <- readProjectLocalFreezeConfig verbosity distDirLayout - extra <- readProjectLocalExtraConfig verbosity distDirLayout - return (global <> local <> freeze <> extra) - - --- | Reads an explicit @cabal.project@ file in the given project root dir, --- or returns the default project config for an implicitly defined project. --- -readProjectLocalConfigOrDefault :: Verbosity - -> DistDirLayout - -> Rebuild ProjectConfig -readProjectLocalConfigOrDefault verbosity distDirLayout = do - usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile - if usesExplicitProjectRoot - then do - readProjectFile verbosity distDirLayout "" "project file" - else do - monitorFiles [monitorNonExistentFile projectFile] - return defaultImplicitProjectConfig - - where - projectFile = distProjectFile distDirLayout "" - - defaultImplicitProjectConfig :: ProjectConfig - defaultImplicitProjectConfig = - mempty { - -- We expect a package in the current directory. - projectPackages = [ "./*.cabal" ], - - projectConfigProvenance = Set.singleton Implicit - } - --- | Reads a @cabal.project.local@ file in the given project root dir, --- or returns empty. This file gets written by @cabal configure@, or in --- principle can be edited manually or by other tools. --- -readProjectLocalExtraConfig :: Verbosity -> DistDirLayout - -> Rebuild ProjectConfig -readProjectLocalExtraConfig verbosity distDirLayout = - readProjectFile verbosity distDirLayout "local" - "project local configuration file" - --- | Reads a @cabal.project.freeze@ file in the given project root dir, --- or returns empty. This file gets written by @cabal freeze@, or in --- principle can be edited manually or by other tools. --- -readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout - -> Rebuild ProjectConfig -readProjectLocalFreezeConfig verbosity distDirLayout = - readProjectFile verbosity distDirLayout "freeze" - "project freeze file" - --- | Reads a named config file in the given project root dir, or returns empty. --- -readProjectFile :: Verbosity - -> DistDirLayout - -> String - -> String - -> Rebuild ProjectConfig -readProjectFile verbosity DistDirLayout{distProjectFile} - extensionName extensionDescription = do - exists <- liftIO $ doesFileExist extensionFile - if exists - then do monitorFiles [monitorFileHashed extensionFile] - addProjectFileProvenance <$> liftIO readExtensionFile - else do monitorFiles [monitorNonExistentFile extensionFile] - return mempty - where - extensionFile = distProjectFile extensionName - - readExtensionFile = - reportParseResult verbosity extensionDescription extensionFile - . parseProjectConfig - =<< readFile extensionFile - - addProjectFileProvenance config = - config { - projectConfigProvenance = - Set.insert (Explicit extensionFile) (projectConfigProvenance config) - } - - --- | Parse the 'ProjectConfig' format. --- --- For the moment this is implemented in terms of parsers for legacy --- configuration types, plus a conversion. --- -parseProjectConfig :: String -> OldParser.ParseResult ProjectConfig -parseProjectConfig content = - convertLegacyProjectConfig <$> - parseLegacyProjectConfig content - - --- | Render the 'ProjectConfig' format. --- --- For the moment this is implemented in terms of a pretty printer for the --- legacy configuration types, plus a conversion. --- -showProjectConfig :: ProjectConfig -> String -showProjectConfig = - showLegacyProjectConfig . convertToLegacyProjectConfig - - --- | Write a @cabal.project.local@ file in the given project root dir. --- -writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () -writeProjectLocalExtraConfig DistDirLayout{distProjectFile} = - writeProjectConfigFile (distProjectFile "local") - - --- | Write a @cabal.project.freeze@ file in the given project root dir. --- -writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () -writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} = - writeProjectConfigFile (distProjectFile "freeze") - - --- | Write in the @cabal.project@ format to the given file. --- -writeProjectConfigFile :: FilePath -> ProjectConfig -> IO () -writeProjectConfigFile file = - writeFile file . showProjectConfig - - --- | Read the user's @~/.cabal/config@ file. --- -readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig -readGlobalConfig verbosity configFileFlag = do - config <- liftIO (loadConfig verbosity configFileFlag) - configFile <- liftIO (getConfigFilePath configFileFlag) - monitorFiles [monitorFileHashed configFile] - return (convertLegacyGlobalConfig config) - -reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult a -> IO a -reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do - unless (null warnings) $ - let msg = unlines (map (OldParser.showPWarning filename) warnings) - in warn verbosity msg - return x -reportParseResult verbosity filetype filename (OldParser.ParseFailed err) = - let (line, msg) = OldParser.locatedErrorMsg err - in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - - ---------------------------------------------- --- Finding packages in the project --- - --- | The location of a package as part of a project. Local file paths are --- either absolute (if the user specified it as such) or they are relative --- to the project root. --- -data ProjectPackageLocation = - ProjectPackageLocalCabalFile FilePath - | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file - | ProjectPackageLocalTarball FilePath - | ProjectPackageRemoteTarball URI - | ProjectPackageRemoteRepo SourceRepoList - | ProjectPackageNamed PackageVersionConstraint - deriving Show - - --- | Exception thrown by 'findProjectPackages'. --- -data BadPackageLocations - = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] -#if MIN_VERSION_base(4,8,0) - deriving (Show, Typeable) -#else - deriving (Typeable) - -instance Show BadPackageLocations where - show = renderBadPackageLocations -#endif - -instance Exception BadPackageLocations where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadPackageLocations -#endif ---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc - -data BadPackageLocation - = BadPackageLocationFile BadPackageLocationMatch - | BadLocGlobEmptyMatch String - | BadLocGlobBadMatches String [BadPackageLocationMatch] - | BadLocUnexpectedUriScheme String - | BadLocUnrecognisedUri String - | BadLocUnrecognised String - deriving Show - -data BadPackageLocationMatch - = BadLocUnexpectedFile String - | BadLocNonexistantFile String - | BadLocDirNoCabalFile String - | BadLocDirManyCabalFiles String - deriving Show - -renderBadPackageLocations :: BadPackageLocations -> String -renderBadPackageLocations (BadPackageLocations provenance bpls) - -- There is no provenance information, - -- render standard bad package error information. - | Set.null provenance = renderErrors renderBadPackageLocation - - -- The configuration is implicit, render bad package locations - -- using possibly specialized error messages. - | Set.singleton Implicit == provenance = - renderErrors renderImplicitBadPackageLocation - - -- The configuration contains both implicit and explicit provenance. - -- This should not occur, and a message is output to assist debugging. - | Implicit `Set.member` provenance = - "Warning: both implicit and explicit configuration is present." - ++ renderExplicit - - -- The configuration was read from one or more explicit path(s), - -- list the locations and render the bad package error information. - -- The intent is to supersede this with the relevant location information - -- per package error. - | otherwise = renderExplicit - where - renderErrors f = unlines (map f bpls) - - renderExplicit = - "When using configuration(s) from " - ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance)) - ++ ", the following errors occurred:\n" - ++ renderErrors renderBadPackageLocation - - getExplicit (Explicit path) = Just path - getExplicit Implicit = Nothing - ---TODO: [nice to have] keep track of the config file (and src loc) packages --- were listed, to use in error messages - --- | Render bad package location error information for the implicit --- @cabal.project@ configuration. --- --- TODO: This is currently not fully realized, with only one of the implicit --- cases handled. More cases should be added with informative help text --- about the issues related specifically when having no project configuration --- is present. -renderImplicitBadPackageLocation :: BadPackageLocation -> String -renderImplicitBadPackageLocation bpl = case bpl of - BadLocGlobEmptyMatch pkglocstr -> - "No cabal.project file or cabal file matching the default glob '" - ++ pkglocstr ++ "' was found.\n" - ++ "Please create a package description file .cabal " - ++ "or a cabal.project file referencing the packages you " - ++ "want to build." - _ -> renderBadPackageLocation bpl - -renderBadPackageLocation :: BadPackageLocation -> String -renderBadPackageLocation bpl = case bpl of - BadPackageLocationFile badmatch -> - renderBadPackageLocationMatch badmatch - BadLocGlobEmptyMatch pkglocstr -> - "The package location glob '" ++ pkglocstr - ++ "' does not match any files or directories." - BadLocGlobBadMatches pkglocstr failures -> - "The package location glob '" ++ pkglocstr ++ "' does not match any " - ++ "recognised forms of package. " - ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures - BadLocUnexpectedUriScheme pkglocstr -> - "The package location URI '" ++ pkglocstr ++ "' does not use a " - ++ "supported URI scheme. The supported URI schemes are http, https and " - ++ "file." - BadLocUnrecognisedUri pkglocstr -> - "The package location URI '" ++ pkglocstr ++ "' does not appear to " - ++ "be a valid absolute URI." - BadLocUnrecognised pkglocstr -> - "The package location syntax '" ++ pkglocstr ++ "' is not recognised." - -renderBadPackageLocationMatch :: BadPackageLocationMatch -> String -renderBadPackageLocationMatch bplm = case bplm of - BadLocUnexpectedFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' is not recognised. The " - ++ "supported file targets are .cabal files, .tar.gz tarballs or package " - ++ "directories (i.e. directories containing a .cabal file)." - BadLocNonexistantFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' does not exist." - BadLocDirNoCabalFile pkglocstr -> - "The package directory '" ++ pkglocstr ++ "' does not contain any " - ++ ".cabal file." - BadLocDirManyCabalFiles pkglocstr -> - "The package directory '" ++ pkglocstr ++ "' contains multiple " - ++ ".cabal files (which is not currently supported)." - --- | Given the project config, --- --- Throws 'BadPackageLocations'. --- -findProjectPackages :: DistDirLayout -> ProjectConfig - -> Rebuild [ProjectPackageLocation] -findProjectPackages DistDirLayout{distProjectRootDirectory} - ProjectConfig{..} = do - - requiredPkgs <- findPackageLocations True projectPackages - optionalPkgs <- findPackageLocations False projectPackagesOptional - let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo - namedPkgs = map ProjectPackageNamed projectPackagesNamed - - return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs]) - where - findPackageLocations required pkglocstr = do - (problems, pkglocs) <- - partitionEithers <$> traverse (findPackageLocation required) pkglocstr - unless (null problems) $ - liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems - return (concat pkglocs) - - - findPackageLocation :: Bool -> String - -> Rebuild (Either BadPackageLocation - [ProjectPackageLocation]) - findPackageLocation _required@True pkglocstr = - -- strategy: try first as a file:// or http(s):// URL. - -- then as a file glob (usually encompassing single file) - -- finally as a single file, for files that fail to parse as globs - checkIsUriPackage pkglocstr - `mplusMaybeT` checkIsFileGlobPackage pkglocstr - `mplusMaybeT` checkIsSingleFilePackage pkglocstr - >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return - - - findPackageLocation _required@False pkglocstr = do - -- just globs for optional case - res <- checkIsFileGlobPackage pkglocstr - case res of - Nothing -> return (Left (BadLocUnrecognised pkglocstr)) - Just (Left _) -> return (Right []) -- it's optional - Just (Right pkglocs) -> return (Right pkglocs) - - - checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage - :: String -> Rebuild (Maybe (Either BadPackageLocation - [ProjectPackageLocation])) - checkIsUriPackage pkglocstr = - case parseAbsoluteURI pkglocstr of - Just uri@URI { - uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host }, - uriPath = path, - uriQuery = query, - uriFragment = frag - } - | recognisedScheme && not (null host) -> - return (Just (Right [ProjectPackageRemoteTarball uri])) - - | scheme == "file:" && null host && null query && null frag -> - checkIsSingleFilePackage path - - | not recognisedScheme && not (null host) -> - return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) - - | recognisedScheme && null host -> - return (Just (Left (BadLocUnrecognisedUri pkglocstr))) - where - recognisedScheme = scheme == "http:" || scheme == "https:" - || scheme == "file:" - - _ -> return Nothing - - - checkIsFileGlobPackage pkglocstr = - case simpleParsec pkglocstr of - Nothing -> return Nothing - Just glob -> liftM Just $ do - matches <- matchFileGlob glob - case matches of - [] | isJust (isTrivialFilePathGlob glob) - -> return (Left (BadPackageLocationFile - (BadLocNonexistantFile pkglocstr))) - - [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) - - _ -> do - (failures, pkglocs) <- partitionEithers <$> - traverse checkFilePackageMatch matches - return $! case (failures, pkglocs) of - ([failure], []) | isJust (isTrivialFilePathGlob glob) - -> Left (BadPackageLocationFile failure) - (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) - _ -> Right pkglocs - - - checkIsSingleFilePackage pkglocstr = do - let filename = distProjectRootDirectory pkglocstr - isFile <- liftIO $ doesFileExist filename - isDir <- liftIO $ doesDirectoryExist filename - if isFile || isDir - then checkFilePackageMatch pkglocstr - >>= either (return . Just . Left . BadPackageLocationFile) - (return . Just . Right . (\x->[x])) - else return Nothing - - - checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch - ProjectPackageLocation) - checkFilePackageMatch pkglocstr = do - -- The pkglocstr may be absolute or may be relative to the project root. - -- Either way, does the right thing here. We return relative paths if - -- they were relative in the first place. - let abspath = distProjectRootDirectory pkglocstr - isFile <- liftIO $ doesFileExist abspath - isDir <- liftIO $ doesDirectoryExist abspath - parentDirExists <- case takeDirectory abspath of - [] -> return False - dir -> liftIO $ doesDirectoryExist dir - case () of - _ | isDir - -> do matches <- matchFileGlob (globStarDotCabal pkglocstr) - case matches of - [cabalFile] - -> return (Right (ProjectPackageLocalDirectory - pkglocstr cabalFile)) - [] -> return (Left (BadLocDirNoCabalFile pkglocstr)) - _ -> return (Left (BadLocDirManyCabalFiles pkglocstr)) - - | extensionIsTarGz pkglocstr - -> return (Right (ProjectPackageLocalTarball pkglocstr)) - - | takeExtension pkglocstr == ".cabal" - -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) - - | isFile - -> return (Left (BadLocUnexpectedFile pkglocstr)) - - | parentDirExists - -> return (Left (BadLocNonexistantFile pkglocstr)) - - | otherwise - -> return (Left (BadLocUnexpectedFile pkglocstr)) - - - extensionIsTarGz f = takeExtension f == ".gz" - && takeExtension (dropExtension f) == ".tar" - - --- | A glob to find all the cabal files in a directory. --- --- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@. --- The directory part can be either absolute or relative. --- -globStarDotCabal :: FilePath -> FilePathGlob -globStarDotCabal dir = - FilePathGlob - (if isAbsolute dir then FilePathRoot root else FilePathRelative) - (foldr (\d -> GlobDir [Literal d]) - (GlobFile [WildCard, Literal ".cabal"]) dirComponents) - where - (root, dirComponents) = fmap splitDirectories (splitDrive dir) - - ---TODO: [code cleanup] use sufficiently recent transformers package -mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) -mplusMaybeT ma mb = do - mx <- ma - case mx of - Nothing -> mb - Just x -> return (Just x) - - -------------------------------------------------- --- Fetching and reading packages in the project --- - --- | Read the @.cabal@ files for a set of packages. For remote tarballs and --- VCS source repos this also fetches them if needed. --- --- Note here is where we convert from project-root relative paths to absolute --- paths. --- -fetchAndReadSourcePackages - :: Verbosity - -> DistDirLayout - -> ProjectConfigShared - -> ProjectConfigBuildOnly - -> [ProjectPackageLocation] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -fetchAndReadSourcePackages verbosity distDirLayout - projectConfigShared - projectConfigBuildOnly - pkgLocations = do - - pkgsLocalDirectory <- - sequenceA - [ readSourcePackageLocalDirectory verbosity dir cabalFile - | location <- pkgLocations - , (dir, cabalFile) <- projectPackageLocal location ] - - pkgsLocalTarball <- - sequenceA - [ readSourcePackageLocalTarball verbosity path - | ProjectPackageLocalTarball path <- pkgLocations ] - - pkgsRemoteTarball <- do - getTransport <- delayInitSharedResource $ - configureTransport verbosity progPathExtra - preferredHttpTransport - sequenceA - [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout - getTransport uri - | ProjectPackageRemoteTarball uri <- pkgLocations ] - - pkgsRemoteRepo <- - syncAndReadSourcePackagesRemoteRepos - verbosity distDirLayout - projectConfigShared - [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ] - - let pkgsNamed = - [ NamedPackage pkgname [PackagePropertyVersion verrange] - | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ] - - return $ concat - [ pkgsLocalDirectory - , pkgsLocalTarball - , pkgsRemoteTarball - , pkgsRemoteRepo - , pkgsNamed - ] - where - projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)] - projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)] - where dir = takeDirectory file - projectPackageLocal _ = [] - - progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared) - preferredHttpTransport = - flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly) - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'. --- We simply read the @.cabal@ file. --- -readSourcePackageLocalDirectory - :: Verbosity - -> FilePath -- ^ The package directory - -> FilePath -- ^ The package @.cabal@ file - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -readSourcePackageLocalDirectory verbosity dir cabalFile = do - monitorFiles [monitorFileHashed cabalFile] - root <- askRoot - let location = LocalUnpackedPackage (root dir) - liftIO $ fmap (mkSpecificSourcePackage location) - . readSourcePackageCabalFile verbosity cabalFile - =<< BS.readFile (root cabalFile) - - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find --- the @.cabal@ file and read that. --- -readSourcePackageLocalTarball - :: Verbosity - -> FilePath - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -readSourcePackageLocalTarball verbosity tarballFile = do - monitorFiles [monitorFile tarballFile] - root <- askRoot - let location = LocalTarballPackage (root tarballFile) - liftIO $ fmap (mkSpecificSourcePackage location) - . uncurry (readSourcePackageCabalFile verbosity) - =<< extractTarballPackageCabalFile (root tarballFile) - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir --- and after that handle it like the local tarball case. --- -fetchAndReadSourcePackageRemoteTarball - :: Verbosity - -> DistDirLayout - -> Rebuild HttpTransport - -> URI - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -fetchAndReadSourcePackageRemoteTarball verbosity - DistDirLayout { - distDownloadSrcDirectory - } - getTransport - tarballUri = - -- The tarball download is expensive so we use another layer of file - -- monitor to avoid it whenever possible. - rerunIfChanged verbosity monitor tarballUri $ do - - -- Download - transport <- getTransport - liftIO $ do - transportCheckHttps verbosity transport tarballUri - notice verbosity ("Downloading " ++ show tarballUri) - createDirectoryIfMissingVerbose verbosity True - distDownloadSrcDirectory - _ <- downloadURI transport verbosity tarballUri tarballFile - return () - - -- Read - monitorFiles [monitorFile tarballFile] - let location = RemoteTarballPackage tarballUri tarballFile - liftIO $ fmap (mkSpecificSourcePackage location) - . uncurry (readSourcePackageCabalFile verbosity) - =<< extractTarballPackageCabalFile tarballFile - where - tarballStem = distDownloadSrcDirectory - localFileNameForRemoteTarball tarballUri - tarballFile = tarballStem <.> "tar.gz" - - monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - monitor = newFileMonitor (tarballStem <.> "cache") - - --- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of --- 'ProjectPackageRemoteRepo'. --- -syncAndReadSourcePackagesRemoteRepos - :: Verbosity - -> DistDirLayout - -> ProjectConfigShared - -> [SourceRepoList] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -syncAndReadSourcePackagesRemoteRepos verbosity - DistDirLayout{distDownloadSrcDirectory} - ProjectConfigShared { - projectConfigProgPathExtra - } - repos = do - - repos' <- either reportSourceRepoProblems return $ - validateSourceRepos repos - - -- All 'SourceRepo's grouped by referring to the "same" remote repo - -- instance. So same location but can differ in commit/tag/branch/subdir. - let reposByLocation :: Map (RepoType, String) - [(SourceRepoList, RepoType)] - reposByLocation = Map.fromListWith (++) - [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) - | (repo, rloc, rtype, vcs) <- repos' ] - - --TODO: pass progPathExtra on to 'configureVCS' - let _progPathExtra = fromNubList projectConfigProgPathExtra - getConfiguredVCS <- delayInitSharedResources $ \repoType -> - let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in - configureVCS verbosity {-progPathExtra-} vcs - - concat <$> sequenceA - [ rerunIfChanged verbosity monitor repoGroup' $ do - vcs' <- getConfiguredVCS repoType - syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup' - | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation - , let repoGroup' = map fst repoGroup - pathStem = distDownloadSrcDirectory - localFileNameForRemoteRepo primaryRepo - monitor :: FileMonitor - [SourceRepoList] - [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] - monitor = newFileMonitor (pathStem <.> "cache") - ] - where - syncRepoGroupAndReadSourcePackages - :: VCS ConfiguredProgram - -> FilePath - -> [SourceRepoList] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] - syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do - liftIO $ createDirectoryIfMissingVerbose verbosity False - distDownloadSrcDirectory - - -- For syncing we don't care about different 'SourceRepo' values that - -- are just different subdirs in the same repo. - syncSourceRepos verbosity vcs - [ (repo, repoPath) - | (repo, _, repoPath) <- repoGroupWithPaths ] - -- TODO phadej 2020-06-18 add post-sync script - - -- But for reading we go through each 'SourceRepo' including its subdir - -- value and have to know which path each one ended up in. - sequenceA - [ readPackageFromSourceRepo repoWithSubdir repoPath - | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths - , repoWithSubdir <- NE.toList reposWithSubdir ] - where - -- So to do both things above, we pair them up here. - repoGroupWithPaths - :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] - repoGroupWithPaths = - zipWith (\(x, y) z -> (x,y,z)) - (mapGroup - [ (repo { srpSubdir = Proxy }, repo) - | repo <- foldMap (NE.toList . srpFanOut) repoGroup - ]) - repoPaths - - mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] - mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) - - -- The repos in a group are given distinct names by simple enumeration - -- foo, foo-2, foo-3 etc - repoPaths :: [FilePath] - repoPaths = pathStem - : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] - - readPackageFromSourceRepo - :: SourceRepositoryPackage Maybe - -> FilePath - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - readPackageFromSourceRepo repo repoPath = do - let packageDir :: FilePath - packageDir = maybe repoPath (repoPath ) (srpSubdir repo) - - entries <- liftIO $ getDirectoryContents packageDir - --TODO: dcoutts 2018-06-23: wrap exceptions - case filter (\e -> takeExtension e == ".cabal") entries of - [] -> liftIO $ throwIO $ NoCabalFileFound packageDir - (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir - [cabalFileName] -> do - let cabalFilePath = packageDir cabalFileName - monitorFiles [monitorFileHashed cabalFilePath] - gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath - - -- write sdist tarball, to repoPath-pgkid - tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir - let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz" - liftIO $ LBS.writeFile tarballPath tarball - - let location = RemoteSourceRepoPackage repo tarballPath - return $ mkSpecificSourcePackage location gpd - - reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a - reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems - - renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String - renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" - - --- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an --- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package --- from a given location. --- -mkSpecificSourcePackage :: PackageLocation FilePath - -> GenericPackageDescription - -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) -mkSpecificSourcePackage location pkg = - SpecificSourcePackage SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing - } - - --- | Errors reported upon failing to parse a @.cabal@ file. --- -data CabalFileParseError = CabalFileParseError - FilePath -- ^ @.cabal@ file path - BS.ByteString -- ^ @.cabal@ file contents - (NonEmpty PError) -- ^ errors - (Maybe Version) -- ^ We might discover the spec version the package needs - [PWarning] -- ^ warnings - deriving (Typeable) - --- | Manual instance which skips file contentes -instance Show CabalFileParseError where - showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10) - $ showString "CabalFileParseError" - . showChar ' ' . showsPrec 11 fp - . showChar ' ' . showsPrec 11 ("" :: String) - . showChar ' ' . showsPrec 11 es - . showChar ' ' . showsPrec 11 mv - . showChar ' ' . showsPrec 11 ws - -instance Exception CabalFileParseError -#if MIN_VERSION_base(4,8,0) - where - displayException = renderCabalFileParseError -#endif - -renderCabalFileParseError :: CabalFileParseError -> String -renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) = - renderParseError filePath contents errors warnings - --- | Wrapper for the @.cabal@ file parser. It reports warnings on higher --- verbosity levels and throws 'CabalFileParseError' on failure. --- -readSourcePackageCabalFile :: Verbosity - -> FilePath - -> BS.ByteString - -> IO GenericPackageDescription -readSourcePackageCabalFile verbosity pkgfilename content = - case runParseResult (parseGenericPackageDescription content) of - (warnings, Right pkg) -> do - unless (null warnings) $ - info verbosity (formatWarnings warnings) - return pkg - - (warnings, Left (mspecVersion, errors)) -> - throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings - where - formatWarnings warnings = - "The package description file " ++ pkgfilename - ++ " has warnings: " - ++ unlines (map (showPWarning pkgfilename) warnings) - - --- | When looking for a package's @.cabal@ file we can find none, or several, --- both of which are failures. --- -data CabalFileSearchFailure - = NoCabalFileFound FilePath - | MultipleCabalFilesFound FilePath - deriving (Show, Typeable) - -instance Exception CabalFileSearchFailure - - --- | Find the @.cabal@ file within a tarball file and return it by value. --- --- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception. --- -extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString) -extractTarballPackageCabalFile tarballFile = - withBinaryFile tarballFile ReadMode $ \hnd -> do - content <- LBS.hGetContents hnd - case extractTarballPackageCabalFilePure tarballFile content of - Left (Left e) -> throwIO e - Left (Right e) -> throwIO e - Right (fileName, fileContent) -> - (,) fileName <$> evaluate (LBS.toStrict fileContent) - - --- | Scan through a tar file stream and collect the @.cabal@ file, or fail. --- -extractTarballPackageCabalFilePure :: FilePath - -> LBS.ByteString - -> Either (Either Tar.FormatError - CabalFileSearchFailure) - (FilePath, LBS.ByteString) -extractTarballPackageCabalFilePure tarballFile = - check - . accumEntryMap - . Tar.filterEntries isCabalFile - . Tar.read - . GZipUtils.maybeDecompress - where - accumEntryMap = Tar.foldlEntries - (\m e -> Map.insert (Tar.entryTarPath e) e m) - Map.empty - - check (Left (e, _m)) = Left (Left e) - check (Right m) = case Map.elems m of - [] -> Left (Right $ NoCabalFileFound tarballFile) - [file] -> case Tar.entryContent file of - Tar.NormalFile content _ -> Right (Tar.entryPath file, content) - _ -> Left (Right $ NoCabalFileFound tarballFile) - _files -> Left (Right $ MultipleCabalFilesFound tarballFile) - - isCabalFile e = case splitPath (Tar.entryPath e) of - [ _dir, file] -> takeExtension file == ".cabal" - [".", _dir, file] -> takeExtension file == ".cabal" - _ -> False - - --- | The name to use for a local file for a remote tarball 'SourceRepo'. --- This is deterministic based on the remote tarball URI, and is intended --- to produce non-clashing file names for different tarballs. --- -localFileNameForRemoteTarball :: URI -> FilePath -localFileNameForRemoteTarball uri = - mangleName uri - ++ "-" ++ showHex locationHash "" - where - mangleName = truncateString 10 . dropExtension . dropExtension - . takeFileName . dropTrailingPathSeparator . uriPath - - locationHash :: Word - locationHash = fromIntegral (Hashable.hash (uriToString id uri "")) - - --- | The name to use for a local file or dir for a remote 'SourceRepo'. --- This is deterministic based on the source repo identity details, and --- intended to produce non-clashing file names for different repos. --- -localFileNameForRemoteRepo :: SourceRepoList -> FilePath -localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} = - mangleName srpLocation ++ "-" ++ showHex locationHash "" - where - mangleName = truncateString 10 . dropExtension - . takeFileName . dropTrailingPathSeparator - - -- just the parts that make up the "identity" of the repo - locationHash :: Word - locationHash = - fromIntegral (Hashable.hash (show srpType, srpLocation)) - - --- | Truncate a string, with a visual indication that it is truncated. -truncateString :: Int -> String -> String -truncateString n s | length s <= n = s - | otherwise = take (n-1) s ++ "_" - - --- TODO: add something like this, here or in the project planning --- Based on the package location, which packages will be built inplace in the --- build tree vs placed in the store. This has various implications on what we --- can do with the package, e.g. can we run tests, ghci etc. --- --- packageIsLocalToProject :: ProjectPackageLocation -> Bool - - ---------------------------------------------- --- Checking configuration sanity --- - -data BadPerPackageCompilerPaths - = BadPerPackageCompilerPaths [(PackageName, String)] -#if MIN_VERSION_base(4,8,0) - deriving (Show, Typeable) -#else - deriving (Typeable) - -instance Show BadPerPackageCompilerPaths where - show = renderBadPerPackageCompilerPaths -#endif - -instance Exception BadPerPackageCompilerPaths where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadPerPackageCompilerPaths -#endif ---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc - -renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String -renderBadPerPackageCompilerPaths - (BadPerPackageCompilerPaths ((pkgname, progname) : _)) = - "The path to the compiler program (or programs used by the compiler) " - ++ "cannot be specified on a per-package basis in the cabal.project file " - ++ "(i.e. setting the '" ++ progname ++ "-location' for package '" - ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so " - ++ "specify the path in a global 'program-locations' section." - --TODO: [nice to have] better format control so we can pretty-print the - -- offending part of the project file. Currently the line wrapping breaks any - -- formatting. -renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" - --- | The project configuration is not allowed to specify program locations for --- programs used by the compiler as these have to be the same for each set of --- packages. --- --- We cannot check this until we know which programs the compiler uses, which --- in principle is not until we've configured the compiler. --- --- Throws 'BadPerPackageCompilerPaths' --- -checkBadPerPackageCompilerPaths :: [ConfiguredProgram] - -> Map PackageName PackageConfig - -> IO () -checkBadPerPackageCompilerPaths compilerPrograms packagesConfig = - case [ (pkgname, progname) - | let compProgNames = Set.fromList (map programId compilerPrograms) - , (pkgname, pkgconf) <- Map.toList packagesConfig - , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf)) - , progname `Set.member` compProgNames ] of - [] -> return () - ps -> throwIO (BadPerPackageCompilerPaths ps) diff --git a/Distribution/Client/ProjectConfig/Legacy.hs b/Distribution/Client/ProjectConfig/Legacy.hs deleted file mode 100644 --- a/Distribution/Client/ProjectConfig/Legacy.hs +++ /dev/null @@ -1,1479 +0,0 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds #-} - --- | Project configuration, implementation in terms of legacy types. --- -module Distribution.Client.ProjectConfig.Legacy ( - - -- * Project config in terms of legacy types - LegacyProjectConfig, - parseLegacyProjectConfig, - showLegacyProjectConfig, - - -- * Conversion to and from legacy config types - commandLineFlagsToProjectConfig, - convertLegacyProjectConfig, - convertLegacyGlobalConfig, - convertToLegacyProjectConfig, - - -- * Internals, just for tests - parsePackageLocationTokenQ, - renderPackageLocationToken, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Types.Flag (parsecFlagAssignment) - -import Distribution.Client.ProjectConfig.Types -import Distribution.Client.Types.RepoName (RepoName (..), unRepoName) -import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo) -import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..)) -import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) - -import Distribution.Client.Config - ( SavedConfig(..), remoteRepoFields, postProcessRepo ) - -import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..), defaultClientInstallFlags - , clientInstallOptions ) - -import Distribution.Solver.Types.ConstraintSource - -import Distribution.FieldGrammar -import Distribution.Package -import Distribution.Types.SourceRepo (RepoType) -import Distribution.PackageDescription - ( dispFlagAssignment ) -import Distribution.Simple.Compiler - ( OptimisationLevel(..), DebugInfoLevel(..) ) -import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) -import Distribution.Simple.Setup - ( Flag(Flag), toFlag, fromFlagOrDefault - , ConfigFlags(..), configureOptions - , HaddockFlags(..), haddockOptions, defaultHaddockFlags - , TestFlags(..), testOptions', defaultTestFlags - , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags - , programDbPaths', splitArgs - ) -import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) -import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags) -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand - , ConfigExFlags(..), configureExOptions, defaultConfigExFlags - , InstallFlags(..), installOptions, defaultInstallFlags ) -import Distribution.Simple.Program - ( programName, knownPrograms ) -import Distribution.Simple.Program.Db - ( ProgramDb, defaultProgramDb ) -import Distribution.Simple.Utils - ( lowercase ) -import Distribution.Utils.NubList - ( toNubList, fromNubList, overNubList ) -import Distribution.Simple.LocalBuildInfo - ( toPathTemplate, fromPathTemplate ) - -import qualified Distribution.Deprecated.ReadP as Parse -import Distribution.Deprecated.ReadP - ( ReadP, (+++) ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint - ( Doc, ($+$) ) -import qualified Distribution.Deprecated.ParseUtils as ParseUtils -import Distribution.Deprecated.ParseUtils - ( ParseResult(..), PError(..), syntaxError, PWarning(..) - , commaNewLineListFieldParsec, newLineListField, parseTokenQ - , parseHaskellString, showToken - , simpleFieldParsec - ) -import Distribution.Client.ParseUtils -import Distribution.Simple.Command - ( CommandUI(commandOptions), ShowOrParseArgs(..) - , OptionField, option, reqArg' ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint ) -import Distribution.Parsec (ParsecParser) - -import qualified Data.Map as Map - -import Network.URI (URI (..)) - ------------------------------------------------------------------- --- Representing the project config file in terms of legacy types --- - --- | We already have parsers\/pretty-printers for almost all the fields in the --- project config file, but they're in terms of the types used for the command --- line flags for Setup.hs or cabal commands. We don't want to redefine them --- all, at least not yet so for the moment we use the parsers at the old types --- and use conversion functions. --- --- Ultimately if\/when this project-based approach becomes the default then we --- can redefine the parsers directly for the new types. --- -data LegacyProjectConfig = LegacyProjectConfig { - legacyPackages :: [String], - legacyPackagesOptional :: [String], - legacyPackagesRepo :: [SourceRepoList], - legacyPackagesNamed :: [PackageVersionConstraint], - - legacySharedConfig :: LegacySharedConfig, - legacyAllConfig :: LegacyPackageConfig, - legacyLocalConfig :: LegacyPackageConfig, - legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig - } deriving Generic - -instance Monoid LegacyProjectConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup LegacyProjectConfig where - (<>) = gmappend - -data LegacyPackageConfig = LegacyPackageConfig { - legacyConfigureFlags :: ConfigFlags, - legacyInstallPkgFlags :: InstallFlags, - legacyHaddockFlags :: HaddockFlags, - legacyTestFlags :: TestFlags, - legacyBenchmarkFlags :: BenchmarkFlags - } deriving Generic - -instance Monoid LegacyPackageConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup LegacyPackageConfig where - (<>) = gmappend - -data LegacySharedConfig = LegacySharedConfig { - legacyGlobalFlags :: GlobalFlags, - legacyConfigureShFlags :: ConfigFlags, - legacyConfigureExFlags :: ConfigExFlags, - legacyInstallFlags :: InstallFlags, - legacyClientInstallFlags:: ClientInstallFlags, - legacyProjectFlags :: ProjectFlags - } deriving Generic - -instance Monoid LegacySharedConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup LegacySharedConfig where - (<>) = gmappend - - ------------------------------------------------------------------- --- Converting from and to the legacy types --- - --- | Convert configuration from the @cabal configure@ or @cabal build@ command --- line into a 'ProjectConfig' value that can combined with configuration from --- other sources. --- --- At the moment this uses the legacy command line flag types. See --- 'LegacyProjectConfig' for an explanation. --- -commandLineFlagsToProjectConfig :: GlobalFlags - -> NixStyleFlags a - -> ClientInstallFlags - -> ProjectConfig -commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags = - mempty { - projectConfigBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configFlags - installFlags clientInstallFlags - haddockFlags testFlags benchmarkFlags, - projectConfigShared = convertLegacyAllPackageFlags - globalFlags configFlags - configExFlags installFlags projectFlags, - projectConfigLocalPackages = localConfig, - projectConfigAllPackages = allConfig - } - where (localConfig, allConfig) = splitConfig - (convertLegacyPerPackageFlags - configFlags installFlags - haddockFlags testFlags benchmarkFlags) - -- split the package config (from command line arguments) into - -- those applied to all packages and those to local only. - -- - -- for now we will just copy over the ProgramPaths/Args/Extra into - -- the AllPackages. The LocalPackages do not inherit them from - -- AllPackages, and as such need to retain them. - -- - -- The general decision rule for what to put into allConfig - -- into localConfig is the following: - -- - -- - anything that is host/toolchain/env specific should be applied - -- to all packages, as packagesets have to be host/toolchain/env - -- consistent. - -- - anything else should be in the local config and could potentially - -- be lifted into all-packages vial the `package *` cabal.project - -- section. - -- - splitConfig :: PackageConfig -> (PackageConfig, PackageConfig) - splitConfig pc = (pc - , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc - , packageConfigProgramArgs = packageConfigProgramArgs pc - , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc - , packageConfigDocumentation = packageConfigDocumentation pc }) - --- | Convert from the types currently used for the user-wide @~/.cabal/config@ --- file into the 'ProjectConfig' type. --- --- Only a subset of the 'ProjectConfig' can be represented in the user-wide --- config. In particular it does not include packages that are in the project, --- and it also doesn't support package-specific configuration (only --- configuration that applies to all packages). --- -convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig -convertLegacyGlobalConfig - SavedConfig { - savedGlobalFlags = globalFlags, - savedInstallFlags = installFlags, - savedClientInstallFlags= clientInstallFlags, - savedConfigureFlags = configFlags, - savedConfigureExFlags = configExFlags, - savedUserInstallDirs = _, - savedGlobalInstallDirs = _, - savedUploadFlags = _, - savedReportFlags = _, - savedHaddockFlags = haddockFlags, - savedTestFlags = testFlags, - savedBenchmarkFlags = benchmarkFlags, - savedProjectFlags = projectFlags - } = - mempty { - projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configShared, - projectConfigAllPackages = configAllPackages - } - where - --TODO: [code cleanup] eliminate use of default*Flags here and specify the - -- defaults in the various resolve functions in terms of the new types. - configExFlags' = defaultConfigExFlags <> configExFlags - installFlags' = defaultInstallFlags <> installFlags - clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags - haddockFlags' = defaultHaddockFlags <> haddockFlags - testFlags' = defaultTestFlags <> testFlags - benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags - projectFlags' = defaultProjectFlags <> projectFlags - - configAllPackages = convertLegacyPerPackageFlags - configFlags installFlags' - haddockFlags' testFlags' benchmarkFlags' - configShared = convertLegacyAllPackageFlags - globalFlags configFlags - configExFlags' installFlags' projectFlags' - configBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configFlags - installFlags' clientInstallFlags' - haddockFlags' testFlags' benchmarkFlags' - - --- | Convert the project config from the legacy types to the 'ProjectConfig' --- and associated types. See 'LegacyProjectConfig' for an explanation of the --- approach. --- -convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig -convertLegacyProjectConfig - LegacyProjectConfig { - legacyPackages, - legacyPackagesOptional, - legacyPackagesRepo, - legacyPackagesNamed, - legacySharedConfig = LegacySharedConfig globalFlags configShFlags - configExFlags installSharedFlags - clientInstallFlags projectFlags, - legacyAllConfig, - legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags - haddockFlags testFlags benchmarkFlags, - legacySpecificConfig - } = - - ProjectConfig { - projectPackages = legacyPackages, - projectPackagesOptional = legacyPackagesOptional, - projectPackagesRepo = legacyPackagesRepo, - projectPackagesNamed = legacyPackagesNamed, - - projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configPackagesShared, - projectConfigProvenance = mempty, - projectConfigAllPackages = configAllPackages, - projectConfigLocalPackages = configLocalPackages, - projectConfigSpecificPackage = fmap perPackage legacySpecificConfig - } - where - configAllPackages = convertLegacyPerPackageFlags g i h t b - where LegacyPackageConfig g i h t b = legacyAllConfig - configLocalPackages = convertLegacyPerPackageFlags - configFlags installPerPkgFlags haddockFlags - testFlags benchmarkFlags - configPackagesShared= convertLegacyAllPackageFlags - globalFlags (configFlags <> configShFlags) - configExFlags installSharedFlags projectFlags - configBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configShFlags - installSharedFlags clientInstallFlags - haddockFlags testFlags benchmarkFlags - - perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags - perPkgHaddockFlags perPkgTestFlags - perPkgBenchmarkFlags) = - convertLegacyPerPackageFlags - perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags - perPkgTestFlags perPkgBenchmarkFlags - - --- | Helper used by other conversion functions that returns the --- 'ProjectConfigShared' subset of the 'ProjectConfig'. --- -convertLegacyAllPackageFlags - :: GlobalFlags - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> ProjectFlags - -> ProjectConfigShared -convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags = - ProjectConfigShared{..} - where - GlobalFlags { - globalConfigFile = projectConfigConfigFile, - globalRemoteRepos = projectConfigRemoteRepos, - globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, - globalActiveRepos = projectConfigActiveRepos, - globalProgPathExtra = projectConfigProgPathExtra, - globalStoreDir = projectConfigStoreDir - } = globalFlags - - ConfigFlags { - configDistPref = projectConfigDistDir, - configHcFlavor = projectConfigHcFlavor, - configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg - --configProgramPathExtra = projectConfigProgPathExtra DELETE ME - --configInstallDirs = projectConfigInstallDirs, - --configUserInstall = projectConfigUserInstall, - --configPackageDBs = projectConfigPackageDBs, - } = configFlags - - ConfigExFlags { - configCabalVersion = projectConfigCabalVersion, - configExConstraints = projectConfigConstraints, - configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer, - configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy - } = configExFlags - - InstallFlags { - installHaddockIndex = projectConfigHaddockIndex, - --installReinstall = projectConfigReinstall, - --installAvoidReinstalls = projectConfigAvoidReinstalls, - --installOverrideReinstall = projectConfigOverrideReinstall, - installIndexState = projectConfigIndexState, - installMaxBackjumps = projectConfigMaxBackjumps, - --installUpgradeDeps = projectConfigUpgradeDeps, - installReorderGoals = projectConfigReorderGoals, - installCountConflicts = projectConfigCountConflicts, - installFineGrainedConflicts = projectConfigFineGrainedConflicts, - installMinimizeConflictSet = projectConfigMinimizeConflictSet, - installPerComponent = projectConfigPerComponent, - installIndependentGoals = projectConfigIndependentGoals, - --installShadowPkgs = projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags, - installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, - installOnlyConstrained = projectConfigOnlyConstrained - } = installFlags - - ProjectFlags - { flagProjectFileName = projectConfigProjectFile - , flagIgnoreProject = projectConfigIgnoreProject - } = projectFlags - --- | Helper used by other conversion functions that returns the --- 'PackageConfig' subset of the 'ProjectConfig'. --- -convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags - -> TestFlags -> BenchmarkFlags -> PackageConfig -convertLegacyPerPackageFlags configFlags installFlags - haddockFlags testFlags benchmarkFlags = - PackageConfig{..} - where - ConfigFlags { - configProgramPaths, - configProgramArgs, - configProgramPathExtra = packageConfigProgramPathExtra, - configVanillaLib = packageConfigVanillaLib, - configProfLib = packageConfigProfLib, - configSharedLib = packageConfigSharedLib, - configStaticLib = packageConfigStaticLib, - configDynExe = packageConfigDynExe, - configFullyStaticExe = packageConfigFullyStaticExe, - configProfExe = packageConfigProfExe, - configProf = packageConfigProf, - configProfDetail = packageConfigProfDetail, - configProfLibDetail = packageConfigProfLibDetail, - configConfigureArgs = packageConfigConfigureArgs, - configOptimization = packageConfigOptimization, - configProgPrefix = packageConfigProgPrefix, - configProgSuffix = packageConfigProgSuffix, - configGHCiLib = packageConfigGHCiLib, - configSplitSections = packageConfigSplitSections, - configSplitObjs = packageConfigSplitObjs, - configStripExes = packageConfigStripExes, - configStripLibs = packageConfigStripLibs, - configExtraLibDirs = packageConfigExtraLibDirs, - configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, - configExtraIncludeDirs = packageConfigExtraIncludeDirs, - configConfigurationsFlags = packageConfigFlagAssignment, - configTests = packageConfigTests, - configBenchmarks = packageConfigBenchmarks, - configCoverage = coverage, - configLibCoverage = libcoverage, --deprecated - configDebugInfo = packageConfigDebugInfo, - configRelocatable = packageConfigRelocatable - } = configFlags - packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths) - packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs) - - packageConfigCoverage = coverage <> libcoverage - --TODO: defer this merging to the resolve phase - - InstallFlags { - installDocumentation = packageConfigDocumentation, - installRunTests = packageConfigRunTests - } = installFlags - - HaddockFlags { - haddockHoogle = packageConfigHaddockHoogle, - haddockHtml = packageConfigHaddockHtml, - haddockHtmlLocation = packageConfigHaddockHtmlLocation, - haddockForeignLibs = packageConfigHaddockForeignLibs, - haddockForHackage = packageConfigHaddockForHackage, - haddockExecutables = packageConfigHaddockExecutables, - haddockTestSuites = packageConfigHaddockTestSuites, - haddockBenchmarks = packageConfigHaddockBenchmarks, - haddockInternal = packageConfigHaddockInternal, - haddockCss = packageConfigHaddockCss, - haddockLinkedSource = packageConfigHaddockLinkedSource, - haddockQuickJump = packageConfigHaddockQuickJump, - haddockHscolourCss = packageConfigHaddockHscolourCss, - haddockContents = packageConfigHaddockContents - } = haddockFlags - - TestFlags { - testHumanLog = packageConfigTestHumanLog, - testMachineLog = packageConfigTestMachineLog, - testShowDetails = packageConfigTestShowDetails, - testKeepTix = packageConfigTestKeepTix, - testWrapper = packageConfigTestWrapper, - testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, - testOptions = packageConfigTestTestOptions - } = testFlags - - BenchmarkFlags { - benchmarkOptions = packageConfigBenchmarkOptions - } = benchmarkFlags - - --- | Helper used by other conversion functions that returns the --- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'. --- -convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags - -> InstallFlags -> ClientInstallFlags - -> HaddockFlags -> TestFlags - -> BenchmarkFlags - -> ProjectConfigBuildOnly -convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags clientInstallFlags - haddockFlags _ _ = - ProjectConfigBuildOnly{..} - where - projectConfigClientInstallFlags = clientInstallFlags - GlobalFlags { - globalCacheDir = projectConfigCacheDir, - globalLogsDir = projectConfigLogsDir, - globalWorldFile = _, - globalHttpTransport = projectConfigHttpTransport, - globalIgnoreExpiry = projectConfigIgnoreExpiry - } = globalFlags - - ConfigFlags { - configVerbosity = projectConfigVerbosity - } = configFlags - - InstallFlags { - installDryRun = projectConfigDryRun, - installOnly = _, - installOnlyDeps = projectConfigOnlyDeps, - installRootCmd = _, - installSummaryFile = projectConfigSummaryFile, - installLogFile = projectConfigLogFile, - installBuildReports = projectConfigBuildReports, - installReportPlanningFailure = projectConfigReportPlanningFailure, - installSymlinkBinDir = projectConfigSymlinkBinDir, - installOneShot = projectConfigOneShot, - installNumJobs = projectConfigNumJobs, - installKeepGoing = projectConfigKeepGoing, - installOfflineMode = projectConfigOfflineMode - } = installFlags - - HaddockFlags { - haddockKeepTempFiles = projectConfigKeepTempFiles --TODO: this ought to live elsewhere - } = haddockFlags - - -convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig -convertToLegacyProjectConfig - projectConfig@ProjectConfig { - projectPackages, - projectPackagesOptional, - projectPackagesRepo, - projectPackagesNamed, - projectConfigAllPackages, - projectConfigLocalPackages, - projectConfigSpecificPackage - } = - LegacyProjectConfig { - legacyPackages = projectPackages, - legacyPackagesOptional = projectPackagesOptional, - legacyPackagesRepo = projectPackagesRepo, - legacyPackagesNamed = projectPackagesNamed, - legacySharedConfig = convertToLegacySharedConfig projectConfig, - legacyAllConfig = convertToLegacyPerPackageConfig - projectConfigAllPackages, - legacyLocalConfig = convertToLegacyAllPackageConfig projectConfig - <> convertToLegacyPerPackageConfig - projectConfigLocalPackages, - legacySpecificConfig = fmap convertToLegacyPerPackageConfig - projectConfigSpecificPackage - } - -convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig -convertToLegacySharedConfig - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly {..}, - projectConfigShared = ProjectConfigShared {..}, - projectConfigAllPackages = PackageConfig { - packageConfigDocumentation - } - } = - - LegacySharedConfig - { legacyGlobalFlags = globalFlags - , legacyConfigureShFlags = configFlags - , legacyConfigureExFlags = configExFlags - , legacyInstallFlags = installFlags - , legacyClientInstallFlags = projectConfigClientInstallFlags - , legacyProjectFlags = projectFlags - } - where - globalFlags = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty, - globalConfigFile = projectConfigConfigFile, - globalConstraintsFile = mempty, - globalRemoteRepos = projectConfigRemoteRepos, - globalCacheDir = projectConfigCacheDir, - globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, - globalActiveRepos = projectConfigActiveRepos, - globalLogsDir = projectConfigLogsDir, - globalWorldFile = mempty, - globalIgnoreExpiry = projectConfigIgnoreExpiry, - globalHttpTransport = projectConfigHttpTransport, - globalNix = mempty, - globalStoreDir = projectConfigStoreDir, - globalProgPathExtra = projectConfigProgPathExtra - } - - configFlags = mempty { - configVerbosity = projectConfigVerbosity, - configDistPref = projectConfigDistDir - } - - configExFlags = ConfigExFlags { - configCabalVersion = projectConfigCabalVersion, - configExConstraints = projectConfigConstraints, - configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer, - configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy - } - - installFlags = InstallFlags { - installDocumentation = packageConfigDocumentation, - installHaddockIndex = projectConfigHaddockIndex, - installDest = Flag NoCopyDest, - installDryRun = projectConfigDryRun, - installReinstall = mempty, --projectConfigReinstall, - installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls, - installOverrideReinstall = mempty, --projectConfigOverrideReinstall, - installMaxBackjumps = projectConfigMaxBackjumps, - installUpgradeDeps = mempty, --projectConfigUpgradeDeps, - installReorderGoals = projectConfigReorderGoals, - installCountConflicts = projectConfigCountConflicts, - installFineGrainedConflicts = projectConfigFineGrainedConflicts, - installMinimizeConflictSet = projectConfigMinimizeConflictSet, - installIndependentGoals = projectConfigIndependentGoals, - installShadowPkgs = mempty, --projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags, - installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, - installOnlyConstrained = projectConfigOnlyConstrained, - installOnly = mempty, - installOnlyDeps = projectConfigOnlyDeps, - installIndexState = projectConfigIndexState, - installRootCmd = mempty, --no longer supported - installSummaryFile = projectConfigSummaryFile, - installLogFile = projectConfigLogFile, - installBuildReports = projectConfigBuildReports, - installReportPlanningFailure = projectConfigReportPlanningFailure, - installSymlinkBinDir = projectConfigSymlinkBinDir, - installPerComponent = projectConfigPerComponent, - installOneShot = projectConfigOneShot, - installNumJobs = projectConfigNumJobs, - installKeepGoing = projectConfigKeepGoing, - installRunTests = mempty, - installOfflineMode = projectConfigOfflineMode - } - - projectFlags = ProjectFlags - { flagProjectFileName = projectConfigProjectFile - , flagIgnoreProject = projectConfigIgnoreProject - } - - -convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig -convertToLegacyAllPackageConfig - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly {..}, - projectConfigShared = ProjectConfigShared {..} - } = - - LegacyPackageConfig { - legacyConfigureFlags = configFlags, - legacyInstallPkgFlags= mempty, - legacyHaddockFlags = haddockFlags, - legacyTestFlags = mempty, - legacyBenchmarkFlags = mempty - } - where - configFlags = ConfigFlags { - configArgs = mempty, - configPrograms_ = mempty, - configProgramPaths = mempty, - configProgramArgs = mempty, - configProgramPathExtra = mempty, - configHcFlavor = projectConfigHcFlavor, - configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg, - configInstantiateWith = mempty, - configVanillaLib = mempty, - configProfLib = mempty, - configSharedLib = mempty, - configStaticLib = mempty, - configDynExe = mempty, - configFullyStaticExe = mempty, - configProfExe = mempty, - configProf = mempty, - configProfDetail = mempty, - configProfLibDetail = mempty, - configConfigureArgs = mempty, - configOptimization = mempty, - configProgPrefix = mempty, - configProgSuffix = mempty, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configCabalFilePath = mempty, - configVerbosity = mempty, - configUserInstall = mempty, --projectConfigUserInstall, - configPackageDBs = mempty, --projectConfigPackageDBs, - configGHCiLib = mempty, - configSplitSections = mempty, - configSplitObjs = mempty, - configStripExes = mempty, - configStripLibs = mempty, - configExtraLibDirs = mempty, - configExtraFrameworkDirs = mempty, - configConstraints = mempty, - configDependencies = mempty, - configExtraIncludeDirs = mempty, - configDeterministic = mempty, - configIPID = mempty, - configCID = mempty, - configConfigurationsFlags = mempty, - configTests = mempty, - configCoverage = mempty, --TODO: don't merge - configLibCoverage = mempty, --TODO: don't merge - configExactConfiguration = mempty, - configBenchmarks = mempty, - configFlagError = mempty, --TODO: ??? - configRelocatable = mempty, - configDebugInfo = mempty, - configUseResponseFiles = mempty, - configAllowDependingOnPrivateLibs = mempty - } - - haddockFlags = mempty { - haddockKeepTempFiles = projectConfigKeepTempFiles - } - - -convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig -convertToLegacyPerPackageConfig PackageConfig {..} = - LegacyPackageConfig { - legacyConfigureFlags = configFlags, - legacyInstallPkgFlags = installFlags, - legacyHaddockFlags = haddockFlags, - legacyTestFlags = testFlags, - legacyBenchmarkFlags = benchmarkFlags - } - where - configFlags = ConfigFlags { - configArgs = mempty, - configPrograms_ = configPrograms_ mempty, - configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths), - configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs), - configProgramPathExtra = packageConfigProgramPathExtra, - configHcFlavor = mempty, - configHcPath = mempty, - configHcPkg = mempty, - configInstantiateWith = mempty, - configVanillaLib = packageConfigVanillaLib, - configProfLib = packageConfigProfLib, - configSharedLib = packageConfigSharedLib, - configStaticLib = packageConfigStaticLib, - configDynExe = packageConfigDynExe, - configFullyStaticExe = packageConfigFullyStaticExe, - configProfExe = packageConfigProfExe, - configProf = packageConfigProf, - configProfDetail = packageConfigProfDetail, - configProfLibDetail = packageConfigProfLibDetail, - configConfigureArgs = packageConfigConfigureArgs, - configOptimization = packageConfigOptimization, - configProgPrefix = packageConfigProgPrefix, - configProgSuffix = packageConfigProgSuffix, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configCabalFilePath = mempty, - configVerbosity = mempty, - configUserInstall = mempty, - configPackageDBs = mempty, - configGHCiLib = packageConfigGHCiLib, - configSplitSections = packageConfigSplitSections, - configSplitObjs = packageConfigSplitObjs, - configStripExes = packageConfigStripExes, - configStripLibs = packageConfigStripLibs, - configExtraLibDirs = packageConfigExtraLibDirs, - configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, - configConstraints = mempty, - configDependencies = mempty, - configExtraIncludeDirs = packageConfigExtraIncludeDirs, - configIPID = mempty, - configCID = mempty, - configDeterministic = mempty, - configConfigurationsFlags = packageConfigFlagAssignment, - configTests = packageConfigTests, - configCoverage = packageConfigCoverage, --TODO: don't merge - configLibCoverage = packageConfigCoverage, --TODO: don't merge - configExactConfiguration = mempty, - configBenchmarks = packageConfigBenchmarks, - configFlagError = mempty, --TODO: ??? - configRelocatable = packageConfigRelocatable, - configDebugInfo = packageConfigDebugInfo, - configUseResponseFiles = mempty, - configAllowDependingOnPrivateLibs = mempty - } - - installFlags = mempty { - installDocumentation = packageConfigDocumentation, - installRunTests = packageConfigRunTests - } - - haddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = mempty, - haddockHoogle = packageConfigHaddockHoogle, - haddockHtml = packageConfigHaddockHtml, - haddockHtmlLocation = packageConfigHaddockHtmlLocation, - haddockForHackage = packageConfigHaddockForHackage, - haddockForeignLibs = packageConfigHaddockForeignLibs, - haddockExecutables = packageConfigHaddockExecutables, - haddockTestSuites = packageConfigHaddockTestSuites, - haddockBenchmarks = packageConfigHaddockBenchmarks, - haddockInternal = packageConfigHaddockInternal, - haddockCss = packageConfigHaddockCss, - haddockLinkedSource = packageConfigHaddockLinkedSource, - haddockQuickJump = packageConfigHaddockQuickJump, - haddockHscolourCss = packageConfigHaddockHscolourCss, - haddockContents = packageConfigHaddockContents, - haddockDistPref = mempty, - haddockKeepTempFiles = mempty, - haddockVerbosity = mempty, - haddockCabalFilePath = mempty, - haddockArgs = mempty - } - - testFlags = TestFlags { - testDistPref = mempty, - testVerbosity = mempty, - testHumanLog = packageConfigTestHumanLog, - testMachineLog = packageConfigTestMachineLog, - testShowDetails = packageConfigTestShowDetails, - testKeepTix = packageConfigTestKeepTix, - testWrapper = packageConfigTestWrapper, - testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, - testOptions = packageConfigTestTestOptions - } - - benchmarkFlags = BenchmarkFlags { - benchmarkDistPref = mempty, - benchmarkVerbosity = mempty, - benchmarkOptions = packageConfigBenchmarkOptions - } - ------------------------------------------------- --- Parsing and showing the project config file --- - -parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig -parseLegacyProjectConfig = - parseConfig legacyProjectConfigFieldDescrs - legacyPackageConfigSectionDescrs - legacyPackageConfigFGSectionDescrs - mempty - -showLegacyProjectConfig :: LegacyProjectConfig -> String -showLegacyProjectConfig config = - Disp.render $ - showConfig legacyProjectConfigFieldDescrs - legacyPackageConfigSectionDescrs - legacyPackageConfigFGSectionDescrs - config - $+$ - Disp.text "" - - -legacyProjectConfigFieldDescrs :: [FieldDescr LegacyProjectConfig] -legacyProjectConfigFieldDescrs = - - [ newLineListField "packages" - (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ - legacyPackages - (\v flags -> flags { legacyPackages = v }) - , newLineListField "optional-packages" - (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ - legacyPackagesOptional - (\v flags -> flags { legacyPackagesOptional = v }) - , commaNewLineListFieldParsec "extra-packages" - pretty parsec - legacyPackagesNamed - (\v flags -> flags { legacyPackagesNamed = v }) - ] - - ++ map (liftField - legacySharedConfig - (\flags conf -> conf { legacySharedConfig = flags })) - legacySharedConfigFieldDescrs - - ++ map (liftField - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags })) - legacyPackageConfigFieldDescrs - --- | This is a bit tricky since it has to cover globs which have embedded @,@ --- chars. But we don't just want to parse strictly as a glob since we want to --- allow http urls which don't parse as globs, and possibly some --- system-dependent file paths. So we parse fairly liberally as a token, but --- we allow @,@ inside matched @{}@ braces. --- -parsePackageLocationTokenQ :: ReadP r String -parsePackageLocationTokenQ = parseHaskellString - Parse.<++ parsePackageLocationToken - where - parsePackageLocationToken :: ReadP r String - parsePackageLocationToken = fmap fst (Parse.gather outerTerm) - where - outerTerm = alternateEither1 outerToken (braces innerTerm) - innerTerm = alternateEither innerToken (braces innerTerm) - outerToken = Parse.munch1 outerChar >> return () - innerToken = Parse.munch1 innerChar >> return () - outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',') - innerChar c = not (isSpace c || c == '{' || c == '}') - braces = Parse.between (Parse.char '{') (Parse.char '}') - - alternateEither, alternateEither1, - alternatePQs, alternate1PQs, alternateQsP, alternate1QsP - :: ReadP r () -> ReadP r () -> ReadP r () - - alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p - alternateEither p q = alternateEither1 p q +++ return () - alternate1PQs p q = p >> alternateQsP q p - alternatePQs p q = alternate1PQs p q +++ return () - alternate1QsP q p = Parse.many1 q >> alternatePQs p q - alternateQsP q p = alternate1QsP q p +++ return () - -renderPackageLocationToken :: String -> String -renderPackageLocationToken s | needsQuoting = show s - | otherwise = s - where - needsQuoting = not (ok 0 s) - || s == "." -- . on its own on a line has special meaning - || take 2 s == "--" -- on its own line is comment syntax - --TODO: [code cleanup] these "." and "--" escaping issues - -- ought to be dealt with systematically in ParseUtils. - ok :: Int -> String -> Bool - ok n [] = n == 0 - ok _ ('"':_) = False - ok n ('{':cs) = ok (n+1) cs - ok n ('}':cs) = ok (n-1) cs - ok n (',':cs) = (n > 0) && ok n cs - ok _ (c:_) - | isSpace c = False - ok n (_ :cs) = ok n cs - - -legacySharedConfigFieldDescrs :: [FieldDescr LegacySharedConfig] -legacySharedConfigFieldDescrs = concat - [ liftFields - legacyGlobalFlags - (\flags conf -> conf { legacyGlobalFlags = flags }) - . addFields - [ newLineListField "extra-prog-path-shared-only" - showTokenQ parseTokenQ - (fromNubList . globalProgPathExtra) - (\v conf -> conf { globalProgPathExtra = toNubList v }) - ] - . filterFields - [ "remote-repo-cache" - , "logs-dir", "store-dir", "ignore-expiry", "http-transport" - , "active-repositories" - ] - . commandOptionsToFields - $ commandOptions (globalCommand []) ParseArgs - - , liftFields - legacyConfigureShFlags - (\flags conf -> conf { legacyConfigureShFlags = flags }) - . filterFields ["verbose", "builddir" ] - . commandOptionsToFields - $ configureOptions ParseArgs - - , liftFields - legacyConfigureExFlags - (\flags conf -> conf { legacyConfigureExFlags = flags }) - . addFields - [ commaNewLineListFieldParsec "constraints" - (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec) - configExConstraints (\v conf -> conf { configExConstraints = v }) - - , commaNewLineListFieldParsec "preferences" - pretty parsec - configPreferences (\v conf -> conf { configPreferences = v }) - - , monoidFieldParsec "allow-older" - (maybe mempty pretty) (fmap Just parsec) - (fmap unAllowOlder . configAllowOlder) - (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) - - , monoidFieldParsec "allow-newer" - (maybe mempty pretty) (fmap Just parsec) - (fmap unAllowNewer . configAllowNewer) - (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) - ] - . filterFields - [ "cabal-lib-version", "solver", "write-ghc-environment-files" - -- not "constraint" or "preference", we use our own plural ones above - ] - . commandOptionsToFields - $ configureExOptions ParseArgs constraintSrc - - , liftFields - legacyInstallFlags - (\flags conf -> conf { legacyInstallFlags = flags }) - . addFields - [ newLineListField "build-summary" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - (fromNubList . installSummaryFile) - (\v conf -> conf { installSummaryFile = toNubList v }) - ] - . filterFields - [ "doc-index-file" - , "root-cmd", "symlink-bindir" - , "build-log" - , "remote-build-reporting", "report-planning-failure" - , "one-shot", "jobs", "keep-going", "offline", "per-component" - -- solver flags: - , "max-backjumps", "reorder-goals", "count-conflicts" - , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals" - , "strong-flags" , "allow-boot-library-installs" - , "reject-unconstrained-dependencies", "index-state" - ] - . commandOptionsToFields - $ installOptions ParseArgs - - , liftFields - legacyClientInstallFlags - (\flags conf -> conf { legacyClientInstallFlags = flags }) - . commandOptionsToFields - $ clientInstallOptions ParseArgs - - , liftFields - legacyProjectFlags - (\flags conf -> conf { legacyProjectFlags = flags }) - . commandOptionsToFields - $ projectFlagsOptions ParseArgs - - ] - where - constraintSrc = ConstraintSourceProjectConfig "TODO" -- TODO: is a filepath - - -legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] -legacyPackageConfigFieldDescrs = - ( liftFields - legacyConfigureFlags - (\flags conf -> conf { legacyConfigureFlags = flags }) - . addFields - [ newLineListField "extra-include-dirs" - showTokenQ parseTokenQ - configExtraIncludeDirs - (\v conf -> conf { configExtraIncludeDirs = v }) - , newLineListField "extra-lib-dirs" - showTokenQ parseTokenQ - configExtraLibDirs - (\v conf -> conf { configExtraLibDirs = v }) - , newLineListField "extra-framework-dirs" - showTokenQ parseTokenQ - configExtraFrameworkDirs - (\v conf -> conf { configExtraFrameworkDirs = v }) - , newLineListField "extra-prog-path" - showTokenQ parseTokenQ - (fromNubList . configProgramPathExtra) - (\v conf -> conf { configProgramPathExtra = toNubList v }) - , newLineListField "configure-options" - showTokenQ parseTokenQ - configConfigureArgs - (\v conf -> conf { configConfigureArgs = v }) - , simpleFieldParsec "flags" - dispFlagAssignment parsecFlagAssignment - configConfigurationsFlags - (\v conf -> conf { configConfigurationsFlags = v }) - ] - . filterFields - [ "with-compiler", "with-hc-pkg" - , "program-prefix", "program-suffix" - , "library-vanilla", "library-profiling" - , "shared", "static", "executable-dynamic", "executable-static" - , "profiling", "executable-profiling" - , "profiling-detail", "library-profiling-detail" - , "library-for-ghci", "split-objs", "split-sections" - , "executable-stripping", "library-stripping" - , "tests", "benchmarks" - , "coverage", "library-coverage" - , "relocatable" - -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs" - -- or "extra-prog-path". We use corrected ones above that parse - -- as list fields. - ] - . commandOptionsToFields - ) (configureOptions ParseArgs) - ++ - liftFields - legacyConfigureFlags - (\flags conf -> conf { legacyConfigureFlags = flags }) - [ overrideFieldCompiler - , overrideFieldOptimization - , overrideFieldDebugInfo - ] - ++ - ( liftFields - legacyInstallPkgFlags - (\flags conf -> conf { legacyInstallPkgFlags = flags }) - . filterFields - [ "documentation", "run-tests" - ] - . commandOptionsToFields - ) (installOptions ParseArgs) - ++ - ( liftFields - legacyHaddockFlags - (\flags conf -> conf { legacyHaddockFlags = flags }) - . mapFieldNames - ("haddock-"++) - . addFields - [ simpleFieldParsec "for-hackage" - -- TODO: turn this into a library function - (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty) - haddockForHackage (\v conf -> conf { haddockForHackage = v }) - ] - . filterFields - [ "hoogle", "html", "html-location" - , "foreign-libraries" - , "executables", "tests", "benchmarks", "all", "internal", "css" - , "hyperlink-source", "quickjump", "hscolour-css" - , "contents-location", "keep-temp-files" - ] - . commandOptionsToFields - ) (haddockOptions ParseArgs) - ++ - ( liftFields - legacyTestFlags - (\flags conf -> conf { legacyTestFlags = flags }) - . mapFieldNames - prefixTest - . addFields - [ newLineListField "test-options" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - testOptions - (\v conf -> conf { testOptions = v }) - ] - . filterFields - [ "log", "machine-log", "show-details", "keep-tix-files" - , "fail-when-no-test-suites", "test-wrapper" ] - . commandOptionsToFields - ) (testOptions' ParseArgs) - ++ - ( liftFields - legacyBenchmarkFlags - (\flags conf -> conf { legacyBenchmarkFlags = flags }) - . addFields - [ newLineListField "benchmark-options" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - benchmarkOptions - (\v conf -> conf { benchmarkOptions = v }) - ] - . filterFields - [] - . commandOptionsToFields - ) (benchmarkOptions' ParseArgs) - - - where - overrideFieldCompiler = - simpleFieldParsec "compiler" - (fromFlagOrDefault Disp.empty . fmap pretty) - (toFlag <$> parsec <|> pure mempty) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - - - -- TODO: [code cleanup] The following is a hack. The "optimization" and - -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that. - -- Instead of a hand-written parser and printer, we should handle this case - -- properly in the library. - - overrideFieldOptimization = - liftField configOptimization - (\v flags -> flags { configOptimization = v }) $ - let name = "optimization" in - FieldDescr name - (\f -> case f of - Flag NoOptimisation -> Disp.text "False" - Flag NormalOptimisation -> Disp.text "True" - Flag MaximumOptimisation -> Disp.text "2" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoOptimisation) - | str == "True" -> ParseOk [] (Flag NormalOptimisation) - | str == "0" -> ParseOk [] (Flag NoOptimisation) - | str == "1" -> ParseOk [] (Flag NormalOptimisation) - | str == "2" -> ParseOk [] (Flag MaximumOptimisation) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") - - overrideFieldDebugInfo = - liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ - let name = "debug-info" in - FieldDescr name - (\f -> case f of - Flag NoDebugInfo -> Disp.text "False" - Flag MinimalDebugInfo -> Disp.text "1" - Flag NormalDebugInfo -> Disp.text "True" - Flag MaximalDebugInfo -> Disp.text "3" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) - | str == "True" -> ParseOk [] (Flag NormalDebugInfo) - | str == "0" -> ParseOk [] (Flag NoDebugInfo) - | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) - | str == "2" -> ParseOk [] (Flag NormalDebugInfo) - | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") - - prefixTest name | "test-" `isPrefixOf` name = name - | otherwise = "test-" ++ name - - -legacyPackageConfigFGSectionDescrs - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType), c (List NoCommaFSep FilePathNT String) - ) - => [FGSectionDescr g LegacyProjectConfig] -legacyPackageConfigFGSectionDescrs = - [ packageRepoSectionDescr - ] - -legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] -legacyPackageConfigSectionDescrs = - [ packageSpecificOptionsSectionDescr - , liftSection - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags }) - programOptionsSectionDescr - , liftSection - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags }) - programLocationsSectionDescr - , liftSection - legacySharedConfig - (\flags conf -> conf { legacySharedConfig = flags }) $ - liftSection - legacyGlobalFlags - (\flags conf -> conf { legacyGlobalFlags = flags }) - remoteRepoSectionDescr - ] - -packageRepoSectionDescr - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType), c (List NoCommaFSep FilePathNT String) - ) - => FGSectionDescr g LegacyProjectConfig -packageRepoSectionDescr = FGSectionDescr - { fgSectionName = "source-repository-package" - , fgSectionGrammar = sourceRepositoryPackageGrammar - , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo - , fgSectionSet = - \lineno unused pkgrepo projconf -> do - unless (null unused) $ - syntaxError lineno "the section 'source-repository-package' takes no arguments" - return projconf { - legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo] - } - } - --- | The definitions of all the fields that can appear in the @package pkgfoo@ --- and @package *@ sections of the @cabal.project@-format files. --- -packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig] -packageSpecificOptionsFieldDescrs = - legacyPackageConfigFieldDescrs - ++ programOptionsFieldDescrs - (configProgramArgs . legacyConfigureFlags) - (\args pkgconf -> pkgconf { - legacyConfigureFlags = (legacyConfigureFlags pkgconf) { - configProgramArgs = args - } - } - ) - ++ liftFields - legacyConfigureFlags - (\flags pkgconf -> pkgconf { - legacyConfigureFlags = flags - } - ) - programLocationsFieldDescrs - --- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format --- files. This section is per-package name. The special package @*@ applies to all --- packages used anywhere by the project, locally or as dependencies. --- -packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig -packageSpecificOptionsSectionDescr = - SectionDescr { - sectionName = "package", - sectionFields = packageSpecificOptionsFieldDescrs, - sectionSubsections = [], - sectionGet = \projconf -> - [ (prettyShow pkgname, pkgconf) - | (pkgname, pkgconf) <- - Map.toList . getMapMappend - . legacySpecificConfig $ projconf ] - ++ [ ("*", legacyAllConfig projconf) ], - sectionSet = - \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of - "*" -> return projconf { - legacyAllConfig = legacyAllConfig projconf <> pkgconf - } - _ -> do - pkgname <- case simpleParsec pkgnamestr of - Just pkgname -> return pkgname - Nothing -> syntaxError lineno $ - "a 'package' section requires a package name " - ++ "as an argument" - return projconf { - legacySpecificConfig = - MapMappend $ - Map.insertWith mappend pkgname pkgconf - (getMapMappend $ legacySpecificConfig projconf) - }, - sectionEmpty = mempty - } - -programOptionsFieldDescrs :: (a -> [(String, [String])]) - -> ([(String, [String])] -> a -> a) - -> [FieldDescr a] -programOptionsFieldDescrs get' set = - commandOptionsToFields - $ programDbOptions - defaultProgramDb - ParseArgs get' set - -programOptionsSectionDescr :: SectionDescr LegacyPackageConfig -programOptionsSectionDescr = - SectionDescr { - sectionName = "program-options", - sectionFields = programOptionsFieldDescrs - configProgramArgs - (\args conf -> conf { configProgramArgs = args }), - sectionSubsections = [], - sectionGet = (\x->[("", x)]) - . legacyConfigureFlags, - sectionSet = - \lineno unused confflags pkgconf -> do - unless (null unused) $ - syntaxError lineno "the section 'program-options' takes no arguments" - return pkgconf { - legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags - }, - sectionEmpty = mempty - } - -programLocationsFieldDescrs :: [FieldDescr ConfigFlags] -programLocationsFieldDescrs = - commandOptionsToFields - $ programDbPaths' - (++ "-location") - defaultProgramDb - ParseArgs - configProgramPaths - (\paths conf -> conf { configProgramPaths = paths }) - -programLocationsSectionDescr :: SectionDescr LegacyPackageConfig -programLocationsSectionDescr = - SectionDescr { - sectionName = "program-locations", - sectionFields = programLocationsFieldDescrs, - sectionSubsections = [], - sectionGet = (\x->[("", x)]) - . legacyConfigureFlags, - sectionSet = - \lineno unused confflags pkgconf -> do - unless (null unused) $ - syntaxError lineno "the section 'program-locations' takes no arguments" - return pkgconf { - legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags - }, - sectionEmpty = mempty - } - - --- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ --- 'OptionField'. -programDbOptions - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programDbOptions progDb showOrParseArgs get' set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG"] - ParseArgs -> map (programOptions . programName . fst) - (knownPrograms progDb) - where - programOptions prog = - option "" [prog ++ "-options"] - ("give extra options to " ++ prog) - get' set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) - (\progArgs -> [ joinsArgs args - | (prog', args) <- progArgs, prog==prog' ])) - - - joinsArgs = unwords . map escape - escape arg | any isSpace arg = "\"" ++ arg ++ "\"" - | otherwise = arg - - --- The implementation is slight hack: we parse all as remote repository --- but if the url schema is file+noindex, we switch to local. -remoteRepoSectionDescr :: SectionDescr GlobalFlags -remoteRepoSectionDescr = SectionDescr - { sectionName = "repository" - , sectionEmpty = emptyRemoteRepo (RepoName "") - , sectionFields = remoteRepoFields - , sectionSubsections = [] - , sectionGet = getS - , sectionSet = setS - } - where - getS :: GlobalFlags -> [(String, RemoteRepo)] - getS gf = - map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) - ++ - map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) - - setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags - setS lineno reponame repo0 conf = do - repo1 <- postProcessRepo lineno reponame repo0 - case repo1 of - Left repo -> return conf - { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf) - } - Right repo -> return conf - { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) - } - - localToRemote :: LocalRepo -> RemoteRepo - localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name) - { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "") - } - -------------------------------- --- Local field utils --- - --- | Parser combinator for simple fields which uses the field type's --- 'Monoid' instance for combining multiple occurrences of the field. -monoidFieldParsec - :: Monoid a => String -> (a -> Doc) -> ParsecParser a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -monoidFieldParsec name showF readF get' set = - liftField get' set' $ ParseUtils.fieldParsec name showF readF - where - set' xs b = set (get' b `mappend` xs) b - - ---TODO: [code cleanup] local redefinition that should replace the version in --- D.ParseUtils called showFilePath. This version escapes "." and "--" which --- otherwise are special syntax. -showTokenQ :: String -> Doc -showTokenQ "" = Disp.empty -showTokenQ x@('-':'-':_) = Disp.text (show x) -showTokenQ x@('.':[]) = Disp.text (show x) -showTokenQ x = showToken x - - --- Handy util -addFields :: [FieldDescr a] - -> ([FieldDescr a] -> [FieldDescr a]) -addFields = (++) diff --git a/Distribution/Client/ProjectConfig/Types.hs b/Distribution/Client/ProjectConfig/Types.hs deleted file mode 100644 --- a/Distribution/Client/ProjectConfig/Types.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} - --- | Handling project configuration, types. --- -module Distribution.Client.ProjectConfig.Types ( - - -- * Types for project config - ProjectConfig(..), - ProjectConfigBuildOnly(..), - ProjectConfigShared(..), - ProjectConfigProvenance(..), - PackageConfig(..), - - -- * Resolving configuration - SolverSettings(..), - BuildTimeSettings(..), - - -- * Extra useful Monoids - MapLast(..), - MapMappend(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo ) -import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) ) -import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy ) -import Distribution.Client.Dependency.Types - ( PreSolver ) -import Distribution.Client.Targets - ( UserConstraint ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Types.SourceRepo (SourceRepoList) - -import Distribution.Client.IndexUtils.IndexState - ( TotalIndexState ) -import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) - -import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..) ) - -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.ConstraintSource - -import Distribution.Package - ( PackageName, PackageId, UnitId ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint ) -import Distribution.Version - ( Version ) -import Distribution.System - ( Platform ) -import Distribution.PackageDescription - ( FlagAssignment ) -import Distribution.Simple.Compiler - ( Compiler, CompilerFlavor - , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) -import Distribution.Simple.Setup - ( Flag, HaddockTarget(..), TestShowDetails(..) ) -import Distribution.Simple.InstallDirs - ( PathTemplate ) -import Distribution.Utils.NubList - ( NubList ) - -import qualified Data.Map as Map - -------------------------------- --- Project config types --- - --- | This type corresponds directly to what can be written in the --- @cabal.project@ file. Other sources of configuration can also be injected --- into this type, such as the user-wide @~/.cabal/config@ file and the --- command line of @cabal configure@ or @cabal build@. --- --- Since it corresponds to the external project file it is an instance of --- 'Monoid' and all the fields can be empty. This also means there has to --- be a step where we resolve configuration. At a minimum resolving means --- applying defaults but it can also mean merging information from multiple --- sources. For example for package-specific configuration the project file --- can specify configuration that applies to all local packages, and then --- additional configuration for a specific package. --- --- Future directions: multiple profiles, conditionals. If we add these --- features then the gap between configuration as written in the config file --- and resolved settings we actually use will become even bigger. --- -data ProjectConfig - = ProjectConfig { - - -- | Packages in this project, including local dirs, local .cabal files - -- local and remote tarballs. When these are file globs, they must - -- match at least one package. - projectPackages :: [String], - - -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that - -- file globs are allowed to match nothing. The primary use case for - -- this is to be able to say @optional-packages: */@ to automagically - -- pick up deps that we unpack locally without erroring when - -- there aren't any. - projectPackagesOptional :: [String], - - -- | Packages in this project from remote source repositories. - projectPackagesRepo :: [SourceRepoList], - - -- | Packages in this project from hackage repositories. - projectPackagesNamed :: [PackageVersionConstraint], - - -- See respective types for an explanation of what these - -- values are about: - projectConfigBuildOnly :: ProjectConfigBuildOnly, - projectConfigShared :: ProjectConfigShared, - projectConfigProvenance :: Set ProjectConfigProvenance, - - -- | Configuration to be applied to *all* packages, - -- whether named in `cabal.project` or not. - projectConfigAllPackages :: PackageConfig, - - -- | Configuration to be applied to *local* packages; i.e., - -- any packages which are explicitly named in `cabal.project`. - projectConfigLocalPackages :: PackageConfig, - projectConfigSpecificPackage :: MapMappend PackageName PackageConfig - } - deriving (Eq, Show, Generic, Typeable) - --- | That part of the project configuration that only affects /how/ we build --- and not the /value/ of the things we build. This means this information --- does not need to be tracked for changes since it does not affect the --- outcome. --- -data ProjectConfigBuildOnly - = ProjectConfigBuildOnly { - projectConfigVerbosity :: Flag Verbosity, - projectConfigDryRun :: Flag Bool, - projectConfigOnlyDeps :: Flag Bool, - projectConfigSummaryFile :: NubList PathTemplate, - projectConfigLogFile :: Flag PathTemplate, - projectConfigBuildReports :: Flag ReportLevel, - projectConfigReportPlanningFailure :: Flag Bool, - projectConfigSymlinkBinDir :: Flag FilePath, - projectConfigOneShot :: Flag Bool, - projectConfigNumJobs :: Flag (Maybe Int), - projectConfigKeepGoing :: Flag Bool, - projectConfigOfflineMode :: Flag Bool, - projectConfigKeepTempFiles :: Flag Bool, - projectConfigHttpTransport :: Flag String, - projectConfigIgnoreExpiry :: Flag Bool, - projectConfigCacheDir :: Flag FilePath, - projectConfigLogsDir :: Flag FilePath, - projectConfigClientInstallFlags :: ClientInstallFlags - } - deriving (Eq, Show, Generic) - - --- | Project configuration that is shared between all packages in the project. --- In particular this includes configuration that affects the solver. --- -data ProjectConfigShared - = ProjectConfigShared { - projectConfigDistDir :: Flag FilePath, - projectConfigConfigFile :: Flag FilePath, - projectConfigProjectFile :: Flag FilePath, - projectConfigIgnoreProject :: Flag Bool, - projectConfigHcFlavor :: Flag CompilerFlavor, - projectConfigHcPath :: Flag FilePath, - projectConfigHcPkg :: Flag FilePath, - projectConfigHaddockIndex :: Flag PathTemplate, - - -- Things that only make sense for manual mode, not --local mode - -- too much control! - --projectConfigUserInstall :: Flag Bool, - --projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), - --TODO: [required eventually] decide what to do with InstallDirs - -- currently we don't allow it to be specified in the config file - --projectConfigPackageDBs :: [Maybe PackageDB], - - -- configuration used both by the solver and other phases - projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. - projectConfigLocalNoIndexRepos :: NubList LocalRepo, - projectConfigActiveRepos :: Flag ActiveRepos, - projectConfigIndexState :: Flag TotalIndexState, - projectConfigStoreDir :: Flag FilePath, - - -- solver configuration - projectConfigConstraints :: [(UserConstraint, ConstraintSource)], - projectConfigPreferences :: [PackageVersionConstraint], - projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused - projectConfigSolver :: Flag PreSolver, - projectConfigAllowOlder :: Maybe AllowOlder, - projectConfigAllowNewer :: Maybe AllowNewer, - projectConfigWriteGhcEnvironmentFilesPolicy - :: Flag WriteGhcEnvironmentFilesPolicy, - projectConfigMaxBackjumps :: Flag Int, - projectConfigReorderGoals :: Flag ReorderGoals, - projectConfigCountConflicts :: Flag CountConflicts, - projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, - projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, - projectConfigStrongFlags :: Flag StrongFlags, - projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, - projectConfigOnlyConstrained :: Flag OnlyConstrained, - projectConfigPerComponent :: Flag Bool, - projectConfigIndependentGoals :: Flag IndependentGoals, - - projectConfigProgPathExtra :: NubList FilePath - - -- More things that only make sense for manual mode, not --local mode - -- too much control! - --projectConfigShadowPkgs :: Flag Bool, - --projectConfigReinstall :: Flag Bool, - --projectConfigAvoidReinstalls :: Flag Bool, - --projectConfigOverrideReinstall :: Flag Bool, - --projectConfigUpgradeDeps :: Flag Bool - } - deriving (Eq, Show, Generic) - - --- | Specifies the provenance of project configuration, whether defaults were --- used or if the configuration was read from an explicit file path. -data ProjectConfigProvenance - - -- | The configuration is implicit due to no explicit configuration - -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig' - -- for how implicit configuration is determined. - = Implicit - - -- | The path the project configuration was explicitly read from. - -- | The configuration was explicitly read from the specified 'FilePath'. - | Explicit FilePath - deriving (Eq, Ord, Show, Generic) - - --- | Project configuration that is specific to each package, that is where we --- can in principle have different values for different packages in the same --- project. --- -data PackageConfig - = PackageConfig { - packageConfigProgramPaths :: MapLast String FilePath, - packageConfigProgramArgs :: MapMappend String [String], - packageConfigProgramPathExtra :: NubList FilePath, - packageConfigFlagAssignment :: FlagAssignment, - packageConfigVanillaLib :: Flag Bool, - packageConfigSharedLib :: Flag Bool, - packageConfigStaticLib :: Flag Bool, - packageConfigDynExe :: Flag Bool, - packageConfigFullyStaticExe :: Flag Bool, - packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out - packageConfigProfLib :: Flag Bool, -- this duplication - packageConfigProfExe :: Flag Bool, -- and consistency - packageConfigProfDetail :: Flag ProfDetailLevel, - packageConfigProfLibDetail :: Flag ProfDetailLevel, - packageConfigConfigureArgs :: [String], - packageConfigOptimization :: Flag OptimisationLevel, - packageConfigProgPrefix :: Flag PathTemplate, - packageConfigProgSuffix :: Flag PathTemplate, - packageConfigExtraLibDirs :: [FilePath], - packageConfigExtraFrameworkDirs :: [FilePath], - packageConfigExtraIncludeDirs :: [FilePath], - packageConfigGHCiLib :: Flag Bool, - packageConfigSplitSections :: Flag Bool, - packageConfigSplitObjs :: Flag Bool, - packageConfigStripExes :: Flag Bool, - packageConfigStripLibs :: Flag Bool, - packageConfigTests :: Flag Bool, - packageConfigBenchmarks :: Flag Bool, - packageConfigCoverage :: Flag Bool, - packageConfigRelocatable :: Flag Bool, - packageConfigDebugInfo :: Flag DebugInfoLevel, - packageConfigRunTests :: Flag Bool, --TODO: [required eventually] use this - packageConfigDocumentation :: Flag Bool, --TODO: [required eventually] use this - -- Haddock options - packageConfigHaddockHoogle :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHtml :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this - packageConfigHaddockForeignLibs :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockExecutables :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockTestSuites :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockBenchmarks :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockInternal :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this - packageConfigHaddockForHackage :: Flag HaddockTarget, - -- Test options - packageConfigTestHumanLog :: Flag PathTemplate, - packageConfigTestMachineLog :: Flag PathTemplate, - packageConfigTestShowDetails :: Flag TestShowDetails, - packageConfigTestKeepTix :: Flag Bool, - packageConfigTestWrapper :: Flag FilePath, - packageConfigTestFailWhenNoTestSuites :: Flag Bool, - packageConfigTestTestOptions :: [PathTemplate], - -- Benchmark options - packageConfigBenchmarkOptions :: [PathTemplate] - } - deriving (Eq, Show, Generic) - -instance Binary ProjectConfig -instance Binary ProjectConfigBuildOnly -instance Binary ProjectConfigShared -instance Binary ProjectConfigProvenance -instance Binary PackageConfig - -instance Structured ProjectConfig -instance Structured ProjectConfigBuildOnly -instance Structured ProjectConfigShared -instance Structured ProjectConfigProvenance -instance Structured PackageConfig - --- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes --- the last value rather than the first value for overlapping keys. -newtype MapLast k v = MapLast { getMapLast :: Map k v } - deriving (Eq, Show, Functor, Generic, Binary, Typeable) - -instance (Structured k, Structured v) => Structured (MapLast k v) - -instance Ord k => Monoid (MapLast k v) where - mempty = MapLast Map.empty - mappend = (<>) - -instance Ord k => Semigroup (MapLast k v) where - MapLast a <> MapLast b = MapLast $ Map.union b a - -- rather than Map.union which is the normal Map monoid instance - - --- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that --- 'mappend's values of overlapping keys rather than taking the first. -newtype MapMappend k v = MapMappend { getMapMappend :: Map k v } - deriving (Eq, Show, Functor, Generic, Binary, Typeable) - -instance (Structured k, Structured v) => Structured (MapMappend k v) - -instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where - mempty = MapMappend Map.empty - mappend = (<>) - -instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where - MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b) - -- rather than Map.union which is the normal Map monoid instance - - -instance Monoid ProjectConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup ProjectConfig where - (<>) = gmappend - - -instance Monoid ProjectConfigBuildOnly where - mempty = gmempty - mappend = (<>) - -instance Semigroup ProjectConfigBuildOnly where - (<>) = gmappend - - -instance Monoid ProjectConfigShared where - mempty = gmempty - mappend = (<>) - -instance Semigroup ProjectConfigShared where - (<>) = gmappend - - -instance Monoid PackageConfig where - mempty = gmempty - mappend = (<>) - -instance Semigroup PackageConfig where - (<>) = gmappend - ----------------------------------------- --- Resolving configuration to settings --- - --- | Resolved configuration for the solver. The idea is that this is easier to --- use than the raw configuration because in the raw configuration everything --- is optional (monoidial). In the 'BuildTimeSettings' every field is filled --- in, if only with the defaults. --- --- Use 'resolveSolverSettings' to make one from the project config (by --- applying defaults etc). --- -data SolverSettings - = SolverSettings { - solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. - solverSettingLocalNoIndexRepos :: [LocalRepo], - solverSettingConstraints :: [(UserConstraint, ConstraintSource)], - solverSettingPreferences :: [PackageVersionConstraint], - solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages - solverSettingFlagAssignments :: Map PackageName FlagAssignment, - solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused - solverSettingSolver :: PreSolver, - solverSettingAllowOlder :: AllowOlder, - solverSettingAllowNewer :: AllowNewer, - solverSettingMaxBackjumps :: Maybe Int, - solverSettingReorderGoals :: ReorderGoals, - solverSettingCountConflicts :: CountConflicts, - solverSettingFineGrainedConflicts :: FineGrainedConflicts, - solverSettingMinimizeConflictSet :: MinimizeConflictSet, - solverSettingStrongFlags :: StrongFlags, - solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, - solverSettingOnlyConstrained :: OnlyConstrained, - solverSettingIndexState :: Maybe TotalIndexState, - solverSettingActiveRepos :: Maybe ActiveRepos, - solverSettingIndependentGoals :: IndependentGoals - -- Things that only make sense for manual mode, not --local mode - -- too much control! - --solverSettingShadowPkgs :: Bool, - --solverSettingReinstall :: Bool, - --solverSettingAvoidReinstalls :: Bool, - --solverSettingOverrideReinstall :: Bool, - --solverSettingUpgradeDeps :: Bool - } - deriving (Eq, Show, Generic, Typeable) - -instance Binary SolverSettings -instance Structured SolverSettings - - --- | Resolved configuration for things that affect how we build and not the --- value of the things we build. The idea is that this is easier to use than --- the raw configuration because in the raw configuration everything is --- optional (monoidial). In the 'BuildTimeSettings' every field is filled in, --- if only with the defaults. --- --- Use 'resolveBuildTimeSettings' to make one from the project config (by --- applying defaults etc). --- -data BuildTimeSettings - = BuildTimeSettings { - buildSettingDryRun :: Bool, - buildSettingOnlyDeps :: Bool, - buildSettingSummaryFile :: [PathTemplate], - buildSettingLogFile :: Maybe (Compiler -> Platform - -> PackageId -> UnitId - -> FilePath), - buildSettingLogVerbosity :: Verbosity, - buildSettingBuildReports :: ReportLevel, - buildSettingReportPlanningFailure :: Bool, - buildSettingSymlinkBinDir :: [FilePath], - buildSettingOneShot :: Bool, - buildSettingNumJobs :: Int, - buildSettingKeepGoing :: Bool, - buildSettingOfflineMode :: Bool, - buildSettingKeepTempFiles :: Bool, - buildSettingRemoteRepos :: [RemoteRepo], - buildSettingLocalNoIndexRepos :: [LocalRepo], - buildSettingCacheDir :: FilePath, - buildSettingHttpTransport :: Maybe String, - buildSettingIgnoreExpiry :: Bool, - buildSettingProgPathExtra :: [FilePath] - } diff --git a/Distribution/Client/ProjectFlags.hs b/Distribution/Client/ProjectFlags.hs deleted file mode 100644 --- a/Distribution/Client/ProjectFlags.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -module Distribution.Client.ProjectFlags ( - ProjectFlags(..), - defaultProjectFlags, - projectFlagsOptions, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.ReadE (succeedReadE) -import Distribution.Simple.Command (MkOptDescr, OptionField, ShowOrParseArgs (..), boolOpt', option, reqArg) -import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg) - -data ProjectFlags = ProjectFlags - { flagProjectFileName :: Flag FilePath - -- ^ The cabal project file name; defaults to @cabal.project@. - -- The name itself denotes the cabal project file name, but it also - -- is the base of auxiliary project files, such as - -- @cabal.project.local@ and @cabal.project.freeze@ which are also - -- read and written out in some cases. If the path is not found - -- in the current working directory, we will successively probe - -- relative to parent directories until this name is found. - - , flagIgnoreProject :: Flag Bool - -- ^ Whether to ignore the local project (i.e. don't search for cabal.project) - -- The exact interpretation might be slightly different per command. - } - deriving (Show, Generic) - -defaultProjectFlags :: ProjectFlags -defaultProjectFlags = ProjectFlags - { flagProjectFileName = mempty - , flagIgnoreProject = toFlag False - -- Should we use 'Last' here? - } - -projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags] -projectFlagsOptions showOrParseArgs = - [ option [] ["project-file"] - "Set the name of the cabal.project file to search for in parent directories" - flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf }) - (reqArg "FILE" (succeedReadE Flag) flagToList) - , option ['z'] ["ignore-project"] - "Ignore local project configuration" - flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v }) - (yesNoOpt showOrParseArgs) - ] - -instance Monoid ProjectFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ProjectFlags where - (<>) = gmappend - -yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b -yesNoOpt ShowArgs sf lf = trueArg sf lf -yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs deleted file mode 100644 --- a/Distribution/Client/ProjectOrchestration.hs +++ /dev/null @@ -1,1255 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} - --- | This module deals with building and incrementally rebuilding a collection --- of packages. It is what backs the @cabal build@ and @configure@ commands, --- as well as being a core part of @run@, @test@, @bench@ and others. --- --- The primary thing is in fact rebuilding (and trying to make that quick by --- not redoing unnecessary work), so building from scratch is just a special --- case. --- --- The build process and the code can be understood by breaking it down into --- three major parts: --- --- * The 'ElaboratedInstallPlan' type --- --- * The \"what to do\" phase, where we look at the all input configuration --- (project files, .cabal files, command line etc) and produce a detailed --- plan of what to do -- the 'ElaboratedInstallPlan'. --- --- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we --- re-execute it. --- --- As far as possible, the \"what to do\" phase embodies all the policy, leaving --- the \"do it\" phase policy free. The first phase contains more of the --- complicated logic, but it is contained in code that is either pure or just --- has read effects (except cache updates). Then the second phase does all the --- actions to build packages, but as far as possible it just follows the --- instructions and avoids any logic for deciding what to do (apart from --- recompilation avoidance in executing the plan). --- --- This division helps us keep the code under control, making it easier to --- understand, test and debug. So when you are extending these modules, please --- think about which parts of your change belong in which part. It is --- perfectly ok to extend the description of what to do (i.e. the --- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the --- first phase. Also, the second phase does not have direct access to any of --- the input configuration anyway; all the information has to flow via the --- 'ElaboratedInstallPlan'. --- -module Distribution.Client.ProjectOrchestration ( - -- * Discovery phase: what is in the project? - CurrentCommand(..), - establishProjectBaseContext, - establishProjectBaseContextWithRoot, - ProjectBaseContext(..), - BuildTimeSettings(..), - commandLineFlagsToProjectConfig, - - -- * Pre-build phase: decide what to do. - withInstallPlan, - runProjectPreBuildPhase, - ProjectBuildContext(..), - - -- ** Selecting what targets we mean - readTargetSelectors, - reportTargetSelectorProblems, - resolveTargets, - TargetsMap, - TargetSelector(..), - TargetImplicitCwd(..), - PackageId, - AvailableTarget(..), - AvailableTargetStatus(..), - TargetRequested(..), - ComponentName(..), - ComponentKind(..), - ComponentTarget(..), - SubComponentTarget(..), - selectComponentTargetBasic, - distinctTargetComponents, - -- ** Utils for selecting targets - filterTargetsKind, - filterTargetsKindWith, - selectBuildableTargets, - selectBuildableTargetsWith, - selectBuildableTargets', - selectBuildableTargetsWith', - forgetTargetsDetail, - - -- ** Adjusting the plan - pruneInstallPlanToTargets, - TargetAction(..), - pruneInstallPlanToDependencies, - CannotPruneDependencies(..), - printPlan, - - -- * Build phase: now do it. - runProjectBuildPhase, - - -- * Post build actions - runProjectPostBuildPhase, - dieOnBuildFailures, - - -- * Dummy projects - establishDummyProjectBaseContext, - establishDummyDistDirLayout, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Distribution.Compat.Directory - ( makeAbsolute ) - -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning - hiding ( pruneInstallPlanToTargets ) -import qualified Distribution.Client.ProjectPlanning as ProjectPlanning - ( pruneInstallPlanToTargets ) -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding -import Distribution.Client.ProjectPlanOutput -import Distribution.Client.RebuildMonad ( runRebuild ) - -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) -import Distribution.Client.Types - ( GenericReadyPackage(..), UnresolvedSourcePackage - , PackageSpecifier(..) - , SourcePackageDb(..) - , WriteGhcEnvironmentFilesPolicy(..) ) -import Distribution.Solver.Types.PackageIndex - ( lookupPackageName ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.TargetSelector - ( TargetSelector(..), TargetImplicitCwd(..) - , ComponentKind(..), componentKind - , readTargetSelectors, reportTargetSelectorProblems ) -import Distribution.Client.DistDirLayout -import Distribution.Client.Config (getCabalDir) -import Distribution.Client.Setup hiding (packageName) -import Distribution.Compiler - ( CompilerFlavor(GHC) ) -import Distribution.Types.ComponentName - ( componentNameString ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, packageNameToUnqualComponentName ) - -import Distribution.Solver.Types.OptionalStanza - -import Distribution.Package -import Distribution.Types.Flag - ( FlagAssignment, showFlagAssignment, diffFlagAssignment ) -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), pkgComponents ) -import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe ) -import qualified Distribution.Simple.Setup as Setup -import Distribution.Simple.Command (commandShowOptions) -import Distribution.Simple.Configure (computeEffectiveProfiling) - -import Distribution.Simple.Utils - ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose ) -import Distribution.Verbosity -import Distribution.Version - ( mkVersion ) -import Distribution.Simple.Compiler - ( compilerCompatVersion, showCompilerId - , OptimisationLevel(..)) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Exception (assert) -#ifdef MIN_VERSION_unix -import System.Posix.Signals (sigKILL, sigSEGV) -#endif - - --- | Tracks what command is being executed, because we need to hide this somewhere --- for cases that need special handling (usually for error reporting). -data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand - deriving (Show, Eq) - --- | This holds the context of a project prior to solving: the content of the --- @cabal.project@ and all the local package @.cabal@ files. --- -data ProjectBaseContext = ProjectBaseContext { - distDirLayout :: DistDirLayout, - cabalDirLayout :: CabalDirLayout, - projectConfig :: ProjectConfig, - localPackages :: [PackageSpecifier UnresolvedSourcePackage], - buildSettings :: BuildTimeSettings, - currentCommand :: CurrentCommand - } - -establishProjectBaseContext - :: Verbosity - -> ProjectConfig - -> CurrentCommand - -> IO ProjectBaseContext -establishProjectBaseContext verbosity cliConfig currentCommand = do - projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile - establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand - where - mprojectFile = Setup.flagToMaybe projectConfigProjectFile - ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig - --- | Like 'establishProjectBaseContext' but doesn't search for project root. -establishProjectBaseContextWithRoot - :: Verbosity - -> ProjectConfig - -> ProjectRoot - -> CurrentCommand - -> IO ProjectBaseContext -establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do - cabalDir <- getCabalDir - - let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory - - (projectConfig, localPackages) <- - rebuildProjectConfig verbosity - distDirLayout - cliConfig - - let ProjectConfigBuildOnly { - projectConfigLogsDir - } = projectConfigBuildOnly projectConfig - - ProjectConfigShared { - projectConfigStoreDir - } = projectConfigShared projectConfig - - mlogsDir = Setup.flagToMaybe projectConfigLogsDir - mstoreDir <- sequenceA $ makeAbsolute - <$> Setup.flagToMaybe projectConfigStoreDir - let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - -- https://github.com/haskell/cabal/issues/6013 - when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $ - warn verbosity "There are no packages or optional-packages in the project" - - return ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings, - currentCommand - } - where - mdistDirectory = Setup.flagToMaybe projectConfigDistDir - ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig - - --- | This holds the context between the pre-build, build and post-build phases. --- -data ProjectBuildContext = ProjectBuildContext { - -- | This is the improved plan, before we select a plan subset based on - -- the build targets, and before we do the dry-run. So this contains - -- all packages in the project. - elaboratedPlanOriginal :: ElaboratedInstallPlan, - - -- | This is the 'elaboratedPlanOriginal' after we select a plan subset - -- and do the dry-run phase to find out what is up-to or out-of date. - -- This is the plan that will be executed during the build phase. So - -- this contains only a subset of packages in the project. - elaboratedPlanToExecute:: ElaboratedInstallPlan, - - -- | The part of the install plan that's shared between all packages in - -- the plan. This does not change between the two plan variants above, - -- so there is just the one copy. - elaboratedShared :: ElaboratedSharedConfig, - - -- | The result of the dry-run phase. This tells us about each member of - -- the 'elaboratedPlanToExecute'. - pkgsBuildStatus :: BuildStatusMap, - - -- | The targets selected by @selectPlanSubset@. This is useful eg. in - -- CmdRun, where we need a valid target to execute. - targetsMap :: TargetsMap - } - - --- | Pre-build phase: decide what to do. --- -withInstallPlan - :: Verbosity - -> ProjectBaseContext - -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a) - -> IO a -withInstallPlan - verbosity - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages - } - action = do - -- Take the project configuration and make a plan for how to build - -- everything in the project. This is independent of any specific targets - -- the user has asked for. - -- - (elaboratedPlan, _, elaboratedShared, _, _) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - action elaboratedPlan elaboratedShared - -runProjectPreBuildPhase - :: Verbosity - -> ProjectBaseContext - -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) - -> IO ProjectBuildContext -runProjectPreBuildPhase - verbosity - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages - } - selectPlanSubset = do - -- Take the project configuration and make a plan for how to build - -- everything in the project. This is independent of any specific targets - -- the user has asked for. - -- - (elaboratedPlan, _, elaboratedShared, _, _) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - - -- The plan for what to do is represented by an 'ElaboratedInstallPlan' - - -- Now given the specific targets the user has asked for, decide - -- which bits of the plan we will want to execute. - -- - (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan - - -- Check which packages need rebuilding. - -- This also gives us more accurate reasons for the --dry-run output. - -- - pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared - elaboratedPlan' - - -- Improve the plan by marking up-to-date packages as installed. - -- - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' - debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') - - return ProjectBuildContext { - elaboratedPlanOriginal = elaboratedPlan, - elaboratedPlanToExecute = elaboratedPlan'', - elaboratedShared, - pkgsBuildStatus, - targetsMap = targets - } - - --- | Build phase: now do it. --- --- Execute all or parts of the description of what to do to build or --- rebuild the various packages needed. --- -runProjectBuildPhase :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> IO BuildOutcomes -runProjectBuildPhase _ ProjectBaseContext{buildSettings} _ - | buildSettingDryRun buildSettings - = return Map.empty - -runProjectBuildPhase verbosity - ProjectBaseContext{..} ProjectBuildContext {..} = - fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $ - rebuildTargets verbosity - distDirLayout - (cabalStoreDirLayout cabalDirLayout) - elaboratedPlanToExecute - elaboratedShared - pkgsBuildStatus - buildSettings - where - previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes - previousBuildOutcomes = - Map.mapMaybe $ \status -> case status of - BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess) - --TODO: [nice to have] record build failures persistently - _ -> Nothing - --- | Post-build phase: various administrative tasks --- --- Update bits of state based on the build outcomes and report any failures. --- -runProjectPostBuildPhase :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> BuildOutcomes - -> IO () -runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ - | buildSettingDryRun buildSettings - = return () - -runProjectPostBuildPhase verbosity - ProjectBaseContext {..} ProjectBuildContext {..} - buildOutcomes = do - -- Update other build artefacts - -- TODO: currently none, but could include: - -- - bin symlinks/wrappers - -- - haddock/hoogle/ctags indexes - -- - delete stale lib registrations - -- - delete stale package dirs - - postBuildStatus <- updatePostBuildProjectStatus - verbosity - distDirLayout - elaboratedPlanOriginal - pkgsBuildStatus - buildOutcomes - - -- Write the .ghc.environment file (if allowed by the env file write policy). - let writeGhcEnvFilesPolicy = - projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared - $ projectConfig - - shouldWriteGhcEnvironment = - case fromFlagOrDefault NeverWriteGhcEnvironmentFiles - writeGhcEnvFilesPolicy - of - AlwaysWriteGhcEnvironmentFiles -> True - NeverWriteGhcEnvironmentFiles -> False - WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> - let compiler = pkgConfigCompiler elaboratedShared - ghcCompatVersion = compilerCompatVersion GHC compiler - in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion - - when shouldWriteGhcEnvironment $ - void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) - elaboratedPlanOriginal - elaboratedShared - postBuildStatus - - -- Finally if there were any build failures then report them and throw - -- an exception to terminate the program - dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes - - -- Note that it is a deliberate design choice that the 'buildTargets' is - -- not passed to phase 1, and the various bits of input config is not - -- passed to phase 2. - -- - -- We make the install plan without looking at the particular targets the - -- user asks us to build. The set of available things we can build is - -- discovered from the env and config and is used to make the install plan. - -- The targets just tell us which parts of the install plan to execute. - -- - -- Conversely, executing the plan does not directly depend on any of the - -- input config. The bits that are needed (or better, the decisions based - -- on it) all go into the install plan. - - -- Notionally, the 'BuildFlags' should be things that do not affect what - -- we build, just how we do it. These ones of course do - - ------------------------------------------------------------------------------- --- Taking targets into account, selecting what to build --- - --- | The set of components to build, represented as a mapping from 'UnitId's --- to the 'ComponentTarget's within the unit that will be selected --- (e.g. selected to build, test or repl). --- --- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that --- matched this target. Typically this is exactly one, but in general it is --- possible to for different selectors to match the same target. This extra --- information is primarily to help make helpful error messages. --- -type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])] - --- | Given a set of 'TargetSelector's, resolve which 'UnitId's and --- 'ComponentTarget's they ought to refer to. --- --- The idea is that every user target identifies one or more roots in the --- 'ElaboratedInstallPlan', which we will use to determine the closure --- of what packages need to be built, dropping everything from the plan --- that is unnecessary. This closure and pruning is done by --- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms --- of 'UnitId's and the 'ComponentTarget's within those. --- --- This means we first need to translate the 'TargetSelector's into the --- 'UnitId's and 'ComponentTarget's. This translation has to be different for --- the different command line commands, like @build@, @repl@ etc. For example --- the command @build pkgfoo@ could select a different set of components in --- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and --- all executables, whereas @repl@ would select the library or a single --- executable. Furthermore, both of these examples could fail, and fail in --- different ways and each needs to be able to produce helpful error messages. --- --- So 'resolveTargets' takes two helpers: one to select the targets to be used --- by user targets that refer to a whole package ('TargetPackage'), and --- another to check user targets that refer to a component (or a module or --- file within a component). These helpers can fail, and use their own error --- type. Both helpers get given the 'AvailableTarget' info about the --- component(s). --- --- While commands vary quite a bit in their behaviour about which components to --- select for a whole-package target, most commands have the same behaviour for --- checking a user target that refers to a specific component. To help with --- this commands can use 'selectComponentTargetBasic', either directly or as --- a basis for their own @selectComponentTarget@ implementation. --- -resolveTargets :: forall err. - (forall k. TargetSelector - -> [AvailableTarget k] - -> Either (TargetProblem err) [k]) - -> (forall k. SubComponentTarget - -> AvailableTarget k - -> Either (TargetProblem err) k ) - -> ElaboratedInstallPlan - -> Maybe (SourcePackageDb) - -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap -resolveTargets selectPackageTargets selectComponentTarget - installPlan mPkgDb = - fmap mkTargetsMap - . either (Left . toList) Right - . checkErrors - . map (\ts -> (,) ts <$> checkTarget ts) - where - mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])] - -> TargetsMap - mkTargetsMap targets = - Map.map nubComponentTargets - $ Map.fromListWith (++) - [ (uid, [(ct, ts)]) - | (ts, cts) <- targets - , (uid, ct) <- cts ] - - AvailableTargetIndexes{..} = availableTargetIndexes installPlan - - checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)] - - -- We can ask to build any whole package, project-local or a dependency - checkTarget bt@(TargetPackage _ [pkgid] mkfilter) - | Just ats <- fmap (maybe id filterTargetsKind mkfilter) - $ Map.lookup pkgid availableTargetsByPackageId - = fmap (componentTargets WholeComponent) - $ selectPackageTargets bt ats - - | otherwise - = Left (TargetProblemNoSuchPackage pkgid) - - checkTarget (TargetPackage _ pkgids _) - = error ("TODO: add support for multiple packages in a directory. Got\n" - ++ unlines (map prettyShow pkgids)) - -- For the moment this error cannot happen here, because it gets - -- detected when the package config is being constructed. This case - -- will need handling properly when we do add support. - -- - -- TODO: how should this use case play together with the - -- '--cabal-file' option of 'configure' which allows using multiple - -- .cabal files for a single package? - - checkTarget bt@(TargetAllPackages mkfilter) = - fmap (componentTargets WholeComponent) - . selectPackageTargets bt - . maybe id filterTargetsKind mkfilter - . filter availableTargetLocalToProject - $ concat (Map.elems availableTargetsByPackageId) - - checkTarget (TargetComponent pkgid cname subtarget) - | Just ats <- Map.lookup (pkgid, cname) - availableTargetsByPackageIdAndComponentName - = fmap (componentTargets subtarget) - $ selectComponentTargets subtarget ats - - | Map.member pkgid availableTargetsByPackageId - = Left (TargetProblemNoSuchComponent pkgid cname) - - | otherwise - = Left (TargetProblemNoSuchPackage pkgid) - - checkTarget (TargetComponentUnknown pkgname ecname subtarget) - | Just ats <- case ecname of - Left ucname -> - Map.lookup (pkgname, ucname) - availableTargetsByPackageNameAndUnqualComponentName - Right cname -> - Map.lookup (pkgname, cname) - availableTargetsByPackageNameAndComponentName - = fmap (componentTargets subtarget) - $ selectComponentTargets subtarget ats - - | Map.member pkgname availableTargetsByPackageName - = Left (TargetProblemUnknownComponent pkgname ecname) - - | otherwise - = Left (TargetNotInProject pkgname) - - checkTarget bt@(TargetPackageNamed pkgname mkfilter) - | Just ats <- fmap (maybe id filterTargetsKind mkfilter) - $ Map.lookup pkgname availableTargetsByPackageName - = fmap (componentTargets WholeComponent) - . selectPackageTargets bt - $ ats - - | Just SourcePackageDb{ packageIndex } <- mPkgDb - , let pkg = lookupPackageName packageIndex pkgname - , not (null pkg) - = Left (TargetAvailableInIndex pkgname) - - | otherwise - = Left (TargetNotInProject pkgname) - - componentTargets :: SubComponentTarget - -> [(b, ComponentName)] - -> [(b, ComponentTarget)] - componentTargets subtarget = - map (fmap (\cname -> ComponentTarget cname subtarget)) - - selectComponentTargets :: SubComponentTarget - -> [AvailableTarget k] - -> Either (TargetProblem err) [k] - selectComponentTargets subtarget = - either (Left . NE.head) Right - . checkErrors - . map (selectComponentTarget subtarget) - - checkErrors :: [Either e a] -> Either (NonEmpty e) [a] - checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') }) - . partitionEithers - - -data AvailableTargetIndexes = AvailableTargetIndexes { - availableTargetsByPackageIdAndComponentName - :: AvailableTargetsMap (PackageId, ComponentName), - - availableTargetsByPackageId - :: AvailableTargetsMap PackageId, - - availableTargetsByPackageName - :: AvailableTargetsMap PackageName, - - availableTargetsByPackageNameAndComponentName - :: AvailableTargetsMap (PackageName, ComponentName), - - availableTargetsByPackageNameAndUnqualComponentName - :: AvailableTargetsMap (PackageName, UnqualComponentName) - } -type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] - --- We define a bunch of indexes to help 'resolveTargets' with resolving --- 'TargetSelector's to specific 'UnitId's. --- --- They are all derived from the 'availableTargets' index. --- The 'availableTargetsByPackageIdAndComponentName' is just that main index, --- while the others are derived by re-grouping on the index key. --- --- They are all constructed lazily because they are not necessarily all used. --- -availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes -availableTargetIndexes installPlan = AvailableTargetIndexes{..} - where - availableTargetsByPackageIdAndComponentName = - availableTargets installPlan - - availableTargetsByPackageId = - Map.mapKeysWith - (++) (\(pkgid, _cname) -> pkgid) - availableTargetsByPackageIdAndComponentName - `Map.union` availableTargetsEmptyPackages - - availableTargetsByPackageName = - Map.mapKeysWith - (++) packageName - availableTargetsByPackageId - - availableTargetsByPackageNameAndComponentName = - Map.mapKeysWith - (++) (\(pkgid, cname) -> (packageName pkgid, cname)) - availableTargetsByPackageIdAndComponentName - - availableTargetsByPackageNameAndUnqualComponentName = - Map.mapKeysWith - (++) (\(pkgid, cname) -> let pname = packageName pkgid - cname' = unqualComponentName pname cname - in (pname, cname')) - availableTargetsByPackageIdAndComponentName - where - unqualComponentName :: - PackageName -> ComponentName -> UnqualComponentName - unqualComponentName pkgname = - fromMaybe (packageNameToUnqualComponentName pkgname) - . componentNameString - - -- Add in all the empty packages. These do not appear in the - -- availableTargetsByComponent map, since that only contains - -- components, so packages with no components are invisible from - -- that perspective. The empty packages need to be there for - -- proper error reporting, so users can select the empty package - -- and then we can report that it is empty, otherwise we falsely - -- report there is no such package at all. - availableTargetsEmptyPackages = - Map.fromList - [ (packageId pkg, []) - | InstallPlan.Configured pkg <- InstallPlan.toList installPlan - , case elabPkgOrComp pkg of - ElabComponent _ -> False - ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) - ] - - --TODO: [research required] what if the solution has multiple - -- versions of this package? - -- e.g. due to setup deps or due to multiple independent sets - -- of packages being built (e.g. ghc + ghcjs in a project) - -filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k] -filterTargetsKind ckind = filterTargetsKindWith (== ckind) - -filterTargetsKindWith :: (ComponentKind -> Bool) - -> [AvailableTarget k] -> [AvailableTarget k] -filterTargetsKindWith p ts = - [ t | t@(AvailableTarget _ cname _ _) <- ts - , p (componentKind cname) ] - -selectBuildableTargets :: [AvailableTarget k] -> [k] -selectBuildableTargets ts = - [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] - -selectBuildableTargetsWith :: (TargetRequested -> Bool) - -> [AvailableTarget k] -> [k] -selectBuildableTargetsWith p ts = - [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] - -selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()]) -selectBuildableTargets' ts = - (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] - [ forgetTargetDetail t - | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ] - -selectBuildableTargetsWith' :: (TargetRequested -> Bool) - -> [AvailableTarget k] -> ([k], [AvailableTarget ()]) -selectBuildableTargetsWith' p ts = - (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] - [ forgetTargetDetail t - | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ] - - -forgetTargetDetail :: AvailableTarget k -> AvailableTarget () -forgetTargetDetail = fmap (const ()) - -forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()] -forgetTargetsDetail = map forgetTargetDetail - --- | A basic @selectComponentTarget@ implementation to use or pass to --- 'resolveTargets', that does the basic checks that the component is --- buildable and isn't a test suite or benchmark that is disabled. This --- can also be used to do these basic checks as part of a custom impl that --- -selectComponentTargetBasic :: SubComponentTarget - -> AvailableTarget k - -> Either (TargetProblem a) k -selectComponentTargetBasic subtarget - AvailableTarget { - availableTargetPackageId = pkgid, - availableTargetComponentName = cname, - availableTargetStatus - } = - case availableTargetStatus of - TargetDisabledByUser -> - Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) - - TargetDisabledBySolver -> - Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget) - - TargetNotLocal -> - Left (TargetComponentNotProjectLocal pkgid cname subtarget) - - TargetNotBuildable -> - Left (TargetComponentNotBuildable pkgid cname subtarget) - - TargetBuildable targetKey _ -> - Right targetKey - --- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts --- for the extra unneeded info in the 'TargetsMap'. --- -pruneInstallPlanToTargets :: TargetAction -> TargetsMap - -> ElaboratedInstallPlan -> ElaboratedInstallPlan -pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = - assert (Map.size targetsMap > 0) $ - ProjectPlanning.pruneInstallPlanToTargets - targetActionType - (Map.map (map fst) targetsMap) - elaboratedPlan - --- | Utility used by repl and run to check if the targets spans multiple --- components, since those commands do not support multiple components. --- -distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) -distinctTargetComponents targetsMap = - Set.fromList [ (uid, cname) - | (uid, cts) <- Map.toList targetsMap - , (ComponentTarget cname _, _) <- cts ] - - ------------------------------------------------------------------------------- --- Displaying what we plan to do --- - --- | Print a user-oriented presentation of the install plan, indicating what --- will be built. --- -printPlan :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> IO () -printPlan verbosity - ProjectBaseContext { - buildSettings = BuildTimeSettings{buildSettingDryRun}, - projectConfig = ProjectConfig { - projectConfigLocalPackages = - PackageConfig {packageConfigOptimization} - } - } - ProjectBuildContext { - elaboratedPlanToExecute = elaboratedPlan, - elaboratedShared, - pkgsBuildStatus - } - - | null pkgs - = notice verbosity "Up to date" - - | otherwise - = noticeNoWrap verbosity $ unlines $ - (showBuildProfile ++ "In order, the following " - ++ wouldWill ++ " be built" - ++ ifNormal " (use -v for more details)" ++ ":") - : map showPkgAndReason pkgs - - where - pkgs = InstallPlan.executionOrder elaboratedPlan - - ifVerbose s | verbosity >= verbose = s - | otherwise = "" - - ifNormal s | verbosity >= verbose = "" - | otherwise = s - - wouldWill | buildSettingDryRun = "would" - | otherwise = "will" - - showPkgAndReason :: ElaboratedReadyPackage -> String - showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $ - [ " -" - , if verbosity >= deafening - then prettyShow (installedUnitId elab) - else prettyShow (packageId elab) - , case elabPkgOrComp elab of - ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg) - ElabComponent comp -> - "(" ++ showComp elab comp ++ ")" - , showFlagAssignment (nonDefaultFlags elab) - , showConfigureFlags elab - , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab - in "(" ++ showBuildStatus buildStatus ++ ")" - ] - - showComp elab comp = - maybe "custom" prettyShow (compComponentName comp) ++ - if Map.null (elabInstantiatedWith elab) - then "" - else " with " ++ - intercalate ", " - -- TODO: Abbreviate the UnitIds - [ prettyShow k ++ "=" ++ prettyShow v - | (k,v) <- Map.toList (elabInstantiatedWith elab) ] - - nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment - nonDefaultFlags elab = - elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab - - showStanzas pkg = concat - $ [ " *test" - | TestStanzas `Set.member` pkgStanzasEnabled pkg ] - ++ [ " *bench" - | BenchStanzas `Set.member` pkgStanzasEnabled pkg ] - - showTargets elab - | null (elabBuildTargets elab) = "" - | otherwise - = "(" - ++ intercalate ", " [ showComponentTarget (packageId elab) t - | t <- elabBuildTargets elab ] - ++ ")" - - showConfigureFlags elab = - let fullConfigureFlags - = setupHsConfigureFlags - (ReadyPackage elab) - elaboratedShared - verbosity - "$builddir" - -- | Given a default value @x@ for a flag, nub @Flag x@ - -- into @NoFlag@. This gives us a tidier command line - -- rendering. - nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a - nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag - nubFlag _ f = f - - (tryLibProfiling, tryExeProfiling) = - computeEffectiveProfiling fullConfigureFlags - - partialConfigureFlags - = mempty { - configProf = - nubFlag False (configProf fullConfigureFlags), - configProfExe = - nubFlag tryExeProfiling (configProfExe fullConfigureFlags), - configProfLib = - nubFlag tryLibProfiling (configProfLib fullConfigureFlags) - -- Maybe there are more we can add - } - -- Not necessary to "escape" it, it's just for user output - in unwords . ("":) $ - commandShowOptions - (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) - partialConfigureFlags - - showBuildStatus status = case status of - BuildStatusPreExisting -> "existing package" - BuildStatusInstalled -> "already installed" - BuildStatusDownload {} -> "requires download & build" - BuildStatusUnpack {} -> "requires build" - BuildStatusRebuild _ rebuild -> case rebuild of - BuildStatusConfigure - (MonitoredValueChanged _) -> "configuration changed" - BuildStatusConfigure mreason -> showMonitorChangedReason mreason - BuildStatusBuild _ buildreason -> case buildreason of - BuildReasonDepsRebuilt -> "dependency rebuilt" - BuildReasonFilesChanged - mreason -> showMonitorChangedReason mreason - BuildReasonExtraTargets _ -> "additional components to build" - BuildReasonEphemeralTargets -> "ephemeral targets" - BuildStatusUpToDate {} -> "up to date" -- doesn't happen - - showMonitorChangedReason (MonitoredFileChanged file) = - "file " ++ file ++ " changed" - showMonitorChangedReason (MonitoredValueChanged _) = "value changed" - showMonitorChangedReason MonitorFirstRun = "first run" - showMonitorChangedReason MonitorCorruptCache = - "cannot read state cache" - - showBuildProfile = "Build profile: " ++ unwords [ - "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, - "-O" ++ (case packageConfigOptimization of - Setup.Flag NoOptimisation -> "0" - Setup.Flag NormalOptimisation -> "1" - Setup.Flag MaximumOptimisation -> "2" - Setup.NoFlag -> "1")] - ++ "\n" - --- | If there are build failures then report them and throw an exception. --- -dieOnBuildFailures :: Verbosity -> CurrentCommand - -> ElaboratedInstallPlan -> BuildOutcomes -> IO () -dieOnBuildFailures verbosity currentCommand plan buildOutcomes - | null failures = return () - - | isSimpleCase = exitFailure - - | otherwise = do - -- For failures where we have a build log, print the log plus a header - sequence_ - [ do notice verbosity $ - '\n' : renderFailureDetail False pkg reason - ++ "\nBuild log ( " ++ logfile ++ " ):" - readFile logfile >>= noticeNoWrap verbosity - | (pkg, ShowBuildSummaryAndLog reason logfile) - <- failuresClassification - ] - - -- For all failures, print either a short summary (if we showed the - -- build log) or all details - dieIfNotHaddockFailure verbosity $ unlines - [ case failureClassification of - ShowBuildSummaryAndLog reason _ - | verbosity > normal - -> renderFailureDetail mentionDepOf pkg reason - - | otherwise - -> renderFailureSummary mentionDepOf pkg reason - ++ ". See the build log above for details." - - ShowBuildSummaryOnly reason -> - renderFailureDetail mentionDepOf pkg reason - - | let mentionDepOf = verbosity <= normal - , (pkg, failureClassification) <- failuresClassification ] - where - failures = [ (pkgid, failure) - | (pkgid, Left failure) <- Map.toList buildOutcomes ] - - failuresClassification = - [ (pkg, classifyBuildFailure failure) - | (pkgid, failure) <- failures - , case buildFailureReason failure of - DependentFailed {} -> verbosity > normal - _ -> True - , InstallPlan.Configured pkg <- - maybeToList (InstallPlan.lookup plan pkgid) - ] - - dieIfNotHaddockFailure - | currentCommand == HaddockCommand = die' - | all isHaddockFailure failuresClassification = warn - | otherwise = die' - where - isHaddockFailure - (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True - isHaddockFailure - (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True - isHaddockFailure - _ = False - - - classifyBuildFailure :: BuildFailure -> BuildFailurePresentation - classifyBuildFailure BuildFailure { - buildFailureReason = reason, - buildFailureLogFile = mlogfile - } = - maybe (ShowBuildSummaryOnly reason) - (ShowBuildSummaryAndLog reason) $ do - logfile <- mlogfile - e <- buildFailureException reason - ExitFailure 1 <- fromException e - return logfile - - -- Special case: we don't want to report anything complicated in the case - -- of just doing build on the current package, since it's clear from - -- context which package failed. - -- - -- We generalise this rule as follows: - -- - if only one failure occurs, and it is in a single root - -- package (i.e. a package with nothing else depending on it) - -- - and that failure is of a kind that always reports enough - -- detail itself (e.g. ghc reporting errors on stdout) - -- - then we do not report additional error detail or context. - -- - isSimpleCase - | [(pkgid, failure)] <- failures - , [pkg] <- rootpkgs - , installedUnitId pkg == pkgid - , isFailureSelfExplanatory (buildFailureReason failure) - , currentCommand /= InstallCommand - = True - | otherwise - = False - - -- NB: if the Setup script segfaulted or was interrupted, - -- we should give more detailed information. So only - -- assume that exit code 1 is "pedestrian failure." - isFailureSelfExplanatory (BuildFailed e) - | Just (ExitFailure 1) <- fromException e = True - - isFailureSelfExplanatory (ConfigureFailed e) - | Just (ExitFailure 1) <- fromException e = True - - isFailureSelfExplanatory _ = False - - rootpkgs = - [ pkg - | InstallPlan.Configured pkg <- InstallPlan.toList plan - , hasNoDependents pkg ] - - ultimateDeps pkgid = - filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) - (InstallPlan.reverseDependencyClosure plan [pkgid]) - - hasNoDependents :: HasUnitId pkg => pkg -> Bool - hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId - - renderFailureDetail mentionDepOf pkg reason = - renderFailureSummary mentionDepOf pkg reason ++ "." - ++ renderFailureExtraDetail reason - ++ maybe "" showException (buildFailureException reason) - - renderFailureSummary mentionDepOf pkg reason = - case reason of - DownloadFailed _ -> "Failed to download " ++ pkgstr - UnpackFailed _ -> "Failed to unpack " ++ pkgstr - ConfigureFailed _ -> "Failed to build " ++ pkgstr - BuildFailed _ -> "Failed to build " ++ pkgstr - ReplFailed _ -> "repl failed for " ++ pkgstr - HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr - TestsFailed _ -> "Tests failed for " ++ pkgstr - BenchFailed _ -> "Benchmarks failed for " ++ pkgstr - InstallFailed _ -> "Failed to build " ++ pkgstr - DependentFailed depid - -> "Failed to build " ++ prettyShow (packageId pkg) - ++ " because it depends on " ++ prettyShow depid - ++ " which itself failed to build" - where - pkgstr = elabConfiguredName verbosity pkg - ++ if mentionDepOf - then renderDependencyOf (installedUnitId pkg) - else "" - - renderFailureExtraDetail (ConfigureFailed _) = - " The failure occurred during the configure step." - renderFailureExtraDetail (InstallFailed _) = - " The failure occurred during the final install step." - renderFailureExtraDetail _ = - "" - - renderDependencyOf pkgid = - case ultimateDeps pkgid of - [] -> "" - (p1:[]) -> - " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" - (p1:p2:[]) -> - " (which is required by " ++ elabPlanPackageName verbosity p1 - ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" - (p1:p2:_) -> - " (which is required by " ++ elabPlanPackageName verbosity p1 - ++ ", " ++ elabPlanPackageName verbosity p2 - ++ " and others)" - - showException e = case fromException e of - Just (ExitFailure 1) -> "" - -#ifdef MIN_VERSION_unix - -- Note [Positive "signal" exit code] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- What's the business with the test for negative and positive - -- signal values? The API for process specifies that if the - -- process died due to a signal, it returns a *negative* exit - -- code. So that's the negative test. - -- - -- What about the positive test? Well, when we find out that - -- a process died due to a signal, we ourselves exit with that - -- exit code. However, we don't "kill ourselves" with the - -- signal; we just exit with the same code as the signal: thus - -- the caller sees a *positive* exit code. So that's what - -- happens when we get a positive exit code. - Just (ExitFailure n) - | -n == fromIntegral sigSEGV -> - " The build process segfaulted (i.e. SIGSEGV)." - - | n == fromIntegral sigSEGV -> - " The build process terminated with exit code " ++ show n - ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." - - | -n == fromIntegral sigKILL -> - " The build process was killed (i.e. SIGKILL). " ++ explanation - - | n == fromIntegral sigKILL -> - " The build process terminated with exit code " ++ show n - ++ " which may be because some part of it was killed " - ++ "(i.e. SIGKILL). " ++ explanation - where - explanation = - "The typical reason for this is that there is not " - ++ "enough memory available (e.g. the OS killed a process " - ++ "using lots of memory)." -#endif - Just (ExitFailure n) -> - " The build process terminated with exit code " ++ show n - - _ -> " The exception was:\n " -#if MIN_VERSION_base(4,8,0) - ++ displayException e -#else - ++ show e -#endif - - buildFailureException reason = - case reason of - DownloadFailed e -> Just e - UnpackFailed e -> Just e - ConfigureFailed e -> Just e - BuildFailed e -> Just e - ReplFailed e -> Just e - HaddocksFailed e -> Just e - TestsFailed e -> Just e - BenchFailed e -> Just e - InstallFailed e -> Just e - DependentFailed _ -> Nothing - -data BuildFailurePresentation = - ShowBuildSummaryOnly BuildFailureReason - | ShowBuildSummaryAndLog BuildFailureReason FilePath - -------------------------------------------------------------------------------- --- Dummy projects -------------------------------------------------------------------------------- - --- | Create a dummy project context, without a .cabal or a .cabal.project file --- (a place where to put a temporary dist directory is still needed) -establishDummyProjectBaseContext - :: Verbosity - -> ProjectConfig - -> DistDirLayout - -- ^ Where to put the dist directory - -> [PackageSpecifier UnresolvedSourcePackage] - -- ^ The packages to be included in the project - -> CurrentCommand - -> IO ProjectBaseContext -establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do - cabalDir <- getCabalDir - - globalConfig <- runRebuild "" - $ readGlobalConfig verbosity - $ projectConfigConfigFile - $ projectConfigShared cliConfig - let projectConfig = globalConfig <> cliConfig - - let ProjectConfigBuildOnly { - projectConfigLogsDir - } = projectConfigBuildOnly projectConfig - - ProjectConfigShared { - projectConfigStoreDir - } = projectConfigShared projectConfig - - mlogsDir = flagToMaybe projectConfigLogsDir - mstoreDir = flagToMaybe projectConfigStoreDir - cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - return ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings, - currentCommand - } - -establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout -establishDummyDistDirLayout verbosity cliConfig tmpDir = do - let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory - - -- Create the dist directories - createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout - createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout - - return distDirLayout - where - mdistDirectory = flagToMaybe - $ projectConfigDistDir - $ projectConfigShared cliConfig - projectRoot = ProjectRootImplicit tmpDir diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs deleted file mode 100644 --- a/Distribution/Client/ProjectPlanOutput.hs +++ /dev/null @@ -1,939 +0,0 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns, - DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, - ScopedTypeVariables #-} - -module Distribution.Client.ProjectPlanOutput ( - -- * Plan output - writePlanExternalRepresentation, - - -- * Project status - -- | Several outputs rely on having a general overview of - PostBuildProjectStatus(..), - updatePostBuildProjectStatus, - createPackageEnvironment, - writePlanGhcEnvironment, - argsEquivalentOfGhcEnvironmentFile, - ) where - -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding.Types -import Distribution.Client.DistDirLayout -import Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..)) -import Distribution.Client.Types.PackageLocation (PackageLocation(..)) -import Distribution.Client.Types.ConfiguredId (confInstId) -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) -import Distribution.Client.HashValue (showHashValue, hashValue) -import Distribution.Client.Utils (cabalInstallVersion) - -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.Utils.Json as J -import qualified Distribution.Simple.InstallDirs as InstallDirs - -import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps - -import Distribution.Package -import Distribution.System -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.PackageDescription as PD -import Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) -import Distribution.Simple.Compiler - ( PackageDBStack, PackageDB(..) - , compilerVersion, compilerFlavor, showCompilerId - , compilerId, CompilerId(..), Compiler ) -import Distribution.Simple.GHC - ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) - , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile - , writeGhcEnvironmentFile ) -import Distribution.Simple.BuildPaths - ( dllExtension, exeExtension ) -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, Node) -import qualified Distribution.Compat.Binary as Binary -import Distribution.Simple.Utils -import Distribution.Verbosity - -import Prelude () -import Distribution.Client.Compat.Prelude - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Builder as BB - -import System.FilePath -import System.IO - -import Distribution.Simple.Program.GHC (packageDbArgsDb) - ------------------------------------------------------------------------------ --- Writing plan.json files --- - --- | Write out a representation of the elaborated install plan. --- --- This is for the benefit of debugging and external tools like editors. --- -writePlanExternalRepresentation :: DistDirLayout - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> IO () -writePlanExternalRepresentation distDirLayout elaboratedInstallPlan - elaboratedSharedConfig = - writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $ - BB.toLazyByteString - . J.encodeToBuilder - $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig - --- | Renders a subset of the elaborated install plan in a semi-stable JSON --- format. --- -encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value -encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = - --TODO: [nice to have] include all of the sharedPackageConfig and all of - -- the parts of the elaboratedInstallPlan - J.object [ "cabal-version" J..= jdisplay cabalInstallVersion - , "cabal-lib-version" J..= jdisplay cabalVersion - , "compiler-id" J..= (J.String . showCompilerId . pkgConfigCompiler) - elaboratedSharedConfig - , "os" J..= jdisplay os - , "arch" J..= jdisplay arch - , "install-plan" J..= installPlanToJ elaboratedInstallPlan - ] - where - plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig - - installPlanToJ :: ElaboratedInstallPlan -> [J.Value] - installPlanToJ = map planPackageToJ . InstallPlan.toList - - planPackageToJ :: ElaboratedPlanPackage -> J.Value - planPackageToJ pkg = - case pkg of - InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi - InstallPlan.Configured elab -> elaboratedPackageToJ False elab - InstallPlan.Installed elab -> elaboratedPackageToJ True elab - -- Note that the plan.json currently only uses the elaborated plan, - -- not the improved plan. So we will not get the Installed state for - -- that case, but the code supports it in case we want to use this - -- later in some use case where we want the status of the build. - - installedPackageInfoToJ :: InstalledPackageInfo -> J.Value - installedPackageInfoToJ ipi = - -- Pre-existing packages lack configuration information such as their flag - -- settings or non-lib components. We only get pre-existing packages for - -- the global/core packages however, so this isn't generally a problem. - -- So these packages are never local to the project. - -- - J.object - [ "type" J..= J.String "pre-existing" - , "id" J..= (jdisplay . installedUnitId) ipi - , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi - , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi - , "depends" J..= map jdisplay (installedDepends ipi) - ] - - elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value - elaboratedPackageToJ isInstalled elab = - J.object $ - [ "type" J..= J.String (if isInstalled then "installed" - else "configured") - , "id" J..= (jdisplay . installedUnitId) elab - , "pkg-name" J..= (jdisplay . pkgName . packageId) elab - , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab - , "flags" J..= J.object [ PD.unFlagName fn J..= v - | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] - , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) - , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) - ] ++ - [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) - | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++ - [ "pkg-src-sha256" J..= J.String (showHashValue hash) - | Just hash <- [elabPkgSourceHash elab] ] ++ - (case elabBuildStyle elab of - BuildInplaceOnly -> - ["dist-dir" J..= J.String dist_dir] - BuildAndInstall -> - -- TODO: install dirs? - [] - ) ++ - case elabPkgOrComp elab of - ElabPackage pkg -> - let components = J.object $ - [ comp2str c J..= (J.object $ - [ "depends" J..= map (jdisplay . confInstId) ldeps - , "exe-depends" J..= map (jdisplay . confInstId) edeps - ] ++ - bin_file c) - | (c,(ldeps,edeps)) - <- ComponentDeps.toList $ - ComponentDeps.zip (pkgLibDependencies pkg) - (pkgExeDependencies pkg) ] - in ["components" J..= components] - ElabComponent comp -> - ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) - ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) - ,"component-name" J..= J.String (comp2str (compSolverName comp)) - ] ++ - bin_file (compSolverName comp) - where - packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value - packageLocationToJ pkgloc = - case pkgloc of - LocalUnpackedPackage local -> - J.object [ "type" J..= J.String "local" - , "path" J..= J.String local - ] - LocalTarballPackage local -> - J.object [ "type" J..= J.String "local-tar" - , "path" J..= J.String local - ] - RemoteTarballPackage uri _ -> - J.object [ "type" J..= J.String "remote-tar" - , "uri" J..= J.String (show uri) - ] - RepoTarballPackage repo _ _ -> - J.object [ "type" J..= J.String "repo-tar" - , "repo" J..= repoToJ repo - ] - RemoteSourceRepoPackage srcRepo _ -> - J.object [ "type" J..= J.String "source-repo" - , "source-repo" J..= sourceRepoToJ srcRepo - ] - - repoToJ :: Repo -> J.Value - repoToJ repo = - case repo of - RepoLocalNoIndex{..} -> - J.object [ "type" J..= J.String "local-repo-no-index" - , "path" J..= J.String repoLocalDir - ] - RepoRemote{..} -> - J.object [ "type" J..= J.String "remote-repo" - , "uri" J..= J.String (show (remoteRepoURI repoRemote)) - ] - RepoSecure{..} -> - J.object [ "type" J..= J.String "secure-repo" - , "uri" J..= J.String (show (remoteRepoURI repoRemote)) - ] - - sourceRepoToJ :: SourceRepoMaybe -> J.Value - sourceRepoToJ SourceRepositoryPackage{..} = - J.object $ filter ((/= J.Null) . snd) $ - [ "type" J..= jdisplay srpType - , "location" J..= J.String srpLocation - , "branch" J..= fmap J.String srpBranch - , "tag" J..= fmap J.String srpTag - , "subdir" J..= fmap J.String srpSubdir - ] - - dist_dir = distBuildDirectory distDirLayout - (elabDistDirParams elaboratedSharedConfig elab) - - bin_file c = case c of - ComponentDeps.ComponentExe s -> bin_file' s - ComponentDeps.ComponentTest s -> bin_file' s - ComponentDeps.ComponentBench s -> bin_file' s - ComponentDeps.ComponentFLib s -> flib_file' s - _ -> [] - bin_file' s = - ["bin-file" J..= J.String bin] - where - bin = if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat - else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat - - flib_file' s = - ["bin-file" J..= J.String bin] - where - bin = if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat - else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat - - comp2str :: ComponentDeps.Component -> String - comp2str = prettyShow - - style2str :: Bool -> BuildStyle -> String - style2str True _ = "local" - style2str False BuildInplaceOnly = "inplace" - style2str False BuildAndInstall = "global" - - jdisplay :: Pretty a => a -> J.Value - jdisplay = J.String . prettyShow - - ------------------------------------------------------------------------------ --- Project status --- - --- So, what is the status of a project after a build? That is, how do the --- inputs (package source files etc) compare to the output artefacts (build --- libs, exes etc)? Do the outputs reflect the current values of the inputs --- or are outputs out of date or invalid? --- --- First of all, what do we mean by out-of-date and what do we mean by --- invalid? We think of the build system as a morally pure function that --- computes the output artefacts given input values. We say an output artefact --- is out of date when its value is not the value that would be computed by a --- build given the current values of the inputs. An output artefact can be --- out-of-date but still be perfectly usable; it simply correspond to a --- previous state of the inputs. --- --- On the other hand there are cases where output artefacts cannot safely be --- used. For example libraries and dynamically linked executables cannot be --- used when the libs they depend on change without them being recompiled --- themselves. Whether an artefact is still usable depends on what it is, e.g. --- dynamically linked vs statically linked and on how it gets updated (e.g. --- only atomically on success or if failure can leave invalid states). We need --- a definition (or two) that is independent of the kind of artefact and can --- be computed just in terms of changes in package graphs, but are still --- useful for determining when particular kinds of artefacts are invalid. --- --- Note that when we talk about packages in this context we just mean nodes --- in the elaborated install plan, which can be components or packages. --- --- There's obviously a close connection between packages being out of date and --- their output artefacts being unusable: most of the time if a package --- remains out of date at the end of a build then some of its output artefacts --- will be unusable. That is true most of the time because a build will have --- attempted to build one of the out-of-date package's dependencies. If the --- build of the dependency succeeded then it changed output artefacts (like --- libs) and if it failed then it may have failed after already changing --- things (think failure after updating some but not all .hi files). --- --- There are a few reasons we may end up with still-usable output artefacts --- for a package even when it remains out of date at the end of a build. --- Firstly if executing a plan fails then packages can be skipped, and thus we --- may have packages where all their dependencies were skipped. Secondly we --- have artefacts like statically linked executables which are not affected by --- libs they depend on being recompiled. Furthermore, packages can be out of --- date due to changes in build tools or Setup.hs scripts they depend on, but --- again libraries or executables in those out-of-date packages remain usable. --- --- So we have two useful definitions of invalid. Both are useful, for --- different purposes, so we will compute both. The first corresponds to the --- invalid libraries and dynamic executables. We say a package is invalid by --- changed deps if any of the packages it depends on (via library dep edges) --- were rebuilt (successfully or unsuccessfully). The second definition --- corresponds to invalid static executables. We say a package is invalid by --- a failed build simply if the package was built but unsuccessfully. --- --- So how do we find out what packages are out of date or invalid? --- --- Obviously we know something for all the packages that were part of the plan --- that was executed, but that is just a subset since we prune the plan down --- to the targets and their dependencies. --- --- Recall the steps we go though: --- --- + starting with the initial improved plan (this is the full project); --- --- + prune the plan to the user's build targets; --- --- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap --- covering the pruned subset of the original plan; --- --- + execute the plan giving us BuildOutcomes which tell us success/failure --- for each package. --- --- So given that the BuildStatusMap and BuildOutcomes do not cover everything --- in the original plan, what can they tell us about the original plan? --- --- The BuildStatusMap tells us directly that some packages are up to date and --- others out of date (but only for the pruned subset). But we know that --- everything that is a reverse dependency of an out-of-date package is itself --- out-of-date (whether or not it is in the pruned subset). Of course after --- a build the BuildOutcomes may tell us that some of those out-of-date --- packages are now up to date (ie a successful build outcome). --- --- The difference is packages that are reverse dependencies of out-of-date --- packages but are not brought up-to-date by the build (i.e. did not have --- successful outcomes, either because they failed or were not in the pruned --- subset to be built). We also know which packages were rebuilt, so we can --- use this to find the now-invalid packages. --- --- Note that there are still packages for which we cannot discover full status --- information. There may be packages outside of the pruned plan that do not --- depend on packages within the pruned plan that were discovered to be --- out-of-date. For these packages we do not know if their build artefacts --- are out-of-date or not. We do know however that they are not invalid, as --- that's not possible given our definition of invalid. Intuitively it is --- because we have not disturbed anything that these packages depend on, e.g. --- we've not rebuilt any libs they depend on. Recall that our widest --- definition of invalid was only concerned about dependencies on libraries --- (to cover problems like shared libs or GHC seeing inconsistent .hi files). --- --- So our algorithm for out-of-date packages is relatively simple: take the --- reverse dependency closure in the original improved plan (pre-pruning) of --- the out-of-date packages (as determined by the BuildStatusMap from the dry --- run). That gives a set of packages that were definitely out of date after --- the dry run. Now we remove from this set the packages that the --- BuildOutcomes tells us are now up-to-date after the build. The remaining --- set is the out-of-date packages. --- --- As for packages that are invalid by changed deps, we start with the plan --- dependency graph but keep only those edges that point to libraries (so --- ignoring deps on exes and setup scripts). We take the packages for which a --- build was attempted (successfully or unsuccessfully, but not counting --- knock-on failures) and take the reverse dependency closure. We delete from --- this set all the packages that were built successfully. Note that we do not --- need to intersect with the out-of-date packages since this follows --- automatically: all rev deps of packages we attempted to build must have --- been out of date at the start of the build, and if they were not built --- successfully then they're still out of date -- meeting our definition of --- invalid. - - -type PackageIdSet = Set UnitId -type PackagesUpToDate = PackageIdSet - -data PostBuildProjectStatus = PostBuildProjectStatus { - - -- | Packages that are known to be up to date. These were found to be - -- up to date before the build, or they have a successful build outcome - -- afterwards. - -- - -- This does not include any packages outside of the subset of the plan - -- that was executed because we did not check those and so don't know - -- for sure that they're still up to date. - -- - packagesDefinitelyUpToDate :: PackageIdSet, - - -- | Packages that are probably still up to date (and at least not - -- known to be out of date, and certainly not invalid). This includes - -- 'packagesDefinitelyUpToDate' plus packages that were up to date - -- previously and are outside of the subset of the plan that was - -- executed. It excludes 'packagesOutOfDate'. - -- - packagesProbablyUpToDate :: PackageIdSet, - - -- | Packages that are known to be out of date. These are packages - -- that were determined to be out of date before the build, and they - -- do not have a successful build outcome afterwards. - -- - -- Note that this can sometimes include packages outside of the subset - -- of the plan that was executed. For example suppose package A and B - -- depend on C, and A is the target so only A and C are in the subset - -- to be built. Now suppose C is found to have changed, then both A - -- and B are out-of-date before the build and since B is outside the - -- subset to be built then it will remain out of date. - -- - -- Note also that this is /not/ the inverse of - -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. - -- There are packages where we have no information (ones that were not - -- in the subset of the plan that was executed). - -- - packagesOutOfDate :: PackageIdSet, - - -- | Packages that depend on libraries that have changed during the - -- build (either build success or failure). - -- - -- This corresponds to the fact that libraries and dynamic executables - -- are invalid once any of the libs they depend on change. - -- - -- This does include packages that themselves failed (i.e. it is a - -- superset of 'packagesInvalidByFailedBuild'). It does not include - -- changes in dependencies on executables (i.e. build tools). - -- - packagesInvalidByChangedLibDeps :: PackageIdSet, - - -- | Packages that themselves failed during the build (i.e. them - -- directly not a dep). - -- - -- This corresponds to the fact that static executables are invalid - -- in unlucky circumstances such as linking failing half way though, - -- or data file generation failing. - -- - -- This is a subset of 'packagesInvalidByChangedLibDeps'. - -- - packagesInvalidByFailedBuild :: PackageIdSet, - - -- | A subset of the plan graph, including only dependency-on-library - -- edges. That is, dependencies /on/ libraries, not dependencies /of/ - -- libraries. This tells us all the libraries that packages link to. - -- - -- This is here as a convenience, as strictly speaking it's not status - -- as it's just a function of the original 'ElaboratedInstallPlan'. - -- - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage), - - -- | As a convenience for 'Set.intersection' with any of the other - -- 'PackageIdSet's to select only packages that are part of the - -- project locally (i.e. with a local source dir). - -- - packagesBuildLocal :: PackageIdSet, - - -- | As a convenience for 'Set.intersection' with any of the other - -- 'PackageIdSet's to select only packages that are being built - -- in-place within the project (i.e. not destined for the store). - -- - packagesBuildInplace :: PackageIdSet, - - -- | As a convenience for 'Set.intersection' or 'Set.difference' with - -- any of the other 'PackageIdSet's to select only packages that were - -- pre-installed or already in the store prior to the build. - -- - packagesAlreadyInStore :: PackageIdSet - } - --- | Work out which packages are out of date or invalid after a build. --- -postBuildProjectStatus :: ElaboratedInstallPlan - -> PackagesUpToDate - -> BuildStatusMap - -> BuildOutcomes - -> PostBuildProjectStatus -postBuildProjectStatus plan previousPackagesUpToDate - pkgBuildStatus buildOutcomes = - PostBuildProjectStatus { - packagesDefinitelyUpToDate, - packagesProbablyUpToDate, - packagesOutOfDate, - packagesInvalidByChangedLibDeps, - packagesInvalidByFailedBuild, - -- convenience stuff - packagesLibDepGraph, - packagesBuildLocal, - packagesBuildInplace, - packagesAlreadyInStore - } - where - packagesDefinitelyUpToDate = - packagesUpToDatePreBuild - `Set.union` - packagesSuccessfulPostBuild - - packagesProbablyUpToDate = - packagesDefinitelyUpToDate - `Set.union` - (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) - - packagesOutOfDate = - packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild - - packagesInvalidByChangedLibDeps = - packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild - - packagesInvalidByFailedBuild = - packagesFailurePostBuild - - -- Note: if any of the intermediate values below turn out to be useful in - -- their own right then we can simply promote them to the result record - - -- The previous set of up-to-date packages will contain bogus package ids - -- when the solver plan or config contributing to the hash changes. - -- So keep only the ones where the package id (i.e. hash) is the same. - previousPackagesUpToDate' = - Set.intersection - previousPackagesUpToDate - (InstallPlan.keysSet plan) - - packagesUpToDatePreBuild = - Set.filter - (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) - -- For packages not in the plan subset we did the dry-run on we don't - -- know anything about their status, so not known to be /up to date/. - (InstallPlan.keysSet plan) - - packagesOutOfDatePreBuild = - Set.fromList . map installedUnitId $ - InstallPlan.reverseDependencyClosure plan - [ ipkgid - | pkg <- InstallPlan.toList plan - , let ipkgid = installedUnitId pkg - , lookupBuildStatusRequiresBuild False ipkgid - -- For packages not in the plan subset we did the dry-run on we don't - -- know anything about their status, so not known to be /out of date/. - ] - - packagesSuccessfulPostBuild = - Set.fromList - [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ] - - -- direct failures, not failures due to deps - packagesFailurePostBuild = - Set.fromList - [ ikgid - | (ikgid, Left failure) <- Map.toList buildOutcomes - , case buildFailureReason failure of - DependentFailed _ -> False - _ -> True - ] - - -- Packages that have a library dependency on a package for which a build - -- was attempted - packagesDepOnChangedLib = - Set.fromList . map Graph.nodeKey $ - fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ - Graph.revClosure packagesLibDepGraph - ( Map.keys - . Map.filter (uncurry buildAttempted) - $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes - ) - - -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) - packagesLibDepGraph = - Graph.fromDistinctList - [ Graph.N pkg (installedUnitId pkg) libdeps - | pkg <- InstallPlan.toList plan - , let libdeps = case pkg of - InstallPlan.PreExisting ipkg -> installedDepends ipkg - InstallPlan.Configured srcpkg -> elabLibDeps srcpkg - InstallPlan.Installed srcpkg -> elabLibDeps srcpkg - ] - elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies - - -- Was a build was attempted for this package? - -- If it doesn't have both a build status and outcome then the answer is no. - buildAttempted :: BuildStatus -> BuildOutcome -> Bool - -- And not if it didn't need rebuilding in the first place. - buildAttempted buildStatus _buildOutcome - | not (buildStatusRequiresBuild buildStatus) - = False - - -- And not if it was skipped due to a dep failing first. - buildAttempted _ (Left BuildFailure {buildFailureReason}) - | DependentFailed _ <- buildFailureReason - = False - - -- Otherwise, succeeded or failed, yes the build was tried. - buildAttempted _ (Left BuildFailure {}) = True - buildAttempted _ (Right _) = True - - lookupBuildStatusRequiresBuild def ipkgid = - case Map.lookup ipkgid pkgBuildStatus of - Nothing -> def -- Not in the plan subset we did the dry-run on - Just buildStatus -> buildStatusRequiresBuild buildStatus - - packagesBuildLocal = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> False - InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg - - packagesBuildInplace = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> False - InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg - == BuildInplaceOnly - - packagesAlreadyInStore = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> True - InstallPlan.Installed _ -> True - InstallPlan.Configured _ -> False - - selectPlanPackageIdSet p = Map.keysSet - . Map.filter p - $ InstallPlan.toMap plan - - - -updatePostBuildProjectStatus :: Verbosity - -> DistDirLayout - -> ElaboratedInstallPlan - -> BuildStatusMap - -> BuildOutcomes - -> IO PostBuildProjectStatus -updatePostBuildProjectStatus verbosity distDirLayout - elaboratedInstallPlan - pkgsBuildStatus buildOutcomes = do - - -- Read the previous up-to-date set, update it and write it back - previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout - let currentBuildStatus@PostBuildProjectStatus{..} - = postBuildProjectStatus - elaboratedInstallPlan - previousUpToDate - pkgsBuildStatus - buildOutcomes - let currentUpToDate = packagesProbablyUpToDate - writePackagesUpToDateCacheFile distDirLayout currentUpToDate - - -- Report various possibly interesting things - -- We additionally intersect with the packagesBuildInplace so that - -- we don't show huge numbers of boring packages from the store. - debugNoWrap verbosity $ - "packages definitely up to date: " - ++ displayPackageIdSet (packagesDefinitelyUpToDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages previously probably up to date: " - ++ displayPackageIdSet (previousUpToDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages now probably up to date: " - ++ displayPackageIdSet (packagesProbablyUpToDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages newly up to date: " - ++ displayPackageIdSet (packagesDefinitelyUpToDate - `Set.difference` previousUpToDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages out to date: " - ++ displayPackageIdSet (packagesOutOfDate - `Set.intersection` packagesBuildInplace) - - debugNoWrap verbosity $ - "packages invalid due to dep change: " - ++ displayPackageIdSet packagesInvalidByChangedLibDeps - - debugNoWrap verbosity $ - "packages invalid due to build failure: " - ++ displayPackageIdSet packagesInvalidByFailedBuild - - return currentBuildStatus - where - displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList - --- | Helper for reading the cache file. --- --- This determines the type and format of the binary cache file. --- -readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate -readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = - handleDoesNotExist Set.empty $ - handleDecodeFailure $ - withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> - Binary.decodeOrFailIO =<< BS.hGetContents hnd - where - handleDecodeFailure = fmap (either (const Set.empty) id) - --- | Helper for writing the package up-to-date cache file. --- --- This determines the type and format of the binary cache file. --- -writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () -writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = - writeFileAtomic (distProjectCacheFile "up-to-date") $ - Binary.encode upToDate - --- | Prepare a package environment that includes all the library dependencies --- for a plan. --- --- When running cabal new-exec, we want to set things up so that the compiler --- can find all the right packages (and nothing else). This function is --- intended to do that work. It takes a location where it can write files --- temporarily, in case the compiler wants to learn this information via the --- filesystem, and returns any environment variable overrides the compiler --- needs. -createPackageEnvironment :: Verbosity - -> FilePath - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> PostBuildProjectStatus - -> IO [(String, Maybe String)] -createPackageEnvironment verbosity - path - elaboratedPlan - elaboratedShared - buildStatus - | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC - = do - envFileM <- writePlanGhcEnvironment - path - elaboratedPlan - elaboratedShared - buildStatus - case envFileM of - Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] - Nothing -> do - warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" - return [] - | otherwise - = do - warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" - return [] - --- Writing .ghc.environment files --- - -writePlanGhcEnvironment :: FilePath - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> PostBuildProjectStatus - -> IO (Maybe FilePath) -writePlanGhcEnvironment path - elaboratedInstallPlan - ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigPlatform = platform - } - postBuildStatus - | compilerFlavor compiler == GHC - , supportsPkgEnvFiles (getImplInfo compiler) - --TODO: check ghcjs compat - = fmap Just $ writeGhcEnvironmentFile - path - platform (compilerVersion compiler) - (renderGhcEnvironmentFile path - elaboratedInstallPlan - postBuildStatus) - --TODO: [required eventually] support for writing user-wide package - -- environments, e.g. like a global project, but we would not put the - -- env file in the home dir, rather it lives under ~/.ghc/ - -writePlanGhcEnvironment _ _ _ _ = return Nothing - -renderGhcEnvironmentFile :: FilePath - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry] -renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan - postBuildStatus = - headerComment - : simpleGhcEnvironmentFile packageDBs unitIds - where - headerComment = - GhcEnvFileComment - $ "This is a GHC environment file written by cabal. This means you can\n" - ++ "run ghc or ghci and get the environment of the project as a whole.\n" - ++ "But you still need to use cabal repl $target to get the environment\n" - ++ "of specific components (libs, exes, tests etc) because each one can\n" - ++ "have its own source dirs, cpp flags etc.\n\n" - unitIds = selectGhcEnvironmentFileLibraries postBuildStatus - packageDBs = relativePackageDBPaths projectRootDir $ - selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan - - -argsEquivalentOfGhcEnvironmentFile - :: Compiler - -> DistDirLayout - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [String] -argsEquivalentOfGhcEnvironmentFile compiler = - case compilerId compiler - of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc - CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc - CompilerId _ _ -> error "Only GHC and GHCJS are supported" - --- TODO remove this when we drop support for non-.ghc.env ghc -argsEquivalentOfGhcEnvironmentFileGhc - :: DistDirLayout - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [String] -argsEquivalentOfGhcEnvironmentFileGhc - distDirLayout - elaboratedInstallPlan - postBuildStatus = - clearPackageDbStackFlag - ++ packageDbArgsDb packageDBs - ++ foldMap packageIdFlag packageIds - where - projectRootDir = distProjectRootDirectory distDirLayout - packageIds = selectGhcEnvironmentFileLibraries postBuildStatus - packageDBs = relativePackageDBPaths projectRootDir $ - selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan - -- TODO use proper flags? but packageDbArgsDb is private - clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] - packageIdFlag uid = ["-package-id", prettyShow uid] - - --- We're producing an environment for users to use in ghci, so of course --- that means libraries only (can't put exes into the ghc package env!). --- The library environment should be /consistent/ with the environment --- that each of the packages in the project use (ie same lib versions). --- So that means all the normal library dependencies of all the things --- in the project (including deps of exes that are local to the project). --- We do not however want to include the dependencies of Setup.hs scripts, --- since these are generally uninteresting but also they need not in --- general be consistent with the library versions that packages local to --- the project use (recall that Setup.hs script's deps can be picked --- independently of other packages in the project). --- --- So, our strategy is as follows: --- --- produce a dependency graph of all the packages in the install plan, --- but only consider normal library deps as edges in the graph. Thus we --- exclude the dependencies on Setup.hs scripts (in the case of --- per-component granularity) or of Setup.hs scripts (in the case of --- per-package granularity). Then take a dependency closure, using as --- roots all the packages/components local to the project. This will --- exclude Setup scripts and their dependencies. --- --- Note: this algorithm will have to be adapted if/when the install plan --- is extended to cover multiple compilers at once, and may also have to --- change if we start to treat unshared deps of test suites in a similar --- way to how we treat Setup.hs script deps (ie being able to pick them --- independently). --- --- Since we had to use all the local packages, including exes, (as roots --- to find the libs) then those exes still end up in our list so we have --- to filter them out at the end. --- -selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] -selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = - case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of - Nothing -> error "renderGhcEnvironmentFile: broken dep closure" - Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes - , hasUpToDateLib pkg ] - where - hasUpToDateLib planpkg = case planpkg of - -- A pre-existing global lib - InstallPlan.PreExisting _ -> True - - -- A package in the store. Check it's a lib. - InstallPlan.Installed pkg -> elabRequiresRegistration pkg - - -- A package we were installing this time, either destined for the store - -- or just locally. Check it's a lib and that it is probably up to date. - InstallPlan.Configured pkg -> - elabRequiresRegistration pkg - && installedUnitId pkg `Set.member` packagesProbablyUpToDate - - -selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack -selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = - -- If we have any inplace packages then their package db stack is the - -- one we should use since it'll include the store + the local db but - -- it's certainly possible to have no local inplace packages - -- e.g. just "extra" packages coming from the store. - case (inplacePackages, sourcePackages) of - ([], pkgs) -> checkSamePackageDBs pkgs - (pkgs, _) -> checkSamePackageDBs pkgs - where - checkSamePackageDBs pkgs = - case ordNub (map elabBuildPackageDBStack pkgs) of - [packageDbs] -> packageDbs - [] -> [] - _ -> error $ "renderGhcEnvironmentFile: packages with " - ++ "different package db stacks" - -- This should not happen at the moment but will happen as soon - -- as we support projects where we build packages with different - -- compilers, at which point we have to consider how to adapt - -- this feature, e.g. write out multiple env files, one for each - -- compiler / project profile. - - inplacePackages = - [ srcpkg - | srcpkg <- sourcePackages - , elabBuildStyle srcpkg == BuildInplaceOnly ] - sourcePackages = - [ srcpkg - | pkg <- InstallPlan.toList elaboratedInstallPlan - , srcpkg <- maybeToList $ case pkg of - InstallPlan.Configured srcpkg -> Just srcpkg - InstallPlan.Installed srcpkg -> Just srcpkg - InstallPlan.PreExisting _ -> Nothing - ] - -relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack -relativePackageDBPaths relroot = map (relativePackageDBPath relroot) - -relativePackageDBPath :: FilePath -> PackageDB -> PackageDB -relativePackageDBPath relroot pkgdb = - case pkgdb of - GlobalPackageDB -> GlobalPackageDB - UserPackageDB -> UserPackageDB - SpecificPackageDB path -> SpecificPackageDB relpath - where relpath = makeRelative relroot path diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs deleted file mode 100644 --- a/Distribution/Client/ProjectPlanning.hs +++ /dev/null @@ -1,3800 +0,0 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} - --- | Planning how to build everything in a project. --- -module Distribution.Client.ProjectPlanning ( - -- * elaborated install plan types - ElaboratedInstallPlan, - ElaboratedConfiguredPackage(..), - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, - - -- * Producing the elaborated install plan - rebuildProjectConfig, - rebuildInstallPlan, - - -- * Build targets - availableTargets, - AvailableTarget(..), - AvailableTargetStatus(..), - TargetRequested(..), - ComponentTarget(..), - SubComponentTarget(..), - showComponentTarget, - nubComponentTargets, - - -- * Selecting a plan subset - pruneInstallPlanToTargets, - TargetAction(..), - pruneInstallPlanToDependencies, - CannotPruneDependencies(..), - - -- * Utils required for building - pkgHasEphemeralBuildTargets, - elabBuildTargetWholeComponents, - - -- * Setup.hs CLI flags for building - setupHsScriptOptions, - setupHsConfigureFlags, - setupHsConfigureArgs, - setupHsBuildFlags, - setupHsBuildArgs, - setupHsReplFlags, - setupHsReplArgs, - setupHsTestFlags, - setupHsTestArgs, - setupHsBenchFlags, - setupHsBenchArgs, - setupHsCopyFlags, - setupHsRegisterFlags, - setupHsHaddockFlags, - setupHsHaddockArgs, - - packageHashInputs, - - -- * Path construction - binDirectoryFor, - binDirectories, - storePackageInstallDirs, - storePackageInstallDirs' - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.HashValue -import Distribution.Client.ProjectPlanning.Types as Ty -import Distribution.Client.PackageHash -import Distribution.Client.RebuildMonad -import Distribution.Client.Store -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanOutput - -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import qualified Distribution.Client.IndexUtils as IndexUtils -import Distribution.Client.Init (incVersion) -import Distribution.Client.Targets (userToPackageConstraint) -import Distribution.Client.DistDirLayout -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import Distribution.Client.Config -import qualified Hackage.Security.Client as Sec -import Distribution.Client.Setup hiding (packageName, cabalVersion) -import Distribution.Utils.NubList -import Distribution.Utils.LogProgress -import Distribution.Utils.MapAccum - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings - -import Distribution.CabalSpecVersion -import Distribution.ModuleName -import Distribution.Package -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.Types.GivenComponent - (GivenComponent(..)) -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.PkgconfigDependency -import Distribution.Types.UnqualComponentName -import Distribution.System -import qualified Distribution.PackageDescription as Cabal -import qualified Distribution.PackageDescription as PD -import qualified Distribution.PackageDescription.Configuration as PD -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Compiler -import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate -import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate -import Distribution.Simple.Program -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Find -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Setup - (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault) -import qualified Distribution.Simple.Configure as Cabal -import qualified Distribution.Simple.LocalBuildInfo as Cabal -import Distribution.Simple.LocalBuildInfo - ( Component(..), pkgComponents, componentBuildInfo - , componentName ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.InstalledPackageInfo as IPI - -import Distribution.Backpack.ConfiguredComponent -import Distribution.Backpack.LinkedComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.FullUnitId -import Distribution.Backpack -import Distribution.Types.ComponentInclude - -import Distribution.Simple.Utils -import Distribution.Version - -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph(IsNode(..)) - -import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma) -import qualified Text.PrettyPrint as Disp -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Monad.State as State -import Control.Exception (assert) -import Data.List (groupBy) -import qualified Data.List.NonEmpty as NE -import System.FilePath - ------------------------------------------------------------------------------- --- * Elaborated install plan ------------------------------------------------------------------------------- - --- "Elaborated" -- worked out with great care and nicety of detail; --- executed with great minuteness: elaborate preparations; --- elaborate care. --- --- So here's the idea: --- --- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc --- all passed in as separate args and which are then further selected, --- transformed etc during the execution of the build. Instead we construct --- an elaborated install plan that includes everything we will need, and then --- during the execution of the plan we do as little transformation of this --- info as possible. --- --- So we're trying to split the work into two phases: construction of the --- elaborated install plan (which as far as possible should be pure) and --- then simple execution of that plan without any smarts, just doing what the --- plan says to do. --- --- So that means we need a representation of this fully elaborated install --- plan. The representation consists of two parts: --- --- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a --- representation of source packages that includes a lot more detail about --- that package's individual configuration --- --- * A 'ElaboratedSharedConfig'. Some package configuration is the same for --- every package in a plan. Rather than duplicate that info every entry in --- the 'GenericInstallPlan' we keep that separately. --- --- The division between the shared and per-package config is /not set in stone --- for all time/. For example if we wanted to generalise the install plan to --- describe a situation where we want to build some packages with GHC and some --- with GHCJS then the platform and compiler would no longer be shared between --- all packages but would have to be per-package (probably with some sanity --- condition on the graph structure). --- - --- Refer to ProjectPlanning.Types for details of these important types: - --- type ElaboratedInstallPlan = ... --- type ElaboratedPlanPackage = ... --- data ElaboratedSharedConfig = ... --- data ElaboratedConfiguredPackage = ... --- data BuildStyle = - - --- | Check that an 'ElaboratedConfiguredPackage' actually makes --- sense under some 'ElaboratedSharedConfig'. -sanityCheckElaboratedConfiguredPackage - :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> a - -> a -sanityCheckElaboratedConfiguredPackage sharedConfig - elab@ElaboratedConfiguredPackage{..} = - (case elabPkgOrComp of - ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg - ElabComponent comp -> sanityCheckElaboratedComponent elab comp) - - -- either a package is being built inplace, or the - -- 'installedPackageId' we assigned is consistent with - -- the 'hashedInstalledPackageId' we would compute from - -- the elaborated configured package - . assert (elabBuildStyle == BuildInplaceOnly || - elabComponentId == hashedInstalledPackageId - (packageHashInputs sharedConfig elab)) - - -- the stanzas explicitly disabled should not be available - . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested) - `Set.intersection` elabStanzasAvailable)) - - -- either a package is built inplace, or we are not attempting to - -- build any test suites or benchmarks (we never build these - -- for remote packages!) - . assert (elabBuildStyle == BuildInplaceOnly || - Set.null elabStanzasAvailable) - -sanityCheckElaboratedComponent - :: ElaboratedConfiguredPackage - -> ElaboratedComponent - -> a - -> a -sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} - ElaboratedComponent{..} = - - -- Should not be building bench or test if not inplace. - assert (elabBuildStyle == BuildInplaceOnly || - case compComponentName of - Nothing -> True - Just (CLibName _) -> True - Just (CExeName _) -> True - -- This is interesting: there's no way to declare a dependency - -- on a foreign library at the moment, but you may still want - -- to install these to the store - Just (CFLibName _) -> True - Just (CBenchName _) -> False - Just (CTestName _) -> False) - - -sanityCheckElaboratedPackage - :: ElaboratedConfiguredPackage - -> ElaboratedPackage - -> a - -> a -sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} - ElaboratedPackage{..} = - -- we should only have enabled stanzas that actually can be built - -- (according to the solver) - assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable) - - -- the stanzas that the user explicitly requested should be - -- enabled (by the previous test, they are also available) - . assert (Map.keysSet (Map.filter id elabStanzasRequested) - `Set.isSubsetOf` pkgStanzasEnabled) - ------------------------------------------------------------------------------- --- * Deciding what to do: making an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------- - --- | Return the up-to-date project config and information about the local --- packages within the project. --- -rebuildProjectConfig :: Verbosity - -> DistDirLayout - -> ProjectConfig - -> IO ( ProjectConfig - , [PackageSpecifier UnresolvedSourcePackage] ) -rebuildProjectConfig verbosity - distDirLayout@DistDirLayout { - distProjectRootDirectory, - distDirectory, - distProjectCacheFile, - distProjectCacheDirectory, - distProjectFile - } - cliConfig = do - - fileMonitorProjectConfigKey <- do - configPath <- getConfigFilePath projectConfigConfigFile - return (configPath, distProjectFile "") - - (projectConfig, localPackages) <- - runRebuild distProjectRootDirectory - $ rerunIfChanged verbosity - fileMonitorProjectConfig - fileMonitorProjectConfigKey - $ do - liftIO $ info verbosity "Project settings changed, reconfiguring..." - projectConfig <- phaseReadProjectConfig - localPackages <- phaseReadLocalPackages projectConfig - return (projectConfig, localPackages) - - info verbosity - $ unlines - $ ("this build was affected by the following (project) config files:" :) - $ [ "- " ++ path - | Explicit path <- Set.toList $ projectConfigProvenance projectConfig - ] - - return (projectConfig <> cliConfig, localPackages) - - where - - ProjectConfigShared { projectConfigConfigFile } = - projectConfigShared cliConfig - - fileMonitorProjectConfig = - newFileMonitor (distProjectCacheFile "config") :: FileMonitor - (FilePath, FilePath) - (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage]) - - -- Read the cabal.project (or implicit config) and combine it with - -- arguments from the command line - -- - phaseReadProjectConfig :: Rebuild ProjectConfig - phaseReadProjectConfig = do - readProjectConfig verbosity projectConfigConfigFile distDirLayout - - -- Look for all the cabal packages in the project - -- some of which may be local src dirs, tarballs etc - -- - phaseReadLocalPackages :: ProjectConfig - -> Rebuild [PackageSpecifier UnresolvedSourcePackage] - phaseReadLocalPackages projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } = do - pkgLocations <- findProjectPackages distDirLayout projectConfig - - -- Create folder only if findProjectPackages did not throw a - -- BadPackageLocations exception. - liftIO $ do - createDirectoryIfMissingVerbose verbosity True distDirectory - createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - - fetchAndReadSourcePackages verbosity distDirLayout - projectConfigShared - projectConfigBuildOnly - pkgLocations - - --- | Return an up-to-date elaborated install plan. --- --- Two variants of the install plan are returned: with and without packages --- from the store. That is, the \"improved\" plan where source packages are --- replaced by pre-existing installed packages from the store (when their ids --- match), and also the original elaborated plan which uses primarily source --- packages. - --- The improved plan is what we use for building, but the original elaborated --- plan is useful for reporting and configuration. For example the @freeze@ --- command needs the source package info to know about flag choices and --- dependencies of executables and setup scripts. --- -rebuildInstallPlan :: Verbosity - -> DistDirLayout -> CabalDirLayout - -> ProjectConfig - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO ( ElaboratedInstallPlan -- with store packages - , ElaboratedInstallPlan -- with source packages - , ElaboratedSharedConfig - , IndexUtils.TotalIndexState - , IndexUtils.ActiveRepos - ) - -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ -rebuildInstallPlan verbosity - distDirLayout@DistDirLayout { - distProjectRootDirectory, - distProjectCacheFile - } - CabalDirLayout { - cabalStoreDirLayout - } = \projectConfig localPackages -> - runRebuild distProjectRootDirectory $ do - progsearchpath <- liftIO $ getSystemSearchPath - let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } - - -- The overall improved plan is cached - rerunIfChanged verbosity fileMonitorImprovedPlan - -- react to changes in the project config, - -- the package .cabal files and the path - (projectConfigMonitored, localPackages, progsearchpath) $ do - - -- And so is the elaborated plan that the improved plan based on - (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <- - rerunIfChanged verbosity fileMonitorElaboratedPlan - (projectConfigMonitored, localPackages, - progsearchpath) $ do - - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) - <- phaseRunSolver projectConfig - compilerEtc - localPackages - (elaboratedPlan, - elaboratedShared) <- phaseElaboratePlan projectConfig - compilerEtc pkgConfigDB - solverPlan - localPackages - - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared - return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - - -- The improved plan changes each time we install something, whereas - -- the underlying elaborated plan only changes when input config - -- changes, so it's worth caching them separately. - improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared - - return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - - where - fileMonitorCompiler = newFileMonitorInCacheDir "compiler" - fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" - fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" - fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" - fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" - - newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b - newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile - - - -- Configure the compiler we're using. - -- - -- This is moderately expensive and doesn't change that often so we cache - -- it independently. - -- - phaseConfigureCompiler :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) - phaseConfigureCompiler ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra - } - } = do - progsearchpath <- liftIO $ getSystemSearchPath - rerunIfChanged verbosity fileMonitorCompiler - (hcFlavor, hcPath, hcPkg, progsearchpath, - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra) $ do - - liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - result@(_, _, progdb') <- liftIO $ - Cabal.configCompilerEx - hcFlavor hcPath hcPkg - progdb verbosity - - -- Note that we added the user-supplied program locations and args - -- for /all/ programs, not just those for the compiler prog and - -- compiler-related utils. In principle we don't know which programs - -- the compiler will configure (and it does vary between compilers). - -- We do know however that the compiler will only configure the - -- programs it cares about, and those are the ones we monitor here. - monitorFiles (programsMonitorFiles progdb') - - return result - where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg - progdb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) - $ defaultProgramDb - - - -- Configuring other programs. - -- - -- Having configred the compiler, now we configure all the remaining - -- programs. This is to check we can find them, and to monitor them for - -- changes. - -- - -- TODO: [required eventually] we don't actually do this yet. - -- - -- We rely on the fact that the previous phase added the program config for - -- all local packages, but that all the programs configured so far are the - -- compiler program or related util programs. - -- - phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do - -- Users are allowed to specify program locations independently for - -- each package (e.g. to use a particular version of a pre-processor - -- for some packages). However they cannot do this for the compiler - -- itself as that's just not going to work. So we check for this. - liftIO $ checkBadPerPackageCompilerPaths - (configuredPrograms compilerprogdb) - (getMapMappend (projectConfigSpecificPackage projectConfig)) - - --TODO: [required eventually] find/configure other programs that the - -- user specifies. - - --TODO: [required eventually] find/configure all build-tools - -- but note that some of them may be built as part of the plan. - - - -- Run the solver to get the initial install plan. - -- This is expensive so we cache it independently. - -- - phaseRunSolver - :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> [PackageSpecifier UnresolvedSourcePackage] - -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) - phaseRunSolver projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } - (compiler, platform, progdb) - localPackages = - rerunIfChanged verbosity fileMonitorSolverPlan - (solverSettings, - localPackages, localPackagesEnabledStanzas, - compiler, platform, programDbSignature progdb) $ do - - installedPkgIndex <- getInstalledPackages verbosity - compiler progdb platform - corePackageDbs - (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx - (solverSettingIndexState solverSettings) - (solverSettingActiveRepos solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb - - --TODO: [code cleanup] it'd be better if the Compiler contained the - -- ConfiguredPrograms that it needs, rather than relying on the progdb - -- since we don't need to depend on all the programs here, just the - -- ones relevant for the compiler. - - liftIO $ do - solver <- chooseSolver verbosity - (solverSettingSolver solverSettings) - (compilerInfo compiler) - - notice verbosity "Resolving dependencies..." - plan <- foldProgress logMsg (die' verbosity) return $ - planPackages verbosity compiler platform solver solverSettings - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages localPackagesEnabledStanzas - return (plan, pkgConfigDB, tis, ar) - where - corePackageDbs = [GlobalPackageDB] - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - solverSettings = resolveSolverSettings projectConfig - logMsg message rest = debugNoWrap verbosity message >> rest - - localPackagesEnabledStanzas = - Map.fromList - [ (pkgname, stanzas) - | pkg <- localPackages - -- TODO: misnormer: we should separate - -- builtin/global/inplace/local packages - -- and packages explicitly mentioned in the project - -- - , let pkgname = pkgSpecifierTarget pkg - testsEnabled = lookupLocalPackageConfig - packageConfigTests - projectConfig pkgname - benchmarksEnabled = lookupLocalPackageConfig - packageConfigBenchmarks - projectConfig pkgname - isLocal = isJust (shouldBeLocal pkg) - stanzas - | isLocal = Map.fromList $ - [ (TestStanzas, enabled) - | enabled <- flagToList testsEnabled ] ++ - [ (BenchStanzas , enabled) - | enabled <- flagToList benchmarksEnabled ] - | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ] - ] - - -- Elaborate the solver's install plan to get a fully detailed plan. This - -- version of the plan has the final nix-style hashed ids. - -- - phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> PkgConfigDb - -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] - -> Rebuild ( ElaboratedInstallPlan - , ElaboratedSharedConfig ) - phaseElaboratePlan ProjectConfig { - projectConfigShared, - projectConfigAllPackages, - projectConfigLocalPackages, - projectConfigSpecificPackage, - projectConfigBuildOnly - } - (compiler, platform, progdb) pkgConfigDB - solverPlan localPackages = do - - liftIO $ debug verbosity "Elaborating the install plan..." - - sourcePackageHashes <- - rerunIfChanged verbosity fileMonitorSourceHashes - (packageLocationsSignature solverPlan) $ - getPackageSourceHashes verbosity withRepoCtx solverPlan - - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - (elaboratedPlan, elaboratedShared) - <- liftIO . runLogProgress verbosity $ - elaborateInstallPlan - verbosity - platform compiler progdb pkgConfigDB - distDirLayout - cabalStoreDirLayout - solverPlan - localPackages - sourcePackageHashes - defaultInstallDirs - projectConfigShared - projectConfigAllPackages - projectConfigLocalPackages - (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan - = instantiateInstallPlan - cabalStoreDirLayout - defaultInstallDirs - elaboratedShared - elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) - return (instantiatedPlan, elaboratedShared) - where - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - - -- Update the files we maintain that reflect our current build environment. - -- In particular we maintain a JSON representation of the elaborated - -- install plan (but not the improved plan since that reflects the state - -- of the build rather than just the input environment). - -- - phaseMaintainPlanOutputs :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild () - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do - debug verbosity "Updating plan.json" - writePlanExternalRepresentation - distDirLayout - elaboratedPlan - elaboratedShared - - - -- Improve the elaborated install plan. The elaborated plan consists - -- mostly of source packages (with full nix-style hashed ids). Where - -- corresponding installed packages already exist in the store, replace - -- them in the plan. - -- - -- Note that we do monitor the store's package db here, so we will redo - -- this improvement phase when the db changes -- including as a result of - -- executing a plan and installing things. - -- - phaseImprovePlan :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan elaboratedShared = do - - liftIO $ debug verbosity "Improving the install plan..." - storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid - let improvedPlan = improveInstallPlanWithInstalledPackages - storePkgIdSet - elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) - -- TODO: [nice to have] having checked which packages from the store - -- we're using, it may be sensible to sanity check those packages - -- by loading up the compiler package db and checking everything - -- matches up as expected, e.g. no dangling deps, files deleted. - return improvedPlan - where - compid = compilerId (pkgConfigCompiler elaboratedShared) - - -programsMonitorFiles :: ProgramDb -> [MonitorFilePath] -programsMonitorFiles progdb = - [ monitor - | prog <- configuredPrograms progdb - , monitor <- monitorFileSearchPath (programMonitorFiles prog) - (programPath prog) - ] - --- | Select the bits of a 'ProgramDb' to monitor for value changes. --- Use 'programsMonitorFiles' for the files to monitor. --- -programDbSignature :: ProgramDb -> [ConfiguredProgram] -programDbSignature progdb = - [ prog { programMonitorFiles = [] - , programOverrideEnv = filter ((/="PATH") . fst) - (programOverrideEnv prog) } - | prog <- configuredPrograms progdb ] - -getInstalledPackages :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDBStack - -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - packagedbs progdb platform) - liftIO $ IndexUtils.getInstalledPackages - verbosity compiler - packagedbs progdb - -{- ---TODO: [nice to have] use this but for sanity / consistency checking -getPackageDBContents :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDB - -> Rebuild InstalledPackageIndex -getPackageDBContents verbosity compiler progdb platform packagedb = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - [packagedb] progdb platform) - liftIO $ do - createPackageDBIfMissing verbosity compiler progdb packagedb - Cabal.getPackageDBContents verbosity compiler - packagedb progdb --} - -getSourcePackages - :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> Maybe IndexUtils.TotalIndexState - -> Maybe IndexUtils.ActiveRepos - -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) -getSourcePackages verbosity withRepoCtx idxState activeRepos = do - (sourcePkgDbWithTIS, repos) <- - liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos - return (sourcePkgDbWithTIS, repoContextRepos repoctx) - - traverse_ needIfExists - . IndexUtils.getSourcePackagesMonitorFiles - $ repos - return sourcePkgDbWithTIS - - -getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb -getPkgConfigDb verbosity progdb = do - dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb - -- Just monitor the dirs so we'll notice new .pc files. - -- Alternatively we could monitor all the .pc files too. - traverse_ monitorDirectoryStatus dirs - liftIO $ readPkgConfigDb verbosity progdb - - --- | Select the config values to monitor for changes package source hashes. -packageLocationsSignature :: SolverInstallPlan - -> [(PackageId, PackageLocation (Maybe FilePath))] -packageLocationsSignature solverPlan = - [ (packageId pkg, srcpkgSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan - ] - - --- | Get the 'HashValue' for all the source packages where we use hashes, --- and download any packages required to do so. --- --- Note that we don't get hashes for local unpacked packages. --- -getPackageSourceHashes :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> SolverInstallPlan - -> Rebuild (Map PackageId PackageSourceHash) -getPackageSourceHashes verbosity withRepoCtx solverPlan = do - - -- Determine if and where to get the package's source hash from. - -- - let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] - allPkgLocations = - [ (packageId pkg, srcpkgSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan ] - - -- Tarballs that were local in the first place. - -- We'll hash these tarball files directly. - localTarballPkgs :: [(PackageId, FilePath)] - localTarballPkgs = - [ (pkgid, tarball) - | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] - - -- Tarballs from remote URLs. We must have downloaded these already - -- (since we extracted the .cabal file earlier) - remoteTarballPkgs = - [ (pkgid, tarball) - | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] - - -- tarballs from source-repository-package stanzas - sourceRepoTarballPkgs = - [ (pkgid, tarball) - | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] - - -- Tarballs from repositories, either where the repository provides - -- hashes as part of the repo metadata, or where we will have to - -- download and hash the tarball. - repoTarballPkgsWithMetadata :: [(PackageId, Repo)] - repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] - (repoTarballPkgsWithMetadata, - repoTarballPkgsWithoutMetadata) = - partitionEithers - [ case repo of - RepoSecure{} -> Left (pkgid, repo) - _ -> Right (pkgid, repo) - | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] - - -- For tarballs from repos that do not have hashes available we now have - -- to check if the packages were downloaded already. - -- - (repoTarballPkgsToDownload, - repoTarballPkgsDownloaded) - <- fmap partitionEithers $ - liftIO $ sequence - [ do mtarball <- checkRepoTarballFetched repo pkgid - case mtarball of - Nothing -> return (Left (pkgid, repo)) - Just tarball -> return (Right (pkgid, tarball)) - | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] - - (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) <- - -- Avoid having to initialise the repository (ie 'withRepoCtx') if we - -- don't have to. (The main cost is configuring the http client.) - if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata - then return (Map.empty, []) - else liftIO $ withRepoCtx $ \repoctx -> do - - -- For tarballs from repos that do have hashes available as part of the - -- repo metadata we now load up the index for each repo and retrieve - -- the hashes for the packages - -- - hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ - sequence - -- Reading the repo index is expensive so we group the packages by repo - [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> - Sec.withIndex secureRepo $ \repoIndex -> - sequence - [ do hash <- Sec.trusted <$> -- strip off Trusted tag - Sec.indexLookupHash repoIndex pkgid - -- Note that hackage-security currently uses SHA256 - -- but this API could in principle give us some other - -- choice in future. - return (pkgid, hashFromTUF hash) - | pkgid <- pkgids ] - | (repo, pkgids) <- - map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp))) - . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) - . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) - $ repoTarballPkgsWithMetadata - ] - - -- For tarballs from repos that do not have hashes available, download - -- the ones we previously determined we need. - -- - repoTarballPkgsNewlyDownloaded <- - sequence - [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid - return (pkgid, tarball) - | (pkgid, repo) <- repoTarballPkgsToDownload ] - - return (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) - - -- Hash tarball files for packages where we have to do that. This includes - -- tarballs that were local in the first place, plus tarballs from repos, - -- either previously cached or freshly downloaded. - -- - let allTarballFilePkgs :: [(PackageId, FilePath)] - allTarballFilePkgs = localTarballPkgs - ++ remoteTarballPkgs - ++ sourceRepoTarballPkgs - ++ repoTarballPkgsDownloaded - ++ repoTarballPkgsNewlyDownloaded - hashesFromTarballFiles <- liftIO $ - fmap Map.fromList $ - sequence - [ do srchash <- readFileHashValue tarball - return (pkgid, srchash) - | (pkgid, tarball) <- allTarballFilePkgs - ] - monitorFiles [ monitorFile tarball - | (_pkgid, tarball) <- allTarballFilePkgs ] - - -- Return the combination - return $! hashesFromRepoMetadata - <> hashesFromTarballFiles - - --- ------------------------------------------------------------ --- * Installation planning --- ------------------------------------------------------------ - -planPackages :: Verbosity - -> Compiler - -> Platform - -> Solver -> SolverSettings - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> Map PackageName (Map OptionalStanza Bool) - -> Progress String String SolverInstallPlan -planPackages verbosity comp platform solver SolverSettings{..} - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages pkgStanzasEnable = - - resolveDependencies - platform (compilerInfo comp) - pkgConfigDB solver - resolverParams - - where - - --TODO: [nice to have] disable multiple instances restriction in - -- the solver, but then make sure we can cope with that in the - -- output. - resolverParams = - - setMaxBackjumps solverSettingMaxBackjumps - - . setIndependentGoals solverSettingIndependentGoals - - . setReorderGoals solverSettingReorderGoals - - . setCountConflicts solverSettingCountConflicts - - . setFineGrainedConflicts solverSettingFineGrainedConflicts - - . setMinimizeConflictSet solverSettingMinimizeConflictSet - - --TODO: [required eventually] should only be configurable for - --custom installs - -- . setAvoidReinstalls solverSettingAvoidReinstalls - - --TODO: [required eventually] should only be configurable for - --custom installs - -- . setShadowPkgs solverSettingShadowPkgs - - . setStrongFlags solverSettingStrongFlags - - . setAllowBootLibInstalls solverSettingAllowBootLibInstalls - - . setOnlyConstrained solverSettingOnlyConstrained - - . setSolverVerbosity verbosity - - --TODO: [required eventually] decide if we need to prefer - -- installed for global packages, or prefer latest even for - -- global packages. Perhaps should be configurable but with a - -- different name than "upgrade-dependencies". - . setPreferenceDefault PreferLatestForSelected - {-(if solverSettingUpgradeDeps - then PreferAllLatest - else PreferLatestForSelected)-} - - . removeLowerBounds solverSettingAllowOlder - . removeUpperBounds solverSettingAllowNewer - - . addDefaultSetupDependencies (defaultSetupDeps comp platform - . PD.packageDescription - . srcpkgDescription) - - . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint - . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- solverSettingPreferences ] - - . addConstraints - -- version constraints from the config file or command line - [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints ] - - . addPreferences - -- enable stanza preference where the user did not specify - [ PackageStanzasPreference pkgname stanzas - | pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Nothing ] - , not (null stanzas) - ] - - . addConstraints - -- enable stanza constraints where the user asked to enable - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyStanzas stanzas)) - ConstraintSourceConfigFlagOrTarget - | pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Just True ] - , not (null stanzas) - ] - - . addConstraints - --TODO: [nice to have] should have checked at some point that the - -- package in question actually has these flags. - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyFlags flags)) - ConstraintSourceConfigFlagOrTarget - | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] - - . addConstraints - --TODO: [nice to have] we have user-supplied flags for unspecified - -- local packages (as well as specific per-package flags). For the - -- former we just apply all these flags to all local targets which - -- is silly. We should check if the flags are appropriate. - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyFlags flags)) - ConstraintSourceConfigFlagOrTarget - | let flags = solverSettingFlagAssignment - , not (PD.nullFlagAssignment flags) - , pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg ] - - $ stdResolverParams - - stdResolverParams = - -- Note: we don't use the standardInstallPolicy here, since that uses - -- its own addDefaultSetupDependencies that is not appropriate for us. - basicInstallPolicy - installedPkgIndex sourcePkgDb - localPackages - - -- While we can talk to older Cabal versions (we need to be able to - -- do so for custom Setup scripts that require older Cabal lib - -- versions), we have problems talking to some older versions that - -- don't support certain features. - -- - -- For example, Cabal-1.16 and older do not know about build targets. - -- Even worse, 1.18 and older only supported the --constraint flag - -- with source package ids, not --dependency with installed package - -- ids. That is bad because we cannot reliably select the right - -- dependencies in the presence of multiple instances (i.e. the - -- store). See issue #3932. So we require Cabal 1.20 as a minimum. - -- - -- Moreover, lib:Cabal generally only supports the interface of - -- current and past compilers; in fact recent lib:Cabal versions - -- will warn when they encounter a too new or unknown GHC compiler - -- version (c.f. #415). To avoid running into unsupported - -- configurations we encode the compatibility matrix as lower - -- bounds on lib:Cabal here (effectively corresponding to the - -- respective major Cabal version bundled with the respective GHC - -- release). - -- - -- GHC 9.0 needs Cabal >= 3.4 - -- GHC 8.10 needs Cabal >= 3.2 - -- GHC 8.8 needs Cabal >= 3.0 - -- GHC 8.6 needs Cabal >= 2.4 - -- GHC 8.4 needs Cabal >= 2.2 - -- GHC 8.2 needs Cabal >= 2.0 - -- GHC 8.0 needs Cabal >= 1.24 - -- GHC 7.10 needs Cabal >= 1.22 - -- - -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is - -- the absolute lower bound) - -- - -- TODO: long-term, this compatibility matrix should be - -- stored as a field inside 'Distribution.Compiler.Compiler' - setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [9,0] = mkVersion [3,4] - | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2] - | isGHC, compVer >= mkVersion [8,8] = mkVersion [3,0] - | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,4] - | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2] - | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] - | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24] - | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22] - | otherwise = mkVersion [1,20] - where - isGHC = compFlav `elem` [GHC,GHCJS] - compFlav = compilerFlavor comp - compVer = compilerVersion comp - - -- As we can't predict the future, we also place a global upper - -- bound on the lib:Cabal version we know how to interact with: - -- - -- The upper bound is computed by incrementing the current major - -- version twice in order to allow for the current version, as - -- well as the next adjacent major version (one of which will not - -- be released, as only "even major" versions of Cabal are - -- released to Hackage or bundled with proper GHC releases). - -- - -- For instance, if the current version of cabal-install is an odd - -- development version, e.g. Cabal-2.1.0.0, then we impose an - -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a - -- stable/release even version, e.g. Cabal-2.2.1.0, the upper - -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility - -- when dealing with development snapshots of Cabal and cabal-install. - -- - setupMaxCabalVersionConstraint = - alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion - ------------------------------------------------------------------------------- --- * Install plan post-processing ------------------------------------------------------------------------------- - --- This phase goes from the InstallPlan we get from the solver and has to --- make an elaborated install plan. --- --- We go in two steps: --- --- 1. elaborate all the source packages that the solver has chosen. --- 2. swap source packages for pre-existing installed packages wherever --- possible. --- --- We do it in this order, elaborating and then replacing, because the easiest --- way to calculate the installed package ids used for the replacement step is --- from the elaborated configuration for each package. - - - - ------------------------------------------------------------------------------- --- * Install plan elaboration ------------------------------------------------------------------------------- - --- Note [SolverId to ConfiguredId] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Dependency solving is a per package affair, so after we're done, we --- end up with 'SolverInstallPlan' that records in 'solverPkgLibDeps' --- and 'solverPkgExeDeps' what packages provide the libraries and executables --- needed by each component of the package (phew!) For example, if I have --- --- library --- build-depends: lib --- build-tool-depends: pkg:exe1 --- build-tools: alex --- --- After dependency solving, I find out that this library component has --- library dependencies on lib-0.2, and executable dependencies on pkg-0.1 --- and alex-0.3 (other components of the package may have different --- dependencies). Note that I've "lost" the knowledge that I depend --- *specifically* on the exe1 executable from pkg. --- --- So, we have a this graph of packages, and we need to transform it into --- a graph of components which we are actually going to build. In particular: --- --- NODE changes from PACKAGE (SolverPackage) to COMPONENTS (ElaboratedConfiguredPackage) --- EDGE changes from PACKAGE DEP (SolverId) to COMPONENT DEPS (ConfiguredId) --- --- In both cases, what was previously a single node/edge may turn into multiple --- nodes/edges. Multiple components, because there may be multiple components --- in a package; multiple component deps, because we may depend upon multiple --- executables from the same package (and maybe, some day, multiple libraries --- from the same package.) --- --- Let's talk about how to do this transformation. Naively, we might consider --- just processing each package, converting it into (zero or) one or more --- components. But we also have to update the edges; this leads to --- two complications: --- --- 1. We don't know what the ConfiguredId of a component is until --- we've configured it, but we cannot configure a component unless --- we know the ConfiguredId of all its dependencies. Thus, we must --- process the 'SolverInstallPlan' in topological order. --- --- 2. When we process a package, we know the SolverIds of its --- dependencies, but we have to do some work to turn these into --- ConfiguredIds. For example, in the case of build-tool-depends, the --- SolverId isn't enough to uniquely determine the ConfiguredId we should --- elaborate to: we have to look at the executable name attached to --- the package name in the package description to figure it out. --- At the same time, we NEED to use the SolverId, because there might --- be multiple versions of the same package in the build plan --- (due to setup dependencies); we can't just look up the package name --- from the package description. --- --- We can adopt the following strategy: --- --- * When a package is transformed into components, record --- a mapping from SolverId to ALL of the components --- which were elaborated. --- --- * When we look up an edge, we use our knowledge of the --- component name to *filter* the list of components into --- the ones we actually wanted to refer to. --- --- By the way, we can tell that SolverInstallPlan is not the "right" type --- because a SolverId cannot adequately represent all possible dependency --- solver states: we may need to record foo-0.1 multiple times in --- the solver install plan with different dependencies. This imprecision in the --- type currently doesn't cause any problems because the dependency solver --- continues to enforce the single instance restriction regardless of compiler --- version. The right way to solve this is to come up with something very much --- like a 'ConfiguredId', in that it incorporates the version choices of its --- dependencies, but less fine grained. - - --- | Produce an elaborated install plan using the policy for local builds with --- a nix-style shared store. --- --- In theory should be able to make an elaborated install plan with a policy --- matching that of the classic @cabal install --user@ or @--global@ --- -elaborateInstallPlan - :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb - -> DistDirLayout - -> StoreDirLayout - -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] - -> Map PackageId PackageSourceHash - -> InstallDirs.InstallDirTemplates - -> ProjectConfigShared - -> PackageConfig - -> PackageConfig - -> Map PackageName PackageConfig - -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) -elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB - distDirLayout@DistDirLayout{..} - storeDirLayout@StoreDirLayout{storePackageDBStack} - solverPlan localPackages - sourcePackageHashes - defaultInstallDirs - sharedPackageConfig - allPackagesConfig - localPackagesConfig - perPackageConfig = do - x <- elaboratedInstallPlan - return (x, elaboratedSharedConfig) - where - elaboratedSharedConfig = - ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = compilerprogdb, - pkgConfigReplOptions = [] - } - - preexistingInstantiatedPkgs = - Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) - where - f (SolverInstallPlan.PreExisting inst) - | let ipkg = instSolverPkgIPI inst - , not (IPI.indefinite ipkg) - = Just (IPI.installedUnitId ipkg, - (FullUnitId (IPI.installedComponentId ipkg) - (Map.fromList (IPI.instantiatedWith ipkg)))) - f _ = Nothing - - elaboratedInstallPlan = - flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> - case planpkg of - SolverInstallPlan.PreExisting pkg -> - return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] - - SolverInstallPlan.Configured pkg -> - let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" - | otherwise = Disp.empty - in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+> - quotes (pretty (packageId pkg))) $ - map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg - - -- NB: We don't INSTANTIATE packages at this point. That's - -- a post-pass. This makes it simpler to compute dependencies. - elaborateSolverToComponents - :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverPackage UnresolvedPkgLoc - -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) - = case mkComponentsGraph (elabEnabledSpec elab0) pd of - Right g -> do - let src_comps = componentsGraphToList g - infoProgress $ hang (text "Component graph for" <+> pretty pkgid <<>> colon) - 4 (dispComponentsWithDeps src_comps) - (_, comps) <- mapAccumM buildComponent - (Map.empty, Map.empty, Map.empty) - (map fst src_comps) - let not_per_component_reasons = why_not_per_component src_comps - if null not_per_component_reasons - then return comps - else do checkPerPackageOk comps not_per_component_reasons - return [elaborateSolverToPackage spkg g $ - comps ++ maybeToList setupComponent] - Left cns -> - dieProgress $ - hang (text "Dependency cycle between the following components:") 4 - (vcat (map (text . componentNameStanza) cns)) - where - -- You are eligible to per-component build if this list is empty - why_not_per_component g - = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage - where - cuz reason = [text reason] - -- We have to disable per-component for now with - -- Configure-type scripts in order to prevent parallel - -- invocation of the same `./configure` script. - -- See https://github.com/haskell/cabal/issues/4548 - -- - -- Moreoever, at this point in time, only non-Custom setup scripts - -- are supported. Implementing per-component builds with - -- Custom would require us to create a new 'ElabSetup' - -- type, and teach all of the code paths how to handle it. - -- Once you've implemented this, swap it for the code below. - cuz_buildtype = - case PD.buildType (elabPkgDescription elab0) of - PD.Configure -> cuz "build-type is Configure" - PD.Custom -> cuz "build-type is Custom" - _ -> [] - -- cabal-format versions prior to 1.8 have different build-depends semantics - -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 - -- see, https://github.com/haskell/cabal/issues/4121 - cuz_spec - | PD.specVersion pd >= CabalSpecV1_8 = [] - | otherwise = cuz "cabal-version is less than 1.8" - -- In the odd corner case that a package has no components at all - -- then keep it as a whole package, since otherwise it turns into - -- 0 component graph nodes and effectively vanishes. We want to - -- keep it around at least for error reporting purposes. - cuz_length - | length g > 0 = [] - | otherwise = cuz "there are no buildable components" - -- For ease of testing, we let per-component builds be toggled - -- at the top level - cuz_flag - | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) - = [] - | otherwise = cuz "you passed --disable-per-component" - -- Enabling program coverage introduces odd runtime dependencies - -- between components. - cuz_coverage - | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) - = cuz "program coverage is enabled" - | otherwise = [] - - -- | Sometimes a package may make use of features which are only - -- supported in per-package mode. If this is the case, we should - -- give an error when this occurs. - checkPerPackageOk comps reasons = do - let is_sublib (CLibName (LSubLibName _)) = True - is_sublib _ = False - when (any (matchElabPkg is_sublib) comps) $ - dieProgress $ - text "Internal libraries only supported with per-component builds." $$ - text "Per-component builds were disabled because" <+> - fsep (punctuate comma reasons) - -- TODO: Maybe exclude Backpack too - - elab0 = elaborateSolverToCommon spkg - pkgid = elabPkgSourceId elab0 - pd = elabPkgDescription elab0 - - -- TODO: This is just a skeleton to get elaborateSolverToPackage - -- working correctly - -- TODO: When we actually support building these components, we - -- have to add dependencies on this from all other components - setupComponent :: Maybe ElaboratedConfiguredPackage - setupComponent - | PD.buildType (elabPkgDescription elab0) == PD.Custom - = Just elab0 { - elabModuleShape = emptyModuleShape, - elabUnitId = notImpl "elabUnitId", - elabComponentId = notImpl "elabComponentId", - elabLinkedInstantiatedWith = Map.empty, - elabInstallDirs = notImpl "elabInstallDirs", - elabPkgOrComp = ElabComponent (ElaboratedComponent {..}) - } - | otherwise - = Nothing - where - compSolverName = CD.ComponentSetup - compComponentName = Nothing - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 - compLibDependencies - = map configuredId dep_pkgs - compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - compOrderLibDependencies = notImpl "compOrderLibDependencies" - -- Not supported: - compExeDependencies = [] - compExeDependencyPaths = [] - compPkgConfigDependencies = [] - - notImpl f = - error $ "Distribution.Client.ProjectPlanning.setupComponent: " ++ - f ++ " not implemented yet" - - - buildComponent - :: (ConfiguredComponentMap, - LinkedComponentMap, - Map ComponentId FilePath) - -> Cabal.Component - -> LogProgress - ((ConfiguredComponentMap, - LinkedComponentMap, - Map ComponentId FilePath), - ElaboratedConfiguredPackage) - buildComponent (cc_map, lc_map, exe_map) comp = - addProgressCtx (text "In the stanza" <+> - quotes (text (componentNameStanza cname))) $ do - - -- 1. Configure the component, but with a place holder ComponentId. - cc0 <- toConfiguredComponent - pd - (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") - (Map.unionWith Map.union external_lib_cc_map cc_map) - (Map.unionWith Map.union external_exe_cc_map cc_map) - comp - - - -- 2. Read out the dependencies from the ConfiguredComponent cc0 - let compLibDependencies = - -- Nub because includes can show up multiple times - ordNub (map (annotatedIdToConfiguredId . ci_ann_id) - (cc_includes cc0)) - compExeDependencies = - map annotatedIdToConfiguredId - (cc_exe_deps cc0) - compExeDependencyPaths = - [ (annotatedIdToConfiguredId aid', path) - | aid' <- cc_exe_deps cc0 - , Just paths <- [Map.lookup (ann_id aid') exe_map1] - , path <- paths ] - elab_comp = ElaboratedComponent {..} - - -- 3. Construct a preliminary ElaboratedConfiguredPackage, - -- and use this to compute the component ID. Fix up cc_id - -- correctly. - let elab1 = elab0 { - elabPkgOrComp = ElabComponent $ elab_comp - } - cid = case elabBuildStyle elab0 of - BuildInplaceOnly -> - mkComponentId $ - prettyShow pkgid ++ "-inplace" ++ - (case Cabal.componentNameString cname of - Nothing -> "" - Just s -> "-" ++ prettyShow s) - BuildAndInstall -> - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab1) -- knot tied - cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) } - infoProgress $ dispConfiguredComponent cc - - -- 4. Perform mix-in linking - let lookup_uid def_uid = - case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of - Just full -> full - Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) - lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) - (Map.union external_lc_map lc_map) cc - infoProgress $ dispLinkedComponent lc - -- NB: elab is setup to be the correct form for an - -- indefinite library, or a definite library with no holes. - -- We will modify it in 'instantiateInstallPlan' to handle - -- instantiated packages. - - -- 5. Construct the final ElaboratedConfiguredPackage - let - elab2 = elab1 { - elabModuleShape = lc_shape lc, - elabUnitId = abstractUnitId (lc_uid lc), - elabComponentId = lc_cid lc, - elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), - elabPkgOrComp = ElabComponent $ elab_comp { - compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)), - compOrderLibDependencies = - ordNub (map (abstractUnitId . ci_id) - (lc_includes lc ++ lc_sig_includes lc)) - } - } - elab = elab2 { - elabInstallDirs = computeInstallDirs - storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab2 - } - - -- 6. Construct the updated local maps - let cc_map' = extendConfiguredComponentMap cc cc_map - lc_map' = extendLinkedComponentMap lc lc_map - exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map - - return ((cc_map', lc_map', exe_map'), elab) - where - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - - cname = Cabal.componentName comp - compComponentName = Just cname - compSolverName = CD.componentNameToComponent cname - - -- NB: compLinkedLibDependencies and - -- compOrderLibDependencies are defined when we define - -- 'elab'. - external_lib_dep_sids = CD.select (== compSolverName) deps0 - external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 - - external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids - - -- Combine library and build-tool dependencies, for backwards - -- compatibility (See issue #5412 and the documentation for - -- InstallPlan.fromSolverInstallPlan), but prefer the versions - -- specified as build-tools. - external_exe_dep_pkgs = - concatMap mapDep $ - ordNubBy (pkgName . packageId) $ - external_exe_dep_sids ++ external_lib_dep_sids - - external_exe_map = Map.fromList $ - [ (getComponentId pkg, paths) - | pkg <- external_exe_dep_pkgs - , let paths = planPackageExePaths pkg ] - exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map - - external_lib_cc_map = Map.fromListWith Map.union - $ map mkCCMapping external_lib_dep_pkgs - external_exe_cc_map = Map.fromListWith Map.union - $ map mkCCMapping external_exe_dep_pkgs - external_lc_map = - Map.fromList $ map mkShapeMapping $ - external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids - - compPkgConfigDependencies = - [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " - ++ prettyShow pn ++ " from " - ++ prettyShow (elabPkgSourceId elab0)) - (pkgConfigDbPkgVersion pkgConfigDB pn)) - | PkgconfigDependency pn _ <- PD.pkgconfigDepends - (Cabal.componentBuildInfo comp) ] - - inplace_bin_dir elab = - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab $ - case Cabal.componentNameString cname of - Just n -> prettyShow n - Nothing -> "" - - - -- | Given a 'SolverId' referencing a dependency on a library, return - -- the 'ElaboratedPlanPackage' corresponding to the library. This - -- returns at most one result. - elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [ElaboratedPlanPackage] - elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep - - -- | Given an 'ElaboratedPlanPackage', return the paths to where the - -- executables that this package represents would be installed. - -- The only case where multiple paths can be returned is the inplace - -- monolithic package one, since there can be multiple exes and each one - -- has its own directory. - planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] - planPackageExePaths = - -- Pre-existing executables are assumed to be in PATH - -- already. In fact, this should be impossible. - InstallPlan.foldPlanPackage (const []) $ \elab -> - let - executables :: [FilePath] - executables = - case elabPkgOrComp elab of - -- Monolithic mode: all exes of the package - ElabPackage _ -> unUnqualComponentName . PD.exeName - <$> PD.executables (elabPkgDescription elab) - -- Per-component mode: just the selected exe - ElabComponent comp -> - case fmap Cabal.componentNameString - (compComponentName comp) of - Just (Just n) -> [prettyShow n] - _ -> [""] - in - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab - <$> executables - - elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc - -> ComponentsGraph - -> [ElaboratedConfiguredPackage] - -> ElaboratedConfiguredPackage - elaborateSolverToPackage - pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride) - _flags _stanzas _deps0 _exe_deps0) - compGraph comps = - -- Knot tying: the final elab includes the - -- pkgInstalledId, which is calculated by hashing many - -- of the other fields of the elaboratedPackage. - elab - where - elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg - elab1 = elab0 { - elabUnitId = newSimpleUnitId pkgInstalledId, - elabComponentId = pkgInstalledId, - elabLinkedInstantiatedWith = Map.empty, - elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, - elabModuleShape = modShape - } - elab = elab1 { - elabInstallDirs = - computeInstallDirs storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab1 - } - - modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of - Nothing -> emptyModuleShape - Just e -> Ty.elabModuleShape e - - pkgInstalledId - | shouldBuildInplaceOnly pkg - = mkComponentId (prettyShow pkgid ++ "-inplace") - - | otherwise - = assert (isJust elabPkgSourceHash) $ - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab) -- recursive use of elab - - | otherwise - = error $ "elaborateInstallPlan: non-inplace package " - ++ " is missing a source hash: " ++ prettyShow pkgid - - -- Need to filter out internal dependencies, because they don't - -- correspond to anything real anymore. - isExt confid = confSrcId confid /= pkgid - filterExt = filter isExt - filterExt' = filter (isExt . fst) - - pkgLibDependencies - = buildComponentDeps (filterExt . compLibDependencies) - pkgExeDependencies - = buildComponentDeps (filterExt . compExeDependencies) - pkgExeDependencyPaths - = buildComponentDeps (filterExt' . compExeDependencyPaths) - -- TODO: Why is this flat? - pkgPkgConfigDependencies - = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies - - pkgDependsOnSelfLib - = CD.fromList [ (CD.componentNameToComponent cn, [()]) - | Graph.N _ cn _ <- fromMaybe [] mb_closure ] - where - mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ] - -- NB: the sublib case should not occur, because sub-libraries - -- are not supported without per-component builds - is_lib (CLibName _) = True - is_lib _ = False - - buildComponentDeps f - = CD.fromList [ (compSolverName comp, f comp) - | ElaboratedConfiguredPackage{ - elabPkgOrComp = ElabComponent comp - } <- comps - ] - - -- NB: This is not the final setting of 'pkgStanzasEnabled'. - -- See [Sticky enabled testsuites]; we may enable some extra - -- stanzas opportunistically when it is cheap to do so. - -- - -- However, we start off by enabling everything that was - -- requested, so that we can maintain an invariant that - -- pkgStanzasEnabled is a superset of elabStanzasRequested - pkgStanzasEnabled = Map.keysSet (Map.filter (id :: Bool -> Bool) elabStanzasRequested) - - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc - -> ElaboratedConfiguredPackage - elaborateSolverToCommon - pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) - flags stanzas deps0 _exe_deps0) = - elaboratedPackage - where - elaboratedPackage = ElaboratedConfiguredPackage {..} - - -- These get filled in later - elabUnitId = error "elaborateSolverToCommon: elabUnitId" - elabComponentId = error "elaborateSolverToCommon: elabComponentId" - elabInstantiatedWith = Map.empty - elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" - elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" - elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" - elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" - - elabIsCanonical = True - elabPkgSourceId = pkgid - elabPkgDescription = case PD.finalizePD - flags elabEnabledSpec (const True) - platform (compilerInfo compiler) - [] gdesc of - Right (desc, _) -> desc - Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" - elabFlagAssignment = flags - elabFlagDefaults = PD.mkFlagAssignment - [ (Cabal.flagName flag, Cabal.flagDefault flag) - | flag <- PD.genPackageFlags gdesc ] - - elabEnabledSpec = enableStanzas stanzas - elabStanzasAvailable = Set.fromList stanzas - elabStanzasRequested = - -- NB: even if a package stanza is requested, if the package - -- doesn't actually have any of that stanza we omit it from - -- the request, to ensure that we don't decide that this - -- package needs to be rebuilt. (It needs to be done here, - -- because the ElaboratedConfiguredPackage is where we test - -- whether or not there have been changes.) - Map.fromList $ [ (TestStanzas, v) | v <- maybeToList tests - , _ <- PD.testSuites elabPkgDescription ] - ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks - , _ <- PD.benchmarks elabPkgDescription ] - where - tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks - - -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' - -- and 'pruneInstallPlanPass2'. We can't populate it here - -- because whether or not tests/benchmarks should be enabled - -- is heuristically calculated based on whether or not the - -- dependencies of the test suite have already been installed, - -- but this function doesn't know what is installed (since - -- we haven't improved the plan yet), so we do it in another pass. - -- Check the comments of those functions for more details. - elabConfigureTargets = [] - elabBuildTargets = [] - elabTestTargets = [] - elabBenchTargets = [] - elabReplTarget = Nothing - elabHaddockTargets = [] - - elabBuildHaddocks = - perPkgOptionFlag pkgid False packageConfigDocumentation - - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes - elabLocalToProject = isLocalToProject pkg - elabBuildStyle = if shouldBuildInplaceOnly pkg - then BuildInplaceOnly else BuildAndInstall - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs - - elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription - elabSetupScriptCliVersion = - packageSetupScriptSpecVersion - elabSetupScriptStyle elabPkgDescription libDepGraph deps0 - elabSetupPackageDBStack = buildAndRegisterDbs - - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = storePackageDbs - - elabPkgDescriptionOverride = descOverride - - elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively - elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary - elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib - elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe - elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe - elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still - - elabProfExe = perPkgOptionFlag pkgid False packageConfigProf - elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary - - (elabProfExeDetail, - elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault - packageConfigProfDetail - packageConfigProfLibDetail - elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - - elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections - elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes - elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - - -- Combine the configured compiler prog settings with the user-supplied - -- config. For the compiler progs any user-supplied config was taken - -- into account earlier when configuring the compiler so its ok that - -- our configured settings for the compiler override the user-supplied - -- config here. - elabProgramPaths = Map.fromList - [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths - elabProgramArgs = Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs prog - , not (null args) - ] - <> perPkgOptionMapMappend pkgid packageConfigProgramArgs - elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - - elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs - elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage - elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource - elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump - elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents - - elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog - elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog - elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails - elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix - elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper - elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites - elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions - - elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions - - perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a - perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a - perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] - - perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) - perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) - perPkgOptionList pkgid f = lookupPerPkgOption pkgid f - perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) - perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) - perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) - - perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) - where - exe = fromFlagOrDefault def bothflag - lib = fromFlagOrDefault def (bothflag <> libflag) - - bothflag = lookupPerPkgOption pkgid fboth - libflag = lookupPerPkgOption pkgid flib - - lookupPerPkgOption :: (Package pkg, Monoid m) - => pkg -> (PackageConfig -> m) -> m - lookupPerPkgOption pkg f = - -- This is where we merge the options from the project config that - -- apply to all packages, all project local packages, and to specific - -- named packages - global `mappend` local `mappend` perpkg - where - global = f allPackagesConfig - local | isLocalToProject pkg - = f localPackagesConfig - | otherwise - = mempty - perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - - inplacePackageDbs = storePackageDbs - ++ [ distPackageDB (compilerId compiler) ] - - storePackageDbs = storePackageDBStack (compilerId compiler) - - -- For this local build policy, every package that lives in a local source - -- dir (as opposed to a tarball), or depends on such a package, will be - -- built inplace into a shared dist dir. Tarball packages that depend on - -- source dir packages will also get unpacked locally. - shouldBuildInplaceOnly :: SolverPackage loc -> Bool - shouldBuildInplaceOnly pkg = Set.member (packageId pkg) - pkgsToBuildInplaceOnly - - pkgsToBuildInplaceOnly :: Set PackageId - pkgsToBuildInplaceOnly = - Set.fromList - $ map packageId - $ SolverInstallPlan.reverseDependencyClosure - solverPlan - (map PlannedId (Set.toList pkgsLocalToProject)) - - isLocalToProject :: Package pkg => pkg -> Bool - isLocalToProject pkg = Set.member (packageId pkg) - pkgsLocalToProject - - pkgsLocalToProject :: Set PackageId - pkgsLocalToProject = - Set.fromList (catMaybes (map shouldBeLocal localPackages)) - --TODO: localPackages is a misnomer, it's all project packages - -- here is where we decide which ones will be local! - - pkgsUseSharedLibrary :: Set PackageId - pkgsUseSharedLibrary = - packagesWithLibDepsDownwardClosedProperty needsSharedLib - where - needsSharedLib pkg = - fromMaybe compilerShouldUseSharedLibByDefault - (liftM2 (||) pkgSharedLib pkgDynExe) - where - pkgid = packageId pkg - pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe - - --TODO: [code cleanup] move this into the Cabal lib. It's currently open - -- coded in Distribution.Simple.Configure, but should be made a proper - -- function of the Compiler or CompilerInfo. - compilerShouldUseSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.isDynamic compiler - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - pkgsUseProfilingLibrary :: Set PackageId - pkgsUseProfilingLibrary = - packagesWithLibDepsDownwardClosedProperty needsProfilingLib - where - needsProfilingLib pkg = - fromFlagOrDefault False (profBothFlag <> profLibFlag) - where - pkgid = packageId pkg - profBothFlag = lookupPerPkgOption pkgid packageConfigProf - profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib - --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe - - libDepGraph = Graph.fromDistinctList $ - map NonSetupLibDepSolverPlanPackage - (SolverInstallPlan.toList solverPlan) - - packagesWithLibDepsDownwardClosedProperty property = - Set.fromList - . map packageId - . fromMaybe [] - $ Graph.closure - libDepGraph - [ Graph.nodeKey pkg - | pkg <- SolverInstallPlan.toList solverPlan - , property pkg ] -- just the packages that satisfy the property - --TODO: [nice to have] this does not check the config consistency, - -- e.g. a package explicitly turning off profiling, but something - -- depending on it that needs profiling. This really needs a separate - -- package config validation/resolution pass. - - --TODO: [nice to have] config consistency checking: - -- + profiling libs & exes, exe needs lib, recursive - -- + shared libs & exes, exe needs lib, recursive - -- + vanilla libs & exes, exe needs lib, recursive - -- + ghci or shared lib needed by TH, recursive, ghc version dependent - --- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping - -shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId -shouldBeLocal NamedPackage{} = Nothing -shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of - LocalUnpackedPackage _ -> Just (packageId pkg) - _ -> Nothing - --- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. -matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool -matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) - --- | Get the appropriate 'ComponentName' which identifies an installed --- component. -ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName -ipiComponentName = CLibName . IPI.sourceLibName - --- | Given a 'ElaboratedConfiguredPackage', report if it matches a --- 'ComponentName'. -matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool -matchElabPkg p elab = - case elabPkgOrComp elab of - ElabComponent comp -> maybe False p (compComponentName comp) - ElabPackage _ -> - -- So, what should we do here? One possibility is to - -- unconditionally return 'True', because whatever it is - -- that we're looking for, it better be in this package. - -- But this is a bit dodgy if the package doesn't actually - -- have, e.g., a library. Fortunately, it's not possible - -- for the build of the library/executables to be toggled - -- by 'pkgStanzasEnabled', so the only thing we have to - -- test is if the component in question is *buildable.* - any (p . componentName) - (Cabal.pkgBuildableComponents (elabPkgDescription elab)) - --- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' --- and 'ComponentName' to the 'ComponentId' that should be used --- in this case. -mkCCMapping :: ElaboratedPlanPackage - -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) -mkCCMapping = - InstallPlan.foldPlanPackage - (\ipkg -> (packageName ipkg, - Map.singleton (ipiComponentName ipkg) - -- TODO: libify - (AnnotatedId { - ann_id = IPI.installedComponentId ipkg, - ann_pid = packageId ipkg, - ann_cname = IPI.sourceComponentName ipkg - }))) - $ \elab -> - let mk_aid cn = AnnotatedId { - ann_id = elabComponentId elab, - ann_pid = packageId elab, - ann_cname = cn - } - in (packageName elab, - case elabPkgOrComp elab of - ElabComponent comp -> - case compComponentName comp of - Nothing -> Map.empty - Just n -> Map.singleton n (mk_aid n) - ElabPackage _ -> - Map.fromList $ - map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) - (Cabal.pkgBuildableComponents (elabPkgDescription elab))) - --- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' --- to the shape of this package, as per mix-in linking. -mkShapeMapping :: ElaboratedPlanPackage - -> (ComponentId, (OpenUnitId, ModuleShape)) -mkShapeMapping dpkg = - (getComponentId dpkg, (indef_uid, shape)) - where - (dcid, shape) = - InstallPlan.foldPlanPackage - -- Uses Monad (->) - (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) - (liftM2 (,) elabComponentId elabModuleShape) - dpkg - indef_uid = - IndefFullUnitId dcid - (Map.fromList [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires shape)]) - --- | Get the bin\/ directories that a package's executables should reside in. --- --- The result may be empty if the package does not build any executables. --- --- The result may have several entries if this is an inplace build of a package --- with multiple executables. -binDirectories - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> [FilePath] -binDirectories layout config package = case elabBuildStyle package of - -- quick sanity check: no sense returning a bin directory if we're not going - -- to put any executables in it, that will just clog up the PATH - _ | noExecutables -> [] - BuildAndInstall -> [installedBinDirectory package] - BuildInplaceOnly -> map (root) $ case elabPkgOrComp package of - ElabComponent comp -> case compSolverName comp of - CD.ComponentExe n -> [prettyShow n] - _ -> [] - ElabPackage _ -> map (prettyShow . PD.exeName) - . PD.executables - . elabPkgDescription - $ package - where - noExecutables = null . PD.executables . elabPkgDescription $ package - root = distBuildDirectory layout (elabDistDirParams config package) - "build" - --- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the --- dependency graph considers only dependencies on libraries which are --- NOT from setup dependencies. Used to compute the set --- of packages needed for profiling and dynamic libraries. -newtype NonSetupLibDepSolverPlanPackage - = NonSetupLibDepSolverPlanPackage - { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } - -instance Package NonSetupLibDepSolverPlanPackage where - packageId = packageId . unNonSetupLibDepSolverPlanPackage - -instance IsNode NonSetupLibDepSolverPlanPackage where - type Key NonSetupLibDepSolverPlanPackage = SolverId - nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage - nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) - = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) - -type InstS = Map UnitId ElaboratedPlanPackage -type InstM a = State InstS a - -getComponentId :: ElaboratedPlanPackage - -> ComponentId -getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg -getComponentId (InstallPlan.Configured elab) = elabComponentId elab -getComponentId (InstallPlan.Installed elab) = elabComponentId elab - -instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan -instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = - InstallPlan.new (IndependentGoals False) - (Graph.fromDistinctList (Map.elems ready_map)) - where - pkgs = InstallPlan.toList plan - - cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] - - instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM DefUnitId - instantiateUnitId cid insts = state $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - let (r, s') = runState (instantiateComponent uid cid insts) - (Map.insert uid r s) - in (def_uid, Map.insert uid r s') - Just _ -> (def_uid, s) - where - def_uid = mkDefUnitId cid insts - uid = unDefUnitId def_uid - - instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName Module - -> InstM ElaboratedPlanPackage - instantiateComponent uid cid insts - | Just planpkg <- Map.lookup cid cmap - = case planpkg of - InstallPlan.Configured (elab0@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp }) -> do - deps <- traverse (substUnitId insts) - (compLinkedLibDependencies comp) - let getDep (Module dep_uid _) = [dep_uid] - elab1 = elab0 { - elabUnitId = uid, - elabComponentId = cid, - elabInstantiatedWith = insts, - elabIsCanonical = Map.null insts, - elabPkgOrComp = ElabComponent comp { - compOrderLibDependencies = - (if Map.null insts then [] else [newSimpleUnitId cid]) ++ - ordNub (map unDefUnitId - (deps ++ concatMap getDep (Map.elems insts))) - } - } - elab = elab1 { - elabInstallDirs = computeInstallDirs storeDirLayout - defaultInstallDirs - elaboratedShared - elab1 - } - return $ InstallPlan.Configured elab - _ -> return planpkg - | otherwise = error ("instantiateComponent: " ++ prettyShow cid) - - substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId - substUnitId _ (DefiniteUnitId uid) = - return uid - substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' - - -- NB: NOT composition - substSubst :: Map ModuleName Module - -> Map ModuleName OpenModule - -> InstM (Map ModuleName Module) - substSubst subst insts = traverse (substModule subst) insts - - substModule :: Map ModuleName Module -> OpenModule -> InstM Module - substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" - substModule subst (OpenModule uid mod_name) = do - uid' <- substUnitId subst uid - return (Module uid' mod_name) - - indefiniteUnitId :: ComponentId -> InstM UnitId - indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - state $ \s -> (uid, Map.insert uid r s) - - indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage - indefiniteComponent _uid cid - -- Only need Configured; this phase happens before improvement, so - -- there shouldn't be any Installed packages here. - | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap - , ElabComponent elab_comp <- elabPkgOrComp epkg - = do -- We need to do a little more processing of the includes: some - -- of them are fully definite even without substitution. We - -- want to build those too; see #5634. - -- - -- This code mimics similar code in Distribution.Backpack.ReadyComponent; - -- however, unlike the conversion from LinkedComponent to - -- ReadyComponent, this transformation is done *without* - -- changing the type in question; and what we are simply - -- doing is enforcing tighter invariants on the data - -- structure in question. The new invariant is that there - -- is no IndefFullUnitId in compLinkedLibDependencies that actually - -- has no holes. We couldn't specify this invariant when - -- we initially created the ElaboratedPlanPackage because - -- we have no way of actually refiying the UnitId into a - -- DefiniteUnitId (that's what substUnitId does!) - new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> - if Set.null (openUnitIdFreeHoles uid) - then fmap DefiniteUnitId (substUnitId Map.empty uid) - else return uid - return $ InstallPlan.Configured epkg { - elabPkgOrComp = ElabComponent elab_comp { - compLinkedLibDependencies = new_deps, - -- I think this is right: any new definite unit ids we - -- minted in the phase above need to be built before us. - -- Add 'em in. This doesn't remove any old dependencies - -- on the indefinite package; they're harmless. - compOrderLibDependencies = - ordNub $ compOrderLibDependencies elab_comp ++ - [unDefUnitId d | DefiniteUnitId d <- new_deps] - } - } - | Just planpkg <- Map.lookup cid cmap - = return planpkg - | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) - - ready_map = execState work Map.empty - - work = for_ pkgs $ \pkg -> - case pkg of - InstallPlan.Configured elab - | not (Map.null (elabLinkedInstantiatedWith elab)) - -> indefiniteUnitId (elabComponentId elab) - >> return () - _ -> instantiateUnitId (getComponentId pkg) Map.empty - >> return () - ---------------------------- --- Build targets --- - --- Refer to ProjectPlanning.Types for details of these important types: - --- data ComponentTarget = ... --- data SubComponentTarget = ... - --- One step in the build system is to translate higher level intentions like --- "build this package", "test that package", or "repl that component" into --- a more detailed specification of exactly which components to build (or other --- actions like repl or build docs). This translation is somewhat different for --- different commands. For example "test" for a package will build a different --- set of components than "build". In addition, the translation of these --- intentions can fail. For example "run" for a package is only unambiguous --- when the package has a single executable. --- --- So we need a little bit of infrastructure to make it easy for the command --- implementations to select what component targets are meant when a user asks --- to do something with a package or component. To do this (and to be able to --- produce good error messages for mistakes and when targets are not available) --- we need to gather and summarise accurate information about all the possible --- targets, both available and unavailable. Then a command implementation can --- decide which of the available component targets should be selected. - --- | An available target represents a component within a package that a user --- command could plausibly refer to. In this sense, all the components defined --- within the package are things the user could refer to, whether or not it --- would actually be possible to build that component. --- --- In particular the available target contains an 'AvailableTargetStatus' which --- informs us about whether it's actually possible to select this component to --- be built, and if not why not. This detail makes it possible for command --- implementations (like @build@, @test@ etc) to accurately report why a target --- cannot be used. --- --- Note that the type parameter is used to help enforce that command --- implementations can only select targets that can actually be built (by --- forcing them to return the @k@ value for the selected targets). --- In particular 'resolveTargets' makes use of this (with @k@ as --- @('UnitId', ComponentName')@) to identify the targets thus selected. --- -data AvailableTarget k = AvailableTarget { - availableTargetPackageId :: PackageId, - availableTargetComponentName :: ComponentName, - availableTargetStatus :: AvailableTargetStatus k, - availableTargetLocalToProject :: Bool - } - deriving (Eq, Show, Functor) - --- | The status of a an 'AvailableTarget' component. This tells us whether --- it's actually possible to select this component to be built, and if not --- why not. --- -data AvailableTargetStatus k = - TargetDisabledByUser -- ^ When the user does @tests: False@ - | TargetDisabledBySolver -- ^ When the solver could not enable tests - | TargetNotBuildable -- ^ When the component has @buildable: False@ - | TargetNotLocal -- ^ When the component is non-core in a non-local package - | TargetBuildable k TargetRequested -- ^ The target can or should be built - deriving (Eq, Ord, Show, Functor) - --- | This tells us whether a target ought to be built by default, or only if --- specifically requested. The policy is that components like libraries and --- executables are built by default by @build@, but test suites and benchmarks --- are not, unless this is overridden in the project configuration. --- -data TargetRequested = - TargetRequestedByDefault -- ^ To be built by default - | TargetNotRequestedByDefault -- ^ Not to be built by default - deriving (Eq, Ord, Show) - --- | Given the install plan, produce the set of 'AvailableTarget's for each --- package-component pair. --- --- Typically there will only be one such target for each component, but for --- example if we have a plan with both normal and profiling variants of a --- component then we would get both as available targets, or similarly if we --- had a plan that contained two instances of the same version of a package. --- This approach makes it relatively easy to select all instances\/variants --- of a component. --- -availableTargets :: ElaboratedInstallPlan - -> Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] -availableTargets installPlan = - let rs = [ (pkgid, cname, fake, target) - | pkg <- InstallPlan.toList installPlan - , (pkgid, cname, fake, target) <- case pkg of - InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg - InstallPlan.Installed elab -> availableSourceTargets elab - InstallPlan.Configured elab -> availableSourceTargets elab - ] - in Map.union - (Map.fromListWith (++) - [ ((pkgid, cname), [target]) - | (pkgid, cname, fake, target) <- rs, not fake]) - (Map.fromList - [ ((pkgid, cname), [target]) - | (pkgid, cname, fake, target) <- rs, fake]) - -- The normal targets mask the fake ones. We get all instances of the - -- normal ones and only one copy of the fake ones (as there are many - -- duplicates of the fake ones). See 'availableSourceTargets' below for - -- more details on this fake stuff is about. - -availableInstalledTargets :: IPI.InstalledPackageInfo - -> [(PackageId, ComponentName, Bool, - AvailableTarget (UnitId, ComponentName))] -availableInstalledTargets ipkg = - let unitid = installedUnitId ipkg - cname = CLibName LMainLibName - status = TargetBuildable (unitid, cname) TargetRequestedByDefault - target = AvailableTarget (packageId ipkg) cname status False - fake = False - in [(packageId ipkg, cname, fake, target)] - -availableSourceTargets :: ElaboratedConfiguredPackage - -> [(PackageId, ComponentName, Bool, - AvailableTarget (UnitId, ComponentName))] -availableSourceTargets elab = - -- We have a somewhat awkward problem here. We need to know /all/ the - -- components from /all/ the packages because these are the things that - -- users could refer to. Unfortunately, at this stage the elaborated install - -- plan does /not/ contain all components: some components have already - -- been deleted because they cannot possibly be built. This is the case - -- for components that are marked @buildable: False@ in their .cabal files. - -- (It's not unreasonable that the unbuildable components have been pruned - -- as the plan invariant is considerably simpler if all nodes can be built) - -- - -- We can recover the missing components but it's not exactly elegant. For - -- a graph node corresponding to a component we still have the information - -- about the package that it came from, and this includes the names of - -- /all/ the other components in the package. So in principle this lets us - -- find the names of all components, plus full details of the buildable - -- components. - -- - -- Consider for example a package with 3 exe components: foo, bar and baz - -- where foo and bar are buildable, but baz is not. So the plan contains - -- nodes for the components foo and bar. Now we look at each of these two - -- nodes and look at the package they come from and the names of the - -- components in this package. This will give us the names foo, bar and - -- baz, twice (once for each of the two buildable components foo and bar). - -- - -- We refer to these reconstructed missing components as fake targets. - -- It is an invariant that they are not available to be built. - -- - -- To produce the final set of targets we put the fake targets in a finite - -- map (thus eliminating the duplicates) and then we overlay that map with - -- the normal buildable targets. (This is done above in 'availableTargets'.) - -- - [ (packageId elab, cname, fake, target) - | component <- pkgComponents (elabPkgDescription elab) - , let cname = componentName component - status = componentAvailableTargetStatus component - target = AvailableTarget { - availableTargetPackageId = packageId elab, - availableTargetComponentName = cname, - availableTargetStatus = status, - availableTargetLocalToProject = elabLocalToProject elab - } - fake = isFakeTarget cname - - -- TODO: The goal of this test is to exclude "instantiated" - -- packages as available targets. This means that you can't - -- ask for a particular instantiated component to be built; - -- it will only get built by a dependency. Perhaps the - -- correct way to implement this is to run selection - -- prior to instantiating packages. If you refactor - -- this, then you can delete this test. - , elabIsCanonical elab - - -- Filter out some bogus parts of the cross product that are never needed - , case status of - TargetBuildable{} | fake -> False - _ -> True - ] - where - isFakeTarget cname = - case elabPkgOrComp elab of - ElabPackage _ -> False - ElabComponent elabComponent -> compComponentName elabComponent - /= Just cname - - componentAvailableTargetStatus - :: Component -> AvailableTargetStatus (UnitId, ComponentName) - componentAvailableTargetStatus component = - case componentOptionalStanza $ CD.componentNameToComponent cname of - -- it is not an optional stanza, so a library, exe or foreign lib - Nothing - | not buildable -> TargetNotBuildable - | otherwise -> TargetBuildable (elabUnitId elab, cname) - TargetRequestedByDefault - - -- it is not an optional stanza, so a testsuite or benchmark - Just stanza -> - case (Map.lookup stanza (elabStanzasRequested elab), - Set.member stanza (elabStanzasAvailable elab)) of - _ | not withinPlan -> TargetNotLocal - (Just False, _) -> TargetDisabledByUser - (Nothing, False) -> TargetDisabledBySolver - _ | not buildable -> TargetNotBuildable - (Just True, True) -> TargetBuildable (elabUnitId elab, cname) - TargetRequestedByDefault - (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) - TargetNotRequestedByDefault - (Just True, False) -> - error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname - where - cname = componentName component - buildable = PD.buildable (componentBuildInfo component) - withinPlan = elabLocalToProject elab - || case elabPkgOrComp elab of - ElabComponent elabComponent -> - compComponentName elabComponent == Just cname - ElabPackage _ -> - case componentName component of - CLibName (LMainLibName) -> True - CExeName _ -> True - --TODO: what about sub-libs and foreign libs? - _ -> False - --- | Merge component targets that overlap each other. Specially when we have --- multiple targets for the same component and one of them refers to the whole --- component (rather than a module or file within) then all the other targets --- for that component are subsumed. --- --- We also allow for information associated with each component target, and --- whenever we targets subsume each other we aggregate their associated info. --- -nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])] -nubComponentTargets = - concatMap (wholeComponentOverrides . map snd) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) - . map compatSubComponentTargets - where - -- If we're building the whole component then that the only target all we - -- need, otherwise we can have several targets within the component. - wholeComponentOverrides :: [(ComponentTarget, a )] - -> [(ComponentTarget, [a])] - wholeComponentOverrides ts = - case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of - (t:_) -> [ (t, map snd ts) ] - [] -> [ (t,[x]) | (t,x) <- ts ] - - -- Not all Cabal Setup.hs versions support sub-component targets, so switch - -- them over to the whole component - compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) - compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) - | not setupHsSupportsSubComponentTargets - = (ComponentTarget cname WholeComponent, x) - | otherwise = target - - -- Actually the reality is that no current version of Cabal's Setup.hs - -- build command actually support building specific files or modules. - setupHsSupportsSubComponentTargets = False - -- TODO: when that changes, adjust this test, e.g. - -- | pkgSetupScriptCliVersion >= Version [x,y] [] - -pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool -pkgHasEphemeralBuildTargets elab = - isJust (elabReplTarget elab) - || (not . null) (elabTestTargets elab) - || (not . null) (elabBenchTargets elab) - || (not . null) (elabHaddockTargets elab) - || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab - , subtarget /= WholeComponent ] - --- | The components that we'll build all of, meaning that after they're built --- we can skip building them again (unlike with building just some modules or --- other files within a component). --- -elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage - -> Set ComponentName -elabBuildTargetWholeComponents elab = - Set.fromList - [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] - - - ------------------------------------------------------------------------------- --- * Install plan pruning ------------------------------------------------------------------------------- - --- | How 'pruneInstallPlanToTargets' should interpret the per-package --- 'ComponentTarget's: as build, repl or haddock targets. --- -data TargetAction = TargetActionConfigure - | TargetActionBuild - | TargetActionRepl - | TargetActionTest - | TargetActionBench - | TargetActionHaddock - --- | Given a set of per-package\/per-component targets, take the subset of the --- install plan needed to build those targets. Also, update the package config --- to specify which optional stanzas to enable, and which targets within each --- package to build. --- --- NB: Pruning happens after improvement, which is important because we --- will prune differently depending on what is already installed (to --- implement "sticky" test suite enabling behavior). --- -pruneInstallPlanToTargets :: TargetAction - -> Map UnitId [ComponentTarget] - -> ElaboratedInstallPlan -> ElaboratedInstallPlan -pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) - . Graph.fromDistinctList - -- We have to do the pruning in two passes - . pruneInstallPlanPass2 - . pruneInstallPlanPass1 - -- Set the targets that will be the roots for pruning - . setRootTargets targetActionType perPkgTargetsMap - . InstallPlan.toList - $ elaboratedPlan - --- | This is a temporary data type, where we temporarily --- override the graph dependencies of an 'ElaboratedPackage', --- so we can take a closure over them. We'll throw out the --- overriden dependencies when we're done so it's strictly temporary. --- --- For 'ElaboratedComponent', this the cached unit IDs always --- coincide with the real thing. -data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] - -instance Package PrunedPackage where - packageId (PrunedPackage elab _) = packageId elab - -instance HasUnitId PrunedPackage where - installedUnitId = nodeKey - -instance IsNode PrunedPackage where - type Key PrunedPackage = UnitId - nodeKey (PrunedPackage elab _) = nodeKey elab - nodeNeighbors (PrunedPackage _ deps) = deps - -fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage -fromPrunedPackage (PrunedPackage elab _) = elab - --- | Set the build targets based on the user targets (but not rev deps yet). --- This is required before we can prune anything. --- -setRootTargets :: TargetAction - -> Map UnitId [ComponentTarget] - -> [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -setRootTargets targetAction perPkgTargetsMap = - assert (not (Map.null perPkgTargetsMap)) $ - assert (all (not . null) (Map.elems perPkgTargetsMap)) $ - - map (mapConfiguredPackage setElabBuildTargets) - where - -- Set the targets we'll build for this package/component. This is just - -- based on the root targets from the user, not targets implied by reverse - -- dependencies. Those comes in the second pass once we know the rev deps. - -- - setElabBuildTargets elab = - case (Map.lookup (installedUnitId elab) perPkgTargetsMap, - targetAction) of - (Nothing, _) -> elab - (Just tgts, TargetActionConfigure) -> elab { elabConfigureTargets = tgts } - (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } - (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } - (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } - (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt - , elabBuildHaddocks = False } - (Just tgts, TargetActionHaddock) -> - foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts - , elabBuildHaddocks = True }) tgts - (Just _, TargetActionRepl) -> - error "pruneInstallPlanToTargets: multiple repl targets" - - setElabHaddockTargets tgt elab - | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True } - | isBenchComponentTarget tgt = elab { elabHaddockBenchmarks = True } - | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True } - | isExeComponentTarget tgt = elab { elabHaddockExecutables = True } - | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True } - | otherwise = elab - --- | Assuming we have previously set the root build targets (i.e. the user --- targets but not rev deps yet), the first pruning pass does two things: --- --- * A first go at determining which optional stanzas (testsuites, benchmarks) --- are needed. We have a second go in the next pass. --- * Take the dependency closure using pruned dependencies. We prune deps that --- are used only by unneeded optional stanzas. These pruned deps are only --- used for the dependency closure and are not persisted in this pass. --- -pruneInstallPlanPass1 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -pruneInstallPlanPass1 pkgs = - map (mapConfiguredPackage fromPrunedPackage) - (fromMaybe [] $ Graph.closure graph roots) - where - pkgs' = map (mapConfiguredPackage prune) pkgs - graph = Graph.fromDistinctList pkgs' - roots = mapMaybe find_root pkgs' - - prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') - where elab' = - setDocumentation - $ addOptionalStanzas elab - - find_root (InstallPlan.Configured (PrunedPackage elab _)) = - if not $ and [ null (elabConfigureTargets elab) - , null (elabBuildTargets elab) - , null (elabTestTargets elab) - , null (elabBenchTargets elab) - , isNothing (elabReplTarget elab) - , null (elabHaddockTargets elab) - ] - then Just (installedUnitId elab) - else Nothing - find_root _ = Nothing - - -- Note [Sticky enabled testsuites] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- The testsuite and benchmark targets are somewhat special in that we need - -- to configure the packages with them enabled, and we need to do that even - -- if we only want to build one of several testsuites. - -- - -- There are two cases in which we will enable the testsuites (or - -- benchmarks): if one of the targets is a testsuite, or if all of the - -- testsuite dependencies are already cached in the store. The rationale - -- for the latter is to minimise how often we have to reconfigure due to - -- the particular targets we choose to build. Otherwise choosing to build - -- a testsuite target, and then later choosing to build an exe target - -- would involve unnecessarily reconfiguring the package with testsuites - -- disabled. Technically this introduces a little bit of stateful - -- behaviour to make this "sticky", but it should be benign. - - -- Decide whether or not to enable testsuites and benchmarks. - -- See [Sticky enabled testsuites] - addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = - elab { - elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) - } - where - stanzas :: Set OptionalStanza - -- By default, we enabled all stanzas requested by the user, - -- as per elabStanzasRequested, done in - -- 'elaborateSolverToPackage' - stanzas = pkgStanzasEnabled pkg - -- optionalStanzasRequiredByTargets has to be done at - -- prune-time because it depends on 'elabTestTargets' - -- et al, which is done by 'setRootTargets' at the - -- beginning of pruning. - <> optionalStanzasRequiredByTargets elab - -- optionalStanzasWithDepsAvailable has to be done at - -- prune-time because it depends on what packages are - -- installed, which is not known until after improvement - -- (pruning is done after improvement) - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - addOptionalStanzas elab = elab - - setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = - elab { - elabBuildHaddocks = - elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab - } - - where - documentationEnabled c = - case c of - CD.ComponentLib -> const True - CD.ComponentSubLib _ -> elabHaddockInternal - CD.ComponentFLib _ -> elabHaddockForeignLibs - CD.ComponentExe _ -> elabHaddockExecutables - CD.ComponentTest _ -> elabHaddockTestSuites - CD.ComponentBench _ -> elabHaddockBenchmarks - CD.ComponentSetup -> const False - - setDocumentation elab = elab - - -- Calculate package dependencies but cut out those needed only by - -- optional stanzas that we've determined we will not enable. - -- These pruned deps are not persisted in this pass since they're based on - -- the optional stanzas and we'll make further tweaks to the optional - -- stanzas in the next pass. - -- - pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] - pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } - = InstallPlan.depends elab -- no pruning - pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } - = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) - where - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - stanzas = pkgStanzasEnabled pkg - - optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage - -> Set OptionalStanza - optionalStanzasRequiredByTargets pkg = - Set.fromList - [ stanza - | ComponentTarget cname _ <- elabBuildTargets pkg - ++ elabTestTargets pkg - ++ elabBenchTargets pkg - ++ maybeToList (elabReplTarget pkg) - ++ elabHaddockTargets pkg - , stanza <- maybeToList $ - componentOptionalStanza $ - CD.componentNameToComponent cname - ] - - availablePkgs = - Set.fromList - [ installedUnitId pkg - | InstallPlan.PreExisting pkg <- pkgs ] - --- | Given a set of already installed packages @availablePkgs@, --- determine the set of available optional stanzas from @pkg@ --- which have all of their dependencies already installed. This is used --- to implement "sticky" testsuites, where once we have installed --- all of the deps needed for the test suite, we go ahead and --- enable it always. -optionalStanzasWithDepsAvailable :: Set UnitId - -> ElaboratedConfiguredPackage - -> ElaboratedPackage - -> Set OptionalStanza -optionalStanzasWithDepsAvailable availablePkgs elab pkg = - Set.fromList - [ stanza - | stanza <- Set.toList (elabStanzasAvailable elab) - , let deps :: [UnitId] - deps = CD.select (optionalStanzaDeps stanza) - -- TODO: probably need to select other - -- dep types too eventually - (pkgOrderDependencies pkg) - , all (`Set.member` availablePkgs) deps - ] - where - optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True - optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True - optionalStanzaDeps _ _ = False - - --- The second pass does three things: --- --- * A second go at deciding which optional stanzas to enable. --- * Prune the dependencies based on the final choice of optional stanzas. --- * Extend the targets within each package to build, now we know the reverse --- dependencies, ie we know which libs are needed as deps by other packages. --- --- Achieving sticky behaviour with enabling\/disabling optional stanzas is --- tricky. The first approximation was handled by the first pass above, but --- it's not quite enough. That pass will enable stanzas if all of the deps --- of the optional stanza are already installed /in the store/. That's important --- but it does not account for dependencies that get built inplace as part of --- the project. We cannot take those inplace build deps into account in the --- pruning pass however because we don't yet know which ones we're going to --- build. Once we do know, we can have another go and enable stanzas that have --- all their deps available. Now we can consider all packages in the pruned --- plan to be available, including ones we already decided to build from --- source. --- --- Deciding which targets to build depends on knowing which packages have --- reverse dependencies (ie are needed). This requires the result of first --- pass, which is another reason we have to split it into two passes. --- --- Note that just because we might enable testsuites or benchmarks (in the --- first or second pass) doesn't mean that we build all (or even any) of them. --- That depends on which targets we picked in the first pass. --- -pruneInstallPlanPass2 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -pruneInstallPlanPass2 pkgs = - map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs - where - setStanzasDepsAndTargets elab = - elab { - elabBuildTargets = ordNub - $ elabBuildTargets elab - ++ libTargetsRequiredForRevDeps - ++ exeTargetsRequiredForRevDeps, - elabPkgOrComp = - case elabPkgOrComp elab of - ElabPackage pkg -> - let stanzas = pkgStanzasEnabled pkg - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - in ElabPackage $ pkg { - pkgStanzasEnabled = stanzas, - pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), - pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), - pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) - } - r@(ElabComponent _) -> r - } - where - libTargetsRequiredForRevDeps = - [ ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent - | installedUnitId elab `Set.member` hasReverseLibDeps - ] - exeTargetsRequiredForRevDeps = - -- TODO: allow requesting executable with different name - -- than package name - [ ComponentTarget (Cabal.CExeName - $ packageNameToUnqualComponentName - $ packageName $ elabPkgSourceId elab) - WholeComponent - | installedUnitId elab `Set.member` hasReverseExeDeps - ] - - - availablePkgs :: Set UnitId - availablePkgs = Set.fromList (map installedUnitId pkgs) - - hasReverseLibDeps :: Set UnitId - hasReverseLibDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderLibDependencies pkg ] - - hasReverseExeDeps :: Set UnitId - hasReverseExeDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderExeDependencies pkg ] - -mapConfiguredPackage :: (srcpkg -> srcpkg') - -> InstallPlan.GenericPlanPackage ipkg srcpkg - -> InstallPlan.GenericPlanPackage ipkg srcpkg' -mapConfiguredPackage f (InstallPlan.Configured pkg) = - InstallPlan.Configured (f pkg) -mapConfiguredPackage f (InstallPlan.Installed pkg) = - InstallPlan.Installed (f pkg) -mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = - InstallPlan.PreExisting pkg - ------------------------------------- --- Support for --only-dependencies --- - --- | Try to remove the given targets from the install plan. --- --- This is not always possible. --- -pruneInstallPlanToDependencies :: Set UnitId - -> ElaboratedInstallPlan - -> Either CannotPruneDependencies - ElaboratedInstallPlan -pruneInstallPlanToDependencies pkgTargets installPlan = - assert (all (isJust . InstallPlan.lookup installPlan) - (Set.toList pkgTargets)) $ - - fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) - . checkBrokenDeps - . Graph.fromDistinctList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) - . InstallPlan.toList - $ installPlan - where - -- Our strategy is to remove the packages we don't want and then check - -- if the remaining graph is broken or not, ie any packages with dangling - -- dependencies. If there are then we cannot prune the given targets. - checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage - -> Either CannotPruneDependencies - (Graph.Graph ElaboratedPlanPackage) - checkBrokenDeps graph = - case Graph.broken graph of - [] -> Right graph - brokenPackages -> - Left $ CannotPruneDependencies - [ (pkg, missingDeps) - | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = mapMaybe lookupDep missingDepIds - ] - where - -- lookup in the original unpruned graph - lookupDep = InstallPlan.lookup installPlan - --- | It is not always possible to prune to only the dependencies of a set of --- targets. It may be the case that removing a package leaves something else --- that still needed the pruned package. --- --- This lists all the packages that would be broken, and their dependencies --- that would be missing if we did prune. --- -newtype CannotPruneDependencies = - CannotPruneDependencies [(ElaboratedPlanPackage, - [ElaboratedPlanPackage])] - deriving (Show) - - ---------------------------- --- Setup.hs script policy --- - --- Handling for Setup.hs scripts is a bit tricky, part of it lives in the --- solver phase, and part in the elaboration phase. We keep the helper --- functions for both phases together here so at least you can see all of it --- in one place. --- --- There are four major cases for Setup.hs handling: --- --- 1. @build-type@ Custom with a @custom-setup@ section --- 2. @build-type@ Custom without a @custom-setup@ section --- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ --- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ --- --- It's also worth noting that packages specifying @cabal-version: >= 1.23@ --- or later that have @build-type@ Custom will always have a @custom-setup@ --- section. Therefore in case 2, the specified @cabal-version@ will always be --- less than 1.23. --- --- In cases 1 and 2 we obviously have to build an external Setup.hs script, --- while in case 4 we can use the internal library API. --- --- TODO:In case 3 we should fail. We don't know how to talk to --- newer ./Setup.hs --- --- data SetupScriptStyle = ... -- see ProjectPlanning.Types - --- | Work out the 'SetupScriptStyle' given the package description. --- -packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle -packageSetupScriptStyle pkg - | buildType == PD.Custom - , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza - , not (PD.defaultSetupDepends setupbi) -- but not one we added internally - = SetupCustomExplicitDeps - - | buildType == PD.Custom - , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as - , PD.defaultSetupDepends setupbi -- the solver fills in the deps - = SetupCustomImplicitDeps - - | buildType == PD.Custom - , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver - = SetupCustomImplicitDeps - - -- here we should fail. - | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against - = SetupNonCustomExternalLib - - | otherwise - = SetupNonCustomInternalLib - where - buildType = PD.buildType pkg - - --- | Part of our Setup.hs handling policy is implemented by getting the solver --- to work out setup dependencies for packages. The solver already handles --- packages that explicitly specify setup dependencies, but we can also tell --- the solver to treat other packages as if they had setup dependencies. --- That's what this function does, it gets called by the solver for all --- packages that don't already have setup dependencies. --- --- The dependencies we want to add is different for each 'SetupScriptStyle'. --- --- Note that adding default deps means these deps are actually /added/ to the --- packages that we get out of the solver in the 'SolverInstallPlan'. Making --- implicit setup deps explicit is a problem in the post-solver stages because --- we still need to distinguish the case of explicit and implict setup deps. --- See 'rememberImplicitSetupDeps'. --- --- Note in addition to adding default setup deps, we also use --- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require --- @Cabal >= 1.20@ for Setup scripts. --- -defaultSetupDeps :: Compiler -> Platform - -> PD.PackageDescription - -> Maybe [Dependency] -defaultSetupDeps compiler platform pkg = - case packageSetupScriptStyle pkg of - - -- For packages with build type custom that do not specify explicit - -- setup dependencies, we add a dependency on Cabal and a number - -- of other packages. - SetupCustomImplicitDeps -> - Just $ - [ Dependency depPkgname anyVersion mainLibSet - | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ - [ Dependency cabalPkgname cabalConstraint mainLibSet - | packageName pkg /= cabalPkgname ] - where - -- The Cabal dep is slightly special: - -- * We omit the dep for the Cabal lib itself, since it bootstraps. - -- * We constrain it to be < 1.25 - -- - -- Note: we also add a global constraint to require Cabal >= 1.20 - -- for Setup scripts (see use addSetupCabalMinVersionConstraint). - -- - cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) - `intersectVersionRanges` - earlierVersion cabalCompatMaxVer - -- The idea here is that at some point we will make significant - -- breaking changes to the Cabal API that Setup.hs scripts use. - -- So for old custom Setup scripts that do not specify explicit - -- constraints, we constrain them to use a compatible Cabal version. - cabalCompatMaxVer = mkVersion [1,25] - - -- For other build types (like Simple) if we still need to compile an - -- external Setup.hs, it'll be one of the simple ones that only depends - -- on Cabal and base. - SetupNonCustomExternalLib -> - Just [ Dependency cabalPkgname cabalConstraint mainLibSet - , Dependency basePkgname anyVersion mainLibSet] - where - cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) - - -- The internal setup wrapper method has no deps at all. - SetupNonCustomInternalLib -> Just [] - - -- This case gets ruled out by the caller, planPackages, see the note - -- above in the SetupCustomImplicitDeps case. - SetupCustomExplicitDeps -> - error $ "defaultSetupDeps: called for a package with explicit " - ++ "setup deps: " ++ prettyShow (packageId pkg) - where - -- we require one less - -- - -- This maps e.g. CabalSpecV3_0 to mkVersion [2,5] - csvToVersion :: CabalSpecVersion -> Version - csvToVersion = mkVersion . cabalSpecMinimumLibraryVersion - --- | Work out which version of the Cabal we will be using to talk to the --- Setup.hs interface for this package. --- --- This depends somewhat on the 'SetupScriptStyle' but most cases are a result --- of what the solver picked for us, based on the explicit setup deps or the --- ones added implicitly by 'defaultSetupDeps'. --- -packageSetupScriptSpecVersion :: SetupScriptStyle - -> PD.PackageDescription - -> Graph.Graph NonSetupLibDepSolverPlanPackage - -> ComponentDeps [SolverId] - -> Version - --- We're going to be using the internal Cabal library, so the spec version of --- that is simply the version of the Cabal library that cabal-install has been --- built with. -packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ = - cabalVersion - --- If we happen to be building the Cabal lib itself then because that --- bootstraps itself then we use the version of the lib we're building. -packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _ - | packageName pkg == cabalPkgname - = packageVersion pkg - --- In all other cases we have a look at what version of the Cabal lib the --- solver picked. Or if it didn't depend on Cabal at all (which is very rare) --- then we look at the .cabal file to see what spec version it declares. -packageSetupScriptSpecVersion _ pkg libDepGraph deps = - case find ((cabalPkgname ==) . packageName) setupLibDeps of - Just dep -> packageVersion dep - Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg)) - where - setupLibDeps = map packageId $ fromMaybe [] $ - Graph.closure libDepGraph (CD.setupDeps deps) - - -cabalPkgname, basePkgname :: PackageName -cabalPkgname = mkPackageName "Cabal" -basePkgname = mkPackageName "base" - - -legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] -legacyCustomSetupPkgs compiler (Platform _ os) = - map mkPackageName $ - [ "array", "base", "binary", "bytestring", "containers" - , "deepseq", "directory", "filepath", "pretty" - , "process", "time", "transformers" ] - ++ [ "Win32" | os == Windows ] - ++ [ "unix" | os /= Windows ] - ++ [ "ghc-prim" | isGHC ] - ++ [ "template-haskell" | isGHC ] - ++ [ "old-time" | notGHC710 ] - where - isGHC = compilerCompatFlavor GHC compiler - notGHC710 = case compilerCompatVersion GHC compiler of - Nothing -> False - Just v -> v <= mkVersion [7,9] - --- The other aspects of our Setup.hs policy lives here where we decide on --- the 'SetupScriptOptions'. --- --- Our current policy for the 'SetupCustomImplicitDeps' case is that we --- try to make the implicit deps cover everything, and we don't allow the --- compiler to pick up other deps. This may or may not be sustainable, and --- we might have to allow the deps to be non-exclusive, but that itself would --- be tricky since we would have to allow the Setup access to all the packages --- in the store and local dbs. - -setupHsScriptOptions :: ElaboratedReadyPackage - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> DistDirLayout - -> FilePath - -> FilePath - -> Bool - -> Lock - -> SetupScriptOptions --- TODO: Fix this so custom is a separate component. Custom can ALWAYS --- be a separate component!!! -setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - plan ElaboratedSharedConfig{..} distdir srcdir builddir - isParallelBuild cacheLock = - SetupScriptOptions { - useCabalVersion = thisVersion elabSetupScriptCliVersion, - useCabalSpecVersion = Just elabSetupScriptCliVersion, - useCompiler = Just pkgConfigCompiler, - usePlatform = Just pkgConfigPlatform, - usePackageDB = elabSetupPackageDBStack, - usePackageIndex = Nothing, - useDependencies = [ (uid, srcid) - | ConfiguredId srcid (Just (CLibName LMainLibName)) uid - <- elabSetupDependencies elab ], - useDependenciesExclusive = True, - useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, - useProgramDb = pkgConfigCompilerProgs, - useDistPref = builddir, - useLoggingHandle = Nothing, -- this gets set later - useWorkingDir = Just srcdir, - useExtraPathEnv = elabExeDependencyPaths elab, - useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan, - useWin32CleanHack = False, --TODO: [required eventually] - forceExternalSetupMethod = isParallelBuild, - setupCacheLock = Just cacheLock, - isInteractive = False - } - - --- | To be used for the input for elaborateInstallPlan. --- --- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. --- -userInstallDirTemplates :: Compiler - -> IO InstallDirs.InstallDirTemplates -userInstallDirTemplates compiler = do - InstallDirs.defaultInstallDirs - (compilerFlavor compiler) - True -- user install - False -- unused - -storePackageInstallDirs :: StoreDirLayout - -> CompilerId - -> InstalledPackageId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs storeDirLayout compid ipkgid = - storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid - -storePackageInstallDirs' :: StoreDirLayout - -> CompilerId - -> UnitId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs' StoreDirLayout{ storePackageDirectory - , storeDirectory } - compid unitid = - InstallDirs.InstallDirs {..} - where - store = storeDirectory compid - prefix = storePackageDirectory compid unitid - bindir = prefix "bin" - libdir = prefix "lib" - libsubdir = "" - -- Note: on macOS, we place libraries into - -- @store/lib@ to work around the load - -- command size limit of macOSs mach-o linker. - -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ - dynlibdir | buildOS == OSX = store "lib" - | otherwise = libdir - flibdir = libdir - libexecdir = prefix "libexec" - libexecsubdir= "" - includedir = libdir "include" - datadir = prefix "share" - datasubdir = "" - docdir = datadir "doc" - mandir = datadir "man" - htmldir = docdir "html" - haddockdir = htmldir - sysconfdir = prefix "etc" - - - -computeInstallDirs :: StoreDirLayout - -> InstallDirs.InstallDirTemplates - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab - | elabBuildStyle elab == BuildInplaceOnly - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - (elabPkgSourceId elab) - (elabUnitId elab) - (compilerInfo (pkgConfigCompiler elaboratedShared)) - InstallDirs.NoCopyDest - (pkgConfigPlatform elaboratedShared) - defaultInstallDirs) { - - -- absoluteInstallDirs sets these as 'undefined' but we have - -- to use them as "Setup.hs configure" args - InstallDirs.libsubdir = "", - InstallDirs.libexecsubdir = "", - InstallDirs.datasubdir = "" - } - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs' - storeDirLayout - (compilerId (pkgConfigCompiler elaboratedShared)) - (elabUnitId elab) - - ---TODO: [code cleanup] perhaps reorder this code --- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, --- make the various Setup.hs {configure,build,copy} flags - - -setupHsConfigureFlags :: ElaboratedReadyPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ConfigFlags -setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig@ElaboratedSharedConfig{..} - verbosity builddir = - sanityCheckElaboratedConfiguredPackage sharedConfig elab - (Cabal.ConfigFlags {..}) - where - configArgs = mempty -- unused, passed via args - configDistPref = toFlag builddir - configCabalFilePath = mempty - configVerbosity = toFlag verbosity - - configInstantiateWith = Map.toList elabInstantiatedWith - - configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese - configIPID = case elabPkgOrComp of - ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg)) - ElabComponent _ -> mempty - configCID = case elabPkgOrComp of - ElabPackage _ -> mempty - ElabComponent _ -> toFlag elabComponentId - - configProgramPaths = Map.toList elabProgramPaths - configProgramArgs - | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True - -- workaround for - -- - -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. - -- custom Setup.hs scripts calling out to GHC even when going via - -- @runProgram ghcProgram@, as e.g. happy does in its - -- - -- (see also ) - -- - -- So for now, let's pass the rather harmless and idempotent - -- `-hide-all-packages` flag to all invocations (which has - -- the benefit that every GHC invocation starts with a - -- conistently well-defined clean slate) until we find a - -- better way. - = Map.toList $ - Map.insertWith (++) "ghc" ["-hide-all-packages"] - elabProgramArgs - | otherwise = Map.toList elabProgramArgs - configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) - configHcPath = mempty -- we use configProgramPaths instead - configHcPkg = mempty -- we use configProgramPaths instead - - configVanillaLib = toFlag elabVanillaLib - configSharedLib = toFlag elabSharedLib - configStaticLib = toFlag elabStaticLib - - configDynExe = toFlag elabDynExe - configFullyStaticExe = toFlag elabFullyStaticExe - configGHCiLib = toFlag elabGHCiLib - configProfExe = mempty - configProfLib = toFlag elabProfLib - configProf = toFlag elabProfExe - - -- configProfDetail is for exe+lib, but overridden by configProfLibDetail - -- so we specify both so we can specify independently - configProfDetail = toFlag elabProfExeDetail - configProfLibDetail = toFlag elabProfLibDetail - - configCoverage = toFlag elabCoverage - configLibCoverage = mempty - - configOptimization = toFlag elabOptimization - configSplitSections = toFlag elabSplitSections - configSplitObjs = toFlag elabSplitObjs - configStripExes = toFlag elabStripExes - configStripLibs = toFlag elabStripLibs - configDebugInfo = toFlag elabDebugInfo - - configConfigurationsFlags = elabFlagAssignment - configConfigureArgs = elabConfigureScriptArgs - configExtraLibDirs = elabExtraLibDirs - configExtraFrameworkDirs = elabExtraFrameworkDirs - configExtraIncludeDirs = elabExtraIncludeDirs - configProgPrefix = maybe mempty toFlag elabProgPrefix - configProgSuffix = maybe mempty toFlag elabProgSuffix - - configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) - elabInstallDirs - - -- we only use configDependencies, unless we're talking to an old Cabal - -- in which case we use configConstraints - -- NB: This does NOT use InstallPlan.depends, which includes executable - -- dependencies which should NOT be fed in here (also you don't have - -- enough info anyway) - configDependencies = [ GivenComponent - (packageName srcid) - ln - cid - | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab - , let ln = case mb_cn - of Just (CLibName lname) -> lname - Just _ -> error "non-library dependency" - Nothing -> LMainLibName - ] - configConstraints = - case elabPkgOrComp of - ElabPackage _ -> - [ thisPackageVersionConstraint srcid - | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] - ElabComponent _ -> [] - - - -- explicitly clear, then our package db stack - -- TODO: [required eventually] have to do this differently for older Cabal versions - configPackageDBs = Nothing : map Just elabBuildPackageDBStack - - configTests = case elabPkgOrComp of - ElabPackage pkg -> toFlag (TestStanzas `Set.member` pkgStanzasEnabled pkg) - ElabComponent _ -> mempty - configBenchmarks = case elabPkgOrComp of - ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg) - ElabComponent _ -> mempty - - configExactConfiguration = toFlag True - configFlagError = mempty --TODO: [research required] appears not to be implemented - configRelocatable = mempty --TODO: [research required] ??? - configScratchDir = mempty -- never use - configUserInstall = mempty -- don't rely on defaults - configPrograms_ = mempty -- never use, shouldn't exist - configUseResponseFiles = mempty - configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler - -setupHsConfigureArgs :: ElaboratedConfiguredPackage - -> [String] -setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] -setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = - [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] - where - cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") - (compComponentName comp) - -setupHsBuildFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BuildFlags -setupHsBuildFlags _ _ verbosity builddir = - Cabal.BuildFlags { - buildProgramPaths = mempty, --unused, set at configure time - buildProgramArgs = mempty, --unused, set at configure time - buildVerbosity = toFlag verbosity, - buildDistPref = toFlag builddir, - buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), - buildArgs = mempty, -- unused, passed via args not flags - buildCabalFilePath= mempty - } - - -setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) - -- Fix for #3335, don't pass build arguments if it's not supported - | elabSetupScriptCliVersion elab >= mkVersion [1,17] - = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) - | otherwise - = [] -setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) - = [] - - -setupHsTestFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.TestFlags -setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags - { testDistPref = toFlag builddir - , testVerbosity = toFlag verbosity - , testMachineLog = maybe mempty toFlag elabTestMachineLog - , testHumanLog = maybe mempty toFlag elabTestHumanLog - , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails - , testKeepTix = toFlag elabTestKeepTix - , testWrapper = maybe mempty toFlag elabTestWrapper - , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites - , testOptions = elabTestTestOptions - } - -setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] --- TODO: Does the issue #3335 affects test as well -setupHsTestArgs elab = - mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) - - -setupHsBenchFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BenchmarkFlags -setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags - { benchmarkDistPref = toFlag builddir - , benchmarkVerbosity = toFlag verbosity - , benchmarkOptions = elabBenchmarkOptions - } - -setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBenchArgs elab = - mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) - - -setupHsReplFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ReplFlags -setupHsReplFlags _ sharedConfig verbosity builddir = - Cabal.ReplFlags { - replProgramPaths = mempty, --unused, set at configure time - replProgramArgs = mempty, --unused, set at configure time - replVerbosity = toFlag verbosity, - replDistPref = toFlag builddir, - replReload = mempty, --only used as callback from repl - replReplOptions = pkgConfigReplOptions sharedConfig --runtime override for repl flags - } - - -setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] -setupHsReplArgs elab = - maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) - --TODO: should be able to give multiple modules in one component - - -setupHsCopyFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.CopyFlags -setupHsCopyFlags _ _ verbosity builddir destdir = - Cabal.CopyFlags { - copyArgs = [], -- TODO: could use this to only copy what we enabled - copyDest = toFlag (InstallDirs.CopyTo destdir), - copyDistPref = toFlag builddir, - copyVerbosity = toFlag verbosity, - copyCabalFilePath = mempty - } - -setupHsRegisterFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.RegisterFlags -setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ - verbosity builddir pkgConfFile = - Cabal.RegisterFlags { - regPackageDB = mempty, -- misfeature - regGenScript = mempty, -- never use - regGenPkgConf = toFlag (Just pkgConfFile), - regInPlace = case elabBuildStyle of - BuildInplaceOnly -> toFlag True - _ -> toFlag False, - regPrintId = mempty, -- never use - regDistPref = toFlag builddir, - regArgs = [], - regVerbosity = toFlag verbosity, - regCabalFilePath = mempty - } - -setupHsHaddockFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.HaddockFlags -setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = - Cabal.HaddockFlags { - haddockProgramPaths = mempty, --unused, set at configure time - haddockProgramArgs = mempty, --unused, set at configure time - haddockHoogle = toFlag elabHaddockHoogle, - haddockHtml = toFlag elabHaddockHtml, - haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, - haddockForHackage = toFlag elabHaddockForHackage, - haddockForeignLibs = toFlag elabHaddockForeignLibs, - haddockExecutables = toFlag elabHaddockExecutables, - haddockTestSuites = toFlag elabHaddockTestSuites, - haddockBenchmarks = toFlag elabHaddockBenchmarks, - haddockInternal = toFlag elabHaddockInternal, - haddockCss = maybe mempty toFlag elabHaddockCss, - haddockLinkedSource = toFlag elabHaddockLinkedSource, - haddockQuickJump = toFlag elabHaddockQuickJump, - haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, - haddockContents = maybe mempty toFlag elabHaddockContents, - haddockDistPref = toFlag builddir, - haddockKeepTempFiles = mempty, --TODO: from build settings - haddockVerbosity = toFlag verbosity, - haddockCabalFilePath = mempty, - haddockArgs = mempty - } - -setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] --- TODO: Does the issue #3335 affects test as well -setupHsHaddockArgs elab = - map (showComponentTarget (packageId elab)) (elabHaddockTargets elab) - -{- -setupHsTestFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.TestFlags -setupHsTestFlags _ _ verbosity builddir = - Cabal.TestFlags { - } --} - ------------------------------------------------------------------------------- --- * Sharing installed packages ------------------------------------------------------------------------------- - --- --- Nix style store management for tarball packages --- --- So here's our strategy: --- --- We use a per-user nix-style hashed store, but /only/ for tarball packages. --- So that includes packages from hackage repos (and other http and local --- tarballs). For packages in local directories we do not register them into --- the shared store by default, we just build them locally inplace. --- --- The reason we do it like this is that it's easy to make stable hashes for --- tarball packages, and these packages benefit most from sharing. By contrast --- unpacked dir packages are harder to hash and they tend to change more --- frequently so there's less benefit to sharing them. --- --- When using the nix store approach we have to run the solver *without* --- looking at the packages installed in the store, just at the source packages --- (plus core\/global installed packages). Then we do a post-processing pass --- to replace configured packages in the plan with pre-existing ones, where --- possible. Where possible of course means where the nix-style package hash --- equals one that's already in the store. --- --- One extra wrinkle is that unless we know package tarball hashes upfront, we --- will have to download the tarballs to find their hashes. So we have two --- options: delay replacing source with pre-existing installed packages until --- the point during the execution of the install plan where we have the --- tarball, or try to do as much up-front as possible and then check again --- during plan execution. The former isn't great because we would end up --- telling users we're going to re-install loads of packages when in fact we --- would just share them. It'd be better to give as accurate a prediction as --- we can. The latter is better for users, but we do still have to check --- during plan execution because it's important that we don't replace existing --- installed packages even if they have the same package hash, because we --- don't guarantee ABI stability. - --- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but --- not replace installed packages with ghc-pkg. - -packageHashInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashInputs -packageHashInputs - pkgshared - elab@(ElaboratedConfiguredPackage { - elabPkgSourceHash = Just srchash - }) = - PackageHashInputs { - pkgHashPkgId = packageId elab, - pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp), - pkgHashSourceHash = srchash, - pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab), - pkgHashDirectDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList $ - [ confInstId dep - | dep <- CD.select relevantDeps pkgLibDependencies ] ++ - [ confInstId dep - | dep <- CD.select relevantDeps pkgExeDependencies ] - ElabComponent comp -> - Set.fromList (map confInstId (compLibDependencies comp - ++ compExeDependencies comp)), - pkgHashOtherConfig = packageHashConfigInputs pkgshared elab - } - where - -- Obviously the main deps are relevant - relevantDeps CD.ComponentLib = True - relevantDeps (CD.ComponentSubLib _) = True - relevantDeps (CD.ComponentFLib _) = True - relevantDeps (CD.ComponentExe _) = True - -- Setup deps can affect the Setup.hs behaviour and thus what is built - relevantDeps CD.ComponentSetup = True - -- However testsuites and benchmarks do not get installed and should not - -- affect the result, so we do not include them. - relevantDeps (CD.ComponentTest _) = False - relevantDeps (CD.ComponentBench _) = False - -packageHashInputs _ pkg = - error $ "packageHashInputs: only for packages with source hashes. " - ++ prettyShow (packageId pkg) - -packageHashConfigInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashConfigInputs -packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = - PackageHashConfigInputs { - pkgHashCompilerId = compilerId pkgConfigCompiler, - pkgHashPlatform = pkgConfigPlatform, - pkgHashFlagAssignment = elabFlagAssignment, - pkgHashConfigureScriptArgs = elabConfigureScriptArgs, - pkgHashVanillaLib = elabVanillaLib, - pkgHashSharedLib = elabSharedLib, - pkgHashDynExe = elabDynExe, - pkgHashFullyStaticExe = elabFullyStaticExe, - pkgHashGHCiLib = elabGHCiLib, - pkgHashProfLib = elabProfLib, - pkgHashProfExe = elabProfExe, - pkgHashProfLibDetail = elabProfLibDetail, - pkgHashProfExeDetail = elabProfExeDetail, - pkgHashCoverage = elabCoverage, - pkgHashOptimization = elabOptimization, - pkgHashSplitSections = elabSplitSections, - pkgHashSplitObjs = elabSplitObjs, - pkgHashStripLibs = elabStripLibs, - pkgHashStripExes = elabStripExes, - pkgHashDebugInfo = elabDebugInfo, - pkgHashProgramArgs = elabProgramArgs, - pkgHashExtraLibDirs = elabExtraLibDirs, - pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, - pkgHashExtraIncludeDirs = elabExtraIncludeDirs, - pkgHashProgPrefix = elabProgPrefix, - pkgHashProgSuffix = elabProgSuffix, - - pkgHashDocumentation = elabBuildHaddocks, - pkgHashHaddockHoogle = elabHaddockHoogle, - pkgHashHaddockHtml = elabHaddockHtml, - pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation, - pkgHashHaddockForeignLibs = elabHaddockForeignLibs, - pkgHashHaddockExecutables = elabHaddockExecutables, - pkgHashHaddockTestSuites = elabHaddockTestSuites, - pkgHashHaddockBenchmarks = elabHaddockBenchmarks, - pkgHashHaddockInternal = elabHaddockInternal, - pkgHashHaddockCss = elabHaddockCss, - pkgHashHaddockLinkedSource = elabHaddockLinkedSource, - pkgHashHaddockQuickJump = elabHaddockQuickJump, - pkgHashHaddockContents = elabHaddockContents - } - where - ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg - --- | Given the 'InstalledPackageIndex' for a nix-style package store, and an --- 'ElaboratedInstallPlan', replace configured source packages by installed --- packages from the store whenever they exist. --- -improveInstallPlanWithInstalledPackages :: Set UnitId - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -improveInstallPlanWithInstalledPackages installedPkgIdSet = - InstallPlan.installed canPackageBeImproved - where - canPackageBeImproved pkg = - installedUnitId pkg `Set.member` installedPkgIdSet - --TODO: sanity checks: - -- * the installed package must have the expected deps etc - -- * the installed package must not be broken, valid dep closure - - --TODO: decide what to do if we encounter broken installed packages, - -- since overwriting is never safe. - - --- Path construction ------- - --- | The path to the directory that contains a specific executable. --- NB: For inplace NOT InstallPaths.bindir installDirs; for an --- inplace build those values are utter nonsense. So we --- have to guess where the directory is going to be. --- Fortunately this is "stable" part of Cabal API. --- But the way we get the build directory is A HORRIBLE --- HACK. -binDirectoryFor - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> FilePath - -> FilePath -binDirectoryFor layout config package exe = case elabBuildStyle package of - BuildAndInstall -> installedBinDirectory package - BuildInplaceOnly -> inplaceBinRoot layout config package exe - --- package has been built and installed. -installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath -installedBinDirectory = InstallDirs.bindir . elabInstallDirs - --- | The path to the @build@ directory for an inplace build. -inplaceBinRoot - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> FilePath -inplaceBinRoot layout config package - = distBuildDirectory layout (elabDistDirParams config package) - "build" diff --git a/Distribution/Client/ProjectPlanning/Types.hs b/Distribution/Client/ProjectPlanning/Types.hs deleted file mode 100644 --- a/Distribution/Client/ProjectPlanning/Types.hs +++ /dev/null @@ -1,840 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} - --- | Types used while planning how to build everything in a project. --- --- Primarily this is the 'ElaboratedInstallPlan'. --- -module Distribution.Client.ProjectPlanning.Types ( - SolverInstallPlan, - - -- * Elaborated install plan types - ElaboratedInstallPlan, - normaliseConfiguredPackage, - ElaboratedConfiguredPackage(..), - - elabDistDirParams, - elabExeDependencyPaths, - elabLibDependencies, - elabOrderLibDependencies, - elabExeDependencies, - elabOrderExeDependencies, - elabSetupDependencies, - elabPkgConfigDependencies, - elabInplaceDependencyBuildCacheFiles, - elabRequiresRegistration, - dataDirsEnvironmentForPlan, - - elabPlanPackageName, - elabConfiguredName, - elabComponentName, - - ElaboratedPackageOrComponent(..), - ElaboratedComponent(..), - ElaboratedPackage(..), - pkgOrderDependencies, - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, - - -- * Build targets - ComponentTarget(..), - showComponentTarget, - showTestComponentTarget, - showBenchComponentTarget, - SubComponentTarget(..), - - isSubLibComponentTarget, - isForeignLibComponentTarget, - isExeComponentTarget, - isTestComponentTarget, - isBenchComponentTarget, - - componentOptionalStanza, - - -- * Setup script - SetupScriptStyle(..), - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.TargetSelector - ( SubComponentTarget(..) ) -import Distribution.Client.PackageHash - -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage(..) ) -import Distribution.Client.SolverInstallPlan - ( SolverInstallPlan ) -import Distribution.Client.DistDirLayout - -import Distribution.Backpack -import Distribution.Backpack.ModuleShape - -import Distribution.Verbosity (normal) -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PackageDescription (PackageDescription(..)) -import Distribution.Package -import Distribution.System -import qualified Distribution.PackageDescription as Cabal -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.Compiler -import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) -import qualified Distribution.Simple.BuildTarget as Cabal -import Distribution.Simple.Program -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), LibraryName(..) ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.InstallDirs (PathTemplate) -import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) -import Distribution.Version - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Simple.Utils (ordNub) - -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Monoid as Mon -import System.FilePath (()) - - --- | The combination of an elaborated install plan plus a --- 'ElaboratedSharedConfig' contains all the details necessary to be able --- to execute the plan without having to make further policy decisions. --- --- It does not include dynamic elements such as resources (such as http --- connections). --- -type ElaboratedInstallPlan - = GenericInstallPlan InstalledPackageInfo - ElaboratedConfiguredPackage - -type ElaboratedPlanPackage - = GenericPlanPackage InstalledPackageInfo - ElaboratedConfiguredPackage - --- | User-friendly display string for an 'ElaboratedPlanPackage'. -elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String -elabPlanPackageName verbosity (PreExisting ipkg) - | verbosity <= normal = prettyShow (packageName ipkg) - | otherwise = prettyShow (installedUnitId ipkg) -elabPlanPackageName verbosity (Configured elab) - = elabConfiguredName verbosity elab -elabPlanPackageName verbosity (Installed elab) - = elabConfiguredName verbosity elab - ---TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle --- even platform and compiler could be different if we're building things --- like a server + client with ghc + ghcjs -data ElaboratedSharedConfig - = ElaboratedSharedConfig { - - pkgConfigPlatform :: Platform, - pkgConfigCompiler :: Compiler, --TODO: [code cleanup] replace with CompilerInfo - -- | The programs that the compiler configured (e.g. for GHC, the progs - -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are - -- used. - pkgConfigCompilerProgs :: ProgramDb, - pkgConfigReplOptions :: [String] - } - deriving (Show, Generic, Typeable) - --TODO: [code cleanup] no Eq instance - -instance Binary ElaboratedSharedConfig -instance Structured ElaboratedSharedConfig - -data ElaboratedConfiguredPackage - = ElaboratedConfiguredPackage { - -- | The 'UnitId' which uniquely identifies this item in a build plan - elabUnitId :: UnitId, - - elabComponentId :: ComponentId, - elabInstantiatedWith :: Map ModuleName Module, - elabLinkedInstantiatedWith :: Map ModuleName OpenModule, - - -- | This is true if this is an indefinite package, or this is a - -- package with no signatures. (Notably, it's not true for instantiated - -- packages.) The motivation for this is if you ask to build - -- @foo-indef@, this probably means that you want to typecheck - -- it, NOT that you want to rebuild all of the various - -- instantiations of it. - elabIsCanonical :: Bool, - - -- | The 'PackageId' of the originating package - elabPkgSourceId :: PackageId, - - -- | Shape of the package/component, for Backpack. - elabModuleShape :: ModuleShape, - - -- | A total flag assignment for the package. - -- TODO: Actually this can be per-component if we drop - -- all flags that don't affect a component. - elabFlagAssignment :: Cabal.FlagAssignment, - - -- | The original default flag assignment, used only for reporting. - elabFlagDefaults :: Cabal.FlagAssignment, - - elabPkgDescription :: Cabal.PackageDescription, - - -- | Where the package comes from, e.g. tarball, local dir etc. This - -- is not the same as where it may be unpacked to for the build. - elabPkgSourceLocation :: PackageLocation (Maybe FilePath), - - -- | The hash of the source, e.g. the tarball. We don't have this for - -- local source dir packages. - elabPkgSourceHash :: Maybe PackageSourceHash, - - -- | Is this package one of the ones specified by location in the - -- project file? (As opposed to a dependency, or a named package pulled - -- in) - elabLocalToProject :: Bool, - - -- | Are we going to build and install this package to the store, or are - -- we going to build it and register it locally. - elabBuildStyle :: BuildStyle, - - -- | Another way of phrasing 'pkgStanzasAvailable'. - elabEnabledSpec :: ComponentRequestedSpec, - - -- | Which optional stanzas (ie testsuites, benchmarks) can be built. - -- This means the solver produced a plan that has them available. - -- This doesn't necessary mean we build them by default. - elabStanzasAvailable :: Set OptionalStanza, - - -- | Which optional stanzas the user explicitly asked to enable or - -- to disable. This tells us which ones we build by default, and - -- helps with error messages when the user asks to build something - -- they explicitly disabled. - -- - -- TODO: The 'Bool' here should be refined into an ADT with three - -- cases: NotRequested, ExplicitlyRequested and - -- ImplicitlyRequested. A stanza is explicitly requested if - -- the user asked, for this *specific* package, that the stanza - -- be enabled; it's implicitly requested if the user asked for - -- all global packages to have this stanza enabled. The - -- difference between an explicit and implicit request is - -- error reporting behavior: if a user asks for tests to be - -- enabled for a specific package that doesn't have any tests, - -- we should warn them about it, but we shouldn't complain - -- that a user enabled tests globally, and some local packages - -- just happen not to have any tests. (But perhaps we should - -- warn if ALL local packages don't have any tests.) - elabStanzasRequested :: Map OptionalStanza Bool, - - elabSetupPackageDBStack :: PackageDBStack, - elabBuildPackageDBStack :: PackageDBStack, - elabRegisterPackageDBStack :: PackageDBStack, - - elabPkgDescriptionOverride :: Maybe CabalFileText, - - -- TODO: make per-component variants of these flags - elabVanillaLib :: Bool, - elabSharedLib :: Bool, - elabStaticLib :: Bool, - elabDynExe :: Bool, - elabFullyStaticExe :: Bool, - elabGHCiLib :: Bool, - elabProfLib :: Bool, - elabProfExe :: Bool, - elabProfLibDetail :: ProfDetailLevel, - elabProfExeDetail :: ProfDetailLevel, - elabCoverage :: Bool, - elabOptimization :: OptimisationLevel, - elabSplitObjs :: Bool, - elabSplitSections :: Bool, - elabStripLibs :: Bool, - elabStripExes :: Bool, - elabDebugInfo :: DebugInfoLevel, - - elabProgramPaths :: Map String FilePath, - elabProgramArgs :: Map String [String], - elabProgramPathExtra :: [FilePath], - elabConfigureScriptArgs :: [String], - elabExtraLibDirs :: [FilePath], - elabExtraFrameworkDirs :: [FilePath], - elabExtraIncludeDirs :: [FilePath], - elabProgPrefix :: Maybe PathTemplate, - elabProgSuffix :: Maybe PathTemplate, - - elabInstallDirs :: InstallDirs.InstallDirs FilePath, - - elabHaddockHoogle :: Bool, - elabHaddockHtml :: Bool, - elabHaddockHtmlLocation :: Maybe String, - elabHaddockForeignLibs :: Bool, - elabHaddockForHackage :: HaddockTarget, - elabHaddockExecutables :: Bool, - elabHaddockTestSuites :: Bool, - elabHaddockBenchmarks :: Bool, - elabHaddockInternal :: Bool, - elabHaddockCss :: Maybe FilePath, - elabHaddockLinkedSource :: Bool, - elabHaddockQuickJump :: Bool, - elabHaddockHscolourCss :: Maybe FilePath, - elabHaddockContents :: Maybe PathTemplate, - - elabTestMachineLog :: Maybe PathTemplate, - elabTestHumanLog :: Maybe PathTemplate, - elabTestShowDetails :: Maybe TestShowDetails, - elabTestKeepTix :: Bool, - elabTestWrapper :: Maybe FilePath, - elabTestFailWhenNoTestSuites :: Bool, - elabTestTestOptions :: [PathTemplate], - - elabBenchmarkOptions :: [PathTemplate], - - -- Setup.hs related things: - - -- | One of four modes for how we build and interact with the Setup.hs - -- script, based on whether it's a build-type Custom, with or without - -- explicit deps and the cabal spec version the .cabal file needs. - elabSetupScriptStyle :: SetupScriptStyle, - - -- | The version of the Cabal command line interface that we are using - -- for this package. This is typically the version of the Cabal lib - -- that the Setup.hs is built against. - -- - -- TODO: We might want to turn this into a enum, - -- yet different enum than 'CabalSpecVersion'. - elabSetupScriptCliVersion :: Version, - - -- Build time related: - elabConfigureTargets :: [ComponentTarget], - elabBuildTargets :: [ComponentTarget], - elabTestTargets :: [ComponentTarget], - elabBenchTargets :: [ComponentTarget], - elabReplTarget :: Maybe ComponentTarget, - elabHaddockTargets :: [ComponentTarget], - - elabBuildHaddocks :: Bool, - - --pkgSourceDir ? -- currently passed in later because they can use temp locations - --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc - - -- | Component/package specific information - elabPkgOrComp :: ElaboratedPackageOrComponent - } - deriving (Eq, Show, Generic, Typeable) - -normaliseConfiguredPackage :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> ElaboratedConfiguredPackage -normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = - pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) } - where - knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs - - pkgDesc :: PackageDescription - pkgDesc = elabPkgDescription pkg - - removeEmpty :: [String] -> Maybe [String] - removeEmpty [] = Nothing - removeEmpty xs = Just xs - - lookupFilter :: String -> [String] -> Maybe [String] - lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of - Just p -> programNormaliseArgs p (getVersion p) pkgDesc args - Nothing -> args - - getVersion :: Program -> Maybe Version - getVersion p = lookupProgram p knownProgramDb >>= programVersion - --- | The package/component contains/is a library and so must be registered -elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool -elabRequiresRegistration elab = - case elabPkgOrComp elab of - ElabComponent comp -> - case compComponentName comp of - Just cn -> is_lib cn && build_target - _ -> False - ElabPackage pkg -> - -- Tricky! Not only do we have to test if the user selected - -- a library as a build target, we also have to test if - -- the library was TRANSITIVELY depended upon, since we will - -- also require a register in this case. - -- - -- NB: It would have been far nicer to just unconditionally - -- register in all cases, but some Custom Setups will fall - -- over if you try to do that, ESPECIALLY if there actually is - -- a library but they hadn't built it. - -- - -- However, as the case of `cpphs-1.20.8` has shown in - -- #5379, in cases when a monolithic package gets - -- installed due to its executable components - -- (i.e. exe:cpphs) into the store we *have* to register - -- if there's a buildable public library (i.e. lib:cpphs) - -- that was built and installed into the same store folder - -- as otherwise this will cause build failures once a - -- target actually depends on lib:cpphs. - build_target || (elabBuildStyle elab == BuildAndInstall && - Cabal.hasPublicLib (elabPkgDescription elab)) - -- the next sub-condition below is currently redundant - -- (see discussion in #5604 for more details), but it's - -- being kept intentionally here as a safeguard because if - -- internal libraries ever start working with - -- non-per-component builds this condition won't be - -- redundant anymore. - || any (depends_on_lib pkg) (elabBuildTargets elab) - where - depends_on_lib pkg (ComponentTarget cn _) = - not (null (CD.select (== CD.componentNameToComponent cn) - (pkgDependsOnSelfLib pkg))) - build_target = - if not (null (elabBuildTargets elab)) - then any is_lib_target (elabBuildTargets elab) - -- Empty build targets mean we build /everything/; - -- that means we have to look more carefully to see - -- if there is anything to register - else Cabal.hasLibs (elabPkgDescription elab) - -- NB: this means we DO NOT reregister if you just built a - -- single file - is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn - is_lib_target _ = False - is_lib (CLibName _) = True - is_lib _ = False - --- | Construct the environment needed for the data files to work. --- This consists of a separate @*_datadir@ variable for each --- inplace package in the plan. -dataDirsEnvironmentForPlan :: DistDirLayout - -> ElaboratedInstallPlan - -> [(String, Maybe FilePath)] -dataDirsEnvironmentForPlan distDirLayout = catMaybes - . fmap (InstallPlan.foldPlanPackage - (const Nothing) - (dataDirEnvVarForPackage distDirLayout)) - . InstallPlan.toList - --- | Construct an environment variable that points --- the package's datadir to its correct location. --- This might be: --- * 'Just' the package's source directory plus the data subdirectory --- for inplace packages. --- * 'Nothing' for packages installed in the store (the path was --- already included in the package at install/build time). -dataDirEnvVarForPackage :: DistDirLayout - -> ElaboratedConfiguredPackage - -> Maybe (String, Maybe FilePath) -dataDirEnvVarForPackage distDirLayout pkg = - case elabBuildStyle pkg - of BuildAndInstall -> Nothing - BuildInplaceOnly -> Just - ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" - , Just $ srcPath (elabPkgSourceLocation pkg) - dataDir (elabPkgDescription pkg)) - where - srcPath (LocalUnpackedPackage path) = path - srcPath (LocalTarballPackage _path) = unpackedPath - srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath - srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath - srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout - -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc - srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error - "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" - unpackedPath = - distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg - -instance Package ElaboratedConfiguredPackage where - packageId = elabPkgSourceId - -instance HasConfiguredId ElaboratedConfiguredPackage where - configuredId elab = - ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab) - -instance HasUnitId ElaboratedConfiguredPackage where - installedUnitId = elabUnitId - -instance IsNode ElaboratedConfiguredPackage where - type Key ElaboratedConfiguredPackage = UnitId - nodeKey = elabUnitId - nodeNeighbors = elabOrderDependencies - -instance Binary ElaboratedConfiguredPackage -instance Structured ElaboratedConfiguredPackage - -data ElaboratedPackageOrComponent - = ElabPackage ElaboratedPackage - | ElabComponent ElaboratedComponent - deriving (Eq, Show, Generic) - -instance Binary ElaboratedPackageOrComponent -instance Structured ElaboratedPackageOrComponent - -elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName -elabComponentName elab = - case elabPkgOrComp elab of - ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this - ElabComponent comp -> compComponentName comp - --- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. -elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String -elabConfiguredName verbosity elab - | verbosity <= normal - = (case elabPkgOrComp elab of - ElabPackage _ -> "" - ElabComponent comp -> - case compComponentName comp of - Nothing -> "setup from " - Just (CLibName LMainLibName) -> "" - Just cname -> prettyShow cname ++ " from ") - ++ prettyShow (packageId elab) - | otherwise - = prettyShow (elabUnitId elab) - -elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams -elabDistDirParams shared elab = DistDirParams { - distParamUnitId = installedUnitId elab, - distParamComponentId = elabComponentId elab, - distParamPackageId = elabPkgSourceId elab, - distParamComponentName = case elabPkgOrComp elab of - ElabComponent comp -> compComponentName comp - ElabPackage _ -> Nothing, - distParamCompilerId = compilerId (pkgConfigCompiler shared), - distParamPlatform = pkgConfigPlatform shared, - distParamOptimization = elabOptimization elab - } - --- | The full set of dependencies which dictate what order we --- need to build things in the install plan: "order dependencies" --- balls everything together. This is mostly only useful for --- ordering; if you are, for example, trying to compute what --- @--dependency@ flags to pass to a Setup script, you need to --- use 'elabLibDependencies'. This method is the same as --- 'nodeNeighbors'. --- --- NB: this method DOES include setup deps. -elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] -elabOrderDependencies elab = - case elabPkgOrComp elab of - -- Important not to have duplicates: otherwise InstallPlan gets - -- confused. - ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) - ElabComponent comp -> compOrderDependencies comp - --- | Like 'elabOrderDependencies', but only returns dependencies on --- libraries. -elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] -elabOrderLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ - ordNub $ CD.flatDeps (pkgLibDependencies pkg) - ElabComponent comp -> compOrderLibDependencies comp - --- | The library dependencies (i.e., the libraries we depend on, NOT --- the dependencies of the library), NOT including setup dependencies. --- These are passed to the @Setup@ script via @--dependency@. -elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] -elabLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) - ElabComponent comp -> compLibDependencies comp - --- | Like 'elabOrderDependencies', but only returns dependencies on --- executables. (This coincides with 'elabExeDependencies'.) -elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] -elabOrderExeDependencies = - map newSimpleUnitId . elabExeDependencies - --- | The executable dependencies (i.e., the executables we depend on); --- these are the executables we must add to the PATH before we invoke --- the setup script. -elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] -elabExeDependencies elab = map confInstId $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp - --- | This returns the paths of all the executables we depend on; we --- must add these paths to PATH before invoking the setup script. --- (This is usually what you want, not 'elabExeDependencies', if you --- actually want to build something.) -elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] -elabExeDependencyPaths elab = - case elabPkgOrComp elab of - ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) - ElabComponent comp -> map snd (compExeDependencyPaths comp) - --- | The setup dependencies (the library dependencies of the setup executable; --- note that it is not legal for setup scripts to have executable --- dependencies at the moment.) -elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] -elabSetupDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] - -elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] -elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } - = pkgPkgConfigDependencies pkg -elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } - = compPkgConfigDependencies comp - --- | The cache files of all our inplace dependencies which, --- when updated, require us to rebuild. See #4202 for --- more details. Essentially, this is a list of filepaths --- that, if our dependencies get rebuilt, will themselves --- get updated. --- --- Note: the hash of these cache files gets built into --- the build cache ourselves, which means that we end --- up tracking transitive dependencies! --- --- Note: This tracks the "build" cache file, but not --- "registration" or "config" cache files. Why not? --- Arguably we should... --- --- Note: This is a bit of a hack, because it is not really --- the hashes of the SOURCES of our (transitive) dependencies --- that we should use to decide whether or not to rebuild, --- but the output BUILD PRODUCTS. The strategy we use --- here will never work if we want to implement unchanging --- rebuilds. -elabInplaceDependencyBuildCacheFiles - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedConfiguredPackage - -> [FilePath] -elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = - go =<< InstallPlan.directDeps plan (nodeKey root_elab) - where - go = InstallPlan.foldPlanPackage (const []) $ \elab -> do - guard (elabBuildStyle elab == BuildInplaceOnly) - return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" - --- | Some extra metadata associated with an --- 'ElaboratedConfiguredPackage' which indicates that the "package" --- in question is actually a single component to be built. Arguably --- it would be clearer if there were an ADT which branched into --- package work items and component work items, but I've structured --- it this way to minimize change to the existing code (which I --- don't feel qualified to rewrite.) -data ElaboratedComponent - = ElaboratedComponent { - -- | The name of the component to be built according to the solver - compSolverName :: CD.Component, - -- | The name of the component to be built. Nothing if - -- it's a setup dep. - compComponentName :: Maybe ComponentName, - -- | The *external* library dependencies of this component. We - -- pass this to the configure script. - compLibDependencies :: [ConfiguredId], - -- | In a component prior to instantiation, this list specifies - -- the 'OpenUnitId's which, after instantiation, are the - -- actual dependencies of this package. Note that this does - -- NOT include signature packages, which do not turn into real - -- ordering dependencies when we instantiate. This is intended to be - -- a purely temporary field, to carry some information to the - -- instantiation phase. It's more precise than - -- 'compLibDependencies', and also stores information about internal - -- dependencies. - compLinkedLibDependencies :: [OpenUnitId], - -- | The executable dependencies of this component (including - -- internal executables). - compExeDependencies :: [ConfiguredId], - -- | The @pkg-config@ dependencies of the component - compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], - -- | The paths all our executable dependencies will be installed - -- to once they are installed. - compExeDependencyPaths :: [(ConfiguredId, FilePath)], - -- | The UnitIds of the libraries (identifying elaborated packages/ - -- components) that must be built before this project. This - -- is used purely for ordering purposes. It can contain both - -- references to definite and indefinite packages; an indefinite - -- UnitId indicates that we must typecheck that indefinite package - -- before we can build this one. - compOrderLibDependencies :: [UnitId] - } - deriving (Eq, Show, Generic) - -instance Binary ElaboratedComponent -instance Structured ElaboratedComponent - --- | See 'elabOrderDependencies'. -compOrderDependencies :: ElaboratedComponent -> [UnitId] -compOrderDependencies comp = - compOrderLibDependencies comp - ++ compOrderExeDependencies comp - --- | See 'elabOrderExeDependencies'. -compOrderExeDependencies :: ElaboratedComponent -> [UnitId] -compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies - -data ElaboratedPackage - = ElaboratedPackage { - pkgInstalledId :: InstalledPackageId, - - -- | The exact dependencies (on other plan packages) - -- - pkgLibDependencies :: ComponentDeps [ConfiguredId], - - -- | Components which depend (transitively) on an internally - -- defined library. These are used by 'elabRequiresRegistration', - -- to determine if a user-requested build is going to need - -- a library registration - -- - pkgDependsOnSelfLib :: ComponentDeps [()], - - -- | Dependencies on executable packages. - -- - pkgExeDependencies :: ComponentDeps [ConfiguredId], - - -- | Paths where executable dependencies live. - -- - pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], - - -- | Dependencies on @pkg-config@ packages. - -- NB: this is NOT per-component (although it could be) - -- because Cabal library does not track per-component - -- pkg-config depends; it always does them all at once. - -- - pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], - - -- | Which optional stanzas (ie testsuites, benchmarks) will actually - -- be enabled during the package configure step. - pkgStanzasEnabled :: Set OptionalStanza - } - deriving (Eq, Show, Generic) - -instance Binary ElaboratedPackage -instance Structured ElaboratedPackage - --- | See 'elabOrderDependencies'. This gives the unflattened version, --- which can be useful in some circumstances. -pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] -pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` - fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) - --- | This is used in the install plan to indicate how the package will be --- built. --- -data BuildStyle = - -- | The classic approach where the package is built, then the files - -- installed into some location and the result registered in a package db. - -- - -- If the package came from a tarball then it's built in a temp dir and - -- the results discarded. - BuildAndInstall - - -- | The package is built, but the files are not installed anywhere, - -- rather the build dir is kept and the package is registered inplace. - -- - -- Such packages can still subsequently be installed. - -- - -- Typically 'BuildAndInstall' packages will only depend on other - -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones. - -- - | BuildInplaceOnly - deriving (Eq, Show, Generic) - -instance Binary BuildStyle -instance Structured BuildStyle - -type CabalFileText = LBS.ByteString - -type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage - - ---------------------------- --- Build targets --- - --- | Specific targets within a package or component to act on e.g. to build, --- haddock or open a repl. --- -data ComponentTarget = ComponentTarget ComponentName SubComponentTarget - deriving (Eq, Ord, Show, Generic) - -instance Binary ComponentTarget -instance Structured ComponentTarget - --- | Unambiguously render a 'ComponentTarget', e.g., to pass --- to a Cabal Setup script. -showComponentTarget :: PackageId -> ComponentTarget -> String -showComponentTarget pkgid = - Cabal.showBuildTarget pkgid . toBuildTarget - where - toBuildTarget :: ComponentTarget -> Cabal.BuildTarget - toBuildTarget (ComponentTarget cname subtarget) = - case subtarget of - WholeComponent -> Cabal.BuildTargetComponent cname - ModuleTarget mname -> Cabal.BuildTargetModule cname mname - FileTarget fname -> Cabal.BuildTargetFile cname fname - -showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String -showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n -showTestComponentTarget _ _ = Nothing - -isTestComponentTarget :: ComponentTarget -> Bool -isTestComponentTarget (ComponentTarget (CTestName _) _) = True -isTestComponentTarget _ = False - -showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String -showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n -showBenchComponentTarget _ _ = Nothing - -isBenchComponentTarget :: ComponentTarget -> Bool -isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True -isBenchComponentTarget _ = False - -isForeignLibComponentTarget :: ComponentTarget -> Bool -isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True -isForeignLibComponentTarget _ = False - -isExeComponentTarget :: ComponentTarget -> Bool -isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True -isExeComponentTarget _ = False - -isSubLibComponentTarget :: ComponentTarget -> Bool -isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True -isSubLibComponentTarget _ = False - -componentOptionalStanza :: CD.Component -> Maybe OptionalStanza -componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas -componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas -componentOptionalStanza _ = Nothing - ---------------------------- --- Setup.hs script policy --- - --- | There are four major cases for Setup.hs handling: --- --- 1. @build-type@ Custom with a @custom-setup@ section --- 2. @build-type@ Custom without a @custom-setup@ section --- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ --- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ --- --- It's also worth noting that packages specifying @cabal-version: >= 1.23@ --- or later that have @build-type@ Custom will always have a @custom-setup@ --- section. Therefore in case 2, the specified @cabal-version@ will always be --- less than 1.23. --- --- In cases 1 and 2 we obviously have to build an external Setup.hs script, --- while in case 4 we can use the internal library API. In case 3 we also have --- to build an external Setup.hs script because the package needs a later --- Cabal lib version than we can support internally. --- -data SetupScriptStyle = SetupCustomExplicitDeps - | SetupCustomImplicitDeps - | SetupNonCustomExternalLib - | SetupNonCustomInternalLib - deriving (Eq, Show, Generic, Typeable) - -instance Binary SetupScriptStyle -instance Structured SetupScriptStyle diff --git a/Distribution/Client/RebuildMonad.hs b/Distribution/Client/RebuildMonad.hs deleted file mode 100644 --- a/Distribution/Client/RebuildMonad.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-} - --- | An abstraction for re-running actions if values or files have changed. --- --- This is not a full-blown make-style incremental build system, it's a bit --- more ad-hoc than that, but it's easier to integrate with existing code. --- --- It's a convenient interface to the "Distribution.Client.FileMonitor" --- functions. --- -module Distribution.Client.RebuildMonad ( - -- * Rebuild monad - Rebuild, - runRebuild, - execRebuild, - askRoot, - - -- * Setting up file monitoring - monitorFiles, - MonitorFilePath, - monitorFile, - monitorFileHashed, - monitorNonExistentFile, - monitorDirectory, - monitorNonExistentDirectory, - monitorDirectoryExistence, - monitorFileOrDirectory, - monitorFileSearchPath, - monitorFileHashedSearchPath, - -- ** Monitoring file globs - monitorFileGlob, - monitorFileGlobExistence, - FilePathGlob(..), - FilePathRoot(..), - FilePathGlobRel(..), - GlobPiece(..), - - -- * Using a file monitor - FileMonitor(..), - newFileMonitor, - rerunIfChanged, - - -- * Utils - delayInitSharedResource, - delayInitSharedResources, - matchFileGlob, - getDirectoryContentsMonitored, - createDirectoryMonitored, - monitorDirectoryStatus, - doesFileExistMonitored, - need, - needIfExists, - findFileWithExtensionMonitored, - findFirstFileMonitored, - findFileMonitored, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.FileMonitor -import Distribution.Client.Glob hiding (matchFileGlob) -import qualified Distribution.Client.Glob as Glob (matchFileGlob) - -import Distribution.Simple.Utils (debug) - -import qualified Data.Map.Strict as Map -import Control.Monad.State as State -import Control.Monad.Reader as Reader -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) -import System.FilePath -import System.Directory - - --- | A monad layered on top of 'IO' to help with re-running actions when the --- input files and values they depend on change. The crucial operations are --- 'rerunIfChanged' and 'monitorFiles'. --- -newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) - deriving (Functor, Applicative, Monad, MonadIO) - --- | Use this wihin the body action of 'rerunIfChanged' to declare that the --- action depends on the given files. This can be based on what the action --- actually did. It is these files that will be checked for changes next --- time 'rerunIfChanged' is called for that 'FileMonitor'. --- --- Relative paths are interpreted as relative to an implicit root, ultimately --- passed in to 'runRebuild'. --- -monitorFiles :: [MonitorFilePath] -> Rebuild () -monitorFiles filespecs = Rebuild (State.modify (filespecs++)) - --- | Run a 'Rebuild' IO action. -unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath]) -unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) [] - --- | Run a 'Rebuild' IO action. -runRebuild :: FilePath -> Rebuild a -> IO a -runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] - --- | Run a 'Rebuild' IO action. -execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] -execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) [] - --- | The root that relative paths are interpreted as being relative to. -askRoot :: Rebuild FilePath -askRoot = Rebuild Reader.ask - --- | This captures the standard use pattern for a 'FileMonitor': given a --- monitor, an action and the input value the action depends on, either --- re-run the action to get its output, or if the value and files the action --- depends on have not changed then return a previously cached action result. --- --- The result is still in the 'Rebuild' monad, so these can be nested. --- --- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. --- -rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b) - => Verbosity - -> FileMonitor a b - -> a - -> Rebuild b - -> Rebuild b -rerunIfChanged verbosity monitor key action = do - rootDir <- askRoot - changed <- liftIO $ checkFileMonitorChanged monitor rootDir key - case changed of - MonitorUnchanged result files -> do - liftIO $ debug verbosity $ "File monitor '" ++ monitorName - ++ "' unchanged." - monitorFiles files - return result - - MonitorChanged reason -> do - liftIO $ debug verbosity $ "File monitor '" ++ monitorName - ++ "' changed: " ++ showReason reason - startTime <- liftIO $ beginUpdateFileMonitor - (result, files) <- liftIO $ unRebuild rootDir action - liftIO $ updateFileMonitor monitor rootDir - (Just startTime) files key result - monitorFiles files - return result - where - monitorName = takeFileName (fileMonitorCacheFile monitor) - - showReason (MonitoredFileChanged file) = "file " ++ file - showReason (MonitoredValueChanged _) = "monitor value changed" - showReason MonitorFirstRun = "first run" - showReason MonitorCorruptCache = "invalid cache file" - - --- | When using 'rerunIfChanged' for each element of a list of actions, it is --- sometimes the case that each action needs to make use of some resource. e.g. --- --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- mkResource --- > ... -- use the resource --- > | ... ] --- --- For efficiency one would like to share the resource between the actions --- but the straightforward way of doing this means initialising it every time --- even when no actions need re-running. --- --- > resource <- mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > ... -- use the resource --- > | ... ] --- --- This utility allows one to get the best of both worlds: --- --- > getResource <- delayInitSharedResource mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- getResource --- > ... -- use the resource --- > | ... ] --- -delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a) -delayInitSharedResource action = do - var <- liftIO (newMVar Nothing) - return (liftIO (getOrInitResource var)) - where - getOrInitResource :: MVar (Maybe a) -> IO a - getOrInitResource var = - modifyMVar var $ \mx -> - case mx of - Just x -> return (Just x, x) - Nothing -> do - x <- action - return (Just x, x) - - --- | Much like 'delayInitSharedResource' but for a keyed set of resources. --- --- > getResource <- delayInitSharedResource mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- getResource key --- > ... -- use the resource --- > | ... ] --- -delayInitSharedResources :: forall k v. Ord k - => (k -> IO v) - -> Rebuild (k -> Rebuild v) -delayInitSharedResources action = do - var <- liftIO (newMVar Map.empty) - return (liftIO . getOrInitResource var) - where - getOrInitResource :: MVar (Map k v) -> k -> IO v - getOrInitResource var k = - modifyMVar var $ \m -> - case Map.lookup k m of - Just x -> return (m, x) - Nothing -> do - x <- action k - let !m' = Map.insert k x m - return (m', x) - - --- | Utility to match a file glob against the file system, starting from a --- given root directory. The results are all relative to the given root. --- --- Since this operates in the 'Rebuild' monad, it also monitors the given glob --- for changes. --- -matchFileGlob :: FilePathGlob -> Rebuild [FilePath] -matchFileGlob glob = do - root <- askRoot - monitorFiles [monitorFileGlobExistence glob] - liftIO $ Glob.matchFileGlob root glob - -getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] -getDirectoryContentsMonitored dir = do - exists <- monitorDirectoryStatus dir - if exists - then liftIO $ getDirectoryContents dir - else return [] - -createDirectoryMonitored :: Bool -> FilePath -> Rebuild () -createDirectoryMonitored createParents dir = do - monitorFiles [monitorDirectoryExistence dir] - liftIO $ createDirectoryIfMissing createParents dir - --- | Monitor a directory as in 'monitorDirectory' if it currently exists or --- as 'monitorNonExistentDirectory' if it does not. -monitorDirectoryStatus :: FilePath -> Rebuild Bool -monitorDirectoryStatus dir = do - exists <- liftIO $ doesDirectoryExist dir - monitorFiles [if exists - then monitorDirectory dir - else monitorNonExistentDirectory dir] - return exists - --- | Like 'doesFileExist', but in the 'Rebuild' monad. This does --- NOT track the contents of 'FilePath'; use 'need' in that case. -doesFileExistMonitored :: FilePath -> Rebuild Bool -doesFileExistMonitored f = do - root <- askRoot - exists <- liftIO $ doesFileExist (root f) - monitorFiles [if exists - then monitorFileExistence f - else monitorNonExistentFile f] - return exists - --- | Monitor a single file -need :: FilePath -> Rebuild () -need f = monitorFiles [monitorFileHashed f] - --- | Monitor a file if it exists; otherwise check for when it --- gets created. This is a bit better for recompilation avoidance --- because sometimes users give bad package metadata, and we don't --- want to repeatedly rebuild in this case (which we would if we --- need'ed a non-existent file). -needIfExists :: FilePath -> Rebuild () -needIfExists f = do - root <- askRoot - exists <- liftIO $ doesFileExist (root f) - monitorFiles [if exists - then monitorFileHashed f - else monitorNonExistentFile f] - --- | Like 'findFileWithExtension', but in the 'Rebuild' monad. -findFileWithExtensionMonitored - :: [String] - -> [FilePath] - -> FilePath - -> Rebuild (Maybe FilePath) -findFileWithExtensionMonitored extensions searchPath baseName = - findFirstFileMonitored id - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | Like 'findFirstFile', but in the 'Rebuild' monad. -findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a) -findFirstFileMonitored file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExistMonitored (file x) - if exists - then return (Just x) - else findFirst xs - --- | Like 'findFile', but in the 'Rebuild' monad. -findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath) -findFileMonitored searchPath fileName = - findFirstFileMonitored id - [ path fileName - | path <- nub searchPath] diff --git a/Distribution/Client/Reconfigure.hs b/Distribution/Client/Reconfigure.hs deleted file mode 100644 --- a/Distribution/Client/Reconfigure.hs +++ /dev/null @@ -1,179 +0,0 @@ -module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where - -import Distribution.Client.Compat.Prelude - -import Data.Monoid ( Any(..) ) -import System.Directory ( doesFileExist ) - -import Distribution.Simple.Configure ( localBuildInfoFile ) -import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag ) -import Distribution.Simple.Utils - ( existsAndIsMoreRecentThan, defaultPackageDesc, info ) - -import Distribution.Client.Config ( SavedConfig(..) ) -import Distribution.Client.Configure ( readConfigFlags ) -import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate ) -import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs ) -import Distribution.Client.Sandbox.PackageEnvironment - ( userPackageEnvironmentFile ) -import Distribution.Client.Setup - ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) ) - --- | @Check@ represents a function to check some condition on type @a@. The --- returned 'Any' is 'True' if any part of the condition failed. -newtype Check a = Check { - runCheck :: Any -- Did any previous check fail? - -> a -- value returned by previous checks - -> IO (Any, a) -- Did this check fail? What value is returned? -} - -instance Semigroup (Check a) where - (<>) c d = Check $ \any0 a0 -> do - (any1, a1) <- runCheck c any0 a0 - (any2, a2) <- runCheck d (any0 <> any1) a1 - return (any0 <> any1 <> any2, a2) - -instance Monoid (Check a) where - mempty = Check $ \_ a -> return (mempty, a) - mappend = (<>) - - --- | Re-configure the package in the current directory if needed. Deciding --- when to reconfigure and with which options is convoluted: --- --- If we are reconfiguring, we must always run @configure@ with the --- verbosity option we are given; however, that a previous configuration --- uses a different verbosity setting is not reason enough to reconfigure. --- --- The package should be configured to use the same \"dist\" prefix as --- given to the @build@ command, otherwise the build will probably --- fail. Not only does this determine the \"dist\" prefix setting if we --- need to reconfigure anyway, but an existing configuration should be --- invalidated if its \"dist\" prefix differs. --- --- If the package has never been configured (i.e., there is no --- LocalBuildInfo), we must configure first, using the default options. --- --- If the package has been configured, there will be a 'LocalBuildInfo'. --- If there no package description file, we assume that the --- 'PackageDescription' is up to date, though the configuration may need --- to be updated for other reasons (see above). If there is a package --- description file, and it has been modified since the 'LocalBuildInfo' --- was generated, then we need to reconfigure. --- --- The caller of this function may also have specific requirements --- regarding the flags the last configuration used. For example, --- 'testAction' requires that the package be configured with test suites --- enabled. The caller may pass the required settings to this function --- along with a function to check the validity of the saved 'ConfigFlags'; --- these required settings will be checked first upon determining that --- a previous configuration exists. -reconfigure - :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()) - -- ^ configure action - -> Verbosity - -- ^ Verbosity setting - -> FilePath - -- ^ \"dist\" prefix - -> Flag (Maybe Int) - -- ^ -j flag for reinstalling add-source deps. - -> Check (ConfigFlags, ConfigExFlags) - -- ^ Check that the required flags are set. - -- If they are not set, provide a message explaining the - -- reason for reconfiguration. - -> [String] -- ^ Extra arguments - -> GlobalFlags -- ^ Global flags - -> SavedConfig - -> IO SavedConfig -reconfigure - configureAction - verbosity - dist - _numJobsFlag - check - extraArgs - globalFlags - config - = do - - savedFlags@(_, _) <- readConfigFlags dist - - useNix <- fmap isJust (findNixExpr globalFlags config) - alreadyInNixShell <- inNixShell - - if useNix && not alreadyInNixShell - then do - - -- If we are using Nix, we must reinstantiate the derivation outside - -- the shell. Eventually, the caller will invoke 'nixShell' which will - -- rerun cabal inside the shell. That will bring us back to 'reconfigure', - -- but inside the shell we'll take the second branch, below. - - -- This seems to have a problem: won't 'configureAction' call 'nixShell' - -- yet again, spawning an infinite tree of subprocesses? - -- No, because 'nixShell' doesn't spawn a new process if it is already - -- running in a Nix shell. - - nixInstantiate verbosity dist False globalFlags config - return config - - else do - - let checks = - checkVerb - <> checkDist - <> checkOutdated - <> check - (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags - - let config' = updateInstallDirs (configUserInstall configFlags) config - - when frc $ configureAction flags extraArgs globalFlags - return config' - - where - - -- Changing the verbosity does not require reconfiguration, but the new - -- verbosity should be used if reconfiguring. - checkVerb = Check $ \_ (configFlags, configExFlags) -> do - let configFlags' = configFlags { configVerbosity = toFlag verbosity} - return (mempty, (configFlags', configExFlags)) - - -- Reconfiguration is required if @--build-dir@ changes. - checkDist = Check $ \_ (configFlags, configExFlags) -> do - -- Always set the chosen @--build-dir@ before saving the flags, - -- or bad things could happen. - savedDist <- findSavedDistPref config (configDistPref configFlags) - let distChanged = dist /= savedDist - when distChanged $ info verbosity "build directory changed" - let configFlags' = configFlags { configDistPref = toFlag dist } - return (Any distChanged, (configFlags', configExFlags)) - - checkOutdated = Check $ \_ flags@(configFlags, _) -> do - let buildConfig = localBuildInfoFile dist - - -- Has the package ever been configured? If not, reconfiguration is - -- required. - configured <- doesFileExist buildConfig - unless configured $ info verbosity "package has never been configured" - - -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need - -- to force reconfigure. Note that it's possible to use @cabal.config@ - -- even without sandboxes. - userPackageEnvironmentFileModified <- - existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig - when userPackageEnvironmentFileModified $ - info verbosity ("user package environment file ('" - ++ userPackageEnvironmentFile ++ "') was modified") - - -- Is the configuration older than the package description? - descrFile <- maybe (defaultPackageDesc verbosity) return - (flagToMaybe (configCabalFilePath configFlags)) - outdated <- existsAndIsMoreRecentThan descrFile buildConfig - when outdated $ info verbosity (descrFile ++ " was changed") - - let failed = - Any outdated - <> Any userPackageEnvironmentFileModified - <> Any (not configured) - return (failed, flags) diff --git a/Distribution/Client/Run.hs b/Distribution/Client/Run.hs deleted file mode 100644 --- a/Distribution/Client/Run.hs +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Run --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Implementation of the 'run' command. ------------------------------------------------------------------------------ - -module Distribution.Client.Run ( run, splitRunArgs ) - where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Types.TargetInfo (targetCLBI) -import Distribution.Types.LocalBuildInfo (componentNameTargets') - -import Distribution.Client.Utils (tryCanonicalizePath) - -import Distribution.Types.UnqualComponentName -import Distribution.PackageDescription (Executable (..), - TestSuite(..), - Benchmark(..), - PackageDescription (..), - BuildInfo(buildable)) -import Distribution.Simple.Compiler (compilerFlavor, CompilerFlavor(..)) -import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) -import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.LocalBuildInfo (ComponentName (..), - LocalBuildInfo (..), - depLibraryPaths) -import Distribution.Simple.Utils (die', notice, warn, - rawSystemExitWithEnv, - addLibraryPath) -import Distribution.System (Platform (..)) - -import qualified Distribution.Simple.GHCJS as GHCJS - -import System.Directory (getCurrentDirectory) -import Distribution.Compat.Environment (getEnvironment) -import System.FilePath ((<.>), ()) - - --- | Return the executable to run and any extra arguments that should be --- forwarded to it. Die in case of error. -splitRunArgs :: Verbosity -> LocalBuildInfo -> [String] - -> IO (Executable, [String]) -splitRunArgs verbosity lbi args = - case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest) - Left err -> do - warn verbosity `traverse_` maybeWarning -- If there is a warning, print it. - die' verbosity err - Right (True, exe, xs) -> return (exe, xs) - Right (False, exe, xs) -> do - let addition = " Interpreting all parameters to `run` as a parameter to" - ++ " the default executable." - -- If there is a warning, print it together with the addition. - warn verbosity `traverse_` fmap (++addition) maybeWarning - return (exe, xs) - where - pkg_descr = localPkgDescr lbi - whichExecutable :: Either String -- Error string. - ( Bool -- If it was manually chosen. - , Executable -- The executable. - , [String] -- The remaining parameters. - ) - whichExecutable = case (enabledExes, args) of - ([] , _) -> Left "Couldn't find any enabled executables." - ([exe], []) -> return (False, exe, []) - ([exe], (x:xs)) - | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs) - | otherwise -> return (False, exe, args) - (_ , []) -> Left - $ "This package contains multiple executables. " - ++ "You must pass the executable name as the first argument " - ++ "to 'cabal run'." - (_ , (x:xs)) -> - case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of - Nothing -> Left $ "No executable named '" ++ x ++ "'." - Just exe -> return (True, exe, xs) - where - enabledExes = filter (buildable . buildInfo) (executables pkg_descr) - - maybeWarning :: Maybe String - maybeWarning = case args of - [] -> Nothing - (x:_) -> lookup (mkUnqualComponentName x) components - where - components :: [(UnqualComponentName, String)] -- Component name, message. - components = - [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.") - | e <- executables pkg_descr - , not . buildable . buildInfo $ e, let name = exeName e] - - ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "'," - ++ " but the `run` command is only for executables.") - | t <- testSuites pkg_descr - , let name = testName t] - - ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "'," - ++ " but the `run` command is only for executables.") - | b <- benchmarks pkg_descr - , let name = benchmarkName b] - --- | Run a given executable. -run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO () -run verbosity lbi exe exeArgs = do - curDir <- getCurrentDirectory - let buildPref = buildDir lbi - pkg_descr = localPkgDescr lbi - dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir", - curDir dataDir pkg_descr) - - (path, runArgs) <- - let exeName' = prettyShow $ exeName exe - in case compilerFlavor (compiler lbi) of - GHCJS -> do - let (script, cmd, cmdArgs) = - GHCJS.runCmd (withPrograms lbi) - (buildPref exeName' exeName') - script' <- tryCanonicalizePath script - return (cmd, cmdArgs ++ [script']) - _ -> do - p <- tryCanonicalizePath $ - buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbi)) - return (p, []) - - env <- (dataDirEnvVar:) <$> getEnvironment - -- Add (DY)LD_LIBRARY_PATH if needed - env' <- if withDynExe lbi - then do let (Platform _ os) = hostPlatform lbi - clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of - [target] -> return (targetCLBI target) - [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" - _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" - paths <- depLibraryPaths True False lbi clbi - return (addLibraryPath os paths env) - else return env - notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..." - rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs deleted file mode 100644 --- a/Distribution/Client/Sandbox.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Sandbox --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- UI for the sandboxing functionality. ------------------------------------------------------------------------------ - -module Distribution.Client.Sandbox ( - loadConfigOrSandboxConfig, - findSavedDistPref, - - updateInstallDirs, - - getPersistOrConfigCompiler - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.Setup - ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' ) -import Distribution.Client.Config - ( SavedConfig(..), defaultUserInstall, loadConfig ) - -import Distribution.Client.Sandbox.PackageEnvironment - ( PackageEnvironmentType(..) - , classifyPackageEnvironment - , loadUserConfig - ) -import Distribution.Client.SetupWrapper - ( SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Simple.Compiler ( Compiler(..) ) -import Distribution.Simple.Configure ( maybeGetPersistBuildConfig - , findDistPrefOrDefault - , findDistPref ) -import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo -import Distribution.Simple.Program ( ProgramDb ) -import Distribution.Simple.Setup ( Flag(..) - , fromFlagOrDefault, flagToMaybe ) -import Distribution.System ( Platform ) - -import System.Directory ( getCurrentDirectory ) - - --- * Basic sandbox functions. --- - -updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig -updateInstallDirs userInstallFlag savedConfig = savedConfig - { savedConfigureFlags = configureFlags - { configInstallDirs = installDirs - } - } - where - configureFlags = savedConfigureFlags savedConfig - userInstallDirs = savedUserInstallDirs savedConfig - globalInstallDirs = savedGlobalInstallDirs savedConfig - installDirs | userInstall = userInstallDirs - | otherwise = globalInstallDirs - userInstall = fromFlagOrDefault defaultUserInstall - (configUserInstall configureFlags `mappend` userInstallFlag) - --- | Check which type of package environment we're in and return a --- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates --- whether we're working in a sandbox. -loadConfigOrSandboxConfig :: Verbosity - -> GlobalFlags -- ^ For @--config-file@ and - -- @--sandbox-config-file@. - -> IO SavedConfig -loadConfigOrSandboxConfig verbosity globalFlags = do - let configFileFlag = globalConfigFile globalFlags - - pkgEnvDir <- getCurrentDirectory - pkgEnvType <- classifyPackageEnvironment pkgEnvDir - case pkgEnvType of - -- Only @cabal.config@ is present. - UserPackageEnvironment -> do - config <- loadConfig verbosity configFileFlag - userConfig <- loadUserConfig verbosity pkgEnvDir Nothing - let config' = config `mappend` userConfig - return config' - - -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present. - AmbientPackageEnvironment -> do - config <- loadConfig verbosity configFileFlag - let globalConstraintsOpt = - flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config - globalConstraintConfig <- - loadUserConfig verbosity pkgEnvDir globalConstraintsOpt - let config' = config `mappend` globalConstraintConfig - return config' - --- | Return the saved \"dist/\" prefix, or the default prefix. -findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath -findSavedDistPref config flagDistPref = do - let defDistPref = useDistPref defaultSetupScriptOptions - flagDistPref' = configDistPref (savedConfigureFlags config) - `mappend` flagDistPref - findDistPref defDistPref flagDistPref' - --- Utils (transitionary) --- - --- | Try to read the most recently configured compiler from the --- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it --- cannot be read. -getPersistOrConfigCompiler :: ConfigFlags - -> IO (Compiler, Platform, ProgramDb) -getPersistOrConfigCompiler configFlags = do - distPref <- findDistPrefOrDefault (configDistPref configFlags) - mlbi <- maybeGetPersistBuildConfig distPref - case mlbi of - Nothing -> do configCompilerAux' configFlags - Just lbi -> return ( LocalBuildInfo.compiler lbi - , LocalBuildInfo.hostPlatform lbi - , LocalBuildInfo.withPrograms lbi - ) diff --git a/Distribution/Client/Sandbox/PackageEnvironment.hs b/Distribution/Client/Sandbox/PackageEnvironment.hs deleted file mode 100644 --- a/Distribution/Client/Sandbox/PackageEnvironment.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Sandbox.PackageEnvironment --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Utilities for working with the package environment file. Patterned after --- Distribution.Client.Config. ------------------------------------------------------------------------------ - -module Distribution.Client.Sandbox.PackageEnvironment ( - PackageEnvironment(..) - , PackageEnvironmentType(..) - , classifyPackageEnvironment - , readPackageEnvironmentFile - , showPackageEnvironment - , showPackageEnvironmentWithComments - , loadUserConfig - - , userPackageEnvironmentFile - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.Config ( SavedConfig(..) - , configFieldDescriptions - , haddockFlagsFields - , installDirsFields, withProgramsFields - , withProgramOptionsFields - ) -import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) -import Distribution.Client.Setup ( ConfigExFlags(..) - ) -import Distribution.Client.Targets ( userConstraintPackageName ) -import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate ) -import Distribution.Simple.Setup ( Flag(..) - , ConfigFlags(..), HaddockFlags(..) - ) -import Distribution.Simple.Utils ( warn, debug ) -import Distribution.Solver.Types.ConstraintSource -import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..) - , commaListFieldParsec, commaNewLineListFieldParsec - , liftField, lineNo, locatedErrorMsg - , readFields - , showPWarning - , syntaxError, warning ) -import System.Directory ( doesFileExist ) -import System.FilePath ( () ) -import System.IO.Error ( isDoesNotExistError ) -import Text.PrettyPrint ( ($+$) ) - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) ) - --- --- * Configuration saved in the package environment file --- - --- TODO: would be nice to remove duplication between --- D.C.Sandbox.PackageEnvironment and D.C.Config. -data PackageEnvironment = PackageEnvironment { - pkgEnvSavedConfig :: SavedConfig -} deriving Generic - -instance Monoid PackageEnvironment where - mempty = gmempty - mappend = (<>) - -instance Semigroup PackageEnvironment where - (<>) = gmappend - --- | Optional package environment file that can be used to customize the default --- settings. Created by the user. -userPackageEnvironmentFile :: FilePath -userPackageEnvironmentFile = "cabal.config" - --- | Type of the current package environment. -data PackageEnvironmentType - = UserPackageEnvironment -- ^ './cabal.config' - | AmbientPackageEnvironment -- ^ '~/.cabal/config' - --- | Is there a 'cabal.config' in this directory? -classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType -classifyPackageEnvironment pkgEnvDir = do - isUser <- configExists userPackageEnvironmentFile - return (classify isUser) - where - configExists fname = doesFileExist (pkgEnvDir fname) - - classify :: Bool -> PackageEnvironmentType - classify True = UserPackageEnvironment - classify False = AmbientPackageEnvironment - - --- | Load the user package environment if it exists (the optional "cabal.config" --- file). If it does not exist locally, attempt to load an optional global one. -userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath - -> IO PackageEnvironment -userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do - let path = pkgEnvDir userPackageEnvironmentFile - minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) - mempty path - case (minp, globalConfigLocation) of - (Just parseRes, _) -> processConfigParse path parseRes - (_, Just globalLoc) -> do - minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) - mempty globalLoc - maybe (warn verbosity ("no constraints file found at " ++ globalLoc) - >> return mempty) - (processConfigParse globalLoc) - minp' - _ -> do - debug verbosity ("no user package environment file found at " ++ pkgEnvDir) - return mempty - where - processConfigParse path (ParseOk warns parseResult) = do - unless (null warns) $ warn verbosity $ - unlines (map (showPWarning path) warns) - return parseResult - processConfigParse path (ParseFailed err) = do - let (line, msg) = locatedErrorMsg err - warn verbosity $ "Error parsing package environment file " ++ path - ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg - return mempty - --- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. -loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig -loadUserConfig verbosity pkgEnvDir globalConfigLocation = - fmap pkgEnvSavedConfig $ - userPackageEnvironment verbosity pkgEnvDir globalConfigLocation - - - --- | Descriptions of all fields in the package environment file. -pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment] -pkgEnvFieldDescrs src = - [ commaNewLineListFieldParsec "constraints" - (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec) - (sortConstraints . configExConstraints - . savedConfigureExFlags . pkgEnvSavedConfig) - (\v pkgEnv -> updateConfigureExFlags pkgEnv - (\flags -> flags { configExConstraints = v })) - - , commaListFieldParsec "preferences" - pretty parsec - (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) - (\v pkgEnv -> updateConfigureExFlags pkgEnv - (\flags -> flags { configPreferences = v })) - ] - ++ map toPkgEnv configFieldDescriptions' - where - configFieldDescriptions' :: [FieldDescr SavedConfig] - configFieldDescriptions' = filter - (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint") - (configFieldDescriptions src) - - toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment - toPkgEnv fieldDescr = - liftField pkgEnvSavedConfig - (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig}) - fieldDescr - - updateConfigureExFlags :: PackageEnvironment - -> (ConfigExFlags -> ConfigExFlags) - -> PackageEnvironment - updateConfigureExFlags pkgEnv f = pkgEnv { - pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) { - savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig - $ pkgEnv - } - } - - sortConstraints = sortBy (comparing $ userConstraintPackageName . fst) - --- | Read the package environment file. -readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath - -> IO (Maybe (ParseResult PackageEnvironment)) -readPackageEnvironmentFile src initial file = - handleNotExists $ - fmap (Just . parsePackageEnvironment src initial) (readFile file) - where - handleNotExists action = catchIO action $ \ioe -> - if isDoesNotExistError ioe - then return Nothing - else ioError ioe - --- | Parse the package environment file. -parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String - -> ParseResult PackageEnvironment -parsePackageEnvironment src initial str = do - fields <- readFields str - let (knownSections, others) = partition isKnownSection fields - pkgEnv <- parse others - let config = pkgEnvSavedConfig pkgEnv - installDirs0 = savedUserInstallDirs config - (haddockFlags, installDirs, paths, args) <- - foldM parseSections - (savedHaddockFlags config, installDirs0, [], []) - knownSections - return pkgEnv { - pkgEnvSavedConfig = config { - savedConfigureFlags = (savedConfigureFlags config) { - configProgramPaths = paths, - configProgramArgs = args - }, - savedHaddockFlags = haddockFlags, - savedUserInstallDirs = installDirs, - savedGlobalInstallDirs = installDirs - } - } - - where - isKnownSection :: ParseUtils.Field -> Bool - isKnownSection (ParseUtils.Section _ "haddock" _ _) = True - isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True - isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True - isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True - isKnownSection _ = False - - parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment - parse = parseFields (pkgEnvFieldDescrs src) initial - - parseSections :: SectionsAccum -> ParseUtils.Field - -> ParseResult SectionsAccum - parseSections accum@(h,d,p,a) - (ParseUtils.Section _ "haddock" name fs) - | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (h', d, p, a) - | otherwise = do - warning "The 'haddock' section should be unnamed" - return accum - parseSections (h,d,p,a) - (ParseUtils.Section line "install-dirs" name fs) - | name == "" = do d' <- parseFields installDirsFields d fs - return (h, d',p,a) - | otherwise = - syntaxError line $ - "Named 'install-dirs' section: '" ++ name - ++ "'. Note that named 'install-dirs' sections are not allowed in the '" - ++ userPackageEnvironmentFile ++ "' file." - parseSections accum@(h, d,p,a) - (ParseUtils.Section _ "program-locations" name fs) - | name == "" = do p' <- parseFields withProgramsFields p fs - return (h, d, p', a) - | otherwise = do - warning "The 'program-locations' section should be unnamed" - return accum - parseSections accum@(h, d, p, a) - (ParseUtils.Section _ "program-default-options" name fs) - | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (h, d, p, a') - | otherwise = do - warning "The 'program-default-options' section should be unnamed" - return accum - parseSections accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - --- | Accumulator type for 'parseSections'. -type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate) - , [(String, FilePath)], [(String, [String])]) - - - --- | Pretty-print the package environment. -showPackageEnvironment :: PackageEnvironment -> String -showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv - --- | Pretty-print the package environment with default values for empty fields --- commented out (just like the default ~/.cabal/config). -showPackageEnvironmentWithComments :: (Maybe PackageEnvironment) - -> PackageEnvironment - -> String -showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $ - ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown) - mdefPkgEnv pkgEnv - $+$ Disp.text "" - $+$ ppSection "install-dirs" "" installDirsFields - (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv) - where - installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig diff --git a/Distribution/Client/SavedFlags.hs b/Distribution/Client/SavedFlags.hs deleted file mode 100644 --- a/Distribution/Client/SavedFlags.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Distribution.Client.SavedFlags - ( readCommandFlags, writeCommandFlags - , readSavedArgs, writeSavedArgs - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Simple.Command -import Distribution.Simple.UserHooks ( Args ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, unintersperse ) -import Distribution.Verbosity - -import System.Directory ( doesFileExist ) -import System.FilePath ( takeDirectory ) - - -writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () -writeSavedArgs verbosity path args = do - createDirectoryIfMissingVerbose - (lessVerbose verbosity) True (takeDirectory path) - writeFile path (intercalate "\0" args) - - --- | Write command-line flags to a file, separated by null characters. This --- format is also suitable for the @xargs -0@ command. Using the null --- character also avoids the problem of escaping newlines or spaces, --- because unlike other whitespace characters, the null character is --- not valid in command-line arguments. -writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO () -writeCommandFlags verbosity path command flags = - writeSavedArgs verbosity path (commandShowOptions command flags) - - -readSavedArgs :: FilePath -> IO (Maybe [String]) -readSavedArgs path = do - exists <- doesFileExist path - if exists - then fmap (Just . unintersperse '\0') (readFile path) - else return Nothing - - --- | Read command-line arguments, separated by null characters, from a file. --- Returns the default flags if the file does not exist. -readCommandFlags :: FilePath -> CommandUI flags -> IO flags -readCommandFlags path command = do - savedArgs <- fmap (fromMaybe []) (readSavedArgs path) - case (commandParseArgs command True savedArgs) of - CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs) - CommandList _ -> throwIO (SavedArgsErrorList savedArgs) - CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs) - CommandReadyToGo (mkFlags, _) -> - return (mkFlags (commandDefaultFlags command)) - --- ----------------------------------------------------------------------------- --- * Exceptions --- ----------------------------------------------------------------------------- - -data SavedArgsError - = SavedArgsErrorHelp Args - | SavedArgsErrorList Args - | SavedArgsErrorOther Args [String] - deriving (Typeable) - -instance Show SavedArgsError where - show (SavedArgsErrorHelp args) = - "unexpected flag '--help', saved command line was:\n" - ++ intercalate " " args - show (SavedArgsErrorList args) = - "unexpected flag '--list-options', saved command line was:\n" - ++ intercalate " " args - show (SavedArgsErrorOther args errs) = - "saved command line was:\n" - ++ intercalate " " args ++ "\n" - ++ "encountered errors:\n" - ++ intercalate "\n" errs - -instance Exception SavedArgsError diff --git a/Distribution/Client/Security/DNS.hs b/Distribution/Client/Security/DNS.hs deleted file mode 100644 --- a/Distribution/Client/Security/DNS.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Distribution.Client.Security.DNS - ( queryBootstrapMirrors - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude -import Network.URI (URI(..), URIAuth(..), parseURI) -import Control.Exception (try) -import Distribution.Simple.Utils - -#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) -import Network.DNS (queryTXT, Name(..), CharStr(..)) -import qualified Data.ByteString.Char8 as BS.Char8 -#else -import Distribution.Simple.Program.Db - ( emptyProgramDb, addKnownProgram - , configureAllKnownPrograms, lookupProgram ) -import Distribution.Simple.Program - ( simpleProgram - , programInvocation - , getProgramInvocationOutput ) -#endif - --- | Try to lookup RFC1464-encoded mirror urls for a Hackage --- repository url by performing a DNS TXT lookup on the --- @_mirrors.@-prefixed URL hostname. --- --- Example: for @http://hackage.haskell.org/@ --- perform a DNS TXT query for the hostname --- @_mirrors.hackage.haskell.org@ which may look like e.g. --- --- > _mirrors.hackage.haskell.org. 300 IN TXT --- > "0.urlbase=http://hackage.fpcomplete.com/" --- > "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/" --- --- NB: hackage-security doesn't require DNS lookups being trustworthy, --- as the trust is established via the cryptographically signed TUF --- meta-data that is retrieved from the resolved Hackage repository. --- Moreover, we already have to protect against a compromised --- @hackage.haskell.org@ DNS entry, so an the additional --- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't --- constitute a significant new attack vector anyway. --- -queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] - -#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) --- use @resolv@ package for performing DNS queries -queryBootstrapMirrors verbosity repoUri - | Just auth <- uriAuthority repoUri = do - let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth)) - - mirrors' <- try $ do - txts <- queryTXT mirrorsDnsName - evaluate (force $ extractMirrors (map snd txts)) - - mirrors <- case mirrors' of - Left e -> do - warn verbosity ("Caught exception during _mirrors lookup:"++ - displayException (e :: SomeException)) - return [] - Right v -> return v - - if null mirrors - then warn verbosity ("No mirrors found for " ++ show repoUri) - else do info verbosity ("located " ++ show (length mirrors) ++ - " mirrors for " ++ show repoUri ++ " :") - for_ mirrors $ \url -> info verbosity ("- " ++ show url) - - return mirrors - - | otherwise = return [] - --- | Extract list of mirrors from 'queryTXT' result -extractMirrors :: [[CharStr]] -> [URI] -extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals - where - vals = [ (kn,v) | CharStr e <- concat txtChunks - , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)] - , Just kn <- [isUrlBase k] - ] - ----------------------------------------------------------------------------- -#else /* !defined(MIN_VERSION_resolv) */ --- use external method via @nslookup@ -queryBootstrapMirrors verbosity repoUri - | Just auth <- uriAuthority repoUri = do - progdb <- configureAllKnownPrograms verbosity $ - addKnownProgram nslookupProg emptyProgramDb - - case lookupProgram nslookupProg progdb of - Nothing -> do - warn verbosity "'nslookup' tool missing - can't locate mirrors" - return [] - - Just nslookup -> do - let mirrorsDnsName = "_mirrors." ++ uriRegName auth - - mirrors' <- try $ do - out <- getProgramInvocationOutput verbosity $ - programInvocation nslookup ["-query=TXT", mirrorsDnsName] - evaluate (force $ extractMirrors mirrorsDnsName out) - - mirrors <- case mirrors' of - Left e -> do - warn verbosity ("Caught exception during _mirrors lookup:"++ - displayException (e :: SomeException)) - return [] - Right v -> return v - - if null mirrors - then warn verbosity ("No mirrors found for " ++ show repoUri) - else do info verbosity ("located " ++ show (length mirrors) ++ - " mirrors for " ++ show repoUri ++ " :") - for_ mirrors $ \url -> info verbosity ("- " ++ show url) - - return mirrors - - | otherwise = return [] - where - nslookupProg = simpleProgram "nslookup" - --- | Extract list of mirrors from @nslookup -query=TXT@ output. -extractMirrors :: String -> String -> [URI] -extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals - where - vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0 - , h == hostname - , e <- ents - , Just (k,v) <- [splitRfc1464 e] - , Just kn <- [isUrlBase k] - ] - --- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly -parseNsLookupTxt :: String -> Maybe [(String,[String])] -parseNsLookupTxt = go0 [] [] - where - -- approximate grammar: - -- := { } - -- ( 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 - -#endif ----------------------------------------------------------------------------- - --- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data -isUrlBase :: String -> Maybe Int -isUrlBase s - | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns - | otherwise = Nothing - where - ns = take (length s - 8) s - --- | Split a TXT string into key and value according to RFC1464. --- Returns 'Nothing' if parsing fails. -splitRfc1464 :: String -> Maybe (String,String) -splitRfc1464 = go "" - where - go _ [] = Nothing - go acc ('`':c:cs) = go (c:acc) cs - go acc ('=':cs) = go2 (reverse acc) "" cs - go acc (c:cs) - | isSpace c = go acc cs - | otherwise = go (c:acc) cs - - go2 k acc [] = Just (k,reverse acc) - go2 _ _ ['`'] = Nothing - go2 k acc ('`':c:cs) = go2 k (c:acc) cs - go2 k acc (c:cs) = go2 k (c:acc) cs diff --git a/Distribution/Client/Security/HTTP.hs b/Distribution/Client/Security/HTTP.hs deleted file mode 100644 --- a/Distribution/Client/Security/HTTP.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} --- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport' -module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - --- stdlibs -import System.Directory - ( getTemporaryDirectory ) -import Network.URI - ( URI ) -import qualified Data.ByteString.Lazy as BS.L -import qualified Network.HTTP as HTTP - --- Cabal/cabal-install -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Client.HttpUtils - ( HttpTransport(..), HttpCode ) -import Distribution.Client.Utils - ( withTempFileName ) - --- hackage-security -import Hackage.Security.Client.Repository.HttpLib (HttpLib (..)) -import qualified Hackage.Security.Client as HC -import qualified Hackage.Security.Client.Repository.HttpLib as HC -import qualified Hackage.Security.Util.Checked as HC -import qualified Hackage.Security.Util.Pretty as HC - -{------------------------------------------------------------------------------- - 'HttpLib' implementation --------------------------------------------------------------------------------} - --- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport' --- --- NOTE: The match between these two APIs is currently not perfect: --- --- * We don't get any response headers back from the 'HttpTransport', so we --- don't know if the server supports range requests. For now we optimistically --- assume that it does. --- * The 'HttpTransport' wants to know where to place the resulting file, --- whereas the 'HttpLib' expects an 'IO' action which streams the download; --- the security library then makes sure that the file gets written to a --- location which is suitable (in particular, to a temporary file in the --- directory where the file needs to end up, so that it can "finalize" the --- file simply by doing 'renameFile'). Right now we write the file to a --- temporary file in the system temp directory here and then read it again --- to pass it to the security library; this is a problem for two reasons: it --- is a source of inefficiency; and it means that the security library cannot --- insist on a minimum download rate (potential security attack). --- Fixing it however would require changing the 'HttpTransport'. -transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib -transportAdapter verbosity getTransport = HttpLib{ - httpGet = \headers uri callback -> do - transport <- getTransport - httpGetImpl verbosity transport headers uri callback - , httpGetRange = \headers uri range callback -> do - transport <- getTransport - getRange verbosity transport headers uri range callback - } - -httpGetImpl - :: HC.Throws HC.SomeRemoteError - => Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI - -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a -httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do - get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br -> - case code of - 200 -> callback respHeaders br - _ -> HC.throwChecked $ UnexpectedResponse uri code - -getRange :: HC.Throws HC.SomeRemoteError - => Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI -> (Int, Int) - -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a -getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do - get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br -> - case code of - 200 -> callback HC.HttpStatus200OK respHeaders br - 206 -> callback HC.HttpStatus206PartialContent respHeaders br - _ -> HC.throwChecked $ UnexpectedResponse uri code - --- | Internal generalization of 'get' and 'getRange' -get' :: Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int) - -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a -get' verbosity transport reqHeaders uri mRange callback = do - tempDir <- getTemporaryDirectory - withTempFileName tempDir "transportAdapterGet" $ \temp -> do - (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders' - br <- HC.bodyReaderFromBS =<< BS.L.readFile temp - callback code [HC.HttpResponseAcceptRangesBytes] br - where - reqHeaders' = mkReqHeaders reqHeaders mRange - -{------------------------------------------------------------------------------- - Request headers --------------------------------------------------------------------------------} - -mkRangeHeader :: Int -> Int -> HTTP.Header -mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader - where - -- Content-Range header uses inclusive rather than exclusive bounds - -- See - rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1) - -mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header] -mkReqHeaders reqHeaders mRange = concat [ - tr [] reqHeaders - , [mkRangeHeader fr to | Just (fr, to) <- [mRange]] - ] - where - tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header] - tr acc [] = - concatMap finalize acc - tr acc (HC.HttpRequestMaxAge0:os) = - tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os - tr acc (HC.HttpRequestNoTransform:os) = - tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os - - -- Some headers are comma-separated, others need multiple headers for - -- multiple options. - -- - -- TODO: Right we just comma-separate all of them. - finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header] - finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] - - insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert x y = modifyAssocList x (++ y) - - -- modify the first matching element - modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] - modifyAssocList a f = go where - go [] = [] - go (p@(a', b) : xs) | a == a' = (a', f b) : xs - | otherwise = p : go xs - -{------------------------------------------------------------------------------- - Custom exceptions --------------------------------------------------------------------------------} - -data UnexpectedResponse = UnexpectedResponse URI Int - deriving (Typeable) - -instance HC.Pretty UnexpectedResponse where - pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code - ++ " for " ++ show uri - -#if MIN_VERSION_base(4,8,0) -deriving instance Show UnexpectedResponse -instance Exception UnexpectedResponse where displayException = HC.pretty -#else -instance Show UnexpectedResponse where show = HC.pretty -instance Exception UnexpectedResponse -#endif - -wrapCustomEx :: ( ( HC.Throws UnexpectedResponse - , HC.Throws IOException - ) => IO a) - -> (HC.Throws HC.SomeRemoteError => IO a) -wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex) - $ HC.handleChecked (\(ex :: IOException) -> go ex) - $ act - where - go ex = HC.throwChecked (HC.SomeRemoteError ex) diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs deleted file mode 100644 --- a/Distribution/Client/Setup.hs +++ /dev/null @@ -1,2683 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Setup --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Distribution.Client.Setup - ( globalCommand, GlobalFlags(..), defaultGlobalFlags - , RepoContext(..), withRepoContext - , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags - , configPackageDB', configCompilerAux' - , configureExCommand, ConfigExFlags(..), defaultConfigExFlags - , buildCommand, BuildFlags(..) - , filterTestFlags - , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions - , configureExOptions, reconfigureCommand - , installCommand, InstallFlags(..), installOptions, defaultInstallFlags - , filterHaddockArgs, filterHaddockFlags, haddockOptions - , defaultSolver, defaultMaxBackjumps - , listCommand, ListFlags(..), listNeedsCompiler - , updateCommand, UpdateFlags(..), defaultUpdateFlags - , infoCommand, InfoFlags(..) - , fetchCommand, FetchFlags(..) - , freezeCommand, FreezeFlags(..) - , genBoundsCommand - , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..) - , getCommand, unpackCommand, GetFlags(..) - , checkCommand - , formatCommand - , uploadCommand, UploadFlags(..), IsCandidate(..) - , reportCommand, ReportFlags(..) - , runCommand - , initCommand, initOptions, IT.InitFlags(..) - , actAsSetupCommand, ActAsSetupFlags(..) - , execCommand, ExecFlags(..), defaultExecFlags - , userConfigCommand, UserConfigFlags(..) - , manpageCommand - , haddockCommand - , cleanCommand - , doctestCommand - , copyCommand - , registerCommand - - , parsePackageArgs - , liftOptions - , yesNoOpt - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (get) - -import Distribution.Client.Types.Credentials (Username (..), Password (..)) -import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..)) -import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..)) -import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy - -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Dependency.Types - ( PreSolver(..) ) -import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) -import Distribution.Client.IndexUtils.IndexState - ( TotalIndexState, headTotalIndexState ) -import qualified Distribution.Client.Init.Types as IT - ( InitFlags(..), PackageType(..), defaultInitFlags ) -import Distribution.Client.Targets - ( UserConstraint, readUserConstraint ) -import Distribution.Utils.NubList - ( NubList, toNubList, fromNubList) - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Settings - -import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack ) -import Distribution.Simple.Program (ProgramDb, defaultProgramDb) -import Distribution.Simple.Command hiding (boolOpt, boolOpt') -import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Configure - ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Flag - ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag - , flagElim, fromFlagOrDefault - ) -import Distribution.Simple.Setup - ( ConfigFlags(..), BuildFlags(..), ReplFlags - , TestFlags, BenchmarkFlags - , HaddockFlags(..) - , CleanFlags(..), DoctestFlags(..) - , CopyFlags(..), RegisterFlags(..) - , readPackageDbList, showPackageDbList - , BooleanFlag(..), optionVerbosity - , boolOpt, boolOpt', trueArg, falseArg - , optionNumJobs ) -import Distribution.Simple.InstallDirs - ( PathTemplate, InstallDirs(..) - , toPathTemplate, fromPathTemplate, combinePathTemplate ) -import Distribution.Version - ( Version, mkVersion ) -import Distribution.Package - ( PackageName ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..) ) -import Distribution.Types.UnqualComponentName - ( unqualComponentNameToPackageName ) -import Distribution.PackageDescription - ( BuildType(..), RepoKind(..), LibraryName(..) ) -import Distribution.System ( Platform ) -import Distribution.ReadE - ( ReadE(..), succeedReadE, parsecToReadE ) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Verbosity - ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) -import Distribution.Simple.Utils - ( wrapText ) -import Distribution.Client.GlobalFlags - ( GlobalFlags(..), defaultGlobalFlags - , RepoContext(..), withRepoContext - ) -import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions) -import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) - -import Data.List - ( deleteFirstsBy ) -import System.FilePath - ( () ) - -globalCommand :: [Command action] -> CommandUI GlobalFlags -globalCommand commands = CommandUI { - commandName = "", - commandSynopsis = - "Command line interface to the Haskell Cabal infrastructure.", - commandUsage = \pname -> - "See http://www.haskell.org/cabal/ for more information.\n" - ++ "\n" - ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", - commandDescription = Just $ \pname -> - let - commands' = commands ++ [commandAddAction helpCommandUI undefined] - cmdDescs = getNormalCommandDescriptions commands' - -- if new commands are added, we want them to appear even if they - -- are not included in the custom listing below. Thus, we calculate - -- the `otherCmds` list and append it under the `other` category. - -- Alternatively, a new testcase could be added that ensures that - -- the set of commands listed here is equal to the set of commands - -- that are actually available. - otherCmds = deleteFirstsBy (==) (map fst cmdDescs) - [ "help" - , "update" - , "install" - , "fetch" - , "list" - , "info" - , "user-config" - , "get" - , "init" - , "configure" - , "build" - , "clean" - , "run" - , "repl" - , "test" - , "bench" - , "check" - , "sdist" - , "upload" - , "report" - , "freeze" - , "gen-bounds" - , "outdated" - , "haddock" - , "hscolour" - , "exec" - , "new-build" - , "new-configure" - , "new-repl" - , "new-freeze" - , "new-run" - , "new-test" - , "new-bench" - , "new-haddock" - , "new-exec" - , "new-update" - , "new-install" - , "new-clean" - , "new-sdist" - , "list-bin" - -- v1 commands, stateful style - , "v1-build" - , "v1-configure" - , "v1-repl" - , "v1-freeze" - , "v1-run" - , "v1-test" - , "v1-bench" - , "v1-haddock" - , "v1-exec" - , "v1-update" - , "v1-install" - , "v1-clean" - , "v1-sdist" - , "v1-doctest" - , "v1-copy" - , "v1-register" - , "v1-reconfigure" - -- v2 commands, nix-style - , "v2-build" - , "v2-configure" - , "v2-repl" - , "v2-freeze" - , "v2-run" - , "v2-test" - , "v2-bench" - , "v2-haddock" - , "v2-exec" - , "v2-update" - , "v2-install" - , "v2-clean" - , "v2-sdist" - ] - maxlen = maximum $ [length name | (name, _) <- cmdDescs] - align str = str ++ replicate (maxlen - length str) ' ' - startGroup n = " ["++n++"]" - par = "" - addCmd n = case lookup n cmdDescs of - Nothing -> "" - Just d -> " " ++ align n ++ " " ++ d - in - "Commands:\n" - ++ unlines ( - [ startGroup "global" - , addCmd "update" - , addCmd "install" - , par - , addCmd "help" - , addCmd "info" - , addCmd "list" - , addCmd "fetch" - , addCmd "user-config" - , par - , startGroup "package" - , addCmd "get" - , addCmd "init" - , par - , addCmd "configure" - , addCmd "build" - , addCmd "clean" - , par - , addCmd "run" - , addCmd "repl" - , addCmd "test" - , addCmd "bench" - , par - , addCmd "check" - , addCmd "sdist" - , addCmd "upload" - , addCmd "report" - , par - , addCmd "freeze" - , addCmd "gen-bounds" - , addCmd "outdated" - , addCmd "haddock" - , addCmd "hscolour" - , addCmd "exec" - , addCmd "list-bin" - , par - , startGroup "new-style projects (forwards-compatible aliases)" - , addCmd "v2-build" - , addCmd "v2-configure" - , addCmd "v2-repl" - , addCmd "v2-run" - , addCmd "v2-test" - , addCmd "v2-bench" - , addCmd "v2-freeze" - , addCmd "v2-haddock" - , addCmd "v2-exec" - , addCmd "v2-update" - , addCmd "v2-install" - , addCmd "v2-clean" - , addCmd "v2-sdist" - , par - , startGroup "legacy command aliases" - , addCmd "v1-build" - , addCmd "v1-configure" - , addCmd "v1-repl" - , addCmd "v1-run" - , addCmd "v1-test" - , addCmd "v1-bench" - , addCmd "v1-freeze" - , addCmd "v1-haddock" - , addCmd "v1-exec" - , addCmd "v1-update" - , addCmd "v1-install" - , addCmd "v1-clean" - , addCmd "v1-sdist" - , addCmd "v1-doctest" - , addCmd "v1-copy" - , addCmd "v1-register" - , addCmd "v1-reconfigure" - ] ++ if null otherCmds then [] else par - :startGroup "other" - :[addCmd n | n <- otherCmds]) - ++ "\n" - ++ "For more information about a command use:\n" - ++ " " ++ pname ++ " COMMAND --help\n" - ++ "or " ++ pname ++ " help COMMAND\n" - ++ "\n" - ++ "To install Cabal packages from hackage use:\n" - ++ " " ++ pname ++ " install foo [--dry-run]\n" - ++ "\n" - ++ "Occasionally you need to update the list of available packages:\n" - ++ " " ++ pname ++ " update\n", - commandNotes = Nothing, - commandDefaultFlags = mempty, - commandOptions = args - } - where - args :: ShowOrParseArgs -> [OptionField GlobalFlags] - args ShowArgs = argsShown - args ParseArgs = argsShown ++ argsNotShown - - -- arguments we want to show in the help - argsShown :: [OptionField GlobalFlags] - argsShown = [ - option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - - ,option [] ["config-file"] - "Set an alternate location for the config file" - globalConfigFile (\v flags -> flags { globalConfigFile = v }) - (reqArgFlag "FILE") - - ,option [] ["default-user-config"] - "Set a location for a cabal.config file for projects without their own cabal.config freeze file." - globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v}) - (reqArgFlag "FILE") - - ,option [] ["ignore-expiry"] - "Ignore expiry dates on signed metadata (use only in exceptional circumstances)" - globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v }) - trueArg - - ,option [] ["http-transport"] - "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" - globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) - (reqArgFlag "HttpTransport") - ,option [] ["nix"] - "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" - globalNix (\v flags -> flags { globalNix = v }) - (boolOpt [] []) - - ] - - -- arguments we don't want shown in the help - argsNotShown :: [OptionField GlobalFlags] - argsNotShown = [ - option [] ["remote-repo"] - "The name and url for a remote repository" - globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) - (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) - - ,option [] ["local-no-index-repo"] - "The name and a path for a local no-index repository" - globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v }) - (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) - - ,option [] ["remote-repo-cache"] - "The location where downloads from all remote repos are cached" - globalCacheDir (\v flags -> flags { globalCacheDir = v }) - (reqArgFlag "DIR") - - ,option [] ["logs-dir", "logsdir"] - "The location to put log files" - globalLogsDir (\v flags -> flags { globalLogsDir = v }) - (reqArgFlag "DIR") - - ,option [] ["world-file"] - "The location of the world file" - globalWorldFile (\v flags -> flags { globalWorldFile = v }) - (reqArgFlag "FILE") - - ,option [] ["store-dir", "storedir"] - "The location of the nix-local-build store" - globalStoreDir (\v flags -> flags { globalStoreDir = v }) - (reqArgFlag "DIR") - - , option [] ["active-repositories"] - "The active package repositories" - globalActiveRepos (\v flags -> flags { globalActiveRepos = v }) - (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err) - (toFlag `fmap` parsec)) - (map prettyShow . flagToList)) - ] - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - -configureCommand :: CommandUI ConfigFlags -configureCommand = c - { commandName = "configure" - , commandDefaultFlags = mempty - , commandDescription = Just $ \_ -> wrapText $ - "Configure how the package is built by setting " - ++ "package (and other) flags.\n" - ++ "\n" - ++ "The configuration affects several other commands, " - ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n" - , commandUsage = \pname -> - "Usage: " ++ pname ++ " v1-configure [FLAGS]\n" - , commandNotes = Just $ \pname -> - (Cabal.programFlagsDescription defaultProgramDb ++ "\n") - ++ "Examples:\n" - ++ " " ++ pname ++ " v1-configure\n" - ++ " Configure with defaults;\n" - ++ " " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n" - ++ " Configure building package including tests,\n" - ++ " with some package-specific flag.\n" - } - where - c = Cabal.configureCommand defaultProgramDb - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions = commandOptions configureCommand - --- | Given some 'ConfigFlags' for the version of Cabal that --- cabal-install was built with, and a target older 'Version' of --- Cabal that we want to pass these flags to, convert the --- flags into a form that will be accepted by the older --- Setup script. Generally speaking, this just means filtering --- out flags that the old Cabal library doesn't understand, but --- in some cases it may also mean "emulating" a feature using --- some more legacy flags. -filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags -filterConfigureFlags flags cabalLibVersion - -- NB: we expect the latest version to be the most common case, - -- so test it first. - | cabalLibVersion >= mkVersion [2,5,0] = flags_latest - -- The naming convention is that flags_version gives flags with - -- all flags *introduced* in version eliminated. - -- It is NOT the latest version of Cabal library that - -- these flags work for; version of introduction is a more - -- natural metric. - | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10 - | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0 - | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0 - | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0 - | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0 - | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1 - | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2 - | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1 - | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 - | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1 - | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 - | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 - | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 - | cabalLibVersion < mkVersion [2,5,0] = flags_2_5_0 - | otherwise = error "the impossible just happened" -- see first guard - where - flags_latest = flags { - -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. - -- Note: this is not in the wrong place. configConstraints gets - -- repopulated in flags_1_19_1 but it needs to be set to empty for - -- newer versions first. - configConstraints = [] - } - - flags_2_5_0 = flags_latest { - -- Cabal < 2.5 does not understand --dependency=pkg:component=cid - -- (public sublibraries), so we convert it to the legacy - -- --dependency=pkg_or_internal_compoent=cid - configDependencies = - let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = - Just $ GivenComponent - (unqualComponentNameToPackageName cn) - LMainLibName - cid - convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = - Just $ GivenComponent pn LMainLibName cid - in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags - -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'. - , configAllowDependingOnPrivateLibs = NoFlag - -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'. - , configFullyStaticExe = NoFlag - } - - flags_2_1_0 = flags_2_5_0 { - -- Cabal < 2.1 doesn't know about -v +timestamp modifier - configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest) - -- Cabal < 2.1 doesn't know about ---static - , configStaticLib = NoFlag - , configSplitSections = NoFlag - } - - flags_1_25_0 = flags_2_1_0 { - -- Cabal < 1.25.0 doesn't know about --dynlibdir. - configInstallDirs = configInstallDirs_1_25_0, - -- Cabal < 1.25 doesn't have extended verbosity syntax - configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0), - -- Cabal < 1.25 doesn't support --deterministic - configDeterministic = mempty - } - configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in - dirs { dynlibdir = NoFlag - , libexecsubdir = NoFlag - , libexecdir = maybeToFlag $ - combinePathTemplate <$> flagToMaybe (libexecdir dirs) - <*> flagToMaybe (libexecsubdir dirs) - } - -- Cabal < 1.23 doesn't know about '--profiling-detail'. - -- Cabal < 1.23 has a hacked up version of 'enable-profiling' - -- which we shouldn't use. - (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags - flags_1_23_0 = flags_1_25_0 { configProfDetail = NoFlag - , configProfLibDetail = NoFlag - , configIPID = NoFlag - , configProf = NoFlag - , configProfExe = Flag tryExeProfiling - , configProfLib = Flag tryLibProfiling - } - - -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d) - -- due to temporary amnesia of the --*-executable-profiling flags - flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag - , configProfExe = NoFlag - } - - -- Cabal < 1.22 doesn't know about '--disable-debug-info'. - flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag } - - -- Cabal < 1.21.1 doesn't know about 'disable-relocatable' - -- Cabal < 1.21.1 doesn't know about 'enable-profiling' - -- (but we already dealt with it in flags_1_23_0) - flags_1_21_1 = - flags_1_22_0 { configRelocatable = NoFlag - , configCoverage = NoFlag - , configLibCoverage = configCoverage flags - } - -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and - -- '--enable-library-stripping'. - flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag - , configStripLibs = NoFlag } - -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'. - flags_1_19_1 = flags_1_19_2 { configDependencies = [] - , configConstraints = configConstraints flags } - -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. - flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList [] - , configInstallDirs = configInstallDirs_1_18_0} - configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag } - -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'. - flags_1_14_0 = flags_1_18_0 { configBenchmarks = NoFlag } - -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic' - -- and '--enable/disable-library-coverage'. - flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag - , configDynExe = NoFlag } - -- Cabal < 1.10.0 doesn't know about '--disable-tests'. - flags_1_10_0 = flags_1_12_0 { configTests = NoFlag } - -- Cabal < 1.3.10 does not grok the '--constraints' flag. - flags_1_3_10 = flags_1_10_0 { configConstraints = [] } - --- | Get the package database settings from 'ConfigFlags', accounting for --- @--package-db@ and @--user@ flags. -configPackageDB' :: ConfigFlags -> PackageDBStack -configPackageDB' cfg = - interpretPackageDbFlags userInstall (configPackageDBs cfg) - where - userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg) - --- | Configure the compiler, but reduce verbosity during this step. -configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) -configCompilerAux' configFlags = - configCompilerAuxEx configFlags - --FIXME: make configCompilerAux use a sensible verbosity - { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } - --- ------------------------------------------------------------ --- * Config extra flags --- ------------------------------------------------------------ - --- | cabal configure takes some extra flags beyond runghc Setup configure --- -data ConfigExFlags = ConfigExFlags { - configCabalVersion :: Flag Version, - configExConstraints :: [(UserConstraint, ConstraintSource)], - configPreferences :: [PackageVersionConstraint], - configSolver :: Flag PreSolver, - configAllowNewer :: Maybe AllowNewer, - configAllowOlder :: Maybe AllowOlder, - configWriteGhcEnvironmentFilesPolicy - :: Flag WriteGhcEnvironmentFilesPolicy - } - deriving (Eq, Show, Generic) - -defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } - -configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) -configureExCommand = configureCommand { - commandDefaultFlags = (mempty, defaultConfigExFlags), - commandOptions = \showOrParseArgs -> - liftOptions fst setFst - (filter ((`notElem` ["constraint", "dependency", "exact-configuration"]) - . optionName) $ configureOptions showOrParseArgs) - ++ liftOptions snd setSnd - (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) - } - where - setFst a (_,b) = (a,b) - setSnd b (a,_) = (a,b) - -configureExOptions :: ShowOrParseArgs - -> ConstraintSource - -> [OptionField ConfigExFlags] -configureExOptions _showOrParseArgs src = - [ option [] ["cabal-lib-version"] - ("Select which version of the Cabal lib to use to build packages " - ++ "(useful for testing).") - configCabalVersion (\v flags -> flags { configCabalVersion = v }) - (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++) - (fmap toFlag parsec)) - (map prettyShow. flagToList)) - , option [] ["constraint"] - "Specify constraints on a package (version, installed/source, flags)" - configExConstraints (\v flags -> flags { configExConstraints = v }) - (reqArg "CONSTRAINT" - ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) - (map $ prettyShow . fst)) - - , option [] ["preference"] - "Specify preferences (soft constraints) on the version of a package" - configPreferences (\v flags -> flags { configPreferences = v }) - (reqArg "CONSTRAINT" - (parsecToReadE (const "dependency expected") - (fmap (\x -> [x]) parsec)) - (map prettyShow)) - - , optionSolver configSolver (\v flags -> flags { configSolver = v }) - - , option [] ["allow-older"] - ("Ignore lower bounds in all dependencies or DEPS") - (fmap unAllowOlder . configAllowOlder) - (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) - (optArg "DEPS" - (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) - (Just RelaxDepsAll) relaxDepsPrinter) - - , option [] ["allow-newer"] - ("Ignore upper bounds in all dependencies or DEPS") - (fmap unAllowNewer . configAllowNewer) - (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) - (optArg "DEPS" - (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) - (Just RelaxDepsAll) relaxDepsPrinter) - - , option [] ["write-ghc-environment-files"] - ("Whether to create a .ghc.environment file after a successful build" - ++ " (v2-build only)") - configWriteGhcEnvironmentFilesPolicy - (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v}) - (reqArg "always|never|ghc8.4.4+" - writeGhcEnvironmentFilesPolicyParser - writeGhcEnvironmentFilesPolicyPrinter) - ] - - -writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) -writeGhcEnvironmentFilesPolicyParser = ReadE $ \case - "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles - "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles - "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer - policy -> Left $ "Cannot parse the GHC environment file write policy '" - <> policy <> "'" - -writeGhcEnvironmentFilesPolicyPrinter - :: Flag WriteGhcEnvironmentFilesPolicy -> [String] -writeGhcEnvironmentFilesPolicyPrinter = \case - (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"] - (Flag NeverWriteGhcEnvironmentFiles) -> ["never"] - (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] - NoFlag -> [] - - -relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) -relaxDepsParser = - (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',') - -relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] -relaxDepsPrinter Nothing = [] -relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] -relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs - - -instance Monoid ConfigExFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ConfigExFlags where - (<>) = gmappend - -reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags) -reconfigureCommand - = configureExCommand - { commandName = "reconfigure" - , commandSynopsis = "Reconfigure the package if necessary." - , commandDescription = Just $ \pname -> wrapText $ - "Run `configure` with the most recently used flags, or append FLAGS " - ++ "to the most recently used configuration. " - ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. " - ++ "If the package has never been configured, the default flags are " - ++ "used." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-reconfigure\n" - ++ " Configure with the most recently used flags.\n" - ++ " " ++ pname ++ " v1-reconfigure -w PATH\n" - ++ " Reconfigure with the most recently used flags,\n" - ++ " but use the compiler at PATH.\n\n" - , commandUsage = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ] - , commandDefaultFlags = mempty - } - --- ------------------------------------------------------------ --- * Build flags --- ------------------------------------------------------------ - -buildCommand :: CommandUI BuildFlags -buildCommand = parent { - commandName = "build", - commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `v1-configure`.\n", - commandDefaultFlags = commandDefaultFlags parent, - commandUsage = usageAlternatives "v1-build" $ - [ "[FLAGS]", "COMPONENTS [FLAGS]" ], - commandOptions = commandOptions parent - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-build " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " v1-build foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ Cabal.programFlagsDescription defaultProgramDb - } - where - parent = Cabal.buildCommand defaultProgramDb - --- ------------------------------------------------------------ --- * Test flags --- ------------------------------------------------------------ - --- | Given some 'TestFlags' for the version of Cabal that --- cabal-install was built with, and a target older 'Version' of --- Cabal that we want to pass these flags to, convert the --- flags into a form that will be accepted by the older --- Setup script. Generally speaking, this just means filtering --- out flags that the old Cabal library doesn't understand, but --- in some cases it may also mean "emulating" a feature using --- some more legacy flags. -filterTestFlags :: TestFlags -> Version -> TestFlags -filterTestFlags flags cabalLibVersion - -- NB: we expect the latest version to be the most common case, - -- so test it first. - | cabalLibVersion >= mkVersion [3,0,0] = flags_latest - -- The naming convention is that flags_version gives flags with - -- all flags *introduced* in version eliminated. - -- It is NOT the latest version of Cabal library that - -- these flags work for; version of introduction is a more - -- natural metric. - | cabalLibVersion < mkVersion [3,0,0] = flags_3_0_0 - | otherwise = error "the impossible just happened" -- see first guard - where - flags_latest = flags - flags_3_0_0 = flags_latest { - -- Cabal < 3.0 doesn't know about --test-wrapper - Cabal.testWrapper = NoFlag - } - --- ------------------------------------------------------------ --- * Repl command --- ------------------------------------------------------------ - -replCommand :: CommandUI ReplFlags -replCommand = parent { - commandName = "repl", - commandDescription = Just $ \pname -> wrapText $ - "If the current directory contains no package, ignores COMPONENT " - ++ "parameters and opens an interactive interpreter session;\n" - ++ "\n" - ++ "Otherwise, (re)configures with the given or default flags, and " - ++ "loads the interpreter with the relevant modules. For executables, " - ++ "tests and benchmarks, loads the main module (and its " - ++ "dependencies); for libraries all exposed/other modules.\n" - ++ "\n" - ++ "The default component is the library itself, or the executable " - ++ "if that is the only component.\n" - ++ "\n" - ++ "Support for loading specific modules is planned but not " - ++ "implemented yet. For certain scenarios, `" ++ pname - ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will " - ++ "not (re)configure and you will have to specify the location of " - ++ "other modules, if required.\n", - commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n", - commandDefaultFlags = commandDefaultFlags parent, - commandOptions = commandOptions parent, - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-repl " - ++ " The first component in the package\n" - ++ " " ++ pname ++ " v1-repl foo " - ++ " A named component (i.e. lib, exe, test suite)\n" - ++ " " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\"" - ++ " Specifying flags for interpreter\n" - } - where - parent = Cabal.replCommand defaultProgramDb - --- ------------------------------------------------------------ --- * Test command --- ------------------------------------------------------------ - -testCommand :: CommandUI (BuildFlags, TestFlags) -testCommand = parent { - commandName = "test", - commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-tests` flag and builds" - ++ " the test suite.\n" - ++ "\n" - ++ "Remember that the tests' dependencies must be installed if there" - ++ " are additional ones; e.g. with `" ++ pname - ++ " v1-install --only-dependencies --enable-tests`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running tests.\n", - commandUsage = usageAlternatives "v1-test" - [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ], - commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), - commandOptions = - \showOrParseArgs -> liftOptions get1 set1 - (Cabal.buildOptions progDb showOrParseArgs) - ++ - liftOptions get2 set2 - (commandOptions parent showOrParseArgs) - } - where - get1 (a,_) = a; set1 a (_,b) = (a,b) - get2 (_,b) = b; set2 b (a,_) = (a,b) - - parent = Cabal.testCommand - progDb = defaultProgramDb - --- ------------------------------------------------------------ --- * Bench command --- ------------------------------------------------------------ - -benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags) -benchmarkCommand = parent { - commandName = "bench", - commandUsage = usageAlternatives "v1-bench" - [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ], - commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-benchmarks` flag and" - ++ " builds the benchmarks.\n" - ++ "\n" - ++ "Remember that the benchmarks' dependencies must be installed if" - ++ " there are additional ones; e.g. with `" ++ pname - ++ " v1-install --only-dependencies --enable-benchmarks`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running" - ++ " benchmarks.\n", - commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), - commandOptions = - \showOrParseArgs -> liftOptions get1 set1 - (Cabal.buildOptions progDb showOrParseArgs) - ++ - liftOptions get2 set2 - (commandOptions parent showOrParseArgs) - } - where - get1 (a,_) = a; set1 a (_,b) = (a,b) - get2 (_,b) = b; set2 b (a,_) = (a,b) - - parent = Cabal.benchmarkCommand - progDb = defaultProgramDb - --- ------------------------------------------------------------ --- * Fetch command --- ------------------------------------------------------------ - -data FetchFlags = FetchFlags { --- fetchOutput :: Flag FilePath, - fetchDeps :: Flag Bool, - fetchDryRun :: Flag Bool, - fetchSolver :: Flag PreSolver, - fetchMaxBackjumps :: Flag Int, - fetchReorderGoals :: Flag ReorderGoals, - fetchCountConflicts :: Flag CountConflicts, - fetchFineGrainedConflicts :: Flag FineGrainedConflicts, - fetchMinimizeConflictSet :: Flag MinimizeConflictSet, - fetchIndependentGoals :: Flag IndependentGoals, - fetchShadowPkgs :: Flag ShadowPkgs, - fetchStrongFlags :: Flag StrongFlags, - fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, - fetchOnlyConstrained :: Flag OnlyConstrained, - fetchTests :: Flag Bool, - fetchBenchmarks :: Flag Bool, - fetchVerbosity :: Flag Verbosity - } - -defaultFetchFlags :: FetchFlags -defaultFetchFlags = FetchFlags { --- fetchOutput = mempty, - fetchDeps = toFlag True, - fetchDryRun = toFlag False, - fetchSolver = Flag defaultSolver, - fetchMaxBackjumps = Flag defaultMaxBackjumps, - fetchReorderGoals = Flag (ReorderGoals False), - fetchCountConflicts = Flag (CountConflicts True), - fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), - fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), - fetchIndependentGoals = Flag (IndependentGoals False), - fetchShadowPkgs = Flag (ShadowPkgs False), - fetchStrongFlags = Flag (StrongFlags False), - fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - fetchOnlyConstrained = Flag OnlyConstrainedNone, - fetchTests = toFlag False, - fetchBenchmarks = toFlag False, - fetchVerbosity = toFlag normal - } - -fetchCommand :: CommandUI FetchFlags -fetchCommand = CommandUI { - commandName = "fetch", - commandSynopsis = "Downloads packages for later installation.", - commandUsage = usageAlternatives "fetch" [ "[FLAGS] PACKAGES" - ], - commandDescription = Just $ \_ -> - "Note that it currently is not possible to fetch the dependencies for a\n" - ++ "package in the current directory.\n", - commandNotes = Nothing, - commandDefaultFlags = defaultFetchFlags, - commandOptions = \ showOrParseArgs -> [ - optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) - --- , option "o" ["output"] --- "Put the package(s) somewhere specific rather than the usual cache." --- fetchOutput (\v flags -> flags { fetchOutput = v }) --- (reqArgFlag "PATH") - - , option [] ["dependencies", "deps"] - "Resolve and fetch dependencies (default)" - fetchDeps (\v flags -> flags { fetchDeps = v }) - trueArg - - , option [] ["no-dependencies", "no-deps"] - "Ignore dependencies" - fetchDeps (\v flags -> flags { fetchDeps = v }) - falseArg - - , option [] ["dry-run"] - "Do not install anything, only print what would be installed." - fetchDryRun (\v flags -> flags { fetchDryRun = v }) - trueArg - - , option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - fetchTests (\v flags -> flags { fetchTests = v }) - (boolOpt [] []) - - , option "" ["benchmarks"] - "dependency checking and compilation for benchmarks listed in the package description file." - fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v }) - (boolOpt [] []) - - ] ++ - - optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) : - optionSolverFlags showOrParseArgs - fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) - fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) - fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) - fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) - fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) - fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) - fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) - fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) - fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) - fetchOnlyConstrained (\v flags -> flags { fetchOnlyConstrained = v }) - - } - --- ------------------------------------------------------------ --- * Freeze command --- ------------------------------------------------------------ - -data FreezeFlags = FreezeFlags { - freezeDryRun :: Flag Bool, - freezeTests :: Flag Bool, - freezeBenchmarks :: Flag Bool, - freezeSolver :: Flag PreSolver, - freezeMaxBackjumps :: Flag Int, - freezeReorderGoals :: Flag ReorderGoals, - freezeCountConflicts :: Flag CountConflicts, - freezeFineGrainedConflicts :: Flag FineGrainedConflicts, - freezeMinimizeConflictSet :: Flag MinimizeConflictSet, - freezeIndependentGoals :: Flag IndependentGoals, - freezeShadowPkgs :: Flag ShadowPkgs, - freezeStrongFlags :: Flag StrongFlags, - freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, - freezeOnlyConstrained :: Flag OnlyConstrained, - freezeVerbosity :: Flag Verbosity - } - -defaultFreezeFlags :: FreezeFlags -defaultFreezeFlags = FreezeFlags { - freezeDryRun = toFlag False, - freezeTests = toFlag False, - freezeBenchmarks = toFlag False, - freezeSolver = Flag defaultSolver, - freezeMaxBackjumps = Flag defaultMaxBackjumps, - freezeReorderGoals = Flag (ReorderGoals False), - freezeCountConflicts = Flag (CountConflicts True), - freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), - freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), - freezeIndependentGoals = Flag (IndependentGoals False), - freezeShadowPkgs = Flag (ShadowPkgs False), - freezeStrongFlags = Flag (StrongFlags False), - freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - freezeOnlyConstrained = Flag OnlyConstrainedNone, - freezeVerbosity = toFlag normal - } - -freezeCommand :: CommandUI FreezeFlags -freezeCommand = CommandUI { - commandName = "freeze", - commandSynopsis = "Freeze dependencies.", - commandDescription = Just $ \_ -> wrapText $ - "Calculates a valid set of dependencies and their exact versions. " - ++ "If successful, saves the result to the file `cabal.config`.\n" - ++ "\n" - ++ "The package versions specified in `cabal.config` will be used for " - ++ "any future installs.\n" - ++ "\n" - ++ "An existing `cabal.config` is ignored and overwritten.\n", - commandNotes = Nothing, - commandUsage = usageFlags "freeze", - commandDefaultFlags = defaultFreezeFlags, - commandOptions = \ showOrParseArgs -> [ - optionVerbosity freezeVerbosity - (\v flags -> flags { freezeVerbosity = v }) - - , option [] ["dry-run"] - "Do not freeze anything, only print what would be frozen" - freezeDryRun (\v flags -> flags { freezeDryRun = v }) - trueArg - - , option [] ["tests"] - ("freezing of the dependencies of any tests suites " - ++ "in the package description file.") - freezeTests (\v flags -> flags { freezeTests = v }) - (boolOpt [] []) - - , option [] ["benchmarks"] - ("freezing of the dependencies of any benchmarks suites " - ++ "in the package description file.") - freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v }) - (boolOpt [] []) - - ] ++ - - optionSolver - freezeSolver (\v flags -> flags { freezeSolver = v }): - optionSolverFlags showOrParseArgs - freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) - freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) - freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) - freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) - freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) - freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) - freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) - freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) - freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) - freezeOnlyConstrained (\v flags -> flags { freezeOnlyConstrained = v }) - - } - --- ------------------------------------------------------------ --- * 'gen-bounds' command --- ------------------------------------------------------------ - -genBoundsCommand :: CommandUI FreezeFlags -genBoundsCommand = CommandUI { - commandName = "gen-bounds", - commandSynopsis = "Generate dependency bounds.", - commandDescription = Just $ \_ -> wrapText $ - "Generates bounds for all dependencies that do not currently have them. " - ++ "Generated bounds are printed to stdout. " - ++ "You can then paste them into your .cabal file.\n" - ++ "\n", - commandNotes = Nothing, - commandUsage = usageFlags "gen-bounds", - commandDefaultFlags = defaultFreezeFlags, - commandOptions = \ _ -> [ - optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v }) - ] - } - --- ------------------------------------------------------------ --- * 'outdated' command --- ------------------------------------------------------------ - -data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone - | IgnoreMajorVersionBumpsAll - | IgnoreMajorVersionBumpsSome [PackageName] - -instance Monoid IgnoreMajorVersionBumps where - mempty = IgnoreMajorVersionBumpsNone - mappend = (<>) - -instance Semigroup IgnoreMajorVersionBumps where - IgnoreMajorVersionBumpsNone <> r = r - l@IgnoreMajorVersionBumpsAll <> _ = l - l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l - (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r - (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) = - IgnoreMajorVersionBumpsSome (a ++ b) - -data OutdatedFlags = OutdatedFlags { - outdatedVerbosity :: Flag Verbosity, - outdatedFreezeFile :: Flag Bool, - outdatedNewFreezeFile :: Flag Bool, - outdatedProjectFile :: Flag FilePath, - outdatedSimpleOutput :: Flag Bool, - outdatedExitCode :: Flag Bool, - outdatedQuiet :: Flag Bool, - outdatedIgnore :: [PackageName], - outdatedMinor :: Maybe IgnoreMajorVersionBumps - } - -defaultOutdatedFlags :: OutdatedFlags -defaultOutdatedFlags = OutdatedFlags { - outdatedVerbosity = toFlag normal, - outdatedFreezeFile = mempty, - outdatedNewFreezeFile = mempty, - outdatedProjectFile = mempty, - outdatedSimpleOutput = mempty, - outdatedExitCode = mempty, - outdatedQuiet = mempty, - outdatedIgnore = mempty, - outdatedMinor = mempty - } - -outdatedCommand :: CommandUI OutdatedFlags -outdatedCommand = CommandUI { - commandName = "outdated", - commandSynopsis = "Check for outdated dependencies", - commandDescription = Just $ \_ -> wrapText $ - "Checks for outdated dependencies in the package description file " - ++ "or freeze file", - commandNotes = Nothing, - commandUsage = usageFlags "outdated", - commandDefaultFlags = defaultOutdatedFlags, - commandOptions = \ _ -> [ - optionVerbosity outdatedVerbosity - (\v flags -> flags { outdatedVerbosity = v }) - - ,option [] ["freeze-file", "v1-freeze-file"] - "Act on the freeze file" - outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v }) - trueArg - - ,option [] ["v2-freeze-file", "new-freeze-file"] - "Act on the new-style freeze file (default: cabal.project.freeze)" - outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v }) - trueArg - - ,option [] ["project-file"] - "Act on the new-style freeze file named PROJECTFILE.freeze rather than the default cabal.project.freeze" - outdatedProjectFile (\v flags -> flags { outdatedProjectFile = v }) - (reqArgFlag "PROJECTFILE") - - ,option [] ["simple-output"] - "Only print names of outdated dependencies, one per line" - outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v }) - trueArg - - ,option [] ["exit-code"] - "Exit with non-zero when there are outdated dependencies" - outdatedExitCode (\v flags -> flags { outdatedExitCode = v }) - trueArg - - ,option ['q'] ["quiet"] - "Don't print any output. Implies '--exit-code' and '-v0'" - outdatedQuiet (\v flags -> flags { outdatedQuiet = v }) - trueArg - - ,option [] ["ignore"] - "Packages to ignore" - outdatedIgnore (\v flags -> flags { outdatedIgnore = v }) - (reqArg "PKGS" pkgNameListParser (map prettyShow)) - - ,option [] ["minor"] - "Ignore major version bumps for these packages" - outdatedMinor (\v flags -> flags { outdatedMinor = v }) - (optArg "PKGS" ignoreMajorVersionBumpsParser - (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter) - ] - } - where - ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps) - -> [Maybe String] - ignoreMajorVersionBumpsPrinter Nothing = [] - ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] - ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] - ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = - map (Just . prettyShow) $ pkgs - - ignoreMajorVersionBumpsParser = - (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser - - pkgNameListParser = parsecToReadE - ("Couldn't parse the list of package names: " ++) - (fmap toList (P.sepByNonEmpty parsec (P.char ','))) - --- ------------------------------------------------------------ --- * Update command --- ------------------------------------------------------------ - -data UpdateFlags - = UpdateFlags { - updateVerbosity :: Flag Verbosity, - updateIndexState :: Flag TotalIndexState - } deriving Generic - -defaultUpdateFlags :: UpdateFlags -defaultUpdateFlags - = UpdateFlags { - updateVerbosity = toFlag normal, - updateIndexState = toFlag headTotalIndexState - } - -updateCommand :: CommandUI UpdateFlags -updateCommand = CommandUI { - commandName = "update", - commandSynopsis = "Updates list of known packages.", - commandDescription = Just $ \_ -> - "For all known remote repositories, download the package list.\n", - commandNotes = Just $ \_ -> - relevantConfigValuesText ["remote-repo" - ,"remote-repo-cache" - ,"local-repo"], - commandUsage = usageFlags "v1-update", - commandDefaultFlags = defaultUpdateFlags, - commandOptions = \_ -> [ - optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }), - option [] ["index-state"] - ("Update the source package index to its state as it existed at a previous time. " ++ - "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") - updateIndexState (\v flags -> flags { updateIndexState = v }) - (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ - "unix-timestamps (e.g. '@1474732068'), " ++ - "a ISO8601 UTC timestamp " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - ] - } - --- ------------------------------------------------------------ --- * Other commands --- ------------------------------------------------------------ - -cleanCommand :: CommandUI CleanFlags -cleanCommand = Cabal.cleanCommand - { commandUsage = \pname -> - "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" - } - -checkCommand :: CommandUI (Flag Verbosity) -checkCommand = CommandUI { - commandName = "check", - commandSynopsis = "Check the package for common mistakes.", - commandDescription = Just $ \_ -> wrapText $ - "Expects a .cabal package file in the current directory.\n" - ++ "\n" - ++ "The checks correspond to the requirements to packages on Hackage. " - ++ "If no errors and warnings are reported, Hackage will accept this " - ++ "package.\n", - commandNotes = Nothing, - commandUsage = usageFlags "check", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] - } - -formatCommand :: CommandUI (Flag Verbosity) -formatCommand = CommandUI { - commandName = "format", - commandSynopsis = "Reformat the .cabal file using the standard style.", - commandDescription = Nothing, - commandNotes = Nothing, - commandUsage = usageAlternatives "format" ["[FILE]"], - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [] - } - -manpageCommand :: CommandUI ManpageFlags -manpageCommand = CommandUI { - commandName = "man", - commandSynopsis = "Outputs manpage source.", - commandDescription = Just $ \_ -> - "Output manpage source to STDOUT.\n", - commandNotes = Nothing, - commandUsage = usageFlags "man", - commandDefaultFlags = defaultManpageFlags, - commandOptions = manpageOptions - } - -runCommand :: CommandUI BuildFlags -runCommand = CommandUI { - commandName = "run", - commandSynopsis = "Builds and runs an executable.", - commandDescription = Just $ \pname -> wrapText $ - "Builds and then runs the specified executable. If no executable is " - ++ "specified, but the package contains just one executable, that one " - ++ "is built and executed.\n" - ++ "\n" - ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a " - ++ "test-suite and get its full output.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-run\n" - ++ " Run the only executable in the current package;\n" - ++ " " ++ pname ++ " v1-run foo -- --fooflag\n" - ++ " Works similar to `./foo --fooflag`.\n", - commandUsage = usageAlternatives "v1-run" - ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"], - commandDefaultFlags = mempty, - commandOptions = commandOptions parent - } - where - parent = Cabal.buildCommand defaultProgramDb - --- ------------------------------------------------------------ --- * Report flags --- ------------------------------------------------------------ - -data ReportFlags = ReportFlags { - reportUsername :: Flag Username, - reportPassword :: Flag Password, - reportVerbosity :: Flag Verbosity - } deriving Generic - -defaultReportFlags :: ReportFlags -defaultReportFlags = ReportFlags { - reportUsername = mempty, - reportPassword = mempty, - reportVerbosity = toFlag normal - } - -reportCommand :: CommandUI ReportFlags -reportCommand = CommandUI { - commandName = "report", - commandSynopsis = "Upload build reports to a remote server.", - commandDescription = Nothing, - commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.cabal/config file\n", - commandUsage = usageAlternatives "report" ["[FLAGS]"], - commandDefaultFlags = defaultReportFlags, - commandOptions = \_ -> - [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v }) - - ,option ['u'] ["username"] - "Hackage username." - reportUsername (\v flags -> flags { reportUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - reportPassword (\v flags -> flags { reportPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - ] - } - -instance Monoid ReportFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ReportFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Get flags --- ------------------------------------------------------------ - -data GetFlags = GetFlags { - getDestDir :: Flag FilePath, - getPristine :: Flag Bool, - getIndexState :: Flag TotalIndexState, - getActiveRepos :: Flag ActiveRepos, - getSourceRepository :: Flag (Maybe RepoKind), - getVerbosity :: Flag Verbosity - } deriving Generic - -defaultGetFlags :: GetFlags -defaultGetFlags = GetFlags { - getDestDir = mempty, - getPristine = mempty, - getIndexState = mempty, - getActiveRepos = mempty, - getSourceRepository = mempty, - getVerbosity = toFlag normal - } - -getCommand :: CommandUI GetFlags -getCommand = CommandUI { - commandName = "get", - commandSynopsis = "Download/Extract a package's source code (repository).", - commandDescription = Just $ \_ -> wrapText $ - "Creates a local copy of a package's source code. By default it gets " - ++ "the source\ntarball and unpacks it in a local subdirectory. " - ++ "Alternatively, with -s it will\nget the code from the source " - ++ "repository specified by the package.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " get hlint\n" - ++ " Download the latest stable version of hlint;\n" - ++ " " ++ pname ++ " get lens --source-repository=head\n" - ++ " Download the source repository (i.e. git clone from github).\n", - commandUsage = usagePackages "get", - commandDefaultFlags = defaultGetFlags, - commandOptions = \_ -> [ - optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v }) - - ,option "d" ["destdir"] - "Where to place the package source, defaults to the current directory." - getDestDir (\v flags -> flags { getDestDir = v }) - (reqArgFlag "PATH") - - ,option "s" ["source-repository"] - "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." - getSourceRepository (\v flags -> flags { getSourceRepository = v }) - (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository") - (fmap (toFlag . Just) parsec)) - (Flag Nothing) - (map (fmap show) . flagToList)) - - , option [] ["index-state"] - ("Use source package index state as it existed at a previous time. " ++ - "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++ - "This determines which package versions are available as well as " ++ - ".cabal file revision is selected (unless --pristine is used).") - getIndexState (\v flags -> flags { getIndexState = v }) - (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ - "unix-timestamps (e.g. '@1474732068'), " ++ - "a ISO8601 UTC timestamp " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["pristine"] - ("Unpack the original pristine tarball, rather than updating the " - ++ ".cabal file with the latest revision from the package archive.") - getPristine (\v flags -> flags { getPristine = v }) - trueArg - ] - } - --- 'cabal unpack' is a deprecated alias for 'cabal get'. -unpackCommand :: CommandUI GetFlags -unpackCommand = getCommand { - commandName = "unpack", - commandUsage = usagePackages "unpack" - } - -instance Monoid GetFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup GetFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * List flags --- ------------------------------------------------------------ - -data ListFlags = ListFlags - { listInstalled :: Flag Bool - , listSimpleOutput :: Flag Bool - , listCaseInsensitive :: Flag Bool - , listVerbosity :: Flag Verbosity - , listPackageDBs :: [Maybe PackageDB] - , listHcPath :: Flag FilePath - } - deriving Generic - -defaultListFlags :: ListFlags -defaultListFlags = ListFlags - { listInstalled = Flag False - , listSimpleOutput = Flag False - , listCaseInsensitive = Flag True - , listVerbosity = toFlag normal - , listPackageDBs = [] - , listHcPath = mempty - } - -listCommand :: CommandUI ListFlags -listCommand = CommandUI { - commandName = "list", - commandSynopsis = "List packages matching a search string.", - commandDescription = Just $ \_ -> wrapText $ - "List all packages, or all packages matching one of the search" - ++ " strings.\n" - ++ "\n" - ++ "Use the package database specified with --package-db. " - ++ "If not specified, use the user package database.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " list pandoc\n" - ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n", - commandUsage = usageAlternatives "list" [ "[FLAGS]" - , "[FLAGS] STRINGS"], - commandDefaultFlags = defaultListFlags, - commandOptions = const listOptions - } - -listOptions :: [OptionField ListFlags] -listOptions = - [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) - - , option [] ["installed"] - "Only print installed packages" - listInstalled (\v flags -> flags { listInstalled = v }) - trueArg - - , option [] ["simple-output"] - "Print in a easy-to-parse format" - listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) - trueArg - , option ['i'] ["ignore-case"] - "Ignore case destictions" - listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v }) - (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) - - , option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user']," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - listPackageDBs (\v flags -> flags { listPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) - - , option "w" ["with-compiler"] - "give the path to a particular compiler" - listHcPath (\v flags -> flags { listHcPath = v }) - (reqArgFlag "PATH") - ] - -listNeedsCompiler :: ListFlags -> Bool -listNeedsCompiler f = - flagElim False (const True) (listHcPath f) - || fromFlagOrDefault False (listInstalled f) - -instance Monoid ListFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ListFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Info flags --- ------------------------------------------------------------ - -data InfoFlags = InfoFlags { - infoVerbosity :: Flag Verbosity, - infoPackageDBs :: [Maybe PackageDB] - } deriving Generic - -defaultInfoFlags :: InfoFlags -defaultInfoFlags = InfoFlags { - infoVerbosity = toFlag normal, - infoPackageDBs = [] - } - -infoCommand :: CommandUI InfoFlags -infoCommand = CommandUI { - commandName = "info", - commandSynopsis = "Display detailed information about a particular package.", - commandDescription = Just $ \_ -> wrapText $ - "Use the package database specified with --package-db. " - ++ "If not specified, use the user package database.\n", - commandNotes = Nothing, - commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"], - commandDefaultFlags = defaultInfoFlags, - commandOptions = \_ -> [ - optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) - - , option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user']," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - infoPackageDBs (\v flags -> flags { infoPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) - - ] - } - -instance Monoid InfoFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InfoFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Install takes the same flags as configure along with a few extras. --- -data InstallFlags = InstallFlags { - installDocumentation :: Flag Bool, - installHaddockIndex :: Flag PathTemplate, - installDest :: Flag Cabal.CopyDest, - installDryRun :: Flag Bool, - installMaxBackjumps :: Flag Int, - installReorderGoals :: Flag ReorderGoals, - installCountConflicts :: Flag CountConflicts, - installFineGrainedConflicts :: Flag FineGrainedConflicts, - installMinimizeConflictSet :: Flag MinimizeConflictSet, - installIndependentGoals :: Flag IndependentGoals, - installShadowPkgs :: Flag ShadowPkgs, - installStrongFlags :: Flag StrongFlags, - installAllowBootLibInstalls :: Flag AllowBootLibInstalls, - installOnlyConstrained :: Flag OnlyConstrained, - installReinstall :: Flag Bool, - installAvoidReinstalls :: Flag AvoidReinstalls, - installOverrideReinstall :: Flag Bool, - installUpgradeDeps :: Flag Bool, - installOnly :: Flag Bool, - installOnlyDeps :: Flag Bool, - installIndexState :: Flag TotalIndexState, - installRootCmd :: Flag String, - installSummaryFile :: NubList PathTemplate, - installLogFile :: Flag PathTemplate, - installBuildReports :: Flag ReportLevel, - installReportPlanningFailure :: Flag Bool, - -- Note: symlink-bindir is no longer used by v2-install and can be removed - -- when removing v1 commands - installSymlinkBinDir :: Flag FilePath, - installPerComponent :: Flag Bool, - installOneShot :: Flag Bool, - installNumJobs :: Flag (Maybe Int), - installKeepGoing :: Flag Bool, - installRunTests :: Flag Bool, - installOfflineMode :: Flag Bool - } - deriving (Eq, Show, Generic) - -instance Binary InstallFlags - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installDocumentation = Flag False, - installHaddockIndex = Flag docIndexFile, - installDest = Flag Cabal.NoCopyDest, - installDryRun = Flag False, - installMaxBackjumps = Flag defaultMaxBackjumps, - installReorderGoals = Flag (ReorderGoals False), - installCountConflicts = Flag (CountConflicts True), - installFineGrainedConflicts = Flag (FineGrainedConflicts True), - installMinimizeConflictSet = Flag (MinimizeConflictSet False), - installIndependentGoals= Flag (IndependentGoals False), - installShadowPkgs = Flag (ShadowPkgs False), - installStrongFlags = Flag (StrongFlags False), - installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - installOnlyConstrained = Flag OnlyConstrainedNone, - installReinstall = Flag False, - installAvoidReinstalls = Flag (AvoidReinstalls False), - installOverrideReinstall = Flag False, - installUpgradeDeps = Flag False, - installOnly = Flag False, - installOnlyDeps = Flag False, - installIndexState = mempty, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = Flag NoReports, - installReportPlanningFailure = Flag False, - installSymlinkBinDir = mempty, - installPerComponent = Flag True, - installOneShot = Flag False, - installNumJobs = mempty, - installKeepGoing = Flag False, - installRunTests = mempty, - installOfflineMode = Flag False - } - where - docIndexFile = toPathTemplate ("$datadir" "doc" - "$arch-$os-$compiler" "index.html") - -defaultMaxBackjumps :: Int -defaultMaxBackjumps = 4000 - -defaultSolver :: PreSolver -defaultSolver = AlwaysModular - -allSolvers :: String -allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver])) - -installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, TestFlags, BenchmarkFlags - ) -installCommand = CommandUI { - commandName = "install", - commandSynopsis = "Install packages.", - commandUsage = usageAlternatives "v1-install" [ "[FLAGS]" - , "[FLAGS] PACKAGES" - ], - commandDescription = Just $ \_ -> wrapText $ - "Installs one or more packages. By default, the installed package" - ++ " will be registered in the user's package database." - ++ "\n" - ++ "If PACKAGES are specified, downloads and installs those packages." - ++ " Otherwise, install the package in the current directory (and/or its" - ++ " dependencies) (there must be exactly one .cabal file in the current" - ++ " directory).\n" - ++ "\n" - ++ "The flags to `v1-install` are saved and" - ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for" - ++ " `v1-configure` for a list of commands being affected.\n" - ++ "\n" - ++ "Installed executables will by default" - ++ " be put into `~/.cabal/bin/`." - ++ " If you want installed executable to be available globally, make" - ++ " sure that the PATH environment variable contains that directory.\n" - ++ "\n", - commandNotes = Just $ \pname -> - ( case commandNotes - $ Cabal.configureCommand defaultProgramDb - of Just desc -> desc pname ++ "\n" - Nothing -> "" - ) - ++ "Examples:\n" - ++ " " ++ pname ++ " v1-install " - ++ " Package in the current directory\n" - ++ " " ++ pname ++ " v1-install foo " - ++ " Package from the hackage server\n" - ++ " " ++ pname ++ " v1-install foo-1.0 " - ++ " Specific version of a package\n" - ++ " " ++ pname ++ " v1-install 'foo < 2' " - ++ " Constrained package version\n" - ++ " " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" - ++ " " ++ (map (const ' ') pname) - ++ " " - ++ " Change installation destination\n", - commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), - commandOptions = \showOrParseArgs -> - liftOptions get1 set1 - -- Note: [Hidden Flags] - -- hide "constraint", "dependency", and - -- "exact-configuration" from the configure options. - (filter ((`notElem` ["constraint", "dependency" - , "exact-configuration"]) - . optionName) $ - configureOptions showOrParseArgs) - ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) - ++ liftOptions get3 set3 - -- hide "target-package-db" flag from the - -- install options. - (filter ((`notElem` ["target-package-db"]) - . optionName) $ - installOptions showOrParseArgs) - ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) - ++ liftOptions get5 set5 (testOptions showOrParseArgs) - ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) - } - where - get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) - get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) - get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) - get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) - get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) - get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) - -haddockCommand :: CommandUI HaddockFlags -haddockCommand = Cabal.haddockCommand - { commandUsage = usageAlternatives "v1-haddock" $ - [ "[FLAGS]", "COMPONENTS [FLAGS]" ] - } - -filterHaddockArgs :: [String] -> Version -> [String] -filterHaddockArgs args cabalLibVersion - | cabalLibVersion >= mkVersion [2,3,0] = args_latest - | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0 - | otherwise = args_latest - where - args_latest = args - - -- Cabal < 2.3 doesn't know about per-component haddock - args_2_3_0 = [] - -filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags -filterHaddockFlags flags cabalLibVersion - | cabalLibVersion >= mkVersion [2,3,0] = flags_latest - | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0 - | otherwise = flags_latest - where - flags_latest = flags - - flags_2_3_0 = flags_latest { - -- Cabal < 2.3 doesn't know about per-component haddock - haddockArgs = [] - } - -haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] -haddockOptions showOrParseArgs - = [ opt { optionName = "haddock-" ++ name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.haddockCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["hoogle", "html", "html-location" - ,"executables", "tests", "benchmarks", "all", "internal", "css" - ,"hyperlink-source", "quickjump", "hscolour-css" - ,"contents-location", "for-hackage"] - ] - -testOptions :: ShowOrParseArgs -> [OptionField TestFlags] -testOptions showOrParseArgs - = [ opt { optionName = prefixTest name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.testCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["log", "machine-log", "show-details", "keep-tix-files" - ,"fail-when-no-test-suites", "test-options", "test-option" - ,"test-wrapper"] - ] - where - prefixTest name | "test-" `isPrefixOf` name = name - | otherwise = "test-" ++ name - -benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags] -benchmarkOptions showOrParseArgs - = [ opt { optionName = prefixBenchmark name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["benchmark-options", "benchmark-option"] - ] - where - prefixBenchmark name | "benchmark-" `isPrefixOf` name = name - | otherwise = "benchmark-" ++ name - -fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a -fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w -fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w -fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] -fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w - -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] -installOptions showOrParseArgs = - [ option "" ["documentation"] - "building of documentation" - installDocumentation (\v flags -> flags { installDocumentation = v }) - (boolOpt [] []) - - , option [] ["doc-index-file"] - "A central index of haddock API documentation (template cannot use $pkgid)" - installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["dry-run"] - "Do not install anything, only print what would be installed." - installDryRun (\v flags -> flags { installDryRun = v }) - trueArg - - , option "" ["target-package-db"] - "package database to install into. Required when using ${pkgroot} prefix." - installDest (\v flags -> flags { installDest = v }) - (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb)) - (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> [])) - ] ++ - - optionSolverFlags showOrParseArgs - installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) - installReorderGoals (\v flags -> flags { installReorderGoals = v }) - installCountConflicts (\v flags -> flags { installCountConflicts = v }) - installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) - installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) - installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) - installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) - installStrongFlags (\v flags -> flags { installStrongFlags = v }) - installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) - installOnlyConstrained (\v flags -> flags { installOnlyConstrained = v }) ++ - - [ option [] ["reinstall"] - "Install even if it means installing the same version again." - installReinstall (\v flags -> flags { installReinstall = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["avoid-reinstalls"] - "Do not select versions that would destructively overwrite installed packages." - (fmap asBool . installAvoidReinstalls) - (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v }) - (yesNoOpt showOrParseArgs) - - , option [] ["force-reinstalls"] - "Reinstall packages even if they will most likely break other installed packages." - installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["upgrade-dependencies"] - "Pick the latest version for all dependencies, rather than trying to pick an installed version." - installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["only-dependencies"] - "Install only the dependencies necessary to build the given packages" - installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["dependencies-only"] - "A synonym for --only-dependencies" - installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["index-state"] - ("Use source package index state as it existed at a previous time. " ++ - "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") - installIndexState (\v flags -> flags { installIndexState = v }) - (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ - "unix-timestamps (e.g. '@1474732068'), " ++ - "a ISO8601 UTC timestamp " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["root-cmd"] - "(No longer supported, do not use.)" - installRootCmd (\v flags -> flags { installRootCmd = v }) - (reqArg' "COMMAND" toFlag flagToList) - - , option [] ["symlink-bindir"] - "Add symlinks to installed executables into this directory." - installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) - (reqArgFlag "DIR") - - , option [] ["build-summary"] - "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" - installSummaryFile (\v flags -> flags { installSummaryFile = v }) - (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList)) - - , option [] ["build-log"] - "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" - installLogFile (\v flags -> flags { installLogFile = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["remote-build-reporting"] - "Generate build reports to send to a remote server (none, anonymous or detailed)." - installBuildReports (\v flags -> flags { installBuildReports = v }) - (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', " - ++ "'anonymous' or 'detailed'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["report-planning-failure"] - "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." - installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v }) - trueArg - - , option "" ["per-component"] - "Per-component builds when possible" - installPerComponent (\v flags -> flags { installPerComponent = v }) - (boolOpt [] []) - - , option [] ["one-shot"] - "Do not record the packages in the world file." - installOneShot (\v flags -> flags { installOneShot = v }) - (yesNoOpt showOrParseArgs) - - , option [] ["run-tests"] - "Run package test suites during installation." - installRunTests (\v flags -> flags { installRunTests = v }) - trueArg - - , optionNumJobs - installNumJobs (\v flags -> flags { installNumJobs = v }) - - , option [] ["keep-going"] - "After a build failure, continue to build other unaffected packages." - installKeepGoing (\v flags -> flags { installKeepGoing = v }) - trueArg - - , option [] ["offline"] - "Don't download packages from the Internet." - installOfflineMode (\v flags -> flags { installOfflineMode = v }) - (yesNoOpt showOrParseArgs) - - ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" - -- avoids - ParseArgs -> - [ option [] ["only"] - "Only installs the package in the current directory." - installOnly (\v flags -> flags { installOnly = v }) - trueArg ] - _ -> [] - - -instance Monoid InstallFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InstallFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Upload flags --- ------------------------------------------------------------ - --- | Is this a candidate package or a package to be published? -data IsCandidate = IsCandidate | IsPublished - deriving Eq - -data UploadFlags = UploadFlags { - uploadCandidate :: Flag IsCandidate, - uploadDoc :: Flag Bool, - uploadUsername :: Flag Username, - uploadPassword :: Flag Password, - uploadPasswordCmd :: Flag [String], - uploadVerbosity :: Flag Verbosity - } deriving Generic - -defaultUploadFlags :: UploadFlags -defaultUploadFlags = UploadFlags { - uploadCandidate = toFlag IsCandidate, - uploadDoc = toFlag False, - uploadUsername = mempty, - uploadPassword = mempty, - uploadPasswordCmd = mempty, - uploadVerbosity = toFlag normal - } - -uploadCommand :: CommandUI UploadFlags -uploadCommand = CommandUI { - commandName = "upload", - commandSynopsis = "Uploads source packages or documentation to Hackage.", - commandDescription = Nothing, - commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.cabal/config file\n" - ++ relevantConfigValuesText ["username", "password", "password-command"], - commandUsage = \pname -> - "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", - commandDefaultFlags = defaultUploadFlags, - commandOptions = \_ -> - [optionVerbosity uploadVerbosity - (\v flags -> flags { uploadVerbosity = v }) - - ,option [] ["publish"] - "Publish the package instead of uploading it as a candidate." - uploadCandidate (\v flags -> flags { uploadCandidate = v }) - (noArg (Flag IsPublished)) - - ,option ['d'] ["documentation"] - ("Upload documentation instead of a source package. " - ++ "By default, this uploads documentation for a package candidate. " - ++ "To upload documentation for " - ++ "a published package, combine with --publish.") - uploadDoc (\v flags -> flags { uploadDoc = v }) - trueArg - - ,option ['u'] ["username"] - "Hackage username." - uploadUsername (\v flags -> flags { uploadUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - uploadPassword (\v flags -> flags { uploadPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - - ,option ['P'] ["password-command"] - "Command to get Hackage password." - uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v }) - (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe)) - ] - } - -instance Monoid UploadFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup UploadFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Init flags --- ------------------------------------------------------------ - -initCommand :: CommandUI IT.InitFlags -initCommand = CommandUI { - commandName = "init", - commandSynopsis = "Create a new .cabal package file.", - commandDescription = Just $ \_ -> wrapText $ - "Create a .cabal, Setup.hs, and optionally a LICENSE file.\n" - ++ "\n" - ++ "Calling init with no arguments creates an executable, " - ++ "guessing as many options as possible. The interactive " - ++ "mode can be invoked by the -i/--interactive flag, which " - ++ "will try to guess as much as possible and prompt you for " - ++ "the rest. You can change init to always be interactive by " - ++ "setting the interactive flag in your configuration file. " - ++ "Command-line arguments are provided for scripting purposes.\n", - commandNotes = Nothing, - commandUsage = \pname -> - "Usage: " ++ pname ++ " init [FLAGS]\n", - commandDefaultFlags = IT.defaultInitFlags, - commandOptions = initOptions - } - -initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags] -initOptions _ = - [ option ['i'] ["interactive"] - "interactive mode." - IT.interactive (\v flags -> flags { IT.interactive = v }) - (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"])) - - , option ['q'] ["quiet"] - "Do not generate log messages to stdout." - IT.quiet (\v flags -> flags { IT.quiet = v }) - trueArg - - , option [] ["no-comments"] - "Do not generate explanatory comments in the .cabal file." - IT.noComments (\v flags -> flags { IT.noComments = v }) - trueArg - - , option ['m'] ["minimal"] - "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." - IT.minimal (\v flags -> flags { IT.minimal = v }) - trueArg - - , option [] ["overwrite"] - "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." - IT.overwrite (\v flags -> flags { IT.overwrite = v }) - trueArg - - , option [] ["package-dir", "packagedir"] - "Root directory of the package (default = current directory)." - IT.packageDir (\v flags -> flags { IT.packageDir = v }) - (reqArgFlag "DIRECTORY") - - , option ['p'] ["package-name"] - "Name of the Cabal package to create." - IT.packageName (\v flags -> flags { IT.packageName = v }) - (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["version"] - "Initial version of the package." - IT.version (\v flags -> flags { IT.version = v }) - (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["cabal-version"] - "Version of the Cabal specification." - IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) - (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++) - (fmap (toFlag . getSpecVersion) parsec)) - (flagToList . fmap (prettyShow . SpecVersion))) - - , option ['l'] ["license"] - "Project license." - IT.license (\v flags -> flags { IT.license = v }) - (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option ['a'] ["author"] - "Name of the project's author." - IT.author (\v flags -> flags { IT.author = v }) - (reqArgFlag "NAME") - - , option ['e'] ["email"] - "Email address of the maintainer." - IT.email (\v flags -> flags { IT.email = v }) - (reqArgFlag "EMAIL") - - , option ['u'] ["homepage"] - "Project homepage and/or repository." - IT.homepage (\v flags -> flags { IT.homepage = v }) - (reqArgFlag "URL") - - , option ['s'] ["synopsis"] - "Short project synopsis." - IT.synopsis (\v flags -> flags { IT.synopsis = v }) - (reqArgFlag "TEXT") - - , option ['c'] ["category"] - "Project category." - IT.category (\v flags -> flags { IT.category = v }) - (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) - (flagToList . fmap (either id show))) - - , option ['x'] ["extra-source-file"] - "Extra source file to be distributed with tarball." - IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) - (reqArg' "FILE" (Just . (:[])) - (fromMaybe [])) - - , option [] ["lib", "is-library"] - "Build a library." - IT.packageType (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Library)) - - , option [] ["exe", "is-executable"] - "Build an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Executable)) - - , option [] ["libandexe", "is-libandexe"] - "Build a library and an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.LibraryAndExecutable)) - - , option [] ["tests"] - "Generate a test suite for the library." - IT.initializeTestSuite - (\v flags -> flags { IT.initializeTestSuite = v }) - trueArg - - , option [] ["test-dir"] - "Directory containing tests." - IT.testDirs (\v flags -> flags { IT.testDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) - - , option [] ["simple"] - "Create a simple project with sensible defaults." - IT.simpleProject - (\v flags -> flags { IT.simpleProject = v }) - trueArg - - , option [] ["main-is"] - "Specify the main module." - IT.mainIs - (\v flags -> flags { IT.mainIs = v }) - (reqArgFlag "FILE") - - , option [] ["language"] - "Specify the default language." - IT.language - (\v flags -> flags { IT.language = v }) - (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option ['o'] ["expose-module"] - "Export a module from the package." - IT.exposedModules - (\v flags -> flags { IT.exposedModules = v }) - (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) - - , option [] ["extension"] - "Use a LANGUAGE extension (in the other-extensions field)." - IT.otherExts - (\v flags -> flags { IT.otherExts = v }) - (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) - - , option ['d'] ["dependency"] - "Package dependency." - IT.dependencies (\v flags -> flags { IT.dependencies = v }) - (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++) - ((Just . (:[])) `fmap` parsec)) - (maybe [] (fmap prettyShow))) - - , option [] ["application-dir"] - "Directory containing package application executable." - IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v}) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) - - , option [] ["source-dir", "sourcedir"] - "Directory containing package library source." - IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) - - , option [] ["build-tool"] - "Required external build tool." - IT.buildTools (\v flags -> flags { IT.buildTools = v }) - (reqArg' "TOOL" (Just . (:[])) - (fromMaybe [])) - - -- NB: this is a bit of a transitional hack and will likely be - -- removed again if `cabal init` is migrated to the v2-* command - -- framework - , option "w" ["with-compiler"] - "give the path to a particular compiler" - IT.initHcPath (\v flags -> flags { IT.initHcPath = v }) - (reqArgFlag "PATH") - - , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) - ] - --- ------------------------------------------------------------ --- * SDist flags --- ------------------------------------------------------------ - -doctestCommand :: CommandUI DoctestFlags -doctestCommand = Cabal.doctestCommand - { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-doctest [FLAGS]\n" } - -copyCommand :: CommandUI CopyFlags -copyCommand = Cabal.copyCommand - { commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-copy " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " v1-copy foo " - ++ " A component (i.e. lib, exe, test suite)" - , commandUsage = usageAlternatives "v1-copy" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - } - -registerCommand :: CommandUI RegisterFlags -registerCommand = Cabal.registerCommand - { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" } - --- ------------------------------------------------------------ --- * ActAsSetup flags --- ------------------------------------------------------------ - -data ActAsSetupFlags = ActAsSetupFlags { - actAsSetupBuildType :: Flag BuildType -} deriving Generic - -defaultActAsSetupFlags :: ActAsSetupFlags -defaultActAsSetupFlags = ActAsSetupFlags { - actAsSetupBuildType = toFlag Simple -} - -actAsSetupCommand :: CommandUI ActAsSetupFlags -actAsSetupCommand = CommandUI { - commandName = "act-as-setup", - commandSynopsis = "Run as-if this was a Setup.hs", - commandDescription = Nothing, - commandNotes = Nothing, - commandUsage = \pname -> - "Usage: " ++ pname ++ " act-as-setup\n", - commandDefaultFlags = defaultActAsSetupFlags, - commandOptions = \_ -> - [option "" ["build-type"] - "Use the given build type." - actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v }) - (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++) - (fmap toFlag parsec)) - (map prettyShow . flagToList)) - ] -} - -instance Monoid ActAsSetupFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ActAsSetupFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Exec Flags --- ------------------------------------------------------------ - -data ExecFlags = ExecFlags { - execVerbosity :: Flag Verbosity, - execDistPref :: Flag FilePath -} deriving Generic - -defaultExecFlags :: ExecFlags -defaultExecFlags = ExecFlags { - execVerbosity = toFlag normal, - execDistPref = NoFlag - } - -execCommand :: CommandUI ExecFlags -execCommand = CommandUI { - commandName = "exec", - commandSynopsis = "Give a command access to the sandbox package repository.", - commandDescription = Just $ \pname -> wrapText $ - -- TODO: this is too GHC-focused for my liking.. - "A directly invoked GHC will not automatically be aware of any" - ++ " sandboxes: the GHC_PACKAGE_PATH environment variable controls what" - ++ " GHC uses. `" ++ pname ++ " v1-exec` can be used to modify this variable:" - ++ " COMMAND will be executed in a modified environment and thereby uses" - ++ " the sandbox package database.\n" - ++ "\n" - ++ "If there is no sandbox, behaves as identity (executing COMMAND).\n" - ++ "\n" - ++ "Note that other " ++ pname ++ " commands change the environment" - ++ " variable appropriately already, so there is no need to wrap those" - ++ " in `" ++ pname ++ " v1-exec`. But with `" ++ pname ++ " v1-exec`, the user" - ++ " has more control and can, for example, execute custom scripts which" - ++ " indirectly execute GHC.\n" - ++ "\n" - ++ "Note that `" ++ pname ++ " v1-repl` is different from `" ++ pname - ++ " v1-exec -- ghci` as the latter will not forward any additional flags" - ++ " being defined in the local package to ghci.\n" - ++ "\n" - ++ "See `" ++ pname ++ " sandbox`.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-exec -- ghci -Wall\n" - ++ " Start a repl session with sandbox packages and all warnings;\n" - ++ " " ++ pname ++ " v1-exec gitit -- -f gitit.cnf\n" - ++ " Give gitit access to the sandbox packages, and pass it a flag;\n" - ++ " " ++ pname ++ " v1-exec runghc Foo.hs\n" - ++ " Execute runghc on Foo.hs with runghc configured to use the\n" - ++ " sandbox package database (if a sandbox is being used).\n", - commandUsage = \pname -> - "Usage: " ++ pname ++ " v1-exec [FLAGS] [--] COMMAND [--] [ARGS]\n", - - commandDefaultFlags = defaultExecFlags, - commandOptions = \showOrParseArgs -> - [ optionVerbosity execVerbosity - (\v flags -> flags { execVerbosity = v }) - , Cabal.optionDistPref - execDistPref (\d flags -> flags { execDistPref = d }) - showOrParseArgs - ] - } - -instance Monoid ExecFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ExecFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * UserConfig flags --- ------------------------------------------------------------ - -data UserConfigFlags = UserConfigFlags { - userConfigVerbosity :: Flag Verbosity, - userConfigForce :: Flag Bool, - userConfigAppendLines :: Flag [String] - } deriving Generic - -instance Monoid UserConfigFlags where - mempty = UserConfigFlags { - userConfigVerbosity = toFlag normal, - userConfigForce = toFlag False, - userConfigAppendLines = toFlag [] - } - mappend = (<>) - -instance Semigroup UserConfigFlags where - (<>) = gmappend - -userConfigCommand :: CommandUI UserConfigFlags -userConfigCommand = CommandUI { - commandName = "user-config", - commandSynopsis = "Display and update the user's global cabal configuration.", - commandDescription = Just $ \_ -> wrapText $ - "When upgrading cabal, the set of configuration keys and their default" - ++ " values may change. This command provides means to merge the existing" - ++ " config in ~/.cabal/config" - ++ " (i.e. all bindings that are actually defined and not commented out)" - ++ " and the default config of the new version.\n" - ++ "\n" - ++ "init: Creates a new config file at either ~/.cabal/config or as" - ++ " specified by --config-file, if given. An existing file won't be " - ++ " overwritten unless -f or --force is given.\n" - ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and" - ++ " the default configuration that would be created by cabal if the" - ++ " config file did not exist.\n" - ++ "update: Applies the pseudo-diff to the configuration that would be" - ++ " created by default, and write the result back to ~/.cabal/config.", - - commandNotes = Nothing, - commandUsage = usageAlternatives "user-config" ["init", "diff", "update"], - commandDefaultFlags = mempty, - commandOptions = \ _ -> [ - optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v }) - , option ['f'] ["force"] - "Overwrite the config file if it already exists." - userConfigForce (\v flags -> flags { userConfigForce = v }) - trueArg - , option ['a'] ["augment"] - "Additional setting to augment the config file (replacing a previous setting if it existed)." - userConfigAppendLines (\v flags -> flags - {userConfigAppendLines = - Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)}) - (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe)) - ] - } - - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -reqArgFlag :: ArgPlaceHolder -> - MkOptDescr (b -> Flag String) (Flag String -> b -> b) b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -liftOptions :: (b -> a) -> (a -> b -> b) - -> [OptionField a] -> [OptionField b] -liftOptions get set = map (liftOption get set) - -yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b -yesNoOpt ShowArgs sf lf = trueArg sf lf -yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf - -optionSolver :: (flags -> Flag PreSolver) - -> (Flag PreSolver -> flags -> flags) - -> OptionField flags -optionSolver get set = - option [] ["solver"] - ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") - get set - (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - -optionSolverFlags :: ShowOrParseArgs - -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) - -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) - -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) - -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) - -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) - -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) - -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) - -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) - -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) - -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) - -> [OptionField flags] -optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc - getfgc setfgc getmc setmc getig setig getsip setsip - getstrfl setstrfl getib setib getoc setoc = - [ option [] ["max-backjumps"] - ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") - getmbj setmbj - (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral)) - (map show . flagToList)) - , option [] ["reorder-goals"] - "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." - (fmap asBool . getrg) - (setrg . fmap ReorderGoals) - (yesNoOpt showOrParseArgs) - , option [] ["count-conflicts"] - "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." - (fmap asBool . getcc) - (setcc . fmap CountConflicts) - (yesNoOpt showOrParseArgs) - , option [] ["fine-grained-conflicts"] - "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." - (fmap asBool . getfgc) - (setfgc . fmap FineGrainedConflicts) - (yesNoOpt showOrParseArgs) - , option [] ["minimize-conflict-set"] - ("When there is no solution, try to improve the error message by finding " - ++ "a minimal conflict set (default: false). May increase run time " - ++ "significantly.") - (fmap asBool . getmc) - (setmc . fmap MinimizeConflictSet) - (yesNoOpt showOrParseArgs) - , option [] ["independent-goals"] - "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." - (fmap asBool . getig) - (setig . fmap IndependentGoals) - (yesNoOpt showOrParseArgs) - , option [] ["shadow-installed-packages"] - "If multiple package instances of the same version are installed, treat all but one as shadowed." - (fmap asBool . getsip) - (setsip . fmap ShadowPkgs) - (yesNoOpt showOrParseArgs) - , option [] ["strong-flags"] - "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." - (fmap asBool . getstrfl) - (setstrfl . fmap StrongFlags) - (yesNoOpt showOrParseArgs) - , option [] ["allow-boot-library-installs"] - "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." - (fmap asBool . getib) - (setib . fmap AllowBootLibInstalls) - (yesNoOpt showOrParseArgs) - , option [] ["reject-unconstrained-dependencies"] - "Require these packages to have constraints on them if they are to be selected (default: none)." - getoc - setoc - (reqArg "none|all" - (parsecToReadE - (const "reject-unconstrained-dependencies must be 'none' or 'all'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - ] - -usagePackages :: String -> String -> String -usagePackages name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" - -usageFlags :: String -> String -> String -usageFlags name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" - ---TODO: do we want to allow per-package flags? -parsePackageArgs :: [String] -> Either String [PackageVersionConstraint] -parsePackageArgs = traverse p where - p arg = case eitherParsec arg of - Right pvc -> Right pvc - Left err -> Left $ - show arg ++ " is not valid syntax for a package name or" - ++ " package dependency. " ++ err - -showRemoteRepo :: RemoteRepo -> String -showRemoteRepo = prettyShow - -readRemoteRepo :: String -> Maybe RemoteRepo -readRemoteRepo = simpleParsec - -showLocalRepo :: LocalRepo -> String -showLocalRepo = prettyShow - -readLocalRepo :: String -> Maybe LocalRepo -readLocalRepo = simpleParsec - --- ------------------------------------------------------------ --- * Helpers for Documentation --- ------------------------------------------------------------ - -relevantConfigValuesText :: [String] -> String -relevantConfigValuesText vs = - "Relevant global configuration keys:\n" - ++ concat [" " ++ v ++ "\n" |v <- vs] diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs deleted file mode 100644 --- a/Distribution/Client/SetupWrapper.hs +++ /dev/null @@ -1,919 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.SetupWrapper --- Copyright : (c) The University of Glasgow 2006, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Stability : alpha --- Portability : portable --- --- An interface to building and installing Cabal packages. --- If the @Built-Type@ field is specified as something other than --- 'Custom', and the current version of Cabal is acceptable, this performs --- setup actions directly. Otherwise it builds the setup script and --- runs it with the given arguments. - -module Distribution.Client.SetupWrapper ( - getSetup, runSetup, runSetupCommand, setupWrapper, - SetupScriptOptions(..), - defaultSetupScriptOptions, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) -import qualified Distribution.Make as Make -import qualified Distribution.Simple as Simple -import Distribution.Version - ( Version, mkVersion, versionNumbers, VersionRange, anyVersion - , intersectVersionRanges, orLaterVersion - , withinRange ) -import qualified Distribution.Backpack as Backpack -import Distribution.Package - ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId - , PackageId, mkPackageName - , PackageIdentifier(..), packageVersion, packageName ) -import Distribution.PackageDescription - ( GenericPackageDescription(packageDescription) - , PackageDescription(..), specVersion, buildType - , BuildType(..) ) -import Distribution.Types.ModuleRenaming (defaultRenaming) -import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription ) -import Distribution.Simple.Configure - ( configCompilerEx ) -import Distribution.Compiler - ( buildCompilerId, CompilerFlavor(GHC, GHCJS) ) -import Distribution.Simple.Compiler - ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack ) -import Distribution.Simple.PreProcess - ( runSimplePreProcessor, ppUnlit ) -import Distribution.Simple.Build.Macros - ( generatePackageVersionMacros ) -import Distribution.Simple.Program - ( ProgramDb, emptyProgramDb - , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram - , ghcjsProgram ) -import Distribution.Simple.Program.Find - ( programSearchPathAsPATHVar - , ProgramSearchPathEntry(ProgramSearchPathDir) ) -import Distribution.Simple.Program.Run - ( getEffectiveEnvironment ) -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.BuildPaths - ( defaultDistPref, exeExtension ) - -import Distribution.Simple.Command - ( CommandUI(..), commandShowOptions ) -import Distribution.Simple.Program.GHC - ( GhcMode(..), GhcOptions(..), renderGhcOptions ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Client.Types -import Distribution.Client.Config - ( getCabalDir ) -import Distribution.Client.IndexUtils - ( getInstalledPackages ) -import Distribution.Client.JobControl - ( Lock, criticalSection ) -import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Utils.Generic - ( safeHead ) -import Distribution.Simple.Utils - ( die', debug, info, infoNoWrap - , cabalVersion, tryFindPackageDesc - , createDirectoryIfMissingVerbose, installExecutableFile - , copyFileVerbose, rewriteFileEx, rewriteFileLBS ) -import Distribution.Client.Utils - ( inDir, tryCanonicalizePath, withExtraPathEnv - , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides -#ifdef mingw32_HOST_OS - , canonicalizePathNoThrow -#endif - ) - -import Distribution.ReadE -import Distribution.System ( Platform(..), buildPlatform ) -import Distribution.Utils.NubList - ( toNubListR ) -import Distribution.Verbosity -import Distribution.Compat.Stack - -import System.Directory ( doesFileExist ) -import System.FilePath ( (), (<.>) ) -import System.IO ( Handle, hPutStr ) -import Distribution.Compat.Process (createProcess) -import System.Process ( StdStream(..), proc, waitForProcess - , ProcessHandle ) -import qualified System.Process as Process -import Data.List ( foldl1' ) -import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) - -import qualified Data.ByteString.Lazy as BS - -#ifdef mingw32_HOST_OS -import Distribution.Simple.Utils - ( withTempDirectory ) - -import Control.Exception ( bracket ) -import System.FilePath ( equalFilePath, takeDirectory ) -import System.Directory ( doesDirectoryExist ) -import qualified System.Win32 as Win32 -#endif - --- | @Setup@ encapsulates the outcome of configuring a setup method to build a --- particular package. -data Setup = Setup { setupMethod :: SetupMethod - , setupScriptOptions :: SetupScriptOptions - , setupVersion :: Version - , setupBuildType :: BuildType - , setupPackage :: PackageDescription - } - --- | @SetupMethod@ represents one of the methods used to run Cabal commands. -data SetupMethod = InternalMethod - -- ^ run Cabal commands through \"cabal\" in the - -- current process - | SelfExecMethod - -- ^ run Cabal commands through \"cabal\" as a - -- child process - | ExternalMethod FilePath - -- ^ run Cabal commands through a custom \"Setup\" executable - --- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two --- parts: one that has no policy and just does as it's told with all the --- explicit options, and an optional initial part that applies certain --- policies (like if we should add the Cabal lib as a dep, and if so which --- version). This could be structured as an action that returns a fully --- elaborated 'SetupScriptOptions' containing no remaining policy choices. --- --- See also the discussion at https://github.com/haskell/cabal/pull/3094 - --- | @SetupScriptOptions@ are options used to configure and run 'Setup', as --- opposed to options given to the Cabal command at runtime. -data SetupScriptOptions = SetupScriptOptions { - -- | The version of the Cabal library to use (if 'useDependenciesExclusive' - -- is not set). A suitable version of the Cabal library must be installed - -- (or for some build-types be the one cabal-install was built with). - -- - -- The version found also determines the version of the Cabal specification - -- that we us for talking to the Setup.hs, unless overridden by - -- 'useCabalSpecVersion'. - -- - useCabalVersion :: VersionRange, - - -- | This is the version of the Cabal specification that we believe that - -- this package uses. This affects the semantics and in particular the - -- Setup command line interface. - -- - -- This is similar to 'useCabalVersion' but instead of probing the system - -- for a version of the /Cabal library/ you just say exactly which version - -- of the /spec/ we will use. Using this also avoid adding the Cabal - -- library as an additional dependency, so add it to 'useDependencies' - -- if needed. - -- - useCabalSpecVersion :: Maybe Version, - useCompiler :: Maybe Compiler, - usePlatform :: Maybe Platform, - usePackageDB :: PackageDBStack, - usePackageIndex :: Maybe InstalledPackageIndex, - useProgramDb :: ProgramDb, - useDistPref :: FilePath, - useLoggingHandle :: Maybe Handle, - useWorkingDir :: Maybe FilePath, - -- | Extra things to add to PATH when invoking the setup script. - useExtraPathEnv :: [FilePath], - -- | Extra environment variables paired with overrides, where - -- - -- * @'Just' v@ means \"set the environment variable's value to @v@\". - -- * 'Nothing' means \"unset the environment variable\". - useExtraEnvOverrides :: [(String, Maybe FilePath)], - forceExternalSetupMethod :: Bool, - - -- | List of dependencies to use when building Setup.hs. - useDependencies :: [(ComponentId, PackageId)], - - -- | Is the list of setup dependencies exclusive? - -- - -- When this is @False@, if we compile the Setup.hs script we do so with the - -- list in 'useDependencies' but all other packages in the environment are - -- also visible. A suitable version of @Cabal@ library (see - -- 'useCabalVersion') is also added to the list of dependencies, unless - -- 'useDependencies' already contains a Cabal dependency. - -- - -- When @True@, only the 'useDependencies' packages are used, with other - -- packages in the environment hidden. - -- - -- This feature is here to support the setup stanza in .cabal files that - -- specifies explicit (and exclusive) dependencies, as well as the old - -- style with no dependencies. - useDependenciesExclusive :: Bool, - - -- | Should we build the Setup.hs with CPP version macros available? - -- We turn this on when we have a setup stanza in .cabal that declares - -- explicit setup dependencies. - -- - useVersionMacros :: Bool, - - -- Used only by 'cabal clean' on Windows. - -- - -- Note: win32 clean hack - ------------------------- - -- On Windows, running './dist/setup/setup clean' doesn't work because the - -- setup script will try to delete itself (which causes it to fail horribly, - -- unlike on Linux). So we have to move the setup exe out of the way first - -- and then delete it manually. This applies only to the external setup - -- method. - useWin32CleanHack :: Bool, - - -- Used only when calling setupWrapper from parallel code to serialise - -- access to the setup cache; should be Nothing otherwise. - -- - -- Note: setup exe cache - ------------------------ - -- When we are installing in parallel, we always use the external setup - -- method. Since compiling the setup script each time adds noticeable - -- overhead, we use a shared setup script cache - -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal - -- version) combination the cache holds a compiled setup script - -- executable. This only affects the Simple build type; for the Custom, - -- Configure and Make build types we always compile the setup script anew. - setupCacheLock :: Maybe Lock, - - -- | Is the task we are going to run an interactive foreground task, - -- or an non-interactive background task? Based on this flag we - -- decide whether or not to delegate ctrl+c to the spawned task - isInteractive :: Bool - } - -defaultSetupScriptOptions :: SetupScriptOptions -defaultSetupScriptOptions = SetupScriptOptions { - useCabalVersion = anyVersion, - useCabalSpecVersion = Nothing, - useCompiler = Nothing, - usePlatform = Nothing, - usePackageDB = [GlobalPackageDB, UserPackageDB], - usePackageIndex = Nothing, - useDependencies = [], - useDependenciesExclusive = False, - useVersionMacros = False, - useProgramDb = emptyProgramDb, - useDistPref = defaultDistPref, - useLoggingHandle = Nothing, - useWorkingDir = Nothing, - useExtraPathEnv = [], - useExtraEnvOverrides = [], - useWin32CleanHack = False, - forceExternalSetupMethod = False, - setupCacheLock = Nothing, - isInteractive = False - } - -workingDir :: SetupScriptOptions -> FilePath -workingDir options = - case fromMaybe "" (useWorkingDir options) of - [] -> "." - dir -> dir - --- | A @SetupRunner@ implements a 'SetupMethod'. -type SetupRunner = Verbosity - -> SetupScriptOptions - -> BuildType - -> [String] - -> IO () - --- | Prepare to build a package by configuring a 'SetupMethod'. The returned --- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed --- during the configuration process; the final values are given by --- 'setupScriptOptions'. -getSetup :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> IO Setup -getSetup verbosity options mpkg = do - pkg <- maybe getPkg return mpkg - let options' = options { - useCabalVersion = intersectVersionRanges - (useCabalVersion options) - (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)))) - } - buildType' = buildType pkg - (version, method, options'') <- - getSetupMethod verbosity options' pkg buildType' - return Setup { setupMethod = method - , setupScriptOptions = options'' - , setupVersion = version - , setupBuildType = buildType' - , setupPackage = pkg - } - where - getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options)) - >>= readGenericPackageDescription verbosity - >>= return . packageDescription - --- | Decide if we're going to be able to do a direct internal call to the --- entry point in the Cabal library or if we're going to have to compile --- and execute an external Setup.hs script. --- -getSetupMethod - :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType - -> IO (Version, SetupMethod, SetupScriptOptions) -getSetupMethod verbosity options pkg buildType' - | buildType' == Custom - || maybe False (cabalVersion /=) (useCabalSpecVersion options) - || not (cabalVersion `withinRange` useCabalVersion options) = - getExternalSetupMethod verbosity options pkg buildType' - | isJust (useLoggingHandle options) - -- Forcing is done to use an external process e.g. due to parallel - -- build concerns. - || forceExternalSetupMethod options = - return (cabalVersion, SelfExecMethod, options) - | otherwise = return (cabalVersion, InternalMethod, options) - -runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner) -runSetupMethod InternalMethod = internalSetupMethod -runSetupMethod (ExternalMethod path) = externalSetupMethod path -runSetupMethod SelfExecMethod = selfExecSetupMethod - --- | Run a configured 'Setup' with specific arguments. -runSetup :: Verbosity -> Setup - -> [String] -- ^ command-line arguments - -> IO () -runSetup verbosity setup args0 = do - let method = setupMethod setup - options = setupScriptOptions setup - bt = setupBuildType setup - args = verbosityHack (setupVersion setup) args0 - when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $ - infoNoWrap verbose $ - "Applied verbosity hack:\n" ++ - " Before: " ++ show args0 ++ "\n" ++ - " After: " ++ show args ++ "\n" - runSetupMethod method verbosity options bt args - --- | This is a horrible hack to make sure passing fancy verbosity --- flags (e.g., @-v'info +callstack'@) doesn't break horribly on --- old Setup. We can't do it in 'filterConfigureFlags' because --- verbosity applies to ALL commands. -verbosityHack :: Version -> [String] -> [String] -verbosityHack ver args0 - | ver >= mkVersion [2,1] = args0 - | otherwise = go args0 - where - go (('-':'v':rest) : args) - | Just rest' <- munch rest = ("-v" ++ rest') : go args - go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args) - | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args - go ("--verbose" : rest : args) - | Just rest' <- munch rest = "--verbose" : rest' : go args - go rest@("--" : _) = rest - go (arg:args) = arg : go args - go [] = [] - - munch rest = - case runReadE flagToVerbosity rest of - Right v - | ver < mkVersion [2,0], verboseHasFlags v - -- We could preserve the prefix, but since we're assuming - -- it's Cabal's verbosity flag, we can assume that - -- any format is OK - -> Just (showForCabal (verboseNoFlags v)) - | ver < mkVersion [2,1], isVerboseTimestamp v - -- +timestamp wasn't yet available in Cabal-2.0.0 - -> Just (showForCabal (verboseNoTimestamp v)) - _ -> Nothing - --- | Run a command through a configured 'Setup'. -runSetupCommand :: Verbosity -> Setup - -> CommandUI flags -- ^ command definition - -> flags -- ^ command flags - -> [String] -- ^ extra command-line arguments - -> IO () -runSetupCommand verbosity setup cmd flags extraArgs = do - let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs - runSetup verbosity setup args - --- | Configure a 'Setup' and run a command in one step. The command flags --- may depend on the Cabal library version in use. -setupWrapper :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> CommandUI flags - -> (Version -> flags) - -- ^ produce command flags given the Cabal library version - -> (Version -> [String]) - -> IO () -setupWrapper verbosity options mpkg cmd flags extraArgs = do - setup <- getSetup verbosity options mpkg - runSetupCommand verbosity setup - cmd (flags $ setupVersion setup) - (extraArgs $ setupVersion setup) - --- ------------------------------------------------------------ --- * Internal SetupMethod --- ------------------------------------------------------------ - -internalSetupMethod :: SetupRunner -internalSetupMethod verbosity options bt args = do - info verbosity $ "Using internal setup method with build-type " ++ show bt - ++ " and args:\n " ++ show args - inDir (useWorkingDir options) $ do - withEnv "HASKELL_DIST_DIR" (useDistPref options) $ - withExtraPathEnv (useExtraPathEnv options) $ - withEnvOverrides (useExtraEnvOverrides options) $ - buildTypeAction bt args - -buildTypeAction :: BuildType -> ([String] -> IO ()) -buildTypeAction Simple = Simple.defaultMainArgs -buildTypeAction Configure = Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks -buildTypeAction Make = Make.defaultMainArgs -buildTypeAction Custom = error "buildTypeAction Custom" - - --- | @runProcess'@ is a version of @runProcess@ where we have --- the additional option to decide whether or not we should --- delegate CTRL+C to the spawned process. -runProcess' :: FilePath -- ^ Filename of the executable - -> [String] -- ^ Arguments to pass to executable - -> Maybe FilePath -- ^ Optional path to working directory - -> Maybe [(String, String)] -- ^ Optional environment - -> Maybe Handle -- ^ Handle for @stdin@ - -> Maybe Handle -- ^ Handle for @stdout@ - -> Maybe Handle -- ^ Handle for @stderr@ - -> Bool -- ^ Delegate Ctrl+C ? - -> IO ProcessHandle -runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do - (_,_,_,ph) <- - createProcess - (proc cmd args){ Process.cwd = mb_cwd - , Process.env = mb_env - , Process.std_in = mbToStd mb_stdin - , Process.std_out = mbToStd mb_stdout - , Process.std_err = mbToStd mb_stderr - , Process.delegate_ctlc = _delegate - } - return ph - where - mbToStd :: Maybe Handle -> StdStream - mbToStd Nothing = Inherit - mbToStd (Just hdl) = UseHandle hdl - --- ------------------------------------------------------------ --- * Self-Exec SetupMethod --- ------------------------------------------------------------ - -selfExecSetupMethod :: SetupRunner -selfExecSetupMethod verbosity options bt args0 = do - let args = ["act-as-setup", - "--build-type=" ++ prettyShow bt, - "--"] ++ args0 - info verbosity $ "Using self-exec internal setup method with build-type " - ++ show bt ++ " and args:\n " ++ show args - path <- getExecutablePath - info verbosity $ unwords (path : args) - case useLoggingHandle options of - Nothing -> return () - Just logHandle -> info verbosity $ "Redirecting build log to " - ++ show logHandle - - searchpath <- programSearchPathAsPATHVar - (map ProgramSearchPathDir (useExtraPathEnv options) ++ - getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment $ - [ ("PATH", Just searchpath) - , ("HASKELL_DIST_DIR", Just (useDistPref options)) - ] ++ useExtraEnvOverrides options - process <- runProcess' path args - (useWorkingDir options) env Nothing - (useLoggingHandle options) (useLoggingHandle options) - (isInteractive options) - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode - --- ------------------------------------------------------------ --- * External SetupMethod --- ------------------------------------------------------------ - -externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) -externalSetupMethod path verbosity options _ args = do - info verbosity $ unwords (path : args) - case useLoggingHandle options of - Nothing -> return () - Just logHandle -> info verbosity $ "Redirecting build log to " - ++ show logHandle - - -- See 'Note: win32 clean hack' above. -#ifdef mingw32_HOST_OS - if useWin32CleanHack options then doWin32CleanHack path else doInvoke path -#else - doInvoke path -#endif - - where - doInvoke path' = do - searchpath <- programSearchPathAsPATHVar - (map ProgramSearchPathDir (useExtraPathEnv options) ++ - getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment $ - [ ("PATH", Just searchpath) - , ("HASKELL_DIST_DIR", Just (useDistPref options)) - ] ++ useExtraEnvOverrides options - - debug verbosity $ "Setup arguments: "++unwords args - process <- runProcess' path' args - (useWorkingDir options) env Nothing - (useLoggingHandle options) (useLoggingHandle options) - (isInteractive options) - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode - -#ifdef mingw32_HOST_OS - doWin32CleanHack path' = do - info verbosity $ "Using the Win32 clean hack." - -- Recursively removes the temp dir on exit. - withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir -> - bracket (moveOutOfTheWay tmpDir path') - (maybeRestore path') - doInvoke - - moveOutOfTheWay tmpDir path' = do - let newPath = tmpDir "setup" <.> exeExtension buildPlatform - Win32.moveFile path' newPath - return newPath - - maybeRestore oldPath path' = do - let oldPathDir = takeDirectory oldPath - oldPathDirExists <- doesDirectoryExist oldPathDir - -- 'setup clean' didn't complete, 'dist/setup' still exists. - when oldPathDirExists $ - Win32.moveFile path' oldPath -#endif - -getExternalSetupMethod - :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType - -> IO (Version, SetupMethod, SetupScriptOptions) -getExternalSetupMethod verbosity options pkg bt = do - debug verbosity $ "Using external setup method with build-type " ++ show bt - debug verbosity $ "Using explicit dependencies: " - ++ show (useDependenciesExclusive options) - createDirectoryIfMissingVerbose verbosity True setupDir - (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse - debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion - path <- if useCachedSetupExecutable - then getCachedSetupExecutable options' - cabalLibVersion mCabalLibInstalledPkgId - else compileSetupExecutable options' - cabalLibVersion mCabalLibInstalledPkgId False - - -- Since useWorkingDir can change the relative path, the path argument must - -- be turned into an absolute path. On some systems, runProcess' will take - -- path as relative to the new working directory instead of the current - -- working directory. - path' <- tryCanonicalizePath path - - -- See 'Note: win32 clean hack' above. -#ifdef mingw32_HOST_OS - -- setupProgFile may not exist if we're using a cached program - setupProgFile' <- canonicalizePathNoThrow setupProgFile - let win32CleanHackNeeded = (useWin32CleanHack options) - -- Skip when a cached setup script is used. - && setupProgFile' `equalFilePath` path' -#else - let win32CleanHackNeeded = False -#endif - let options'' = options' { useWin32CleanHack = win32CleanHackNeeded } - - return (cabalLibVersion, ExternalMethod path', options'') - - where - setupDir = workingDir options useDistPref options "setup" - setupVersionFile = setupDir "setup" <.> "version" - setupHs = setupDir "setup" <.> "hs" - setupProgFile = setupDir "setup" <.> exeExtension buildPlatform - platform = fromMaybe buildPlatform (usePlatform options) - - useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make) - - maybeGetInstalledPackages :: SetupScriptOptions -> Compiler - -> ProgramDb -> IO InstalledPackageIndex - maybeGetInstalledPackages options' comp progdb = - case usePackageIndex options' of - Just index -> return index - Nothing -> getInstalledPackages verbosity - comp (usePackageDB options') progdb - - -- Choose the version of Cabal to use if the setup script has a dependency on - -- Cabal, and possibly update the setup script options. The version also - -- determines how to filter the flags to Setup. - -- - -- We first check whether the dependency solver has specified a Cabal version. - -- If it has, we use the solver's version without looking at the installed - -- package index (See issue #3436). Otherwise, we pick the Cabal version by - -- checking 'useCabalSpecVersion', then the saved version, and finally the - -- versions available in the index. - -- - -- The version chosen here must match the one used in 'compileSetupExecutable' - -- (See issue #3433). - cabalLibVersionToUse :: IO (Version, Maybe ComponentId - ,SetupScriptOptions) - cabalLibVersionToUse = - case find (isCabalPkgId . snd) (useDependencies options) of - Just (unitId, pkgId) -> do - let version = pkgVersion pkgId - updateSetupScript version bt - writeSetupVersionFile version - return (version, Just unitId, options) - Nothing -> - case useCabalSpecVersion options of - Just version -> do - updateSetupScript version bt - writeSetupVersionFile version - return (version, Nothing, options) - Nothing -> do - savedVer <- savedVersion - case savedVer of - Just version | version `withinRange` useCabalVersion options - -> do updateSetupScript version bt - -- Does the previously compiled setup executable - -- still exist and is it up-to date? - useExisting <- canUseExistingSetup version - if useExisting - then return (version, Nothing, options) - else installedVersion - _ -> installedVersion - where - -- This check duplicates the checks in 'getCachedSetupExecutable' / - -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice - -- because the selected Cabal version may change as a result of this - -- check. - canUseExistingSetup :: Version -> IO Bool - canUseExistingSetup version = - if useCachedSetupExecutable - then do - (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version - doesFileExist cachedSetupProgFile - else - (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs - <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile - - writeSetupVersionFile :: Version -> IO () - writeSetupVersionFile version = - writeFile setupVersionFile (show version ++ "\n") - - installedVersion :: IO (Version, Maybe InstalledPackageId - ,SetupScriptOptions) - installedVersion = do - (comp, progdb, options') <- configureCompiler options - (version, mipkgid, options'') <- installedCabalVersion options' - comp progdb - updateSetupScript version bt - writeSetupVersionFile version - return (version, mipkgid, options'') - - savedVersion :: IO (Maybe Version) - savedVersion = do - versionString <- readFile setupVersionFile `catchIO` \_ -> return "" - case reads versionString of - [(version,s)] | all isSpace s -> return (Just version) - _ -> return Nothing - - -- | Update a Setup.hs script, creating it if necessary. - updateSetupScript :: Version -> BuildType -> IO () - updateSetupScript _ Custom = do - useHs <- doesFileExist customSetupHs - useLhs <- doesFileExist customSetupLhs - unless (useHs || useLhs) $ die' verbosity - "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." - let src = (if useHs then customSetupHs else customSetupLhs) - srcNewer <- src `moreRecentFile` setupHs - when srcNewer $ if useHs - then copyFileVerbose verbosity src setupHs - else runSimplePreProcessor ppUnlit src setupHs verbosity - where - customSetupHs = workingDir options "Setup.hs" - customSetupLhs = workingDir options "Setup.lhs" - - updateSetupScript cabalLibVersion _ = - rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion) - - buildTypeScript :: Version -> BS.ByteString - buildTypeScript cabalLibVersion = case bt of - Simple -> "import Distribution.Simple; main = defaultMain\n" - Configure | cabalLibVersion >= mkVersion [1,3,10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" - | otherwise -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" - Make -> "import Distribution.Make; main = defaultMain\n" - Custom -> error "buildTypeScript Custom" - - installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb - -> IO (Version, Maybe InstalledPackageId - ,SetupScriptOptions) - installedCabalVersion options' _ _ | packageName pkg == mkPackageName "Cabal" - && bt == Custom = - return (packageVersion pkg, Nothing, options') - installedCabalVersion options' compiler progdb = do - index <- maybeGetInstalledPackages options' compiler progdb - let cabalDepName = mkPackageName "Cabal" - cabalDepVersion = useCabalVersion options' - options'' = options' { usePackageIndex = Just index } - case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of - [] -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg) - ++ "' requires Cabal library version " - ++ prettyShow (useCabalVersion options) - ++ " but no suitable version is installed." - pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs - err = error "Distribution.Client.installedCabalVersion: empty version list" - in return (packageVersion ipkginfo - ,Just . IPI.installedComponentId $ ipkginfo, options'') - - bestVersion :: (a -> Version) -> [a] -> a - bestVersion f = firstMaximumBy (comparing (preference . f)) - where - -- Like maximumBy, but picks the first maximum element instead of the - -- last. In general, we expect the preferred version to go first in the - -- list. For the default case, this has the effect of choosing the version - -- installed in the user package DB instead of the global one. See #1463. - -- - -- Note: firstMaximumBy could be written as just - -- `maximumBy cmp . reverse`, but the problem is that the behaviour of - -- maximumBy is not fully specified in the case when there is not a single - -- greatest element. - firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a - firstMaximumBy _ [] = - error "Distribution.Client.firstMaximumBy: empty list" - firstMaximumBy cmp xs = foldl1' maxBy xs - where - maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; } - - preference version = (sameVersion, sameMajorVersion - ,stableVersion, latestVersion) - where - sameVersion = version == cabalVersion - sameMajorVersion = majorVersion version == majorVersion cabalVersion - majorVersion = take 2 . versionNumbers - stableVersion = case versionNumbers version of - (_:x:_) -> even x - _ -> False - latestVersion = version - - configureCompiler :: SetupScriptOptions - -> IO (Compiler, ProgramDb, SetupScriptOptions) - configureCompiler options' = do - (comp, progdb) <- case useCompiler options' of - Just comp -> return (comp, useProgramDb options') - Nothing -> do (comp, _, progdb) <- - configCompilerEx (Just GHC) Nothing Nothing - (useProgramDb options') verbosity - return (comp, progdb) - -- Whenever we need to call configureCompiler, we also need to access the - -- package index, so let's cache it in SetupScriptOptions. - index <- maybeGetInstalledPackages options' comp progdb - return (comp, progdb, options' { useCompiler = Just comp, - usePackageIndex = Just index, - useProgramDb = progdb }) - - -- | Path to the setup exe cache directory and path to the cached setup - -- executable. - cachedSetupDirAndProg :: SetupScriptOptions -> Version - -> IO (FilePath, FilePath) - cachedSetupDirAndProg options' cabalLibVersion = do - cabalDir <- getCabalDir - let setupCacheDir = cabalDir "setup-exe-cache" - cachedSetupProgFile = setupCacheDir - ("setup-" ++ buildTypeString ++ "-" - ++ cabalVersionString ++ "-" - ++ platformString ++ "-" - ++ compilerVersionString) - <.> exeExtension buildPlatform - return (setupCacheDir, cachedSetupProgFile) - where - buildTypeString = show bt - cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion - compilerVersionString = prettyShow $ - maybe buildCompilerId compilerId - $ useCompiler options' - platformString = prettyShow platform - - -- | Look up the setup executable in the cache; update the cache if the setup - -- executable is not found. - getCachedSetupExecutable :: SetupScriptOptions - -> Version -> Maybe InstalledPackageId - -> IO FilePath - getCachedSetupExecutable options' cabalLibVersion - maybeCabalLibInstalledPkgId = do - (setupCacheDir, cachedSetupProgFile) <- - cachedSetupDirAndProg options' cabalLibVersion - cachedSetupExists <- doesFileExist cachedSetupProgFile - if cachedSetupExists - then debug verbosity $ - "Found cached setup executable: " ++ cachedSetupProgFile - else criticalSection' $ do - -- The cache may have been populated while we were waiting. - cachedSetupExists' <- doesFileExist cachedSetupProgFile - if cachedSetupExists' - then debug verbosity $ - "Found cached setup executable: " ++ cachedSetupProgFile - else do - debug verbosity $ "Setup executable not found in the cache." - src <- compileSetupExecutable options' - cabalLibVersion maybeCabalLibInstalledPkgId True - createDirectoryIfMissingVerbose verbosity True setupCacheDir - installExecutableFile verbosity src cachedSetupProgFile - -- Do not strip if we're using GHCJS, since the result may be a script - when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $ - Strip.stripExe verbosity platform (useProgramDb options') - cachedSetupProgFile - return cachedSetupProgFile - where - criticalSection' = maybe id criticalSection $ setupCacheLock options' - - -- | If the Setup.hs is out of date wrt the executable then recompile it. - -- Currently this is GHC/GHCJS only. It should really be generalised. - -- - compileSetupExecutable :: SetupScriptOptions - -> Version -> Maybe ComponentId -> Bool - -> IO FilePath - compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId - forceCompile = do - setupHsNewer <- setupHs `moreRecentFile` setupProgFile - cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile - let outOfDate = setupHsNewer || cabalVersionNewer - when (outOfDate || forceCompile) $ do - debug verbosity "Setup executable needs to be updated, compiling..." - (compiler, progdb, options'') <- configureCompiler options' - let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion - (program, extraOpts) - = case compilerFlavor compiler of - GHCJS -> (ghcjsProgram, ["-build-runner"]) - _ -> (ghcProgram, ["-threaded"]) - cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)]) - maybeCabalLibInstalledPkgId - - -- With 'useDependenciesExclusive' we enforce the deps specified, - -- so only the given ones can be used. Otherwise we allow the use - -- of packages in the ambient environment, and add on a dep on the - -- Cabal library (unless 'useDependencies' already contains one). - -- - -- With 'useVersionMacros' we use a version CPP macros .h file. - -- - -- Both of these options should be enabled for packages that have - -- opted-in and declared a custom-settup stanza. - -- - selectedDeps | useDependenciesExclusive options' - = useDependencies options' - | otherwise = useDependencies options' ++ - if any (isCabalPkgId . snd) - (useDependencies options') - then [] - else cabalDep - addRenaming (ipid, _) = - -- Assert 'DefUnitId' invariant - (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) - ,defaultRenaming) - cppMacrosFile = setupDir "setup_macros.h" - ghcOptions = mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use - -- --ghc-option=-v instead! - ghcOptVerbosity = Flag (min verbosity normal) - , ghcOptMode = Flag GhcModeMake - , ghcOptInputFiles = toNubListR [setupHs] - , ghcOptOutputFile = Flag setupProgFile - , ghcOptObjDir = Flag setupDir - , ghcOptHiDir = Flag setupDir - , ghcOptSourcePathClear = Flag True - , ghcOptSourcePath = case bt of - Custom -> toNubListR [workingDir options'] - _ -> mempty - , ghcOptPackageDBs = usePackageDB options'' - , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') - , ghcOptCabal = Flag (useDependenciesExclusive options') - , ghcOptPackages = toNubListR $ map addRenaming selectedDeps - , ghcOptCppIncludes = toNubListR [ cppMacrosFile - | useVersionMacros options' ] - , ghcOptExtra = extraOpts - } - let ghcCmdLine = renderGhcOptions compiler platform ghcOptions - when (useVersionMacros options') $ - rewriteFileEx verbosity cppMacrosFile - $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) - case useLoggingHandle options of - Nothing -> runDbProgram verbosity program progdb ghcCmdLine - - -- If build logging is enabled, redirect compiler output to - -- the log file. - (Just logHandle) -> do output <- getDbProgramOutput verbosity program - progdb ghcCmdLine - hPutStr logHandle output - return setupProgFile - - -isCabalPkgId :: PackageIdentifier -> Bool -isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/Distribution/Client/SolverInstallPlan.hs b/Distribution/Client/SolverInstallPlan.hs deleted file mode 100644 --- a/Distribution/Client/SolverInstallPlan.hs +++ /dev/null @@ -1,440 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.SolverInstallPlan --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- Stability : provisional --- Portability : portable --- --- The 'SolverInstallPlan' is the graph of packages produced by the --- dependency solver, and specifies at the package-granularity what --- things are going to be installed. To put it another way: the --- dependency solver produces a 'SolverInstallPlan', which is then --- consumed by various other parts of Cabal. --- ------------------------------------------------------------------------------ -module Distribution.Client.SolverInstallPlan( - SolverInstallPlan(..), - SolverPlanPackage, - ResolverPackage(..), - - -- * Operations on 'SolverInstallPlan's - new, - toList, - toMap, - - remove, - - showPlanIndex, - showInstallPlan, - - -- * Checking validity of plans - valid, - closed, - consistent, - acyclic, - - -- ** Details on invalid plans - SolverPlanProblem(..), - showPlanProblem, - problems, - - -- ** Querying the install plan - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, -) where - -import Distribution.Client.Compat.Prelude hiding (toList) -import Prelude () - -import Distribution.Package - ( PackageIdentifier(..), Package(..), PackageName - , HasUnitId(..), PackageId, packageVersion, packageName ) -import Distribution.Types.Flag (nullFlagAssignment) -import qualified Distribution.Solver.Types.ComponentDeps as CD - -import Distribution.Client.Types - ( UnresolvedPkgLoc ) -import Distribution.Version - ( Version ) - -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage - -import Distribution.Compat.Graph (Graph, IsNode(..)) -import qualified Data.Foldable as Foldable -import qualified Data.Graph as OldGraph -import qualified Distribution.Compat.Graph as Graph -import qualified Data.Map as Map -import Data.Array ((!)) - -type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc - -type SolverPlanIndex = Graph SolverPlanPackage - -data SolverInstallPlan = SolverInstallPlan { - planIndex :: !SolverPlanIndex, - planIndepGoals :: !IndependentGoals - } - deriving (Typeable, Generic) - -{- --- | Much like 'planPkgIdOf', but mapping back to full packages. -planPkgOf :: SolverInstallPlan - -> Graph.Vertex - -> SolverPlanPackage -planPkgOf plan v = - case Graph.lookupKey (planIndex plan) - (planPkgIdOf plan v) of - Just pkg -> pkg - Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" --} - - - -instance Binary SolverInstallPlan -instance Structured SolverInstallPlan - -showPlanIndex :: [SolverPlanPackage] -> String -showPlanIndex = intercalate "\n" . map showPlanPackage - -showInstallPlan :: SolverInstallPlan -> String -showInstallPlan = showPlanIndex . toList - -showPlanPackage :: SolverPlanPackage -> String -showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg) - ++ " (" ++ prettyShow (installedUnitId ipkg) - ++ ")" -showPlanPackage (Configured spkg) = - "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps - where - flags - | nullFlagAssignment fa = "" - | otherwise = " " ++ prettyShow (solverPkgFlags spkg) - where - fa = solverPkgFlags spkg - - comps | null deps = "" - | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps) - where - deps = CD.components (solverPkgLibDeps spkg) - <> CD.components (solverPkgExeDeps spkg) - --- | Build an installation plan from a valid set of resolved packages. --- -new :: IndependentGoals - -> SolverPlanIndex - -> Either [SolverPlanProblem] SolverInstallPlan -new indepGoals index = - case problems indepGoals index of - [] -> Right (SolverInstallPlan index indepGoals) - probs -> Left probs - -toList :: SolverInstallPlan -> [SolverPlanPackage] -toList = Foldable.toList . planIndex - -toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage -toMap = Graph.toMap . planIndex - --- | Remove packages from the install plan. This will result in an --- error if there are remaining packages that depend on any matching --- package. This is primarily useful for obtaining an install plan for --- the dependencies of a package or set of packages without actually --- installing the package itself, as when doing development. --- -remove :: (SolverPlanPackage -> Bool) - -> SolverInstallPlan - -> Either [SolverPlanProblem] - (SolverInstallPlan) -remove shouldRemove plan = - new (planIndepGoals plan) newIndex - where - newIndex = Graph.fromDistinctList $ - filter (not . shouldRemove) (toList plan) - --- ------------------------------------------------------------ --- * Checking validity of plans --- ------------------------------------------------------------ - --- | A valid installation plan is a set of packages that is 'acyclic', --- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the --- plan has to have a valid configuration (see 'configuredPackageValid'). --- --- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: IndependentGoals - -> SolverPlanIndex - -> Bool -valid indepGoals index = - null $ problems indepGoals index - -data SolverPlanProblem = - PackageMissingDeps SolverPlanPackage - [PackageIdentifier] - | PackageCycle [SolverPlanPackage] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] - | PackageStateInvalid SolverPlanPackage SolverPlanPackage - -showPlanProblem :: SolverPlanProblem -> String -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " ++ prettyShow (packageId pkg) - ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) - -showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (prettyShow.packageId) cycleGroup) - -showPlanProblem (PackageInconsistency name inconsistencies) = - "Package " ++ prettyShow name - ++ " is required by several packages," - ++ " but they require inconsistent versions:\n" - ++ unlines [ " package " ++ prettyShow pkg ++ " requires " - ++ prettyShow (PackageIdentifier name ver) - | (pkg, ver) <- inconsistencies ] - -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " ++ prettyShow (packageId pkg) - ++ " is in the " ++ showPlanState pkg - ++ " state but it depends on package " ++ prettyShow (packageId pkg') - ++ " which is in the " ++ showPlanState pkg' - ++ " state" - where - showPlanState (PreExisting _) = "pre-existing" - showPlanState (Configured _) = "configured" - --- | For an invalid plan, produce a detailed list of problems as human readable --- error messages. This is mainly intended for debugging purposes. --- Use 'showPlanProblem' for a human readable explanation. --- -problems :: IndependentGoals - -> SolverPlanIndex - -> [SolverPlanProblem] -problems indepGoals index = - - [ PackageMissingDeps pkg - (mapMaybe - (fmap packageId . flip Graph.lookup index) - missingDeps) - | (pkg, missingDeps) <- Graph.broken index ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles index ] - - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - dependencyInconsistencies indepGoals index ] - - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Foldable.toList index - , Just pkg' <- map (flip Graph.lookup index) - (nodeNeighbors pkg) - , not (stateDependencyRelation pkg pkg') ] - - --- | Compute all roots of the install plan, and verify that the transitive --- plans from those roots are all consistent. --- --- NOTE: This does not check for dependency cycles. Moreover, dependency cycles --- may be absent from the subplans even if the larger plan contains a dependency --- cycle. Such cycles may or may not be an issue; either way, we don't check --- for them here. -dependencyInconsistencies :: IndependentGoals - -> SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies indepGoals index = - concatMap dependencyInconsistencies' subplans - where - subplans :: [SolverPlanIndex] - subplans = -- Not Graph.closure!! - map (nonSetupClosure index) - (rootSets indepGoals index) - --- NB: When we check for inconsistencies, packages from the setup --- scripts don't count as part of the closure (this way, we --- can build, e.g., Cabal-1.24.1 even if its setup script is --- built with Cabal-1.24.0). --- --- This is a best effort function that swallows any non-existent --- SolverIds. -nonSetupClosure :: SolverPlanIndex - -> [SolverId] - -> SolverPlanIndex -nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 - where - closure completed [] = completed - closure completed (pkgid:pkgids) = - case Graph.lookup pkgid index of - Nothing -> closure completed pkgids - Just pkg -> - case Graph.lookup (nodeKey pkg) completed of - Just _ -> closure completed pkgids - Nothing -> closure completed' pkgids' - where completed' = Graph.insert pkg completed - pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids - --- | Compute the root sets of a plan --- --- A root set is a set of packages whose dependency closure must be consistent. --- This is the set of all top-level library roots (taken together normally, or --- as singletons sets if we are considering them as independent goals), along --- with all setup dependencies of all packages. -rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]] -rootSets (IndependentGoals indepGoals) index = - if indepGoals then map (:[]) libRoots else [libRoots] - ++ setupRoots index - where - libRoots = libraryRoots index - --- | Compute the library roots of a plan --- --- The library roots are the set of packages with no reverse dependencies --- (no reverse library dependencies but also no reverse setup dependencies). -libraryRoots :: SolverPlanIndex -> [SolverId] -libraryRoots index = - map (nodeKey . toPkgId) roots - where - (graph, toPkgId, _) = Graph.toGraph index - indegree = OldGraph.indegree graph - roots = filter isRoot (OldGraph.vertices graph) - isRoot v = indegree ! v == 0 - --- | The setup dependencies of each package in the plan -setupRoots :: SolverPlanIndex -> [[SolverId]] -setupRoots = filter (not . null) - . map (CD.setupDeps . resolverPackageLibDeps) - . Foldable.toList - --- | Given a package index where we assume we want to use all the packages --- (use 'dependencyClosure' if you need to get such a index subset) find out --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies' :: SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies' index = - [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids]) - | (name, ipid_map) <- Map.toList inverseIndex - , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) - ] - where - -- For each package name (of a dependency, somewhere) - -- and each installed ID of that package - -- the associated package instance - -- and a list of reverse dependencies (as source IDs) - inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId])) - inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) - [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) - | -- For each package @pkg@ - pkg <- Foldable.toList index - -- Find out which @sid@ @pkg@ depends on - , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) - -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) - , Just dep <- [Graph.lookup sid index] - ] - - -- If, in a single install plan, we depend on more than one version of a - -- package, then this is ONLY okay in the (rather special) case that we - -- depend on precisely two versions of that package, and one of them - -- depends on the other. This is necessary for example for the base where - -- we have base-3 depending on base-4. - reallyIsInconsistent :: [SolverPlanPackage] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False - reallyIsInconsistent [p1, p2] = - let pid1 = nodeKey p1 - pid2 = nodeKey p2 - in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) - && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) - reallyIsInconsistent _ = True - - --- | The graph of packages (nodes) and dependencies (edges) must be acyclic. --- --- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out --- which packages are involved in dependency cycles. --- -acyclic :: SolverPlanIndex -> Bool -acyclic = null . Graph.cycles - --- | An installation plan is closed if for every package in the set, all of --- its dependencies are also in the set. That is, the set is closed under the --- dependency relation. --- --- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out --- which packages depend on packages not in the index. --- -closed :: SolverPlanIndex -> Bool -closed = null . Graph.broken - --- | An installation plan is consistent if all dependencies that target a --- single package name, target the same version. --- --- This is slightly subtle. It is not the same as requiring that there be at --- most one version of any package in the set. It only requires that of --- packages which have more than one other package depending on them. We could --- actually make the condition even more precise and say that different --- versions are OK so long as they are not both in the transitive closure of --- any other package (or equivalently that their inverse closures do not --- intersect). The point is we do not want to have any packages depending --- directly or indirectly on two different versions of the same package. The --- current definition is just a safe approximation of that. --- --- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --- find out which packages are. --- -consistent :: SolverPlanIndex -> Bool -consistent = null . dependencyInconsistencies (IndependentGoals False) - --- | The states of packages have that depend on each other must respect --- this relation. That is for very case where package @a@ depends on --- package @b@ we require that @dependencyStatesOk a b = True@. --- -stateDependencyRelation :: SolverPlanPackage - -> SolverPlanPackage - -> Bool -stateDependencyRelation PreExisting{} PreExisting{} = True - -stateDependencyRelation (Configured _) PreExisting{} = True -stateDependencyRelation (Configured _) (Configured _) = True - -stateDependencyRelation _ _ = False - - --- | Compute the dependency closure of a package in a install plan --- -dependencyClosure :: SolverInstallPlan - -> [SolverId] - -> [SolverPlanPackage] -dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan) - - -reverseDependencyClosure :: SolverInstallPlan - -> [SolverId] - -> [SolverPlanPackage] -reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan) - - -topologicalOrder :: SolverInstallPlan - -> [SolverPlanPackage] -topologicalOrder plan = Graph.topSort (planIndex plan) - - -reverseTopologicalOrder :: SolverInstallPlan - -> [SolverPlanPackage] -reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan) diff --git a/Distribution/Client/SourceFiles.hs b/Distribution/Client/SourceFiles.hs deleted file mode 100644 --- a/Distribution/Client/SourceFiles.hs +++ /dev/null @@ -1,167 +0,0 @@ --- | Contains an @sdist@ like function which computes the source files --- that we should track to determine if a rebuild is necessary. --- Unlike @sdist@, we can operate directly on the true --- 'PackageDescription' (not flattened). --- --- The naming convention, roughly, is that to declare we need the --- source for some type T, you use the function needT; some functions --- need auxiliary information. --- --- We can only use this code for non-Custom scripts; Custom scripts --- may have arbitrary extra dependencies (esp. new preprocessors) which --- we cannot "see" easily. -module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where - -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.RebuildMonad - -import Distribution.Solver.Types.OptionalStanza - -import Distribution.Simple.PreProcess - -import Distribution.Types.PackageDescription -import Distribution.Types.Component -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.Library -import Distribution.Types.Executable -import Distribution.Types.Benchmark -import Distribution.Types.BenchmarkInterface -import Distribution.Types.TestSuite -import Distribution.Types.TestSuiteInterface -import Distribution.Types.BuildInfo -import Distribution.Types.ForeignLib - -import Distribution.ModuleName - -import Prelude () -import Distribution.Client.Compat.Prelude - -import System.FilePath -import qualified Data.Set as Set - -needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild () -needElaboratedConfiguredPackage elab = - case elabPkgOrComp elab of - ElabComponent ecomp -> needElaboratedComponent elab ecomp - ElabPackage epkg -> needElaboratedPackage elab epkg - -needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () -needElaboratedPackage elab epkg = - traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) - where - pkg_descr = elabPkgDescription elab - enabled_stanzas = pkgStanzasEnabled epkg - -- TODO: turn this into a helper function somewhere - enabled = - ComponentRequestedSpec { - testsRequested = TestStanzas `Set.member` enabled_stanzas, - benchmarksRequested = BenchStanzas `Set.member` enabled_stanzas - } - -needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild () -needElaboratedComponent elab ecomp = - case mb_comp of - Nothing -> needSetup - Just comp -> needComponent pkg_descr comp - where - pkg_descr = elabPkgDescription elab - mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) - -needComponent :: PackageDescription -> Component -> Rebuild () -needComponent pkg_descr comp = - case comp of - CLib lib -> needLibrary pkg_descr lib - CFLib flib -> needForeignLib pkg_descr flib - CExe exe -> needExecutable pkg_descr exe - CTest test -> needTestSuite pkg_descr test - CBench bench -> needBenchmark pkg_descr bench - -needSetup :: Rebuild () -needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () - -needLibrary :: PackageDescription -> Library -> Rebuild () -needLibrary pkg_descr (Library { exposedModules = modules - , signatures = sigs - , libBuildInfo = bi }) - = needBuildInfo pkg_descr bi (modules ++ sigs) - -needForeignLib :: PackageDescription -> ForeignLib -> Rebuild () -needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs - , foreignLibBuildInfo = bi }) - = do traverse_ needIfExists fs - needBuildInfo pkg_descr bi [] - -needExecutable :: PackageDescription -> Executable -> Rebuild () -needExecutable pkg_descr (Executable { modulePath = mainPath - , buildInfo = bi }) - = do needBuildInfo pkg_descr bi [] - needMainFile bi mainPath - -needTestSuite :: PackageDescription -> TestSuite -> Rebuild () -needTestSuite pkg_descr t - = case testInterface t of - TestSuiteExeV10 _ mainPath -> do - needBuildInfo pkg_descr bi [] - needMainFile bi mainPath - TestSuiteLibV09 _ m -> - needBuildInfo pkg_descr bi [m] - TestSuiteUnsupported _ -> return () -- soft fail - where - bi = testBuildInfo t - -needMainFile :: BuildInfo -> FilePath -> Rebuild () -needMainFile bi mainPath = do - -- The matter here is subtle. It might *seem* that we - -- should just search for mainPath, but as per - -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' - -- will actually be the source file AFTER preprocessing, - -- whereas we need to get the file *prior* to preprocessing. - ppFile <- findFileWithExtensionMonitored - (ppSuffixes knownSuffixHandlers) - (hsSourceDirs bi) - (dropExtension mainPath) - case ppFile of - -- But check the original path in the end, because - -- maybe it's a non-preprocessed file with a non-traditional - -- extension. - Nothing -> findFileMonitored (hsSourceDirs bi) mainPath - >>= maybe (return ()) need - Just pp -> need pp - -needBenchmark :: PackageDescription -> Benchmark -> Rebuild () -needBenchmark pkg_descr bm - = case benchmarkInterface bm of - BenchmarkExeV10 _ mainPath -> do - needBuildInfo pkg_descr bi [] - needMainFile bi mainPath - BenchmarkUnsupported _ -> return () -- soft fail - where - bi = benchmarkBuildInfo bm - -needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild () -needBuildInfo pkg_descr bi modules = do - -- NB: These are separate because there may be both A.hs and - -- A.hs-boot; need to track both. - findNeededModules ["hs", "lhs", "hsig", "lhsig"] - findNeededModules ["hs-boot", "lhs-boot"] - traverse_ needIfExists $ concat - [ cSources bi - , cxxSources bi - , jsSources bi - , cmmSources bi - , asmSources bi - , extraSrcFiles pkg_descr - ] - for_ (installIncludes bi) $ \f -> - findFileMonitored ("." : includeDirs bi) f - >>= maybe (return ()) need - where - findNeededModules exts = traverse_ - (findNeededModule exts) - (modules ++ otherModules bi) - findNeededModule exts m = - findFileWithExtensionMonitored - (ppSuffixes knownSuffixHandlers ++ exts) - (hsSourceDirs bi) - (toFilePath m) - >>= maybe (return ()) need diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs deleted file mode 100644 --- a/Distribution/Client/SrcDist.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Utilities to implemenet cabal @v2-sdist@. -module Distribution.Client.SrcDist ( - allPackageSourceFiles, - packageDirToSdist, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify) -import Control.Monad.Trans (liftIO) -import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell) -import System.FilePath (normalise, takeDirectory, ()) - -import Distribution.Client.Utils (tryFindAddSourcePackageDesc) -import Distribution.Package (Package (packageId)) -import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.PackageDescription.Parsec (readGenericPackageDescription) -import Distribution.Simple.PreProcess (knownSuffixHandlers) -import Distribution.Simple.SrcDist (listPackageSources) -import Distribution.Simple.SrcDist (listPackageSourcesWithDie) -import Distribution.Simple.Utils (die') -import Distribution.Types.GenericPackageDescription (GenericPackageDescription) - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Set as Set - --- | List all source files of a given add-source dependency. Exits with error if --- something is wrong (e.g. there is no .cabal file in the given directory). --- --- Used in sandbox and projectbuilding. --- TODO: when sandboxes are removed, move to ProjectBuilding. --- -allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] -allPackageSourceFiles verbosity packageDir = do - pd <- do - let err = "Error reading source files of package." - desc <- tryFindAddSourcePackageDesc verbosity packageDir err - flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc - - listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers - --- | Create a tarball for a package in a directory -packageDirToSdist - :: Verbosity - -> GenericPackageDescription -- ^ read in GPD - -> FilePath -- ^ directory containing that GPD - -> IO BSL.ByteString -- ^ resulting sdist tarball -packageDirToSdist verbosity gpd dir = do - files' <- listPackageSources verbosity dir (flattenPackageDescription gpd) knownSuffixHandlers - let files = nub $ sort $ map normalise files' - - let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () - entriesM = do - let prefix = prettyShow (packageId gpd) - modify (Set.insert prefix) - case Tar.toTarPath True prefix of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] - - for_ files $ \file -> do - let fileDir = takeDirectory (prefix file) - needsEntry <- gets (Set.notMember fileDir) - - when needsEntry $ do - modify (Set.insert fileDir) - case Tar.toTarPath True fileDir of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] - - contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir file - case Tar.toTarPath False (prefix file) of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }] - - entries <- execWriterT (evalStateT entriesM mempty) - let -- Pretend our GZip file is made on Unix. - normalize bs = BSL.concat [pfx, "\x03", rest'] - where - (pfx, rest) = BSL.splitAt 9 bs - rest' = BSL.tail rest - -- The Unix epoch, which is the default value, is - -- unsuitable because it causes unpacking problems on - -- Windows; we need a post-1980 date. One gigasecond - -- after the epoch is during 2001-09-09, so that does - -- nicely. See #5596. - setModTime entry = entry { Tar.entryTime = 1000000000 } - return . normalize . GZip.compress . Tar.write $ fmap setModTime entries diff --git a/Distribution/Client/Store.hs b/Distribution/Client/Store.hs deleted file mode 100644 --- a/Distribution/Client/Store.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-} - - --- | Management for the installed package store. --- -module Distribution.Client.Store ( - - -- * The store layout - StoreDirLayout(..), - defaultStoreDirLayout, - - -- * Reading store entries - getStoreEntries, - doesStoreEntryExist, - - -- * Creating store entries - newStoreEntry, - NewStoreEntryOutcome(..), - - -- * Concurrency strategy - -- $concurrency - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.DistDirLayout -import Distribution.Client.RebuildMonad - -import Distribution.Package (UnitId, mkUnitId) -import Distribution.Compiler (CompilerId) - -import Distribution.Simple.Utils - ( withTempDirectory, debug, info ) -import Distribution.Verbosity - ( silent ) - -import qualified Data.Set as Set -import Control.Exception -import System.FilePath -import System.Directory - -#ifdef MIN_VERSION_lukko -import Lukko -#else -import System.IO (openFile, IOMode(ReadWriteMode), hClose) -import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock)) -#if MIN_VERSION_base(4,11,0) -import GHC.IO.Handle.Lock (hUnlock) -#endif -#endif - --- $concurrency --- --- We access and update the store concurrently. Our strategy to do that safely --- is as follows. --- --- The store entries once created are immutable. This alone simplifies matters --- considerably. --- --- Additionally, the way 'UnitId' hashes are constructed means that if a store --- entry exists already then we can assume its content is ok to reuse, rather --- than having to re-recreate. This is the nix-style input hashing concept. --- --- A consequence of this is that with a little care it is /safe/ to race --- updates against each other. Consider two independent concurrent builds that --- both want to build a particular 'UnitId', where that entry does not yet --- exist in the store. It is safe for both to build and try to install this --- entry into the store provided that: --- --- * only one succeeds --- * the looser discovers that they lost, they abandon their own build and --- re-use the store entry installed by the winner. --- --- Note that because builds are not reproducible in general (nor even --- necessarily ABI compatible) then it is essential that the loser abandon --- their build and use the one installed by the winner, so that subsequent --- packages are built against the exact package from the store rather than some --- morally equivalent package that may not be ABI compatible. --- --- Our overriding goal is that store reads be simple, cheap and not require --- locking. We will derive our write-side protocol to make this possible. --- --- The read-side protocol is simply: --- --- * check for the existence of a directory entry named after the 'UnitId' in --- question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then --- the store entry can be assumed to be complete and immutable. --- --- Given our read-side protocol, the final step on the write side must be to --- atomically rename a fully-formed store entry directory into its final --- location. While this will indeed be the final step, the preparatory steps --- are more complicated. The tricky aspect is that the store also contains a --- number of shared package databases (one per compiler version). Our read --- strategy means that by the time we install the store dir entry the package --- db must already have been updated. We cannot do the package db update --- as part of atomically renaming the store entry directory however. Furthermore --- it is not safe to allow either package db update because the db entry --- contains the ABI hash and this is not guaranteed to be deterministic. So we --- must register the new package prior to the atomic dir rename. Since this --- combination of steps are not atomic then we need locking. --- --- The write-side protocol is: --- --- * Create a unique temp dir and write all store entry files into it. --- --- * Take a lock named after the 'UnitId' in question. --- --- * Once holding the lock, check again for the existence of the final store --- entry directory. If the entry exists then the process lost the race and it --- must abandon, unlock and re-use the existing store entry. If the entry --- does not exist then the process won the race and it can proceed. --- --- * Register the package into the package db. Note that the files are not in --- their final location at this stage so registration file checks may need --- to be disabled. --- --- * Atomically rename the temp dir to the final store entry location. --- --- * Release the previously-acquired lock. --- --- Obviously this means it is possible to fail after registering but before --- installing the store entry, leaving a dangling package db entry. This is not --- much of a problem because this entry does not determine package existence --- for cabal. It does mean however that the package db update should be insert --- or replace, i.e. not failing if the db entry already exists. - - --- | Check if a particular 'UnitId' exists in the store. --- -doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool -doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = - doesDirectoryExist (storePackageDirectory compid unitid) - - --- | Return the 'UnitId's of all packages\/components already installed in the --- store. --- -getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) -getStoreEntries StoreDirLayout{storeDirectory} compid = do - paths <- getDirectoryContentsMonitored (storeDirectory compid) - return $! mkEntries paths - where - mkEntries = Set.delete (mkUnitId "package.db") - . Set.delete (mkUnitId "incoming") - . Set.fromList - . map mkUnitId - . filter valid - valid ('.':_) = False - valid _ = True - - --- | The outcome of 'newStoreEntry': either the store entry was newly created --- or it existed already. The latter case happens if there was a race between --- two builds of the same store entry. --- -data NewStoreEntryOutcome = UseNewStoreEntry - | UseExistingStoreEntry - deriving (Eq, Show) - --- | Place a new entry into the store. See the concurrency strategy description --- for full details. --- --- In particular, it takes two actions: one to place files into a temporary --- location, and a second to perform any necessary registration. The first --- action is executed without any locks held (the temp dir is unique). The --- second action holds a lock that guarantees that only one cabal process is --- able to install this store entry. This means it is safe to register into --- the compiler package DB or do other similar actions. --- --- Note that if you need to use the registration information later then you --- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry' --- then you must read the existing registration information (unless your --- registration information is constructed fully deterministically). --- -newStoreEntry :: Verbosity - -> StoreDirLayout - -> CompilerId - -> UnitId - -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. - -> IO () -- ^ Register action, if necessary. - -> IO NewStoreEntryOutcome -newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} - compid unitid - copyFiles register = - -- See $concurrency above for an explanation of the concurrency protocol - - withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do - - -- Write all store entry files within the temp dir and return the prefix. - (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir - - -- Take a lock named after the 'UnitId' in question. - withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do - - -- Check for the existence of the final store entry directory. - exists <- doesStoreEntryExist storeDirLayout compid unitid - - if exists - -- If the entry exists then we lost the race and we must abandon, - -- unlock and re-use the existing store entry. - then do - info verbosity $ - "Concurrent build race: abandoning build in favour of existing " - ++ "store entry " ++ prettyShow compid prettyShow unitid - return UseExistingStoreEntry - - -- If the entry does not exist then we won the race and can proceed. - else do - - -- Register the package into the package db (if appropriate). - register - - -- Atomically rename the temp dir to the final store entry location. - renameDirectory incomingEntryDir finalEntryDir - for_ otherFiles $ \file -> do - let finalStoreFile = storeDirectory compid makeRelative (incomingTmpDir (dropDrive (storeDirectory compid))) file - createDirectoryIfMissing True (takeDirectory finalStoreFile) - renameFile file finalStoreFile - - debug verbosity $ - "Installed store entry " ++ prettyShow compid prettyShow unitid - return UseNewStoreEntry - where - finalEntryDir = storePackageDirectory compid unitid - - -withTempIncomingDir :: StoreDirLayout -> CompilerId - -> (FilePath -> IO a) -> IO a -withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do - createDirectoryIfMissing True incomingDir - withTempDirectory silent incomingDir "new" action - where - incomingDir = storeIncomingDirectory compid - - -withIncomingUnitIdLock :: Verbosity -> StoreDirLayout - -> CompilerId -> UnitId - -> IO a -> IO a -withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} - compid unitid action = - bracket takeLock releaseLock (\_hnd -> action) - where -#ifdef MIN_VERSION_lukko - takeLock - | fileLockingSupported = do - fd <- fdOpen (storeIncomingLock compid unitid) - gotLock <- fdTryLock fd ExclusiveLock - unless gotLock $ do - info verbosity $ "Waiting for file lock on store entry " - ++ prettyShow compid prettyShow unitid - fdLock fd ExclusiveLock - return fd - - -- if there's no locking, do nothing. Be careful on AIX. - | otherwise = return undefined -- :( - - releaseLock fd - | fileLockingSupported = do - fdUnlock fd - fdClose fd - | otherwise = return () -#else - takeLock = do - h <- openFile (storeIncomingLock compid unitid) ReadWriteMode - -- First try non-blocking, but if we would have to wait then - -- log an explanation and do it again in blocking mode. - gotlock <- hTryLock h ExclusiveLock - unless gotlock $ do - info verbosity $ "Waiting for file lock on store entry " - ++ prettyShow compid prettyShow unitid - hLock h ExclusiveLock - return h - - releaseLock h = hUnlock h >> hClose h -#endif diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs deleted file mode 100644 --- a/Distribution/Client/Tar.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Tar --- Copyright : (c) 2007 Bjorn Bringert, --- 2008 Andrea Vezzosi, --- 2008-2009 Duncan Coutts --- License : BSD3 --- --- Maintainer : duncan@community.haskell.org --- Portability : portable --- --- Reading, writing and manipulating \"@.tar@\" archive files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Tar ( - -- * @tar.gz@ operations - createTarGzFile, - extractTarGzFile, - - -- * Other local utils - buildTreeRefTypeCode, - buildTreeSnapshotTypeCode, - isBuildTreeRefTypeCode, - filterEntries, - filterEntriesM, - entriesToList, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Data.ByteString.Lazy as BS -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Archive.Tar.Check as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Distribution.Client.GZipUtils as GZipUtils - --- for foldEntries... -import Control.Exception (throw) - --- --- * High level operations --- - -createTarGzFile :: FilePath -- ^ Full Tarball path - -> FilePath -- ^ Base directory - -> FilePath -- ^ Directory to archive, relative to base dir - -> IO () -createTarGzFile tar base dir = - BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir] - -extractTarGzFile :: FilePath -- ^ Destination directory - -> FilePath -- ^ Expected subdir (to check for tarbombs) - -> FilePath -- ^ Tarball - -> IO () -extractTarGzFile dir expected tar = - Tar.unpack dir . Tar.checkTarbomb expected . Tar.read - . GZipUtils.maybeDecompress =<< BS.readFile tar - -instance (Exception a, Exception b) => Exception (Either a b) where - toException (Left e) = toException e - toException (Right e) = toException e - - fromException e = - case fromException e of - Just e' -> Just (Left e') - Nothing -> case fromException e of - Just e' -> Just (Right e') - Nothing -> Nothing - - --- | Type code for the local build tree reference entry type. We don't use the --- symbolic link entry type because it allows only 100 ASCII characters for the --- path. -buildTreeRefTypeCode :: Tar.TypeCode -buildTreeRefTypeCode = 'C' - --- | Type code for the local build tree snapshot entry type. -buildTreeSnapshotTypeCode :: Tar.TypeCode -buildTreeSnapshotTypeCode = 'S' - --- | Is this a type code for a build tree reference? -isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool -isBuildTreeRefTypeCode typeCode - | (typeCode == buildTreeRefTypeCode - || typeCode == buildTreeSnapshotTypeCode) = True - | otherwise = False - -filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e -filterEntries p = - Tar.foldEntries - (\e es -> if p e then Tar.Next e es else es) - Tar.Done - Tar.Fail - -filterEntriesM :: Monad m => (Tar.Entry -> m Bool) - -> Tar.Entries e -> m (Tar.Entries e) -filterEntriesM p = - Tar.foldEntries - (\entry rest -> do - keep <- p entry - xs <- rest - if keep - then return (Tar.Next entry xs) - else return xs) - (return Tar.Done) - (return . Tar.Fail) - -entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry] -entriesToList = Tar.foldEntries (:) [] throw - diff --git a/Distribution/Client/TargetProblem.hs b/Distribution/Client/TargetProblem.hs deleted file mode 100644 --- a/Distribution/Client/TargetProblem.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Client.TargetProblem ( - TargetProblem(..), - TargetProblem', -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Client.ProjectPlanning (AvailableTarget) -import Distribution.Client.TargetSelector (SubComponentTarget, TargetSelector) -import Distribution.Package (PackageId, PackageName) -import Distribution.Simple.LocalBuildInfo (ComponentName (..)) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - --- | Target problems that occur during project orchestration. -data TargetProblem a - = TargetNotInProject PackageName - | TargetAvailableInIndex PackageName - - | TargetComponentNotProjectLocal - PackageId ComponentName SubComponentTarget - - | TargetComponentNotBuildable - PackageId ComponentName SubComponentTarget - - | TargetOptionalStanzaDisabledByUser - PackageId ComponentName SubComponentTarget - - | TargetOptionalStanzaDisabledBySolver - PackageId ComponentName SubComponentTarget - - | TargetProblemUnknownComponent - PackageName (Either UnqualComponentName ComponentName) - - | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] - -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable - - | TargetProblemNoTargets TargetSelector - -- ^ There are no targets at all - - -- The target matching stuff only returns packages local to the project, - -- so these lookups should never fail, but if 'resolveTargets' is called - -- directly then of course it can. - | TargetProblemNoSuchPackage PackageId - | TargetProblemNoSuchComponent PackageId ComponentName - - -- | A custom target problem - | CustomTargetProblem a - deriving (Eq, Show, Functor) - --- | Type alias for a 'TargetProblem' with no user-defined problems/errors. --- --- Can use the utilities below for reporting/rendering problems. -type TargetProblem' = TargetProblem Void diff --git a/Distribution/Client/TargetSelector.hs b/Distribution/Client/TargetSelector.hs deleted file mode 100644 --- a/Distribution/Client/TargetSelector.hs +++ /dev/null @@ -1,2490 +0,0 @@ -{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, - RecordWildCards, NamedFieldPuns #-} --- TODO -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.TargetSelector --- Copyright : (c) Duncan Coutts 2012, 2015, 2016 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified target selectors. --- ------------------------------------------------------------------------------ -module Distribution.Client.TargetSelector ( - - -- * Target selectors - TargetSelector(..), - TargetImplicitCwd(..), - ComponentKind(..), - ComponentKindFilter, - SubComponentTarget(..), - QualLevel(..), - componentKind, - - -- * Reading target selectors - readTargetSelectors, - TargetSelectorProblem(..), - reportTargetSelectorProblems, - showTargetSelector, - TargetString(..), - showTargetString, - parseTargetString, - -- ** non-IO - readTargetSelectorsWith, - DirActions(..), - defaultDirActions, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Package - ( Package(..), PackageId, PackageName, packageName ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName - , packageNameToUnqualComponentName ) -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..) ) - -import Distribution.PackageDescription - ( PackageDescription - , Executable(..) - , TestSuite(..), TestSuiteInterface(..), testModules - , Benchmark(..), BenchmarkInterface(..), benchmarkModules - , BuildInfo(..), explicitLibModules, exeModules ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.ModuleName - ( ModuleName, toFilePath ) -import Distribution.Simple.LocalBuildInfo - ( Component(..), ComponentName(..), LibraryName(..) - , pkgComponents, componentName, componentBuildInfo ) -import Distribution.Types.ForeignLib - -import Distribution.Simple.Utils - ( die', lowercase, ordNub ) -import Distribution.Client.Utils - ( makeRelativeCanonical ) - -import Data.List - ( stripPrefix, groupBy ) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Lazy as Map.Lazy -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Control.Arrow ((&&&)) -import Control.Monad - hiding ( mfilter ) -import qualified Distribution.Deprecated.ReadP as Parse -import Distribution.Deprecated.ReadP - ( (+++), (<++) ) -import Distribution.Deprecated.ParseUtils - ( readPToMaybe ) -import System.FilePath as FilePath - ( takeExtension, dropExtension - , splitDirectories, joinPath, splitPath ) -import qualified System.Directory as IO - ( doesFileExist, doesDirectoryExist, canonicalizePath - , getCurrentDirectory ) -import System.FilePath - ( (), (<.>), normalise, dropTrailingPathSeparator ) -import Text.EditDistance - ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) - -import qualified Prelude (foldr1) - --- ------------------------------------------------------------ --- * Target selector terms --- ------------------------------------------------------------ - --- | A target selector is expression selecting a set of components (as targets --- for a actions like @build@, @run@, @test@ etc). A target selector --- corresponds to the user syntax for referring to targets on the command line. --- --- From the users point of view a target can be many things: packages, dirs, --- component names, files etc. Internally we consider a target to be a specific --- component (or module\/file within a component), and all the users' notions --- of targets are just different ways of referring to these component targets. --- --- So target selectors are expressions in the sense that they are interpreted --- to refer to one or more components. For example a 'TargetPackage' gets --- interpreted differently by different commands to refer to all or a subset --- of components within the package. --- --- The syntax has lots of optional parts: --- --- > [ package name | package dir | package .cabal file ] --- > [ [lib:|exe:] component name ] --- > [ module name | source file ] --- -data TargetSelector = - - -- | One (or more) packages as a whole, or all the components of a - -- particular kind within the package(s). - -- - -- These are always packages that are local to the project. In the case - -- that there is more than one, they all share the same directory location. - -- - TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) - - -- | A package specified by name. This may refer to @extra-packages@ from - -- the @cabal.project@ file, or a dependency of a known project package or - -- could refer to a package from a hackage archive. It needs further - -- context to resolve to a specific package. - -- - | TargetPackageNamed PackageName (Maybe ComponentKindFilter) - - -- | All packages, or all components of a particular kind in all packages. - -- - | TargetAllPackages (Maybe ComponentKindFilter) - - -- | A specific component in a package within the project. - -- - | TargetComponent PackageId ComponentName SubComponentTarget - - -- | A component in a package, but where it cannot be verified that the - -- package has such a component, or because the package is itself not - -- known. - -- - | TargetComponentUnknown PackageName - (Either UnqualComponentName ComponentName) - SubComponentTarget - deriving (Eq, Ord, Show, Generic) - --- | Does this 'TargetPackage' selector arise from syntax referring to a --- package in the current directory (e.g. @tests@ or no giving no explicit --- target at all) or does it come from syntax referring to a package name --- or location. --- -data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed - deriving (Eq, Ord, Show, Generic) - -data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind - deriving (Eq, Ord, Enum, Show) - -type ComponentKindFilter = ComponentKind - --- | Either the component as a whole or detail about a file or module target --- within a component. --- -data SubComponentTarget = - - -- | The component as a whole - WholeComponent - - -- | A specific module within a component. - | ModuleTarget ModuleName - - -- | A specific file within a component. Note that this does not carry the - -- file extension. - | FileTarget FilePath - deriving (Eq, Ord, Show, Generic) - -instance Binary SubComponentTarget -instance Structured SubComponentTarget - - --- ------------------------------------------------------------ --- * Top level, do everything --- ------------------------------------------------------------ - - --- | Parse a bunch of command line args as 'TargetSelector's, failing with an --- error if any are unrecognised. The possible target selectors are based on --- the available packages (and their locations). --- -readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter - -- ^ This parameter is used when there are ambiguous selectors. - -- If it is 'Just', then we attempt to resolve ambiguitiy - -- by applying it, since otherwise there is no way to allow - -- contextually valid yet syntactically ambiguous selectors. - -- (#4676, #5461) - -> [String] - -> IO (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectors = readTargetSelectorsWith defaultDirActions - -readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m - -> [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter - -> [String] - -> m (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = - case parseTargetStrings targetStrs of - ([], usertargets) -> do - usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets - knowntargets <- getKnownTargets dirActions pkgs - case resolveTargetSelectors knowntargets usertargets' mfilter of - ([], btargets) -> return (Right btargets) - (problems, _) -> return (Left problems) - (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) - - -data DirActions m = DirActions { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool, - canonicalizePath :: FilePath -> m FilePath, - getCurrentDirectory :: m FilePath - } - -defaultDirActions :: DirActions IO -defaultDirActions = - DirActions { - doesFileExist = IO.doesFileExist, - doesDirectoryExist = IO.doesDirectoryExist, - -- Workaround for - canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator, - getCurrentDirectory = IO.getCurrentDirectory - } - -makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath -makeRelativeToCwd DirActions{..} path = - makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory - - --- ------------------------------------------------------------ --- * Parsing target strings --- ------------------------------------------------------------ - --- | The outline parse of a target selector. It takes one of the forms: --- --- > str1 --- > str1:str2 --- > str1:str2:str3 --- > str1:str2:str3:str4 --- -data TargetString = - TargetString1 String - | TargetString2 String String - | TargetString3 String String String - | TargetString4 String String String String - | TargetString5 String String String String String - | TargetString7 String String String String String String String - deriving (Show, Eq) - --- | Parse a bunch of 'TargetString's (purely without throwing exceptions). --- -parseTargetStrings :: [String] -> ([String], [TargetString]) -parseTargetStrings = - partitionEithers - . map (\str -> maybe (Left str) Right (parseTargetString str)) - -parseTargetString :: String -> Maybe TargetString -parseTargetString = - readPToMaybe parseTargetApprox - where - parseTargetApprox :: Parse.ReadP r TargetString - parseTargetApprox = - (do a <- tokenQ - return (TargetString1 a)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- tokenQ - return (TargetString2 a b)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- tokenQ - _ <- Parse.char ':' - c <- tokenQ - return (TargetString3 a b c)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - return (TargetString4 a b c d)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - _ <- Parse.char ':' - e <- tokenQ - return (TargetString5 a b c d e)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - _ <- Parse.char ':' - e <- tokenQ - _ <- Parse.char ':' - f <- tokenQ - _ <- Parse.char ':' - g <- tokenQ - return (TargetString7 a b c d e f g)) - - token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') - tokenQ = parseHaskellString <++ token - token0 = Parse.munch (\x -> not (isSpace x) && x /= ':') - tokenQ0= parseHaskellString <++ token0 - parseHaskellString :: Parse.ReadP r String - parseHaskellString = Parse.readS_to_P reads - - --- | Render a 'TargetString' back as the external syntax. This is mainly for --- error messages. --- -showTargetString :: TargetString -> String -showTargetString = intercalate ":" . components - where - components (TargetString1 s1) = [s1] - components (TargetString2 s1 s2) = [s1,s2] - components (TargetString3 s1 s2 s3) = [s1,s2,s3] - components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4] - components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] - components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] - -showTargetSelector :: TargetSelector -> String -showTargetSelector ts = - case [ t | ql <- [QL1 .. QLFull] - , t <- renderTargetSelector ql ts ] - of (t':_) -> showTargetString (forgetFileStatus t') - [] -> "" - -showTargetSelectorKind :: TargetSelector -> String -showTargetSelectorKind bt = case bt of - TargetPackage TargetExplicitNamed _ Nothing -> "package" - TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" - TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" - TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" - TargetPackageNamed _ Nothing -> "named-package" - TargetPackageNamed _ (Just _) -> "named-package:filter" - TargetAllPackages Nothing -> "package *" - TargetAllPackages (Just _) -> "package *:filter" - TargetComponent _ _ WholeComponent -> "component" - TargetComponent _ _ ModuleTarget{} -> "module" - TargetComponent _ _ FileTarget{} -> "file" - TargetComponentUnknown _ _ WholeComponent -> "unknown-component" - TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" - TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" - - --- ------------------------------------------------------------ --- * Checking if targets exist as files --- ------------------------------------------------------------ - -data TargetStringFileStatus = - TargetStringFileStatus1 String FileStatus - | TargetStringFileStatus2 String FileStatus String - | TargetStringFileStatus3 String FileStatus String String - | TargetStringFileStatus4 String String String String - | TargetStringFileStatus5 String String String String String - | TargetStringFileStatus7 String String String String String String String - deriving (Eq, Ord, Show) - -data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath - | FileStatusExistsDir FilePath -- the canonicalised filepath - | FileStatusNotExists Bool -- does the parent dir exist even? - deriving (Eq, Ord, Show) - -noFileStatus :: FileStatus -noFileStatus = FileStatusNotExists False - -getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m - -> TargetString -> m TargetStringFileStatus -getTargetStringFileStatus DirActions{..} t = - case t of - TargetString1 s1 -> - (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 - TargetString2 s1 s2 -> - (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 - TargetString3 s1 s2 s3 -> - (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 - TargetString4 s1 s2 s3 s4 -> - return (TargetStringFileStatus4 s1 s2 s3 s4) - TargetString5 s1 s2 s3 s4 s5 -> - return (TargetStringFileStatus5 s1 s2 s3 s4 s5) - TargetString7 s1 s2 s3 s4 s5 s6 s7 -> - return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) - where - fileStatus f = do - fexists <- doesFileExist f - dexists <- doesDirectoryExist f - case splitPath f of - _ | fexists -> FileStatusExistsFile <$> canonicalizePath f - | dexists -> FileStatusExistsDir <$> canonicalizePath f - (d:_) -> FileStatusNotExists <$> doesDirectoryExist d - _ -> pure (FileStatusNotExists False) - -forgetFileStatus :: TargetStringFileStatus -> TargetString -forgetFileStatus t = case t of - TargetStringFileStatus1 s1 _ -> TargetString1 s1 - TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 - TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 - TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 - TargetStringFileStatus5 s1 s2 s3 s4 - s5 -> TargetString5 s1 s2 s3 s4 s5 - TargetStringFileStatus7 s1 s2 s3 s4 - s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 - -getFileStatus :: TargetStringFileStatus -> Maybe FileStatus -getFileStatus (TargetStringFileStatus1 _ f) = Just f -getFileStatus (TargetStringFileStatus2 _ f _) = Just f -getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f -getFileStatus _ = Nothing - -setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus -setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f -setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2 -setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3 -setFileStatus _ t = t - -copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus -copyFileStatus src dst = - case getFileStatus src of - Just f -> setFileStatus f dst - Nothing -> dst - --- ------------------------------------------------------------ --- * Resolving target strings to target selectors --- ------------------------------------------------------------ - - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. --- -resolveTargetSelectors :: KnownTargets - -> [TargetStringFileStatus] - -> Maybe ComponentKindFilter - -> ([TargetSelectorProblem], - [TargetSelector]) --- default local dir target if there's no given target: -resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = - ([TargetSelectorNoTargetsInProject], []) - -resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ = - ([TargetSelectorNoTargetsInCwd], []) - -resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = - ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) - where - pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] - -resolveTargetSelectors knowntargets targetStrs mfilter = - partitionEithers - . map (resolveTargetSelector knowntargets mfilter) - $ targetStrs - -resolveTargetSelector :: KnownTargets - -> Maybe ComponentKindFilter - -> TargetStringFileStatus - -> Either TargetSelectorProblem TargetSelector -resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = - case findMatch (matcher targetStrStatus) of - - Unambiguous _ - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - - Unambiguous (TargetPackage TargetImplicitCwd [] _) - -> Left (TargetSelectorNoCurrentPackage targetStr) - - Unambiguous target -> Right target - - None errs - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - | otherwise -> Left (classifyMatchErrors errs) - - Ambiguous _ targets - | Just kfilter <- mfilter - , [target] <- applyKindFilter kfilter targets -> Right target - - Ambiguous exactMatch targets -> - case disambiguateTargetSelectors - matcher targetStrStatus exactMatch - targets of - Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') - Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) - Left [] -> internalError "resolveTargetSelector" - where - matcher = matchTargetSelector knowntargets - - targetStr = forgetFileStatus targetStrStatus - - projectIsEmpty = null knownPackagesAll - - classifyMatchErrors errs - | Just expectedNE <- NE.nonEmpty expected - = let (things, got:|_) = NE.unzip expectedNE in - TargetSelectorExpected targetStr (NE.toList things) got - - | not (null nosuch) - = TargetSelectorNoSuch targetStr nosuch - - | otherwise - = internalError $ "classifyMatchErrors: " ++ show errs - where - expected = [ (thing, got) - | (_, MatchErrorExpected thing got) - <- map (innerErr Nothing) errs ] - -- Trim the list of alternatives by dropping duplicates and - -- retaining only at most three most similar (by edit distance) ones. - nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ - [ ((inside, thing, got), Set.fromList alts) - | (inside, MatchErrorNoSuch thing got alts) - <- map (innerErr Nothing) errs - ] - - genResults (inside, thing, got) alts acc = ( - inside - , thing - , got - , take maxResults - $ map fst - $ takeWhile distanceLow - $ sortBy (comparing snd) - $ map addLevDist - $ Set.toList alts - ) : acc - where - addLevDist = id &&& restrictedDamerauLevenshteinDistance - defaultEditCosts got - - distanceLow (_, dist) = dist < length got `div` 2 - - maxResults = 3 - - innerErr _ (MatchErrorIn kind thing m) - = innerErr (Just (kind,thing)) m - innerErr c m = (c,m) - - applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] - applyKindFilter kfilter = filter go - where - go (TargetPackage _ _ (Just filter')) = kfilter == filter' - go (TargetPackageNamed _ (Just filter')) = kfilter == filter' - go (TargetAllPackages (Just filter')) = kfilter == filter' - go (TargetComponent _ cname _) - | CLibName _ <- cname = kfilter == LibKind - | CFLibName _ <- cname = kfilter == FLibKind - | CExeName _ <- cname = kfilter == ExeKind - | CTestName _ <- cname = kfilter == TestKind - | CBenchName _ <- cname = kfilter == BenchKind - go _ = True - --- | The various ways that trying to resolve a 'TargetString' to a --- 'TargetSelector' can fail. --- -data TargetSelectorProblem - = TargetSelectorExpected TargetString [String] String - -- ^ [expected thing] (actually got) - | TargetSelectorNoSuch TargetString - [(Maybe (String, String), String, String, [String])] - -- ^ [([in thing], no such thing, actually got, alternatives)] - | TargetSelectorAmbiguous TargetString - [(TargetString, TargetSelector)] - - | MatchingInternalError TargetString TargetSelector - [(TargetString, [TargetSelector])] - | TargetSelectorUnrecognised String - -- ^ Syntax error when trying to parse a target string. - | TargetSelectorNoCurrentPackage TargetString - | TargetSelectorNoTargetsInCwd - | TargetSelectorNoTargetsInProject - deriving (Show, Eq) - --- | Qualification levels. --- Given the filepath src/F, executable component A, and package foo: -data QualLevel = QL1 -- ^ @src/F@ - | QL2 -- ^ @foo:src/F | A:src/F@ - | QL3 -- ^ @foo:A:src/F | exe:A:src/F@ - | QLFull -- ^ @pkg:foo:exe:A:file:src/F@ - deriving (Eq, Enum, Show) - -disambiguateTargetSelectors - :: (TargetStringFileStatus -> Match TargetSelector) - -> TargetStringFileStatus -> MatchClass - -> [TargetSelector] - -> Either [(TargetSelector, [(TargetString, [TargetSelector])])] - [(TargetString, TargetSelector)] -disambiguateTargetSelectors matcher matchInput exactMatch matchResults = - case partitionEithers results of - (errs@(_:_), _) -> Left errs - ([], ok) -> Right ok - where - -- So, here's the strategy. We take the original match results, and make a - -- table of all their renderings at all qualification levels. - -- Note there can be multiple renderings at each qualification level. - - -- Note that renderTargetSelector won't immediately work on any file syntax - -- When rendering syntax, the FileStatus is always FileStatusNotExists, - -- which will never match on syntaxForm1File! - -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile. - -- So we need to copy over the file status from the input - -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus - matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])] - matchResultsRenderings = - [ (matchResult, matchRenderings) - | matchResult <- matchResults - , let matchRenderings = - [ copyFileStatus matchInput rendering - | ql <- [QL1 .. QLFull] - , rendering <- renderTargetSelector ql matchResult ] - ] - - -- Of course the point is that we're looking for renderings that are - -- unambiguous matches. So we build another memo table of all the matches - -- for all of those renderings. So by looking up in this table we can see - -- if we've got an unambiguous match. - - memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) - memoisedMatches = - -- avoid recomputing the main one if it was an exact match - (if exactMatch == Exact - then Map.insert matchInput (Match Exact 0 matchResults) - else id) - $ Map.Lazy.fromList - -- (matcher rendering) should *always* be a Match! Otherwise we will hit - -- the internal error later on. - [ (rendering, matcher rendering) - | rendering <- concatMap snd matchResultsRenderings ] - - -- Finally, for each of the match results, we go through all their - -- possible renderings (in order of qualification level, though remember - -- there can be multiple renderings per level), and find the first one - -- that has an unambiguous match. - results :: [Either (TargetSelector, [(TargetString, [TargetSelector])]) - (TargetString, TargetSelector)] - results = - [ case findUnambiguous originalMatch matchRenderings of - Just unambiguousRendering -> - Right ( forgetFileStatus unambiguousRendering - , originalMatch) - - -- This case is an internal error, but we bubble it up and report it - Nothing -> - Left ( originalMatch - , [ (forgetFileStatus rendering, matches) - | rendering <- matchRenderings - , let Match m _ matches = - memoisedMatches Map.! rendering - , m /= Inexact - ] ) - - | (originalMatch, matchRenderings) <- matchResultsRenderings ] - - findUnambiguous :: TargetSelector - -> [TargetStringFileStatus] - -> Maybe TargetStringFileStatus - findUnambiguous _ [] = Nothing - findUnambiguous t (r:rs) = - case memoisedMatches Map.! r of - Match Exact _ [t'] | t == t' - -> Just r - Match Exact _ _ -> findUnambiguous t rs - Match Unknown _ _ -> findUnambiguous t rs - Match Inexact _ _ -> internalError "Match Inexact" - NoMatch _ _ -> internalError "NoMatch" - -internalError :: String -> a -internalError msg = - error $ "TargetSelector: internal error: " ++ msg - - --- | Throw an exception with a formatted message if there are any problems. --- -reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a -reportTargetSelectorProblems verbosity problems = do - - case [ str | TargetSelectorUnrecognised str <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised target syntax for '" ++ name ++ "'." - | name <- targets ] - - case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of - [] -> return () - ((target, originalMatch, renderingsAndMatches):_) -> - die' verbosity $ "Internal error in target matching. It should always " - ++ "be possible to find a syntax that's sufficiently qualified to " - ++ "give an unambiguous match. However when matching '" - ++ showTargetString target ++ "' we found " - ++ showTargetSelector originalMatch - ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does " - ++ "not have an unambiguous syntax. The possible syntax and the " - ++ "targets they match are as follows:\n" - ++ unlines - [ "'" ++ showTargetString rendering ++ "' which matches " - ++ intercalate ", " - [ showTargetSelector match ++ - " (" ++ showTargetSelectorKind match ++ ")" - | match <- matches ] - | (rendering, matches) <- renderingsAndMatches ] - - case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised target '" ++ showTargetString target - ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unknown target '" ++ showTargetString target ++ - "'.\n" ++ unlines - [ (case inside of - Just (kind, "") - -> "The " ++ kind ++ " has no " - Just (kind, thing) - -> "The " ++ kind ++ " " ++ thing ++ " has no " - Nothing -> "There is no ") - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got, _alts) <- nosuch' ] ++ "." - ++ if null alternatives then "" else - "\nPerhaps you meant " ++ intercalate ";\nor " - [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" - | (thing, alts) <- alternatives ] - | (inside, nosuch') <- groupByContainer nosuch - , let alternatives = - [ (thing, alts) - | (thing,_got,alts@(_:_)) <- nosuch' ] - ] - | (target, nosuch) <- targets - , let groupByContainer = - map (\g@((inside,_,_,_):_) -> - (inside, [ (thing,got,alts) - | (_,thing,got,alts) <- g ])) - . groupBy ((==) `on` (\(x,_,_,_) -> x)) - . sortBy (compare `on` (\(x,_,_,_) -> x)) - ] - where - mungeThing "file" = "file target" - mungeThing thing = thing - - case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Ambiguous target '" ++ showTargetString target - ++ "'. It could be:\n " - ++ unlines [ " "++ showTargetString ut ++ - " (" ++ showTargetSelectorKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - - case [ t | TargetSelectorNoCurrentPackage t <- problems ] of - [] -> return () - target:_ -> - die' verbosity $ - "The target '" ++ showTargetString target ++ "' refers to the " - ++ "components in the package in the current directory, but there " - ++ "is no package in the current directory (or at least not listed " - ++ "as part of the project)." - --TODO: report a different error if there is a .cabal file but it's - -- not a member of the project - - case [ () | TargetSelectorNoTargetsInCwd <- problems ] of - [] -> return () - _:_ -> - die' verbosity $ - "No targets given and there is no package in the current " - ++ "directory. Use the target 'all' for all packages in the " - ++ "project or specify packages or components by name or location. " - ++ "See 'cabal build --help' for more details on target options." - - case [ () | TargetSelectorNoTargetsInProject <- problems ] of - [] -> return () - _:_ -> - die' verbosity $ - "There is no .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 -type Renderer = TargetSelector -> [TargetStringFileStatus] - -foldSyntax :: (a -> a -> a) -> (a -> a -> a) - -> (QualLevel -> Matcher -> Renderer -> a) - -> (Syntax -> a) -foldSyntax ambiguous unambiguous syntax = go - where - go (Syntax ql match render) = syntax ql match render - go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) - go (ShadowingAlternatives a b) = unambiguous (go a) (go b) - - ----------------------------------- --- Top level renderer and matcher --- - -renderTargetSelector :: QualLevel -> TargetSelector - -> [TargetStringFileStatus] -renderTargetSelector ql ts = - foldSyntax - (++) (++) - (\ql' _ render -> guard (ql == ql') >> render ts) - syntax - where - syntax = syntaxForms emptyKnownTargets - -- don't need known targets for rendering - -matchTargetSelector :: KnownTargets - -> TargetStringFileStatus - -> Match TargetSelector -matchTargetSelector knowntargets = \usertarget -> - nubMatchesBy (==) $ - - let ql = targetQualLevel usertarget in - foldSyntax - (<|>) () - (\ql' match _ -> guard (ql == ql') >> match usertarget) - syntax - where - syntax = syntaxForms knowntargets - - targetQualLevel TargetStringFileStatus1{} = QL1 - targetQualLevel TargetStringFileStatus2{} = QL2 - targetQualLevel TargetStringFileStatus3{} = QL3 - targetQualLevel TargetStringFileStatus4{} = QLFull - targetQualLevel TargetStringFileStatus5{} = QLFull - targetQualLevel TargetStringFileStatus7{} = QLFull - - ----------------------------------- --- Syntax forms --- - --- | All the forms of syntax for 'TargetSelector'. --- -syntaxForms :: KnownTargets -> Syntax -syntaxForms KnownTargets { - knownPackagesAll = pinfo, - knownPackagesPrimary = ppinfo, - knownComponentsAll = cinfo, - knownComponentsPrimary = pcinfo, - knownComponentsOther = ocinfo - } = - -- The various forms of syntax here are ambiguous in many cases. - -- Our policy is by default we expose that ambiguity and report - -- ambiguous matches. In certain cases we override the ambiguity - -- by having some forms shadow others. - -- - -- We make modules shadow files because module name "Q" clashes - -- with file "Q" with no extension but these refer to the same - -- thing anyway so it's not a useful ambiguity. Other cases are - -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q". - - ambiguousAlternatives - -- convenient single-component forms - [ shadowingAlternatives - [ ambiguousAlternatives - [ syntaxForm1All - , syntaxForm1Filter ppinfo - , shadowingAlternatives - [ syntaxForm1Component pcinfo - , syntaxForm1Package pinfo - ] - ] - , syntaxForm1Component ocinfo - , syntaxForm1Module cinfo - , syntaxForm1File pinfo - ] - - -- two-component partially qualified forms - -- fully qualified form for 'all' - , syntaxForm2MetaAll - , syntaxForm2AllFilter - , syntaxForm2NamespacePackage pinfo - , syntaxForm2PackageComponent pinfo - , syntaxForm2PackageFilter pinfo - , syntaxForm2KindComponent cinfo - , shadowingAlternatives - [ syntaxForm2PackageModule pinfo - , syntaxForm2PackageFile pinfo - ] - , shadowingAlternatives - [ syntaxForm2ComponentModule cinfo - , syntaxForm2ComponentFile cinfo - ] - - -- rarely used partially qualified forms - , syntaxForm3PackageKindComponent pinfo - , shadowingAlternatives - [ syntaxForm3PackageComponentModule pinfo - , syntaxForm3PackageComponentFile pinfo - ] - , shadowingAlternatives - [ syntaxForm3KindComponentModule cinfo - , syntaxForm3KindComponentFile cinfo - ] - , syntaxForm3NamespacePackageFilter pinfo - - -- fully-qualified forms for all and cwd with filter - , syntaxForm3MetaAllFilter - , syntaxForm3MetaCwdFilter ppinfo - - -- fully-qualified form for package and package with filter - , syntaxForm3MetaNamespacePackage pinfo - , syntaxForm4MetaNamespacePackageFilter pinfo - - -- fully-qualified forms for component, module and file - , syntaxForm5MetaNamespacePackageKindComponent pinfo - , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo - , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo - ] - where - ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives - shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives - - --- | Syntax: "all" to select all packages in the project --- --- > cabal build all --- -syntaxForm1All :: Syntax -syntaxForm1All = - syntaxForm1 render $ \str1 _fstatus1 -> do - guardMetaAll str1 - return (TargetAllPackages Nothing) - where - render (TargetAllPackages Nothing) = - [TargetStringFileStatus1 "all" noFileStatus] - render _ = [] - --- | Syntax: filter --- --- > cabal build tests --- -syntaxForm1Filter :: [KnownPackage] -> Syntax -syntaxForm1Filter ps = - syntaxForm1 render $ \str1 _fstatus1 -> do - kfilter <- matchComponentKindFilter str1 - return (TargetPackage TargetImplicitCwd pids (Just kfilter)) - where - pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] - render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = - [TargetStringFileStatus1 (dispF kfilter) noFileStatus] - render _ = [] - - --- | Syntax: package (name, dir or file) --- --- > cabal build foo --- > cabal build ../bar ../bar/bar.cabal --- -syntaxForm1Package :: [KnownPackage] -> Syntax -syntaxForm1Package pinfo = - syntaxForm1 render $ \str1 fstatus1 -> do - guardPackage str1 fstatus1 - p <- matchPackage pinfo str1 fstatus1 - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) - KnownPackageName pn -> - return (TargetPackageNamed pn Nothing) - where - render (TargetPackage TargetExplicitNamed [p] Nothing) = - [TargetStringFileStatus1 (dispP p) noFileStatus] - render (TargetPackageNamed pn Nothing) = - [TargetStringFileStatus1 (dispPN pn) noFileStatus] - render _ = [] - --- | Syntax: component --- --- > cabal build foo --- -syntaxForm1Component :: [KnownComponent] -> Syntax -syntaxForm1Component cs = - syntaxForm1 render $ \str1 _fstatus1 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus1 (dispC p c) noFileStatus] - render _ = [] - --- | Syntax: module --- --- > cabal build Data.Foo --- -syntaxForm1Module :: [KnownComponent] -> Syntax -syntaxForm1Module cs = - syntaxForm1 render $ \str1 _fstatus1 -> do - guardModuleName str1 - let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str1 - return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) - where - render (TargetComponent _p _c (ModuleTarget m)) = - [TargetStringFileStatus1 (dispM m) noFileStatus] - render _ = [] - --- | Syntax: file name --- --- > cabal build Data/Foo.hs bar/Main.hsc --- -syntaxForm1File :: [KnownPackage] -> Syntax -syntaxForm1File ps = - -- Note there's a bit of an inconsistency here vs the other syntax forms - -- for files. For the single-part syntax the target has to point to a file - -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for - -- all the other forms we don't require that. - syntaxForm1 render $ \str1 fstatus1 -> - expecting "file" str1 $ do - (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) - -- always returns the KnownPackage case - <- matchPackageDirectoryPrefix ps fstatus1 - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - (filepath, c) <- matchComponentFile pinfoComponents pkgfile - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - where - render (TargetComponent _p _c (FileTarget f)) = - [TargetStringFileStatus1 f noFileStatus] - render _ = [] - ---- - --- | Syntax: :all --- --- > cabal build :all --- -syntaxForm2MetaAll :: Syntax -syntaxForm2MetaAll = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardNamespaceMeta str1 - guardMetaAll str2 - return (TargetAllPackages Nothing) - where - render (TargetAllPackages Nothing) = - [TargetStringFileStatus2 "" noFileStatus "all"] - render _ = [] - --- | Syntax: all : filer --- --- > cabal build all:tests --- -syntaxForm2AllFilter :: Syntax -syntaxForm2AllFilter = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardMetaAll str1 - kfilter <- matchComponentKindFilter str2 - return (TargetAllPackages (Just kfilter)) - where - render (TargetAllPackages (Just kfilter)) = - [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)] - render _ = [] - --- | Syntax: package : filer --- --- > cabal build foo:tests --- -syntaxForm2PackageFilter :: [KnownPackage] -> Syntax -syntaxForm2PackageFilter ps = - syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - p <- matchPackage ps str1 fstatus1 - kfilter <- matchComponentKindFilter str2 - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) - KnownPackageName pn -> - return (TargetPackageNamed pn (Just kfilter)) - where - render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = - [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] - render (TargetPackageNamed pn (Just kfilter)) = - [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)] - render _ = [] - --- | Syntax: pkg : package name --- --- > cabal build pkg:foo --- -syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax -syntaxForm2NamespacePackage pinfo = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardNamespacePackage str1 - guardPackageName str2 - p <- matchPackage pinfo str2 noFileStatus - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) - KnownPackageName pn -> - return (TargetPackageNamed pn Nothing) - where - render (TargetPackage TargetExplicitNamed [p] Nothing) = - [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] - render (TargetPackageNamed pn Nothing) = - [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)] - render _ = [] - --- | Syntax: package : component --- --- > cabal build foo:foo --- > cabal build ./foo:foo --- > cabal build ./foo.cabal:foo --- -syntaxForm2PackageComponent :: [KnownPackage] -> Syntax -syntaxForm2PackageComponent ps = - syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentName pinfoComponents str2 - return (TargetComponent pinfoId (cinfoName c) WholeComponent) - --TODO: the error here ought to say there's no component by that name in - -- this package, and name the package - KnownPackageName pn -> - let cn = mkUnqualComponentName str2 in - return (TargetComponentUnknown pn (Left cn) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] - render (TargetComponentUnknown pn (Left cn) WholeComponent) = - [TargetStringFileStatus2 (dispPN pn) noFileStatus (prettyShow cn)] - render _ = [] - --- | Syntax: namespace : component --- --- > cabal build lib:foo exe:foo --- -syntaxForm2KindComponent :: [KnownComponent] -> Syntax -syntaxForm2KindComponent cs = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)] - render _ = [] - --- | Syntax: package : module --- --- > cabal build foo:Data.Foo --- > cabal build ./foo:Data.Foo --- > cabal build ./foo.cabal:Data.Foo --- -syntaxForm2PackageModule :: [KnownPackage] -> Syntax -syntaxForm2PackageModule ps = - syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardModuleName str2 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str2 - return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName pn -> do - m <- matchModuleNameUnknown str2 - -- We assume the primary library component of the package: - return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m)) - where - render (TargetComponent p _c (ModuleTarget m)) = - [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] - render _ = [] - --- | Syntax: component : module --- --- > cabal build foo:Data.Foo --- -syntaxForm2ComponentModule :: [KnownComponent] -> Syntax -syntaxForm2ComponentModule cs = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardComponentName str1 - guardModuleName str2 - c <- matchComponentName cs str1 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str2 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (ModuleTarget m)) - where - render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)] - render _ = [] - --- | Syntax: package : filename --- --- > cabal build foo:Data/Foo.hs --- > cabal build ./foo:Data/Foo.hs --- > cabal build ./foo.cabal:Data/Foo.hs --- -syntaxForm2PackageFile :: [KnownPackage] -> Syntax -syntaxForm2PackageFile ps = - syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - (filepath, c) <- matchComponentFile pinfoComponents str2 - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName pn -> - let filepath = str2 in - -- We assume the primary library component of the package: - return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath)) - where - render (TargetComponent p _c (FileTarget f)) = - [TargetStringFileStatus2 (dispP p) noFileStatus f] - render _ = [] - --- | Syntax: component : filename --- --- > cabal build foo:Data/Foo.hs --- -syntaxForm2ComponentFile :: [KnownComponent] -> Syntax -syntaxForm2ComponentFile cs = - syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str2 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (FileTarget filepath)) - where - render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus2 (dispC p c) noFileStatus f] - render _ = [] - ---- - --- | Syntax: :all : filter --- --- > cabal build :all:tests --- -syntaxForm3MetaAllFilter :: Syntax -syntaxForm3MetaAllFilter = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespaceMeta str1 - guardMetaAll str2 - kfilter <- matchComponentKindFilter str3 - return (TargetAllPackages (Just kfilter)) - where - render (TargetAllPackages (Just kfilter)) = - [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] - render _ = [] - -syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax -syntaxForm3MetaCwdFilter ps = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespaceMeta str1 - guardNamespaceCwd str2 - kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetImplicitCwd pids (Just kfilter)) - where - pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] - render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = - [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] - render _ = [] - --- | Syntax: :pkg : package name --- --- > cabal build :pkg:foo --- -syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax -syntaxForm3MetaNamespacePackage pinfo = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - p <- matchPackage pinfo str3 noFileStatus - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) - KnownPackageName pn -> - return (TargetPackageNamed pn Nothing) - where - render (TargetPackage TargetExplicitNamed [p] Nothing) = - [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] - render (TargetPackageNamed pn Nothing) = - [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)] - render _ = [] - --- | Syntax: package : namespace : component --- --- > cabal build foo:lib:foo --- > cabal build foo/:lib:foo --- > cabal build foo.cabal:lib:foo --- -syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax -syntaxForm3PackageKindComponent ps = - syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - ckind <- matchComponentKind str2 - guardComponentName str3 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentKindAndName pinfoComponents ckind str3 - return (TargetComponent pinfoId (cinfoName c) WholeComponent) - KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in - return (TargetComponentUnknown pn (Right cn) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] - render (TargetComponentUnknown pn (Right c) WholeComponent) = - [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)] - render _ = [] - --- | Syntax: package : component : module --- --- > cabal build foo:foo:Data.Foo --- > cabal build foo/:foo:Data.Foo --- > cabal build foo.cabal:foo:Data.Foo --- -syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax -syntaxForm3PackageComponentModule ps = - syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - guardModuleName str3 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentName pinfoComponents str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName pn -> do - let cn = mkUnqualComponentName str2 - m <- matchModuleNameUnknown str3 - return (TargetComponentUnknown pn (Left cn) (ModuleTarget m)) - where - render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] - render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) = - [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)] - render _ = [] - --- | Syntax: namespace : component : module --- --- > cabal build lib:foo:Data.Foo --- -syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax -syntaxForm3KindComponentModule cs = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - guardModuleName str3 - c <- matchComponentKindAndName cs ckind str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (ModuleTarget m)) - where - render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)] - render _ = [] - --- | Syntax: package : component : filename --- --- > cabal build foo:foo:Data/Foo.hs --- > cabal build foo/:foo:Data/Foo.hs --- > cabal build foo.cabal:foo:Data/Foo.hs --- -syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax -syntaxForm3PackageComponentFile ps = - syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - p <- matchPackage ps str1 fstatus1 - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentName pinfoComponents str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName pn -> - let cn = mkUnqualComponentName str2 - filepath = str3 in - return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) - where - render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] - render (TargetComponentUnknown pn (Left c) (FileTarget f)) = - [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f] - render _ = [] - --- | Syntax: namespace : component : filename --- --- > cabal build lib:foo:Data/Foo.hs --- -syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax -syntaxForm3KindComponentFile cs = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (FileTarget filepath)) - where - render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f] - render _ = [] - -syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax -syntaxForm3NamespacePackageFilter ps = - syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespacePackage str1 - guardPackageName str2 - p <- matchPackage ps str2 noFileStatus - kfilter <- matchComponentKindFilter str3 - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) - KnownPackageName pn -> - return (TargetPackageNamed pn (Just kfilter)) - where - render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = - [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] - render (TargetPackageNamed pn (Just kfilter)) = - [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)] - render _ = [] - --- - -syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax -syntaxForm4MetaNamespacePackageFilter ps = - syntaxForm4 render $ \str1 str2 str3 str4 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - p <- matchPackage ps str3 noFileStatus - kfilter <- matchComponentKindFilter str4 - case p of - KnownPackage{pinfoId} -> - return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) - KnownPackageName pn -> - return (TargetPackageNamed pn (Just kfilter)) - where - render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = - [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] - render (TargetPackageNamed pn (Just kfilter)) = - [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)] - render _ = [] - --- | Syntax: :pkg : package : namespace : component --- --- > cabal build :pkg:foo:lib:foo --- -syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax -syntaxForm5MetaNamespacePackageKindComponent ps = - syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - ckind <- matchComponentKind str4 - guardComponentName str5 - p <- matchPackage ps str3 noFileStatus - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentKindAndName pinfoComponents ckind str5 - return (TargetComponent pinfoId (cinfoName c) WholeComponent) - KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in - return (TargetComponentUnknown pn (Right cn) WholeComponent) - where - render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] - render (TargetComponentUnknown pn (Right c) WholeComponent) = - [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)] - render _ = [] - --- | Syntax: :pkg : package : namespace : component : module : module --- --- > cabal build :pkg:foo:lib:foo:module:Data.Foo --- -syntaxForm7MetaNamespacePackageKindComponentNamespaceModule - :: [KnownPackage] -> Syntax -syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = - syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - ckind <- matchComponentKind str4 - guardComponentName str5 - guardNamespaceModule str6 - p <- matchPackage ps str3 noFileStatus - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentKindAndName pinfoComponents ckind str5 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str7 - return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName pn -> do - let cn = mkComponentName pn ckind (mkUnqualComponentName str2) - m <- matchModuleNameUnknown str7 - return (TargetComponentUnknown pn (Right cn) (ModuleTarget m)) - where - render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispCK c) (dispC p c) - "module" (dispM m)] - render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) = - [TargetStringFileStatus7 "" "pkg" (dispPN pn) - (dispCK c) (dispC' pn c) - "module" (dispM m)] - render _ = [] - --- | Syntax: :pkg : package : namespace : component : file : filename --- --- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs --- -syntaxForm7MetaNamespacePackageKindComponentNamespaceFile - :: [KnownPackage] -> Syntax -syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = - syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 - ckind <- matchComponentKind str4 - guardComponentName str5 - guardNamespaceFile str6 - p <- matchPackage ps str3 noFileStatus - case p of - KnownPackage{pinfoId, pinfoComponents} -> - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - c <- matchComponentKindAndName pinfoComponents ckind str5 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath,_) <- matchComponentFile [c] str7 - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str5) - filepath = str7 in - return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) - where - render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispCK c) (dispC p c) - "file" f] - render (TargetComponentUnknown pn (Right c) (FileTarget f)) = - [TargetStringFileStatus7 "" "pkg" (dispPN pn) - (dispCK c) (dispC' pn c) - "file" f] - render _ = [] - - ---------------------------------------- --- Syntax utils --- - -type Match1 = String -> FileStatus -> Match TargetSelector -type Match2 = String -> FileStatus -> String - -> Match TargetSelector -type Match3 = String -> FileStatus -> String -> String - -> Match TargetSelector -type Match4 = String -> String -> String -> String - -> Match TargetSelector -type Match5 = String -> String -> String -> String -> String - -> Match TargetSelector -type Match7 = String -> String -> String -> String -> String -> String -> String - -> Match TargetSelector - -syntaxForm1 :: Renderer -> Match1 -> Syntax -syntaxForm2 :: Renderer -> Match2 -> Syntax -syntaxForm3 :: Renderer -> Match3 -> Syntax -syntaxForm4 :: Renderer -> Match4 -> Syntax -syntaxForm5 :: Renderer -> Match5 -> Syntax -syntaxForm7 :: Renderer -> Match7 -> Syntax - -syntaxForm1 render f = - Syntax QL1 match render - where - match = \(TargetStringFileStatus1 str1 fstatus1) -> - f str1 fstatus1 - -syntaxForm2 render f = - Syntax QL2 match render - where - match = \(TargetStringFileStatus2 str1 fstatus1 str2) -> - f str1 fstatus1 str2 - -syntaxForm3 render f = - Syntax QL3 match render - where - match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) -> - f str1 fstatus1 str2 str3 - -syntaxForm4 render f = - Syntax QLFull match render - where - match (TargetStringFileStatus4 str1 str2 str3 str4) - = f str1 str2 str3 str4 - match _ = mzero - -syntaxForm5 render f = - Syntax QLFull match render - where - match (TargetStringFileStatus5 str1 str2 str3 str4 str5) - = f str1 str2 str3 str4 str5 - match _ = mzero - -syntaxForm7 render f = - Syntax QLFull match render - where - match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) - = f str1 str2 str3 str4 str5 str6 str7 - match _ = mzero - -dispP :: Package p => p -> String -dispP = prettyShow . packageName - -dispPN :: PackageName -> String -dispPN = prettyShow - -dispC :: PackageId -> ComponentName -> String -dispC = componentStringName . packageName - -dispC' :: PackageName -> ComponentName -> String -dispC' = componentStringName - -dispCN :: UnqualComponentName -> String -dispCN = prettyShow - -dispK :: ComponentKind -> String -dispK = showComponentKindShort - -dispCK :: ComponentName -> String -dispCK = dispK . componentKind - -dispF :: ComponentKind -> String -dispF = showComponentKindFilterShort - -dispM :: ModuleName -> String -dispM = prettyShow - - -------------------------------- --- Package and component info --- - -data KnownTargets = KnownTargets { - knownPackagesAll :: [KnownPackage], - knownPackagesPrimary :: [KnownPackage], - knownPackagesOther :: [KnownPackage], - knownComponentsAll :: [KnownComponent], - knownComponentsPrimary :: [KnownComponent], - knownComponentsOther :: [KnownComponent] - } - deriving Show - -data KnownPackage = - KnownPackage { - pinfoId :: PackageId, - pinfoDirectory :: Maybe (FilePath, FilePath), - pinfoPackageFile :: Maybe (FilePath, FilePath), - pinfoComponents :: [KnownComponent] - } - | KnownPackageName { - pinfoName :: PackageName - } - deriving Show - -data KnownComponent = KnownComponent { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoPackageId :: PackageId, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoCFiles :: [FilePath], - cinfoJsFiles :: [FilePath] - } - deriving Show - -type ComponentStringName = String - -knownPackageName :: KnownPackage -> PackageName -knownPackageName KnownPackage{pinfoId} = packageName pinfoId -knownPackageName KnownPackageName{pinfoName} = pinfoName - -emptyKnownTargets :: KnownTargets -emptyKnownTargets = KnownTargets [] [] [] [] [] [] - -getKnownTargets :: (Applicative m, Monad m) - => DirActions m - -> [PackageSpecifier (SourcePackage (PackageLocation a))] - -> m KnownTargets -getKnownTargets dirActions@DirActions{..} pkgs = do - pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs - cwd <- getCurrentDirectory - let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo - return KnownTargets { - knownPackagesAll = pinfo, - knownPackagesPrimary = ppinfo, - knownPackagesOther = opinfo, - knownComponentsAll = allComponentsIn pinfo, - knownComponentsPrimary = allComponentsIn ppinfo, - knownComponentsOther = allComponentsIn opinfo - } - where - selectPrimaryPackage :: FilePath - -> [KnownPackage] - -> ([KnownPackage], [KnownPackage]) - selectPrimaryPackage cwd = partition isPkgDirCwd - where - isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) } - | dir == cwd = True - isPkgDirCwd _ = False - allComponentsIn ps = - [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] - - -collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m - -> PackageSpecifier (SourcePackage (PackageLocation a)) - -> m KnownPackage -collectKnownPackageInfo _ (NamedPackage pkgname _props) = - return (KnownPackageName pkgname) -collectKnownPackageInfo dirActions@DirActions{..} - (SpecificSourcePackage SourcePackage { - srcpkgDescription = pkg, - srcpkgSource = loc - }) = do - (pkgdir, pkgfile) <- - case loc of - --TODO: local tarballs, remote tarballs etc - LocalUnpackedPackage dir -> do - dirabs <- canonicalizePath dir - dirrel <- makeRelativeToCwd dirActions dirabs - --TODO: ought to get this earlier in project reading - let fileabs = dirabs prettyShow (packageName pkg) <.> "cabal" - filerel = dirrel prettyShow (packageName pkg) <.> "cabal" - exists <- doesFileExist fileabs - return ( Just (dirabs, dirrel) - , if exists then Just (fileabs, filerel) else Nothing - ) - _ -> return (Nothing, Nothing) - let pinfo = - KnownPackage { - pinfoId = packageId pkg, - pinfoDirectory = pkgdir, - pinfoPackageFile = pkgfile, - pinfoComponents = collectKnownComponentInfo - (flattenPackageDescription pkg) - } - return pinfo - - -collectKnownComponentInfo :: PackageDescription -> [KnownComponent] -collectKnownComponentInfo pkg = - [ KnownComponent { - cinfoName = componentName c, - cinfoStrName = componentStringName (packageName pkg) (componentName c), - cinfoPackageId = packageId pkg, - cinfoSrcDirs = ordNub (hsSourceDirs bi), - cinfoModules = ordNub (componentModules c), - cinfoHsFiles = ordNub (componentHsFiles c), - cinfoCFiles = ordNub (cSources bi), - cinfoJsFiles = ordNub (jsSources bi) - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] - - -componentStringName :: PackageName -> ComponentName -> ComponentStringName -componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname -componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name -componentStringName _ (CFLibName name) = unUnqualComponentName name -componentStringName _ (CExeName name) = unUnqualComponentName name -componentStringName _ (CTestName name) = unUnqualComponentName name -componentStringName _ (CBenchName name) = unUnqualComponentName name - -componentModules :: Component -> [ModuleName] --- I think it's unlikely users will ask to build a requirement --- which is not mentioned locally. -componentModules (CLib lib) = explicitLibModules lib -componentModules (CFLib flib) = foreignLibModules flib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test -componentModules (CBench bench) = benchmarkModules bench - -componentHsFiles :: Component -> [FilePath] -componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] - - ------------------------------- --- Matching meta targets --- - -guardNamespaceMeta :: String -> Match () -guardNamespaceMeta = guardToken [""] "meta namespace" - -guardMetaAll :: String -> Match () -guardMetaAll = guardToken ["all"] "meta-target 'all'" - -guardNamespacePackage :: String -> Match () -guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace" - -guardNamespaceCwd :: String -> Match () -guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace" - -guardNamespaceModule :: String -> Match () -guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace" - -guardNamespaceFile :: String -> Match () -guardNamespaceFile = guardToken ["file"] "'file' namespace" - -guardToken :: [String] -> String -> String -> Match () -guardToken tokens msg s - | caseFold s `elem` tokens = increaseConfidence - | otherwise = matchErrorExpected msg s - - ------------------------------- --- Matching component kinds --- - -componentKind :: ComponentName -> ComponentKind -componentKind (CLibName _) = LibKind -componentKind (CFLibName _) = FLibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind -componentKind (CBenchName _) = BenchKind - -cinfoKind :: KnownComponent -> ComponentKind -cinfoKind = componentKind . cinfoName - -matchComponentKind :: String -> Match ComponentKind -matchComponentKind s - | s' `elem` liblabels = increaseConfidence >> return LibKind - | s' `elem` fliblabels = increaseConfidence >> return FLibKind - | s' `elem` exelabels = increaseConfidence >> return ExeKind - | s' `elem` testlabels = increaseConfidence >> return TestKind - | s' `elem` benchlabels = increaseConfidence >> return BenchKind - | otherwise = matchErrorExpected "component kind" s - where - s' = caseFold s - liblabels = ["lib", "library"] - fliblabels = ["flib", "foreign-library"] - exelabels = ["exe", "executable"] - testlabels = ["tst", "test", "test-suite"] - benchlabels = ["bench", "benchmark"] - -matchComponentKindFilter :: String -> Match ComponentKind -matchComponentKindFilter s - | s' `elem` liblabels = increaseConfidence >> return LibKind - | s' `elem` fliblabels = increaseConfidence >> return FLibKind - | s' `elem` exelabels = increaseConfidence >> return ExeKind - | s' `elem` testlabels = increaseConfidence >> return TestKind - | s' `elem` benchlabels = increaseConfidence >> return BenchKind - | otherwise = matchErrorExpected "component kind filter" s - where - s' = caseFold s - liblabels = ["libs", "libraries"] - fliblabels = ["flibs", "foreign-libraries"] - exelabels = ["exes", "executables"] - testlabels = ["tests", "test-suites"] - benchlabels = ["benches", "benchmarks"] - -showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind FLibKind = "foreign library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" -showComponentKind BenchKind = "benchmark" - -showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort FLibKind = "flib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" -showComponentKindShort BenchKind = "bench" - -showComponentKindFilterShort :: ComponentKind -> String -showComponentKindFilterShort LibKind = "libs" -showComponentKindFilterShort FLibKind = "flibs" -showComponentKindFilterShort ExeKind = "exes" -showComponentKindFilterShort TestKind = "tests" -showComponentKindFilterShort BenchKind = "benchmarks" - - ------------------------------- --- Matching package targets --- - -guardPackage :: String -> FileStatus -> Match () -guardPackage str fstatus = - guardPackageName str - <|> guardPackageDir str fstatus - <|> guardPackageFile str fstatus - - -guardPackageName :: String -> Match () -guardPackageName s - | validPackageName s = increaseConfidence - | otherwise = matchErrorExpected "package name" s - -validPackageName :: String -> Bool -validPackageName s = - all validPackageNameChar s - && not (null s) - where - validPackageNameChar c = isAlphaNum c || c == '-' - - -guardPackageDir :: String -> FileStatus -> Match () -guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence -guardPackageDir str _ = matchErrorExpected "package directory" str - - -guardPackageFile :: String -> FileStatus -> Match () -guardPackageFile _ (FileStatusExistsFile file) - | takeExtension file == ".cabal" - = increaseConfidence -guardPackageFile str _ = matchErrorExpected "package .cabal file" str - - -matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage -matchPackage pinfo = \str fstatus -> - orNoThingIn "project" "" $ - matchPackageName pinfo str - (matchPackageNameUnknown str - <|> matchPackageDir pinfo str fstatus - <|> matchPackageFile pinfo str fstatus) - - -matchPackageName :: [KnownPackage] -> String -> Match KnownPackage -matchPackageName ps = \str -> do - guard (validPackageName str) - orNoSuchThing "package" str - (map (prettyShow . knownPackageName) ps) $ - increaseConfidenceFor $ - matchInexactly caseFold (prettyShow . knownPackageName) ps str - - -matchPackageNameUnknown :: String -> Match KnownPackage -matchPackageNameUnknown str = do - pn <- matchParse str - unknownMatch (KnownPackageName pn) - - -matchPackageDir :: [KnownPackage] - -> String -> FileStatus -> Match KnownPackage -matchPackageDir ps = \str fstatus -> - case fstatus of - FileStatusExistsDir canondir -> - orNoSuchThing "package directory" str (map (snd . fst) dirs) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) dirs canondir - _ -> mzero - where - dirs = [ ((dabs,drel),p) - | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ] - - -matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage -matchPackageFile ps = \str fstatus -> do - case fstatus of - FileStatusExistsFile canonfile -> - orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) files canonfile - _ -> mzero - where - files = [ ((fabs,frel),p) - | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ] - ---TODO: test outcome when dir exists but doesn't match any known one - ---TODO: perhaps need another distinction, vs no such thing, point is the --- thing is not known, within the project, but could be outside project - - ------------------------------- --- Matching component targets --- - - -guardComponentName :: String -> Match () -guardComponentName s - | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s - where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' - - -matchComponentName :: [KnownComponent] -> String -> Match KnownComponent -matchComponentName cs str = - orNoSuchThing "component" str (map cinfoStrName cs) - $ increaseConfidenceFor - $ matchInexactly caseFold cinfoStrName cs str - - -matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String - -> Match KnownComponent -matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - (map render cs) - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - (\c -> (cinfoKind c, cinfoStrName c)) - cs - (ckind, str) - where - render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c - - ------------------------------- --- Matching module targets --- - -guardModuleName :: String -> Match () -guardModuleName s = - case simpleParsec s :: Maybe ModuleName of - Just _ -> increaseConfidence - _ | all validModuleChar s - && not (null s) -> return () - | otherwise -> matchErrorExpected "module name" s - where - validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' - - -matchModuleName :: [ModuleName] -> String -> Match ModuleName -matchModuleName ms str = - orNoSuchThing "module" str (map prettyShow ms) - $ increaseConfidenceFor - $ matchInexactly caseFold prettyShow ms str - - -matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) -matchModuleNameAnd ms str = - orNoSuchThing "module" str (map (prettyShow . fst) ms) - $ increaseConfidenceFor - $ matchInexactly caseFold (prettyShow . fst) ms str - - -matchModuleNameUnknown :: String -> Match ModuleName -matchModuleNameUnknown str = - expecting "module" str - $ increaseConfidenceFor - $ matchParse str - - ------------------------------- --- Matching file targets --- - -matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus - -> Match (FilePath, KnownPackage) -matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = - increaseConfidenceFor $ - matchDirectoryPrefix pkgdirs filepath - where - pkgdirs = [ (dir, p) - | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] -matchPackageDirectoryPrefix _ _ = mzero - - -matchComponentFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) -matchComponentFile cs str = - orNoSuchThing "file" str [] $ - matchComponentModuleFile cs str - <|> matchComponentOtherFile cs str - - -matchComponentOtherFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) -matchComponentOtherFile cs = - matchFile - [ (normalise (srcdir file), c) - | c <- cs - , srcdir <- cinfoSrcDirs c - , file <- cinfoHsFiles c - ++ cinfoCFiles c - ++ cinfoJsFiles c - ] - . normalise - - -matchComponentModuleFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) -matchComponentModuleFile cs str = do - matchFile - [ (normalise (d toFilePath m), c) - | c <- cs - , d <- cinfoSrcDirs c - , m <- cinfoModules c - ] - (dropExtension (normalise str)) -- Drop the extension because FileTarget - -- is stored without the extension - --- utils - -matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) -matchFile fs = - increaseConfidenceFor - . matchInexactly caseFold fst fs - -matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) -matchDirectoryPrefix dirs filepath = - tryEach $ - [ (file, x) - | (dir,x) <- dirs - , file <- maybeToList (stripDirectory dir) ] - where - stripDirectory :: FilePath -> Maybe FilePath - stripDirectory dir = - joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit - - filepathsplit = splitDirectories filepath - - ------------------------------- --- Matching monad --- - --- | A matcher embodies a way to match some input as being some recognised --- value. In particular it deals with multiple and ambiguous matches. --- --- There are various matcher primitives ('matchExactly', 'matchInexactly'), --- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we --- can run a matcher against an input using 'findMatch'. --- -data Match a = NoMatch !Confidence [MatchError] - | Match !MatchClass !Confidence [a] - deriving Show - --- | The kind of match, inexact or exact. We keep track of this so we can --- prefer exact over inexact matches. The 'Ord' here is important: we try --- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. --- -data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package - -- name without it being a specific known package - | Inexact -- ^ Matches a known thing inexactly - -- e.g. matches a known package case insensitively - | Exact -- ^ Exactly matches a known thing, - -- e.g. matches a known package case sensitively - deriving (Show, Eq, Ord) - -type Confidence = Int - -data MatchError = MatchErrorExpected String String -- thing got - | MatchErrorNoSuch String String [String] -- thing got alts - | MatchErrorIn String String MatchError -- kind thing - deriving (Show, Eq) - - -instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (Match m d xs) = Match m d (fmap f xs) - -instance Applicative Match where - pure a = Match Exact 0 [a] - (<*>) = ap - -instance Alternative Match where - empty = NoMatch 0 [] - (<|>) = matchPlus - -instance Monad Match where - return = pure - NoMatch d ms >>= _ = NoMatch d ms - Match m d xs >>= f = - -- To understand this, it needs to be read in context with the - -- implementation of 'matchPlus' below - case msum (map f xs) of - Match m' d' xs' -> Match (min m m') (d + d') xs' - -- The minimum match class is the one we keep. The match depth is - -- tracked but not used in the Match case. - - NoMatch d' ms -> NoMatch (d + d') ms - -- Here is where we transfer the depth we were keeping track of in - -- the Match case over to the NoMatch case where it finally gets used. - -instance MonadPlus Match where - mzero = empty - mplus = matchPlus - -() :: Match a -> Match a -> Match a -() = matchPlusShadowing - -infixl 3 - --- | Combine two matchers. Exact matches are used over inexact matches --- but if we have multiple exact, or inexact then the we collect all the --- ambiguous matches. --- --- This operator is associative, has unit 'mzero' and is also commutative. --- -matchPlus :: Match a -> Match a -> Match a -matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a -matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b -matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b) - | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. - | d_a < d_b = b - | otherwise = NoMatch d_a (ms_a ++ ms_b) -matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) - | m_a > m_b = a -- exact over inexact - | m_a < m_b = b -- exact over inexact - | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b) - --- | Combine two matchers. This is similar to 'matchPlus' with the --- difference that an exact match from the left matcher shadows any exact --- match on the right. Inexact matches are still collected however. --- --- This operator is associative, has unit 'mzero' and is not commutative. --- -matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(Match Exact _ _) _ = a -matchPlusShadowing a b = matchPlus a b - - ------------------------------- --- Various match primitives --- - -matchErrorExpected :: String -> String -> Match a -matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] - -matchErrorNoSuch :: String -> String -> [String] -> Match a -matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] - -expecting :: String -> String -> Match a -> Match a -expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m - -orNoSuchThing :: String -> String -> [String] -> Match a -> Match a -orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts -orNoSuchThing _ _ _ m = m - -orNoThingIn :: String -> String -> Match a -> Match a -orNoThingIn kind name (NoMatch n ms) = - NoMatch n [ MatchErrorIn kind name m | m <- ms ] -orNoThingIn _ _ m = m - -increaseConfidence :: Match () -increaseConfidence = Match Exact 1 [()] - -increaseConfidenceFor :: Match a -> Match a -increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r - -nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a -nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs -nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) - --- | Lift a list of matches to an exact match. --- -exactMatches, inexactMatches :: [a] -> Match a - -exactMatches [] = mzero -exactMatches xs = Match Exact 0 xs - -inexactMatches [] = mzero -inexactMatches xs = Match Inexact 0 xs - -unknownMatch :: a -> Match a -unknownMatch x = Match Unknown 0 [x] - -tryEach :: [a] -> Match a -tryEach = exactMatches - - ------------------------------- --- Top level match runner --- - --- | Given a matcher and a key to look up, use the matcher to find all the --- possible matches. There may be 'None', a single 'Unambiguous' match or --- you may have an 'Ambiguous' match with several possibilities. --- -findMatch :: Match a -> MaybeAmbiguous a -findMatch match = case match of - NoMatch _ msgs -> None msgs - Match _ _ [x] -> Unambiguous x - Match m d [] -> error $ "findMatch: impossible: " ++ show match' - where match' = Match m d [] :: Match () - -- TODO: Maybe use Data.List.NonEmpty inside - -- Match so that this case would be correct - -- by construction? - Match m _ xs -> Ambiguous m xs - -data MaybeAmbiguous a = None [MatchError] - | Unambiguous a - | Ambiguous MatchClass [a] - deriving Show - - ------------------------------- --- Basic matchers --- - --- | A primitive matcher that looks up a value in a finite 'Map'. The --- value must match exactly. --- -matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) -matchExactly key xs = - \k -> case Map.lookup k m of - Nothing -> mzero - Just ys -> exactMatches ys - where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] - --- | A primitive matcher that looks up a value in a finite 'Map'. It checks --- for an exact or inexact match. We get an inexact match if the match --- is not exact, but the canonical forms match. It takes a canonicalisation --- function for this purpose. --- --- So for example if we used string case fold as the canonicalisation --- function, then we would get case insensitive matching (but it will still --- report an exact match when the case matches too). --- -matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) - -> [a] -> (k -> Match a) -matchInexactly cannonicalise key xs = - \k -> case Map.lookup k m of - Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise k) m' of - Just ys -> inexactMatches ys - Nothing -> mzero - where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] - - -- the map of canonicalised keys to groups of inexact matches - m' = Map.mapKeysWith (++) cannonicalise m - -matchParse :: Parsec a => String -> Match a -matchParse = maybe mzero return . simpleParsec - - ------------------------------- --- Utils --- - -caseFold :: String -> String -caseFold = lowercase - --- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the --- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's --- primary library from named private libraries. --- -mkComponentName :: PackageName - -> ComponentKind - -> UnqualComponentName - -> ComponentName -mkComponentName pkgname ckind ucname = - case ckind of - LibKind - | packageNameToUnqualComponentName pkgname == ucname - -> CLibName LMainLibName - | otherwise -> CLibName $ LSubLibName ucname - FLibKind -> CFLibName ucname - ExeKind -> CExeName ucname - TestKind -> CTestName ucname - BenchKind -> CBenchName ucname - - ------------------------------- --- Example inputs --- - -{- -ex1pinfo :: [KnownPackage] -ex1pinfo = - [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ - KnownPackage { - pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), - pinfoDirectory = Just ("/the/foo", "foo"), - pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), - pinfoComponents = [] - } - , KnownPackage { - pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), - pinfoDirectory = Just ("/the/bar", "bar"), - pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), - pinfoComponents = [] - } - ] - where - addComponent n ds ms p = - p { - pinfoComponents = - KnownComponent n (componentStringName (pinfoId p) n) - p ds (map mkMn ms) - [] [] [] - : pinfoComponents p - } - - mkMn :: String -> ModuleName - mkMn = ModuleName.fromString --} -{- -stargets = - [ TargetComponent (CExeName "foo") WholeComponent - , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo")) - , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo")) - ] - where - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - -ex_pkgid :: PackageIdentifier -Just ex_pkgid = simpleParse "thelib" --} - -{- -ex_cs :: [KnownComponent] -ex_cs = - [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) - , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) - ] - where - mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms) - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - pkgid :: PackageIdentifier - Just pkgid = simpleParse "thelib" --} diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs deleted file mode 100644 --- a/Distribution/Client/Targets.hs +++ /dev/null @@ -1,746 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Targets --- Copyright : (c) Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified targets ------------------------------------------------------------------------------ -module Distribution.Client.Targets ( - -- * User targets - UserTarget(..), - readUserTargets, - - -- * Resolving user targets to package specifiers - resolveUserTargets, - - -- ** Detailed interface - UserTargetProblem(..), - readUserTarget, - reportUserTargetProblems, - expandUserTarget, - - PackageTarget(..), - fetchPackageTarget, - readPackageTarget, - - PackageTargetProblem(..), - reportPackageTargetProblems, - - disambiguatePackageTargets, - disambiguatePackageName, - - -- * User constraints - UserQualifier(..), - UserConstraintScope(..), - UserConstraint(..), - userConstraintPackageName, - readUserConstraint, - userToPackageConstraint, - - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Package - ( Package(..), PackageName, unPackageName, mkPackageName - , packageName ) -import Distribution.Types.Dependency -import Distribution.Client.Types - ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage - , PackageSpecifier(..) ) - -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackageIndex (PackageIndex) -import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage - -import qualified Distribution.Client.World as World -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.FetchUtils -import Distribution.Client.Utils ( tryFindPackageDesc ) -import Distribution.Client.GlobalFlags - ( RepoContext(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint (..) ) - -import Distribution.PackageDescription - ( GenericPackageDescription ) -import Distribution.Types.Flag - ( nullFlagAssignment, parsecFlagAssignmentNonEmpty ) -import Distribution.Version - ( anyVersion, isAnyVersion ) -import Distribution.Simple.Utils - ( die', warn, lowercase ) - -import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) - -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as BS -import qualified Distribution.Client.GZipUtils as GZipUtils -import qualified Distribution.Compat.CharParsing as P -import System.FilePath - ( takeExtension, dropExtension, takeDirectory, splitPath ) -import System.Directory - ( doesFileExist, doesDirectoryExist ) -import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI ) - --- ------------------------------------------------------------ --- * User targets --- ------------------------------------------------------------ - --- | Various ways that a user may specify a package or package collection. --- -data UserTarget = - - -- | A partially specified package, identified by name and possibly with - -- an exact version or a version constraint. - -- - -- > cabal install foo - -- > cabal install foo-1.0 - -- > cabal install 'foo < 2' - -- - UserTargetNamed PackageVersionConstraint - - -- | A special virtual package that refers to the collection of packages - -- recorded in the world file that the user specifically installed. - -- - -- > cabal install world - -- - | UserTargetWorld - - -- | A specific package that is unpacked in a local directory, often the - -- current directory. - -- - -- > cabal install . - -- > cabal install ../lib/other - -- - -- * Note: in future, if multiple @.cabal@ files are allowed in a single - -- directory then this will refer to the collection of packages. - -- - | UserTargetLocalDir FilePath - - -- | A specific local unpacked package, identified by its @.cabal@ file. - -- - -- > cabal install foo.cabal - -- > cabal install ../lib/other/bar.cabal - -- - | UserTargetLocalCabalFile FilePath - - -- | A specific package that is available as a local tarball file - -- - -- > cabal install dist/foo-1.0.tar.gz - -- > cabal install ../build/baz-1.0.tar.gz - -- - | UserTargetLocalTarball FilePath - - -- | A specific package that is available as a remote tarball file - -- - -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz - -- - | UserTargetRemoteTarball URI - deriving (Show,Eq) - - --- ------------------------------------------------------------ --- * Parsing and checking user targets --- ------------------------------------------------------------ - -readUserTargets :: Verbosity -> [String] -> IO [UserTarget] -readUserTargets verbosity targetStrs = do - (problems, targets) <- liftM partitionEithers - (traverse readUserTarget targetStrs) - reportUserTargetProblems verbosity problems - return targets - - -data UserTargetProblem - = UserTargetUnexpectedFile String - | UserTargetNonexistantFile String - | UserTargetUnexpectedUriScheme String - | UserTargetUnrecognisedUri String - | UserTargetUnrecognised String - | UserTargetBadWorldPkg - deriving Show - -readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) -readUserTarget targetstr = - case eitherParsec targetstr of - Right (PackageVersionConstraint pkgn verrange) - | pkgn == mkPackageName "world" - -> return $ if verrange == anyVersion - then Right UserTargetWorld - else Left UserTargetBadWorldPkg - Right dep -> return (Right (UserTargetNamed dep)) - Left _err -> do - fileTarget <- testFileTargets targetstr - case fileTarget of - Just target -> return target - Nothing -> - case testUriTargets targetstr of - Just target -> return target - Nothing -> return (Left (UserTargetUnrecognised targetstr)) - where - testFileTargets filename = do - isDir <- doesDirectoryExist filename - isFile <- doesFileExist filename - parentDirExists <- case takeDirectory filename of - [] -> return False - dir -> doesDirectoryExist dir - let result - | isDir - = Just (Right (UserTargetLocalDir filename)) - - | isFile && extensionIsTarGz filename - = Just (Right (UserTargetLocalTarball filename)) - - | isFile && takeExtension filename == ".cabal" - = Just (Right (UserTargetLocalCabalFile filename)) - - | isFile - = Just (Left (UserTargetUnexpectedFile filename)) - - | parentDirExists - = Just (Left (UserTargetNonexistantFile filename)) - - | otherwise - = Nothing - return result - - testUriTargets str = - case parseAbsoluteURI str of - Just uri@URI { - uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host } - } - | scheme /= "http:" && scheme /= "https:" -> - Just (Left (UserTargetUnexpectedUriScheme targetstr)) - - | null host -> - Just (Left (UserTargetUnrecognisedUri targetstr)) - - | otherwise -> - Just (Right (UserTargetRemoteTarball uri)) - _ -> Nothing - - extensionIsTarGz f = takeExtension f == ".gz" - && takeExtension (dropExtension f) == ".tar" - -reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () -reportUserTargetProblems verbosity problems = do - case [ target | UserTargetUnrecognised target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognised target '" ++ name ++ "'." - | name <- target ] - ++ "Targets can be:\n" - ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" - ++ " - the special 'world' target\n" - ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" - ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" - - case [ () | UserTargetBadWorldPkg <- problems ] of - [] -> return () - _ -> die' verbosity "The special 'world' target does not take any version." - - case [ target | UserTargetNonexistantFile target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "The file does not exist '" ++ name ++ "'." - | name <- target ] - - case [ target | UserTargetUnexpectedFile target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognised file target '" ++ name ++ "'." - | name <- target ] - ++ "File targets can be either package tarballs 'pkgname.tar.gz' " - ++ "or cabal files 'pkgname.cabal'." - - case [ target | UserTargetUnexpectedUriScheme target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "URL target not supported '" ++ name ++ "'." - | name <- target ] - ++ "Only 'http://' and 'https://' URLs are supported." - - case [ target | UserTargetUnrecognisedUri target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognise URL target '" ++ name ++ "'." - | name <- target ] - - --- ------------------------------------------------------------ --- * Resolving user targets to package specifiers --- ------------------------------------------------------------ - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. They can either be specific packages (local dirs, tarballs etc) --- or they can be named packages (with or without version info). --- -resolveUserTargets :: Package pkg - => Verbosity - -> RepoContext - -> FilePath - -> PackageIndex pkg - -> [UserTarget] - -> IO [PackageSpecifier UnresolvedSourcePackage] -resolveUserTargets verbosity repoCtxt worldFile available userTargets = do - - -- given the user targets, get a list of fully or partially resolved - -- package references - packageTargets <- traverse (readPackageTarget verbosity) - =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat - =<< traverse (expandUserTarget verbosity worldFile) userTargets - - -- users are allowed to give package names case-insensitively, so we must - -- disambiguate named package references - let (problems, packageSpecifiers) = - disambiguatePackageTargets available availableExtra packageTargets - - -- use any extra specific available packages to help us disambiguate - availableExtra = [ packageName pkg - | PackageTargetLocation pkg <- packageTargets ] - - reportPackageTargetProblems verbosity problems - - return packageSpecifiers - - --- ------------------------------------------------------------ --- * Package targets --- ------------------------------------------------------------ - --- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. --- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. --- -data PackageTarget pkg = - PackageTargetNamed PackageName [PackageProperty] UserTarget - - -- | A package identified by name, but case insensitively, so it needs - -- to be resolved to the right case-sensitive name. - | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget - | PackageTargetLocation pkg - deriving (Show, Functor, Foldable, Traversable) - - --- ------------------------------------------------------------ --- * Converting user targets to package targets --- ------------------------------------------------------------ - --- | Given a user-specified target, expand it to a bunch of package targets --- (each of which refers to only one package). --- -expandUserTarget :: Verbosity - -> FilePath - -> UserTarget - -> IO [PackageTarget (PackageLocation ())] -expandUserTarget verbosity worldFile userTarget = case userTarget of - - UserTargetNamed (PackageVersionConstraint name vrange) -> - let props = [ PackagePropertyVersion vrange - | not (isAnyVersion vrange) ] - in return [PackageTargetNamedFuzzy name props userTarget] - - UserTargetWorld -> do - worldPkgs <- World.getContents verbosity worldFile - --TODO: should we warn if there are no world targets? - return [ PackageTargetNamed name props userTarget - | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs - , let props = [ PackagePropertyVersion vrange - | not (isAnyVersion vrange) ] - ++ [ PackagePropertyFlags flags - | not (nullFlagAssignment flags) ] ] - - UserTargetLocalDir dir -> - return [ PackageTargetLocation (LocalUnpackedPackage dir) ] - - UserTargetLocalCabalFile file -> do - let dir = takeDirectory file - _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check - return [ PackageTargetLocation (LocalUnpackedPackage dir) ] - - UserTargetLocalTarball tarballFile -> - return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] - - UserTargetRemoteTarball tarballURL -> - return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] - -localPackageError :: FilePath -> String -localPackageError dir = - "Error reading local package.\nCouldn't find .cabal file in: " ++ dir - --- ------------------------------------------------------------ --- * Fetching and reading package targets --- ------------------------------------------------------------ - - --- | Fetch any remote targets so that they can be read. --- -fetchPackageTarget :: Verbosity - -> RepoContext - -> PackageTarget (PackageLocation ()) - -> IO (PackageTarget ResolvedPkgLoc) -fetchPackageTarget verbosity repoCtxt = traverse $ - fetchPackage verbosity repoCtxt . fmap (const Nothing) - - --- | Given a package target that has been fetched, read the .cabal file. --- --- This only affects targets given by location, named targets are unaffected. --- -readPackageTarget :: Verbosity - -> PackageTarget ResolvedPkgLoc - -> IO (PackageTarget UnresolvedSourcePackage) -readPackageTarget verbosity = traverse modifyLocation - where - modifyLocation location = case location of - - LocalUnpackedPackage dir -> do - pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= - readGenericPackageDescription verbosity - return SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing - } - - LocalTarballPackage tarballFile -> - readTarballPackageTarget location tarballFile tarballFile - - RemoteTarballPackage tarballURL tarballFile -> - readTarballPackageTarget location tarballFile (show tarballURL) - - RepoTarballPackage _repo _pkgid _ -> - error "TODO: readPackageTarget RepoTarballPackage" - -- For repo tarballs this info should be obtained from the index. - - RemoteSourceRepoPackage _srcRepo _ -> - error "TODO: readPackageTarget RemoteSourceRepoPackage" - -- This can't happen, because it would have errored out already - -- in fetchPackage, via fetchPackageTarget before it gets to this - -- function. - -- - -- When that is corrected, this will also need to be fixed. - - readTarballPackageTarget location tarballFile tarballOriginalLoc = do - (filename, content) <- extractTarballPackageCabalFile - tarballFile tarballOriginalLoc - case parsePackageDescription' content of - Nothing -> die' verbosity $ "Could not parse the cabal file " - ++ filename ++ " in " ++ tarballFile - Just pkg -> - return SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing - } - - extractTarballPackageCabalFile :: FilePath -> String - -> IO (FilePath, BS.ByteString) - extractTarballPackageCabalFile tarballFile tarballOriginalLoc = - either (die' verbosity . formatErr) return - . check - . accumEntryMap - . Tar.filterEntries isCabalFile - . Tar.read - . GZipUtils.maybeDecompress - =<< BS.readFile tarballFile - where - formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg - - accumEntryMap = Tar.foldlEntries - (\m e -> Map.insert (Tar.entryTarPath e) e m) - Map.empty - - check (Left e) = Left (show e) - check (Right m) = case Map.elems m of - [] -> Left noCabalFile - [file] -> case Tar.entryContent file of - Tar.NormalFile content _ -> Right (Tar.entryPath file, content) - _ -> Left noCabalFile - _files -> Left multipleCabalFiles - where - noCabalFile = "No cabal file found" - multipleCabalFiles = "Multiple cabal files found" - - isCabalFile e = case splitPath (Tar.entryPath e) of - [ _dir, file] -> takeExtension file == ".cabal" - [".", _dir, file] -> takeExtension file == ".cabal" - _ -> False - - parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription - parsePackageDescription' bs = - parseGenericPackageDescriptionMaybe (BS.toStrict bs) - --- ------------------------------------------------------------ --- * Checking package targets --- ------------------------------------------------------------ - -data PackageTargetProblem - = PackageNameUnknown PackageName UserTarget - | PackageNameAmbiguous PackageName [PackageName] UserTarget - deriving Show - - --- | Users are allowed to give package names case-insensitively, so we must --- disambiguate named package references. --- -disambiguatePackageTargets :: Package pkg' - => PackageIndex pkg' - -> [PackageName] - -> [PackageTarget pkg] - -> ( [PackageTargetProblem] - , [PackageSpecifier pkg] ) -disambiguatePackageTargets availablePkgIndex availableExtra targets = - partitionEithers (map disambiguatePackageTarget targets) - where - disambiguatePackageTarget packageTarget = case packageTarget of - PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - - PackageTargetNamed pkgname props userTarget - | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) - -> Left (PackageNameUnknown pkgname userTarget) - | otherwise -> Right (NamedPackage pkgname props) - - PackageTargetNamedFuzzy pkgname props userTarget -> - case disambiguatePackageName packageNameEnv pkgname of - None -> Left (PackageNameUnknown - pkgname userTarget) - Ambiguous pkgnames -> Left (PackageNameAmbiguous - pkgname pkgnames userTarget) - Unambiguous pkgname' -> Right (NamedPackage pkgname' props) - - -- use any extra specific available packages to help us disambiguate - packageNameEnv :: PackageNameEnv - packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) - (extraPackageNameEnv availableExtra) - - --- | Report problems to the user. That is, if there are any problems --- then raise an exception. -reportPackageTargetProblems :: Verbosity - -> [PackageTargetProblem] -> IO () -reportPackageTargetProblems verbosity problems = do - case [ pkg | PackageNameUnknown pkg originalTarget <- problems - , not (isUserTagetWorld originalTarget) ] of - [] -> return () - pkgs -> die' verbosity $ unlines - [ "There is no package named '" ++ prettyShow name ++ "'. " - | name <- pkgs ] - ++ "You may need to run 'cabal update' to get the latest " - ++ "list of available packages." - - case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of - [] -> return () - ambiguities -> die' verbosity $ unlines - [ "There is no package named '" ++ prettyShow name ++ "'. " - ++ (if length matches > 1 - then "However, the following package names exist: " - else "However, the following package name exists: ") - ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches] - ++ "." - | (name, matches) <- ambiguities ] - - case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of - [] -> return () - pkgs -> warn verbosity $ - "The following 'world' packages will be ignored because " - ++ "they refer to packages that cannot be found: " - ++ intercalate ", " (map prettyShow pkgs) ++ "\n" - ++ "You can suppress this warning by correcting the world file." - where - isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False - - --- ------------------------------------------------------------ --- * Disambiguating package names --- ------------------------------------------------------------ - -data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] - --- | Given a package name and a list of matching names, figure out --- which one it might be referring to. If there is an exact --- case-sensitive match then that's ok (i.e. returned via --- 'Unambiguous'). If it matches just one package case-insensitively --- or if it matches multiple packages case-insensitively, in that case --- the result is 'Ambiguous'. --- --- Note: Before cabal 2.2, when only a single package matched --- case-insensitively it would be considered 'Unambigious'. --- -disambiguatePackageName :: PackageNameEnv - -> PackageName - -> MaybeAmbiguous PackageName -disambiguatePackageName (PackageNameEnv pkgNameLookup) name = - case nub (pkgNameLookup name) of - [] -> None - names -> case find (name==) names of - Just name' -> Unambiguous name' - Nothing -> Ambiguous names - - -newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) - -instance Monoid PackageNameEnv where - mempty = PackageNameEnv (const []) - mappend = (<>) - -instance Semigroup PackageNameEnv where - PackageNameEnv lookupA <> PackageNameEnv lookupB = - PackageNameEnv (\name -> lookupA name ++ lookupB name) - -indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv -indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup - where - pkgNameLookup pname = - map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname) - -extraPackageNameEnv :: [PackageName] -> PackageNameEnv -extraPackageNameEnv names = PackageNameEnv pkgNameLookup - where - pkgNameLookup pname = - [ pname' - | let lname = lowercase (unPackageName pname) - , pname' <- names - , lowercase (unPackageName pname') == lname ] - - --- ------------------------------------------------------------ --- * Package constraints --- ------------------------------------------------------------ - --- | Version of 'Qualifier' that a user may specify on the --- command line. -data UserQualifier = - -- | Top-level dependency. - UserQualToplevel - - -- | Setup dependency. - | UserQualSetup PackageName - - -- | Executable dependency. - | UserQualExe PackageName PackageName - deriving (Eq, Show, Generic) - -instance Binary UserQualifier -instance Structured UserQualifier - --- | Version of 'ConstraintScope' that a user may specify on the --- command line. -data UserConstraintScope = - -- | Scope that applies to the package when it has the specified qualifier. - UserQualified UserQualifier PackageName - - -- | Scope that applies to the package when it has a setup qualifier. - | UserAnySetupQualifier PackageName - - -- | Scope that applies to the package when it has any qualifier. - | UserAnyQualifier PackageName - deriving (Eq, Show, Generic) - -instance Binary UserConstraintScope -instance Structured UserConstraintScope - -fromUserQualifier :: UserQualifier -> Qualifier -fromUserQualifier UserQualToplevel = QualToplevel -fromUserQualifier (UserQualSetup name) = QualSetup name -fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 - -fromUserConstraintScope :: UserConstraintScope -> ConstraintScope -fromUserConstraintScope (UserQualified q pn) = - ScopeQualified (fromUserQualifier q) pn -fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn -fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn - --- | Version of 'PackageConstraint' that the user can specify on --- the command line. -data UserConstraint = - UserConstraint UserConstraintScope PackageProperty - deriving (Eq, Show, Generic) - -instance Binary UserConstraint -instance Structured UserConstraint - -userConstraintPackageName :: UserConstraint -> PackageName -userConstraintPackageName (UserConstraint scope _) = scopePN scope - where - scopePN (UserQualified _ pn) = pn - scopePN (UserAnyQualifier pn) = pn - scopePN (UserAnySetupQualifier pn) = pn - -userToPackageConstraint :: UserConstraint -> PackageConstraint -userToPackageConstraint (UserConstraint scope prop) = - PackageConstraint (fromUserConstraintScope scope) prop - -readUserConstraint :: String -> Either String UserConstraint -readUserConstraint str = - case explicitEitherParsec parsec str of - Left err -> Left $ msgCannotParse ++ err - Right c -> Right c - where - msgCannotParse = - "expected a (possibly qualified) package name followed by a " ++ - "constraint, which is either a version range, 'installed', " ++ - "'source', 'test', 'bench', or flags. " - -instance Pretty UserConstraint where - pretty (UserConstraint scope prop) = - dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop - -instance Parsec UserConstraint where - parsec = do - scope <- parseConstraintScope - P.spaces - prop <- P.choice - [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-" - , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be) - , PackagePropertyInstalled <$ P.string "installed" - , PackagePropertySource <$ P.string "source" - , PackagePropertyStanzas [TestStanzas] <$ P.string "test" - , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" - ] - return (UserConstraint scope prop) - - where - parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope - parseConstraintScope = do - pn <- parsec - P.choice - [ P.char '.' *> withDot pn - , P.char ':' *> withColon pn - , return (UserQualified UserQualToplevel pn) - ] - where - withDot :: PackageName -> m UserConstraintScope - withDot pn - | pn == mkPackageName "any" = UserAnyQualifier <$> parsec - | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec - | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn - - withColon :: PackageName -> m UserConstraintScope - withColon pn = UserQualified (UserQualSetup pn) - <$ P.string "setup." - <*> parsec diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs deleted file mode 100644 --- a/Distribution/Client/Types.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Types --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Various common data types for the entire cabal-install system ------------------------------------------------------------------------------ -module Distribution.Client.Types ( - module Distribution.Client.Types.AllowNewer, - module Distribution.Client.Types.ConfiguredId, - module Distribution.Client.Types.ConfiguredPackage, - module Distribution.Client.Types.BuildResults, - module Distribution.Client.Types.PackageLocation, - module Distribution.Client.Types.PackageSpecifier, - module Distribution.Client.Types.ReadyPackage, - module Distribution.Client.Types.Repo, - module Distribution.Client.Types.RepoName, - module Distribution.Client.Types.SourcePackageDb, - module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy, -) where - - -import Distribution.Client.Types.AllowNewer -import Distribution.Client.Types.BuildResults -import Distribution.Client.Types.ConfiguredId -import Distribution.Client.Types.ConfiguredPackage -import Distribution.Client.Types.PackageLocation -import Distribution.Client.Types.PackageSpecifier -import Distribution.Client.Types.Repo -import Distribution.Client.Types.RepoName -import Distribution.Client.Types.ReadyPackage -import Distribution.Client.Types.SourcePackageDb -import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy diff --git a/Distribution/Client/Types/AllowNewer.hs b/Distribution/Client/Types/AllowNewer.hs deleted file mode 100644 --- a/Distribution/Client/Types/AllowNewer.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.AllowNewer ( - AllowNewer (..), - AllowOlder (..), - RelaxDeps (..), - mkRelaxDepSome, - RelaxDepMod (..), - RelaxDepScope (..), - RelaxDepSubject (..), - RelaxedDep (..), - isRelaxDeps, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Parsec (parsecLeadingCommaNonEmpty) -import Distribution.Types.PackageId (PackageId, PackageIdentifier (..)) -import Distribution.Types.PackageName (PackageName, mkPackageName) -import Distribution.Types.Version (nullVersion) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- $setup --- >>> import Distribution.Parsec - --- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled, --- it may make sense to move these definitions to the Solver.Types --- module - --- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag) -newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps } - deriving (Eq, Read, Show, Generic) - --- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) -newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } - deriving (Eq, Read, Show, Generic) - --- | Generic data type for policy when relaxing bounds in dependencies. --- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending --- on whether or not you are relaxing an lower or upper bound --- (respectively). -data RelaxDeps = - - -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages. - -- - -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all - -- dependencies, never choose versions newer (resp. older) than allowed. - RelaxDepsSome [RelaxedDep] - - -- | Ignore upper (resp. lower) bounds in dependencies on all packages. - -- - -- __Note__: This is should be semantically equivalent to - -- - -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] - -- - -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep') - | RelaxDepsAll - deriving (Eq, Read, Show, Generic) - --- | Dependencies can be relaxed either for all packages in the install plan, or --- only for some packages. -data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject - deriving (Eq, Read, Show, Generic) - --- | Specify the scope of a relaxation, i.e. limit which depending --- packages are allowed to have their version constraints relaxed. -data RelaxDepScope = RelaxDepScopeAll - -- ^ Apply relaxation in any package - | RelaxDepScopePackage !PackageName - -- ^ Apply relaxation to in all versions of a package - | RelaxDepScopePackageId !PackageId - -- ^ Apply relaxation to a specific version of a package only - deriving (Eq, Read, Show, Generic) - --- | Modifier for dependency relaxation -data RelaxDepMod = RelaxDepModNone -- ^ Default semantics - | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints - deriving (Eq, Read, Show, Generic) - --- | Express whether to relax bounds /on/ @all@ packages, or a single package -data RelaxDepSubject = RelaxDepSubjectAll - | RelaxDepSubjectPkg !PackageName - deriving (Eq, Ord, Read, Show, Generic) - -instance Pretty RelaxedDep where - pretty (RelaxedDep scope rdmod subj) = case scope of - RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep - RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep - RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep - where - modDep = case rdmod of - RelaxDepModNone -> pretty subj - RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj - -instance Parsec RelaxedDep where - parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) - --- continuation after * -relaxedDepStarP :: CabalParsing m => m RelaxedDep -relaxedDepStarP = - RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec - <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) - --- continuation after package identifier -relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep -relaxedDepPkgidP pid@(PackageIdentifier pn v) - | pn == mkPackageName "all" - , v == nullVersion - = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec - <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) - - | v == nullVersion - = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec - <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)) - - | otherwise - = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec - -modP :: P.CharParsing m => m RelaxDepMod -modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone - -instance Pretty RelaxDepSubject where - pretty RelaxDepSubjectAll = Disp.text "*" - pretty (RelaxDepSubjectPkg pn) = pretty pn - -instance Parsec RelaxDepSubject where - parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn - where - pkgn = do - pn <- parsec - pure $ if pn == mkPackageName "all" - then RelaxDepSubjectAll - else RelaxDepSubjectPkg pn - -instance Pretty RelaxDeps where - pretty rd | not (isRelaxDeps rd) = Disp.text "none" - pretty (RelaxDepsSome pkgs) = Disp.fsep . - Disp.punctuate Disp.comma . - map pretty $ pkgs - pretty RelaxDepsAll = Disp.text "all" - --- | --- --- >>> simpleParsec "all" :: Maybe RelaxDeps --- Just RelaxDepsAll --- --- >>> simpleParsec "none" :: Maybe RelaxDeps --- Just (RelaxDepsSome []) --- --- >>> simpleParsec "*, *" :: Maybe RelaxDeps --- Just RelaxDepsAll --- --- >>> simpleParsec "*:*" :: Maybe RelaxDeps --- Just RelaxDepsAll --- --- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps --- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))]) --- --- This is not a glitch, even it looks like: --- --- >>> simpleParsec ", all" :: Maybe RelaxDeps --- Just RelaxDepsAll --- --- >>> simpleParsec "" :: Maybe RelaxDeps --- Nothing --- -instance Parsec RelaxDeps where - parsec = do - xs <- parsecLeadingCommaNonEmpty parsec - pure $ case toList xs of - [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] - -> RelaxDepsAll - [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)] - | pn == mkPackageName "none" - -> mempty - xs' -> mkRelaxDepSome xs' - -instance Binary RelaxDeps -instance Binary RelaxDepMod -instance Binary RelaxDepScope -instance Binary RelaxDepSubject -instance Binary RelaxedDep -instance Binary AllowNewer -instance Binary AllowOlder - -instance Structured RelaxDeps -instance Structured RelaxDepMod -instance Structured RelaxDepScope -instance Structured RelaxDepSubject -instance Structured RelaxedDep -instance Structured AllowNewer -instance Structured AllowOlder - --- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations --- --- Equivalent to @isRelaxDeps = (/= 'mempty')@ -isRelaxDeps :: RelaxDeps -> Bool -isRelaxDeps (RelaxDepsSome []) = False -isRelaxDeps (RelaxDepsSome (_:_)) = True -isRelaxDeps RelaxDepsAll = True - --- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@. -mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps -mkRelaxDepSome xs - | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs - = RelaxDepsAll - - | otherwise - = RelaxDepsSome xs - --- | 'RelaxDepsAll' is the /absorbing element/ -instance Semigroup RelaxDeps where - -- identity element - RelaxDepsSome [] <> r = r - l@(RelaxDepsSome _) <> RelaxDepsSome [] = l - -- absorbing element - l@RelaxDepsAll <> _ = l - (RelaxDepsSome _) <> r@RelaxDepsAll = r - -- combining non-{identity,absorbing} elements - (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) - --- | @'RelaxDepsSome' []@ is the /identity element/ -instance Monoid RelaxDeps where - mempty = RelaxDepsSome [] - mappend = (<>) - -instance Semigroup AllowNewer where - AllowNewer x <> AllowNewer y = AllowNewer (x <> y) - -instance Semigroup AllowOlder where - AllowOlder x <> AllowOlder y = AllowOlder (x <> y) - -instance Monoid AllowNewer where - mempty = AllowNewer mempty - mappend = (<>) - -instance Monoid AllowOlder where - mempty = AllowOlder mempty - mappend = (<>) diff --git a/Distribution/Client/Types/BuildResults.hs b/Distribution/Client/Types/BuildResults.hs deleted file mode 100644 --- a/Distribution/Client/Types/BuildResults.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.BuildResults ( - BuildOutcome, - BuildOutcomes, - BuildFailure (..), - BuildResult (..), - TestsResult (..), - DocsResult (..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Types.PackageId (PackageId) -import Distribution.Types.UnitId (UnitId) - --- | A summary of the outcome for building a single package. --- -type BuildOutcome = Either BuildFailure BuildResult - --- | A summary of the outcome for building a whole set of packages. --- -type BuildOutcomes = Map UnitId BuildOutcome - -data BuildFailure = PlanningFailed - | DependentFailed PackageId - | DownloadFailed SomeException - | UnpackFailed SomeException - | ConfigureFailed SomeException - | BuildFailed SomeException - | TestsFailed SomeException - | InstallFailed SomeException - deriving (Show, Typeable, Generic) - -instance Exception BuildFailure - --- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only --- the public library's 'InstalledPackageInfo' is stored here, even if --- there were 'InstalledPackageInfo' from internal libraries. This --- 'InstalledPackageInfo' is not used anyway, so it makes no difference. -data BuildResult = BuildResult DocsResult TestsResult - (Maybe InstalledPackageInfo) - deriving (Show, Generic) - -data DocsResult = DocsNotTried | DocsFailed | DocsOk - deriving (Show, Generic, Typeable) -data TestsResult = TestsNotTried | TestsOk - deriving (Show, Generic, Typeable) - -instance Binary BuildFailure -instance Binary BuildResult -instance Binary DocsResult -instance Binary TestsResult - -instance Structured BuildFailure -instance Structured BuildResult -instance Structured DocsResult -instance Structured TestsResult diff --git a/Distribution/Client/Types/ConfiguredId.hs b/Distribution/Client/Types/ConfiguredId.hs deleted file mode 100644 --- a/Distribution/Client/Types/ConfiguredId.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.ConfiguredId ( - InstalledPackageId, - ConfiguredId (..), - annotatedIdToConfiguredId, - HasConfiguredId (..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId) -import Distribution.Package (Package (..)) -import Distribution.Types.AnnotatedId (AnnotatedId (..)) -import Distribution.Types.ComponentId (ComponentId) -import Distribution.Types.ComponentName (ComponentName) -import Distribution.Types.PackageId (PackageId) - -------------------------------------------------------------------------------- --- InstalledPackageId -------------------------------------------------------------------------------- - --- | Within Cabal the library we no longer have a @InstalledPackageId@ type. --- That's because it deals with the compilers' notion of a registered library, --- and those really are libraries not packages. Those are now named units. --- --- The package management layer does however deal with installed packages, as --- whole packages not just as libraries. So we do still need a type for --- installed package ids. At the moment however we track instaled packages via --- their primary library, which is a unit id. In future this may change --- slightly and we may distinguish these two types and have an explicit --- conversion when we register units with the compiler. --- -type InstalledPackageId = ComponentId - -------------------------------------------------------------------------------- --- ConfiguredId -------------------------------------------------------------------------------- - --- | A ConfiguredId is a package ID for a configured package. --- --- Once we configure a source package we know its UnitId. It is still --- however useful in lots of places to also know the source ID for the package. --- We therefore bundle the two. --- --- An already installed package of course is also "configured" (all its --- configuration parameters and dependencies have been specified). -data ConfiguredId = ConfiguredId { - confSrcId :: PackageId - , confCompName :: Maybe ComponentName - , confInstId :: ComponentId - } - deriving (Eq, Ord, Generic) - -annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId -annotatedIdToConfiguredId aid = ConfiguredId { - confSrcId = ann_pid aid, - confCompName = Just (ann_cname aid), - confInstId = ann_id aid - } - -instance Binary ConfiguredId -instance Structured ConfiguredId - -instance Show ConfiguredId where - show cid = show (confInstId cid) - -instance Package ConfiguredId where - packageId = confSrcId - -------------------------------------------------------------------------------- --- HasConfiguredId class -------------------------------------------------------------------------------- - -class HasConfiguredId a where - configuredId :: a -> ConfiguredId - --- NB: This instance is slightly dangerous, in that you'll lose --- information about the specific UnitId you depended on. -instance HasConfiguredId InstalledPackageInfo where - configuredId ipkg = ConfiguredId (packageId ipkg) - (Just (sourceComponentName ipkg)) - (installedComponentId ipkg) diff --git a/Distribution/Client/Types/ConfiguredPackage.hs b/Distribution/Client/Types/ConfiguredPackage.hs deleted file mode 100644 --- a/Distribution/Client/Types/ConfiguredPackage.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -module Distribution.Client.Types.ConfiguredPackage ( - ConfiguredPackage (..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Package (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId) -import Distribution.Types.Flag (FlagAssignment) -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName (LibraryName (..)) -import Distribution.Types.MungedPackageId (computeCompatPackageId) -import Distribution.Simple.Utils (ordNub) - -import Distribution.Client.Types.ConfiguredId -import Distribution.Solver.Types.OptionalStanza (OptionalStanza) -import Distribution.Solver.Types.PackageFixedDeps -import Distribution.Solver.Types.SourcePackage (SourcePackage) - -import qualified Distribution.Solver.Types.ComponentDeps as CD - --- | A 'ConfiguredPackage' is a not-yet-installed package along with the --- total configuration information. The configuration information is total in --- the sense that it provides all the configuration information and so the --- final configure process will be independent of the environment. --- --- 'ConfiguredPackage' is assumed to not support Backpack. Only the --- @v2-build@ codepath supports Backpack. --- -data ConfiguredPackage loc = ConfiguredPackage - { confPkgId :: InstalledPackageId - , confPkgSource :: SourcePackage loc -- ^ package info, including repo - , confPkgFlags :: FlagAssignment -- ^ complete flag assignment for the package - , confPkgStanzas :: [OptionalStanza] -- ^ list of enabled optional stanzas for the package - , confPkgDeps :: CD.ComponentDeps [ConfiguredId] - -- ^ set of exact dependencies (installed or source). - -- - -- These must be consistent with the 'buildDepends' - -- in the 'PackageDescription' that you'd get by - -- applying the flag assignment and optional stanzas. - } - deriving (Eq, Show, Generic) - --- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'. --- This type class is mostly used to conveniently finesse between --- 'ElaboratedPackage' and 'ElaboratedComponent'. --- -instance HasConfiguredId (ConfiguredPackage loc) where - configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg) - --- 'ConfiguredPackage' is the legacy codepath, we are guaranteed --- to never have a nontrivial 'UnitId' -instance PackageFixedDeps (ConfiguredPackage loc) where - depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps - -instance IsNode (ConfiguredPackage loc) where - type Key (ConfiguredPackage loc) = UnitId - nodeKey = newSimpleUnitId . confPkgId - -- TODO: if we update ConfiguredPackage to support order-only - -- dependencies, need to include those here. - -- NB: have to deduplicate, otherwise the planner gets confused - nodeNeighbors = ordNub . CD.flatDeps . depends - -instance (Binary loc) => Binary (ConfiguredPackage loc) - - - - -instance Package (ConfiguredPackage loc) where - packageId cpkg = packageId (confPkgSource cpkg) - -instance HasMungedPackageId (ConfiguredPackage loc) where - mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName - --- Never has nontrivial UnitId -instance HasUnitId (ConfiguredPackage loc) where - installedUnitId = newSimpleUnitId . confPkgId - -instance PackageInstalled (ConfiguredPackage loc) where - installedDepends = CD.flatDeps . depends - - - diff --git a/Distribution/Client/Types/Credentials.hs b/Distribution/Client/Types/Credentials.hs deleted file mode 100644 --- a/Distribution/Client/Types/Credentials.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Distribution.Client.Types.Credentials ( - Username (..), - Password (..), -) where - -import Prelude (String) - -newtype Username = Username { unUsername :: String } -newtype Password = Password { unPassword :: String } diff --git a/Distribution/Client/Types/InstallMethod.hs b/Distribution/Client/Types/InstallMethod.hs deleted file mode 100644 --- a/Distribution/Client/Types/InstallMethod.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.InstallMethod where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - -data InstallMethod - = InstallMethodCopy - | InstallMethodSymlink - deriving (Eq, Show, Generic, Bounded, Enum) - -instance Binary InstallMethod -instance Structured InstallMethod - --- | Last -instance Semigroup InstallMethod where - _ <> x = x - -instance Parsec InstallMethod where - parsec = do - name <- P.munch1 isAlpha - case name of - "copy" -> pure InstallMethodCopy - "symlink" -> pure InstallMethodSymlink - _ -> P.unexpected $ "InstallMethod: " ++ name - -instance Pretty InstallMethod where - pretty InstallMethodCopy = PP.text "copy" - pretty InstallMethodSymlink = PP.text "symlink" diff --git a/Distribution/Client/Types/OverwritePolicy.hs b/Distribution/Client/Types/OverwritePolicy.hs deleted file mode 100644 --- a/Distribution/Client/Types/OverwritePolicy.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.OverwritePolicy where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - -data OverwritePolicy - = NeverOverwrite - | AlwaysOverwrite - deriving (Show, Eq, Generic, Bounded, Enum) - -instance Binary OverwritePolicy -instance Structured OverwritePolicy - -instance Parsec OverwritePolicy where - parsec = do - name <- P.munch1 isAlpha - case name of - "always" -> pure AlwaysOverwrite - "never" -> pure NeverOverwrite - _ -> P.unexpected $ "OverwritePolicy: " ++ name - -instance Pretty OverwritePolicy where - pretty NeverOverwrite = PP.text "never" - pretty AlwaysOverwrite = PP.text "always" diff --git a/Distribution/Client/Types/PackageLocation.hs b/Distribution/Client/Types/PackageLocation.hs deleted file mode 100644 --- a/Distribution/Client/Types/PackageLocation.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.PackageLocation ( - PackageLocation (..), - UnresolvedPkgLoc, - ResolvedPkgLoc, - UnresolvedSourcePackage, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Network.URI (URI) - -import Distribution.Types.PackageId (PackageId) - -import Distribution.Client.Types.Repo -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe) -import Distribution.Solver.Types.SourcePackage (SourcePackage) - -type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) - -type ResolvedPkgLoc = PackageLocation FilePath - -data PackageLocation local = - - -- | An unpacked package in the given dir, or current dir - LocalUnpackedPackage FilePath - - -- | A package as a tarball that's available as a local tarball - | LocalTarballPackage FilePath - - -- | A package as a tarball from a remote URI - | RemoteTarballPackage URI local - - -- | A package available as a tarball from a repository. - -- - -- It may be from a local repository or from a remote repository, with a - -- locally cached copy. ie a package available from hackage - | RepoTarballPackage Repo PackageId local - - -- | A package available from a version control system source repository - | RemoteSourceRepoPackage SourceRepoMaybe local - deriving (Show, Functor, Eq, Ord, Generic, Typeable) - -instance Binary local => Binary (PackageLocation local) -instance Structured local => Structured (PackageLocation local) - --- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. -type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc diff --git a/Distribution/Client/Types/PackageSpecifier.hs b/Distribution/Client/Types/PackageSpecifier.hs deleted file mode 100644 --- a/Distribution/Client/Types/PackageSpecifier.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.PackageSpecifier ( - PackageSpecifier (..), - pkgSpecifierTarget, - pkgSpecifierConstraints, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Package (Package (..), packageName, packageVersion) -import Distribution.Types.PackageName (PackageName) -import Distribution.Version (thisVersion) - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.PackageConstraint - --- | A fully or partially resolved reference to a package. --- -data PackageSpecifier pkg = - - -- | A partially specified reference to a package (either source or - -- installed). It is specified by package name and optionally some - -- required properties. Use a dependency resolver to pick a specific - -- package satisfying these properties. - -- - NamedPackage PackageName [PackageProperty] - - -- | A fully specified source package. - -- - | SpecificSourcePackage pkg - deriving (Eq, Show, Functor, Generic) - -instance Binary pkg => Binary (PackageSpecifier pkg) -instance Structured pkg => Structured (PackageSpecifier pkg) - -pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName -pkgSpecifierTarget (NamedPackage name _) = name -pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg - -pkgSpecifierConstraints :: Package pkg - => PackageSpecifier pkg -> [LabeledPackageConstraint] -pkgSpecifierConstraints (NamedPackage name props) = map toLpc props - where - toLpc prop = LabeledPackageConstraint - (PackageConstraint (scopeToplevel name) prop) - ConstraintSourceUserTarget -pkgSpecifierConstraints (SpecificSourcePackage pkg) = - [LabeledPackageConstraint pc ConstraintSourceUserTarget] - where - pc = PackageConstraint - (ScopeTarget $ packageName pkg) - (PackagePropertyVersion $ thisVersion (packageVersion pkg)) diff --git a/Distribution/Client/Types/ReadyPackage.hs b/Distribution/Client/Types/ReadyPackage.hs deleted file mode 100644 --- a/Distribution/Client/Types/ReadyPackage.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Client.Types.ReadyPackage ( - GenericReadyPackage (..), - ReadyPackage, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) - -import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage) -import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc) -import Distribution.Solver.Types.PackageFixedDeps - --- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be --- installed already, hence itself ready to be installed. -newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. - deriving (Eq, Show, Generic, Package, PackageFixedDeps, - HasMungedPackageId, HasUnitId, PackageInstalled, Binary) - --- Can't newtype derive this -instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where - type Key (GenericReadyPackage srcpkg) = Key srcpkg - nodeKey (ReadyPackage spkg) = nodeKey spkg - nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg - -type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) diff --git a/Distribution/Client/Types/Repo.hs b/Distribution/Client/Types/Repo.hs deleted file mode 100644 --- a/Distribution/Client/Types/Repo.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.Repo ( - -- * Remote repository - RemoteRepo (..), - emptyRemoteRepo, - -- * Local repository (no-index) - LocalRepo (..), - emptyLocalRepo, - localRepoCacheKey, - -- * Repository - Repo (..), - repoName, - isRepoRemote, - maybeRepoRemote, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString) - -import Distribution.Simple.Utils (toUTF8BS) - -import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash) - -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Distribution.Client.Types.RepoName - -------------------------------------------------------------------------------- --- Remote repository -------------------------------------------------------------------------------- - -data RemoteRepo = - RemoteRepo { - remoteRepoName :: RepoName, - remoteRepoURI :: URI, - - -- | Enable secure access? - -- - -- 'Nothing' here represents "whatever the default is"; this is important - -- to allow for a smooth transition from opt-in to opt-out security - -- (once we switch to opt-out, all access to the central Hackage - -- repository should be secure by default) - remoteRepoSecure :: Maybe Bool, - - -- | Root key IDs (for bootstrapping) - remoteRepoRootKeys :: [String], - - -- | Threshold for verification during bootstrapping - remoteRepoKeyThreshold :: Int, - - -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a - -- special case we may know a repo supports both and want to try HTTPS - -- if we can, but still allow falling back to HTTP. - -- - -- This field is not currently stored in the config file, but is filled - -- in automagically for known repos. - remoteRepoShouldTryHttps :: Bool - } - - deriving (Show, Eq, Ord, Generic) - -instance Binary RemoteRepo -instance Structured RemoteRepo - -instance Pretty RemoteRepo where - pretty r = - pretty (remoteRepoName r) <<>> Disp.colon <<>> - Disp.text (uriToString id (remoteRepoURI r) []) - --- | Note: serialised format represends 'RemoteRepo' only partially. -instance Parsec RemoteRepo where - parsec = do - name <- parsec - _ <- P.char ':' - uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String)) - uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr) - return RemoteRepo - { remoteRepoName = name - , remoteRepoURI = uri - , remoteRepoSecure = Nothing - , remoteRepoRootKeys = [] - , remoteRepoKeyThreshold = 0 - , remoteRepoShouldTryHttps = False - } - --- | Construct a partial 'RemoteRepo' value to fold the field parser list over. -emptyRemoteRepo :: RepoName -> RemoteRepo -emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False - -------------------------------------------------------------------------------- --- Local repository -------------------------------------------------------------------------------- - --- | /no-index/ style local repositories. --- --- https://github.com/haskell/cabal/issues/6359 -data LocalRepo = LocalRepo - { localRepoName :: RepoName - , localRepoPath :: FilePath - , localRepoSharedCache :: Bool - } - deriving (Show, Eq, Ord, Generic) - -instance Binary LocalRepo -instance Structured LocalRepo - --- | Note: doesn't parse 'localRepoSharedCache' field. -instance Parsec LocalRepo where - parsec = do - n <- parsec - _ <- P.char ':' - p <- P.munch1 (const True) -- restrict what can be a path? - return (LocalRepo n p False) - -instance Pretty LocalRepo where - pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p - --- | Construct a partial 'LocalRepo' value to fold the field parser list over. -emptyLocalRepo :: RepoName -> LocalRepo -emptyLocalRepo name = LocalRepo name "" False - --- | Calculate a cache key for local-repo. --- --- For remote repositories we just use name, but local repositories may --- all be named "local", so we add a bit of `localRepoPath` into the --- mix. -localRepoCacheKey :: LocalRepo -> String -localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where - hashPart - = showHashValue $ truncateHash 8 $ hashValue - $ LBS.fromStrict $ toUTF8BS $ localRepoPath local - -------------------------------------------------------------------------------- --- Any repository -------------------------------------------------------------------------------- - --- | Different kinds of repositories --- --- NOTE: It is important that this type remains serializable. -data Repo - -- | Local repository, without index. - -- - -- https://github.com/haskell/cabal/issues/6359 - = RepoLocalNoIndex - { repoLocal :: LocalRepo - , repoLocalDir :: FilePath - } - - -- | Standard (unsecured) remote repositores - | RepoRemote { - repoRemote :: RemoteRepo - , repoLocalDir :: FilePath - } - - -- | Secure repositories - -- - -- Although this contains the same fields as 'RepoRemote', we use a separate - -- constructor to avoid confusing the two. - -- - -- Not all access to a secure repo goes through the hackage-security - -- library currently; code paths that do not still make use of the - -- 'repoRemote' and 'repoLocalDir' fields directly. - | RepoSecure { - repoRemote :: RemoteRepo - , repoLocalDir :: FilePath - } - deriving (Show, Eq, Ord, Generic) - -instance Binary Repo -instance Structured Repo - --- | Check if this is a remote repo -isRepoRemote :: Repo -> Bool -isRepoRemote RepoLocalNoIndex{} = False -isRepoRemote _ = True - --- | Extract @RemoteRepo@ from @Repo@ if remote. -maybeRepoRemote :: Repo -> Maybe RemoteRepo -maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing -maybeRepoRemote (RepoRemote r _localDir) = Just r -maybeRepoRemote (RepoSecure r _localDir) = Just r - -repoName :: Repo -> RepoName -repoName (RepoLocalNoIndex r _) = localRepoName r -repoName (RepoRemote r _) = remoteRepoName r -repoName (RepoSecure r _) = remoteRepoName r diff --git a/Distribution/Client/Types/RepoName.hs b/Distribution/Client/Types/RepoName.hs deleted file mode 100644 --- a/Distribution/Client/Types/RepoName.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.RepoName ( - RepoName (..), - unRepoName, -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- $setup --- >>> import Distribution.Parsec - --- | Repository name. --- --- May be used as path segment. --- -newtype RepoName = RepoName String - deriving (Show, Eq, Ord, Generic) - -unRepoName :: RepoName -> String -unRepoName (RepoName n) = n - -instance Binary RepoName -instance Structured RepoName -instance NFData RepoName - -instance Pretty RepoName where - pretty = Disp.text . unRepoName - --- | --- --- >>> simpleParsec "hackage.haskell.org" :: Maybe RepoName --- Just (RepoName "hackage.haskell.org") --- --- >>> simpleParsec "0123" :: Maybe RepoName --- Nothing --- -instance Parsec RepoName where - parsec = RepoName <$> parser where - parser = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlpha c || c == '_' || c == '-' || c == '.') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.') diff --git a/Distribution/Client/Types/SourcePackageDb.hs b/Distribution/Client/Types/SourcePackageDb.hs deleted file mode 100644 --- a/Distribution/Client/Types/SourcePackageDb.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.SourcePackageDb ( - SourcePackageDb (..), -) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Types.PackageName (PackageName) -import Distribution.Types.VersionRange (VersionRange) - -import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage) -import Distribution.Solver.Types.PackageIndex (PackageIndex) - --- | This is the information we get from a @00-index.tar.gz@ hackage index. --- -data SourcePackageDb = SourcePackageDb - { packageIndex :: PackageIndex UnresolvedSourcePackage - , packagePreferences :: Map PackageName VersionRange - } - deriving (Eq, Generic) - -instance Binary SourcePackageDb diff --git a/Distribution/Client/Types/SourceRepo.hs b/Distribution/Client/Types/SourceRepo.hs deleted file mode 100644 --- a/Distribution/Client/Types/SourceRepo.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -module Distribution.Client.Types.SourceRepo ( - SourceRepositoryPackage (..), - SourceRepoList, - SourceRepoMaybe, - SourceRepoProxy, - srpHoist, - srpToProxy, - srpFanOut, - sourceRepositoryPackageGrammar, -) where - -import Distribution.Client.Compat.Prelude -import Distribution.Compat.Lens (Lens, Lens') -import Prelude () - -import Distribution.FieldGrammar -import Distribution.Types.SourceRepo (RepoType (..)) - --- | @source-repository-package@ definition --- -data SourceRepositoryPackage f = SourceRepositoryPackage - { srpType :: !RepoType - , srpLocation :: !String - , srpTag :: !(Maybe String) - , srpBranch :: !(Maybe String) - , srpSubdir :: !(f FilePath) - } - deriving (Generic) - -deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f) -deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f) -deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f) -deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f) -deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f) - --- | Read from @cabal.project@ -type SourceRepoList = SourceRepositoryPackage [] - --- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo' -type SourceRepoMaybe = SourceRepositoryPackage Maybe - --- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory. -type SourceRepoProxy = SourceRepositoryPackage Proxy - -srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g -srpHoist nt s = s { srpSubdir = nt (srpSubdir s) } - -srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy -srpToProxy s = s { srpSubdir = Proxy } - --- | Split single @source-repository-package@ declaration with multiple subdirs, --- into multiple ones with at most single subdir. -srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe) -srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } = - s { srpSubdir = Nothing } :| [] -srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where - f subdir = s { srpSubdir = Just subdir } - -------------------------------------------------------------------------------- --- Lens -------------------------------------------------------------------------------- - -srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType -srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s)) -{-# INLINE srpTypeLens #-} - -srpLocationLens :: Lens' (SourceRepositoryPackage f) String -srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s)) -{-# INLINE srpLocationLens #-} - -srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String) -srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s)) -{-# INLINE srpTagLens #-} - -srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String) -srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s)) -{-# INLINE srpBranchLens #-} - -srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath) -srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s)) -{-# INLINE srpSubdirLens #-} - -------------------------------------------------------------------------------- --- Parser & PPrinter -------------------------------------------------------------------------------- - -sourceRepositoryPackageGrammar - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType) - , c (List NoCommaFSep FilePathNT String) - ) - => g SourceRepoList SourceRepoList -sourceRepositoryPackageGrammar = SourceRepositoryPackage - <$> uniqueField "type" srpTypeLens - <*> uniqueFieldAla "location" Token srpLocationLens - <*> optionalFieldAla "tag" Token srpTagLens - <*> optionalFieldAla "branch" Token srpBranchLens - <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there... -{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-} -{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-} diff --git a/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs deleted file mode 100644 --- a/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( - WriteGhcEnvironmentFilesPolicy (..), -) where - -import Prelude () -import Distribution.Client.Compat.Prelude - --- | Whether 'v2-build' should write a .ghc.environment file after --- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+' --- (8.4.4 is the earliest version that supports --- '-package-env -'). -data WriteGhcEnvironmentFilesPolicy - = AlwaysWriteGhcEnvironmentFiles - | NeverWriteGhcEnvironmentFiles - | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer - deriving (Eq, Enum, Bounded, Generic, Show) - -instance Binary WriteGhcEnvironmentFilesPolicy -instance Structured WriteGhcEnvironmentFilesPolicy diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs deleted file mode 100644 --- a/Distribution/Client/Update.hs +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Update --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.Update - ( update - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Simple.Setup - ( fromFlag ) -import Distribution.Client.Compat.Directory - ( setModificationTime ) -import Distribution.Client.Types - ( Repo(..), RepoName (..), RemoteRepo(..), maybeRepoRemote, unRepoName ) -import Distribution.Client.HttpUtils - ( DownloadResult(..) ) -import Distribution.Client.FetchUtils - ( downloadIndex ) -import Distribution.Client.IndexUtils.Timestamp -import Distribution.Client.IndexUtils.IndexState -import Distribution.Client.IndexUtils - ( updateRepoIndexCache, Index(..), writeIndexTimestamp - , currentIndexTimestamp, indexBaseName ) -import Distribution.Client.JobControl - ( newParallelJobControl, spawnJob, collectJob ) -import Distribution.Client.Setup - ( RepoContext(..), UpdateFlags(..) ) -import Distribution.Verbosity (lessVerbose) - -import Distribution.Simple.Utils - ( writeFileAtomic, warn, notice, noticeNoWrap ) - -import qualified Data.ByteString.Lazy as BS -import Distribution.Client.GZipUtils (maybeDecompress) -import System.FilePath ((<.>), dropExtension) -import Data.Time (getCurrentTime) - -import qualified Hackage.Security.Client as Sec - --- | 'update' downloads the package list from all known servers -update :: Verbosity -> UpdateFlags -> RepoContext -> IO () -update verbosity _ repoCtxt | null (repoContextRepos repoCtxt) = do - warn verbosity $ "No remote package servers have been specified. Usually " - ++ "you would have one specified in the config file." -update verbosity updateFlags repoCtxt = do - let repos = repoContextRepos repoCtxt - remoteRepos = mapMaybe maybeRepoRemote repos - case remoteRepos of - [] -> return () - [remoteRepo] -> - notice verbosity $ "Downloading the latest package list from " - ++ unRepoName (remoteRepoName remoteRepo) - _ -> notice verbosity . unlines - $ "Downloading the latest package lists from: " - : map (("- " ++) . unRepoName . remoteRepoName) remoteRepos - jobCtrl <- newParallelJobControl (length repos) - traverse_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos - traverse_ (\_ -> collectJob jobCtrl) repos - -updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO () -updateRepo verbosity updateFlags repoCtxt repo = do - transport <- repoContextGetTransport repoCtxt - case repo of - RepoLocalNoIndex{} -> return () - RepoRemote{..} -> do - downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir - case downloadResult of - FileAlreadyInCache -> - setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime - FileDownloaded indexPath -> do - writeFileAtomic (dropExtension indexPath) . maybeDecompress - =<< BS.readFile indexPath - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) - RepoSecure remote _ -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do - let index = RepoIndex repoCtxt repo - -- NB: This may be a nullTimestamp if we've never updated before - current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo - - -- NB: always update the timestamp, even if we didn't actually - -- download anything - let rname :: RepoName - rname = remoteRepoName remote - - let repoIndexState :: RepoIndexState - repoIndexState = lookupIndexState rname (fromFlag (updateIndexState updateFlags)) - writeIndexTimestamp index repoIndexState - - ce <- if repoContextIgnoreExpiry repoCtxt - then Just `fmap` getCurrentTime - else return Nothing - updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce - -- Update cabal's internal index as well so that it's not out of sync - -- (If all access to the cache goes through hackage-security this can go) - case updated of - Sec.NoUpdates -> - setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime - Sec.HasUpdates -> - updateRepoIndexCache verbosity index - -- TODO: This will print multiple times if there are multiple - -- repositories: main problem is we don't have a way of updating - -- a specific repo. Once we implement that, update this. - when (current_ts /= nullTimestamp) $ - noticeNoWrap verbosity $ - "To revert to previous state run:\n" ++ - " cabal update --index-state='" ++ prettyShow current_ts ++ "'\n" diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs deleted file mode 100644 --- a/Distribution/Client/Upload.hs +++ /dev/null @@ -1,225 +0,0 @@ -module Distribution.Client.Upload (upload, uploadDoc, report) where - -import Distribution.Client.Compat.Prelude -import qualified Prelude as Unsafe (tail, head, read) - -import Distribution.Client.Types.Credentials ( Username(..), Password(..) ) -import Distribution.Client.Types.Repo (RemoteRepo(..), maybeRepoRemote) -import Distribution.Client.Types.RepoName (unRepoName) -import Distribution.Client.HttpUtils - ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) -import Distribution.Client.Setup - ( IsCandidate(..), RepoContext(..) ) - -import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS) -import Distribution.Client.Config - -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport -import Distribution.Client.BuildReports.Anonymous (parseBuildReport) -import qualified Distribution.Client.BuildReports.Upload as BuildReport - -import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName)) -import Network.HTTP (Header(..), HeaderName(..)) - -import System.IO (hFlush, stdout) -import System.IO.Echo (withoutInputEcho) -import System.FilePath ((), takeExtension, takeFileName, dropExtension) -import qualified System.FilePath.Posix as FilePath.Posix (()) -import System.Directory - -type Auth = Maybe (String, String) - --- > stripExtensions ["tar", "gz"] "foo.tar.gz" --- Just "foo" --- > stripExtensions ["tar", "gz"] "foo.gz.tar" --- Nothing -stripExtensions :: [String] -> FilePath -> Maybe String -stripExtensions exts path = foldM f path (reverse exts) - where - f p e - | takeExtension p == '.':e = Just (dropExtension p) - | otherwise = Nothing - -upload :: Verbosity -> RepoContext - -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath] - -> IO () -upload verbosity repoCtxt mUsername mPassword isCandidate paths = do - let repos = repoContextRepos repoCtxt - transport <- repoContextGetTransport repoCtxt - targetRepo <- - case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die' verbosity "Cannot upload. No remote repositories are configured." - (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) - let targetRepoURI = remoteRepoURI targetRepo - domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI - rootIfEmpty x = if null x then "/" else x - uploadURI = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. - case isCandidate of - IsCandidate -> "packages/candidates" - IsPublished -> "upload" - } - packageURI pkgid = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - ] - } - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword - let auth = Just (username,password) - for_ paths $ \path -> do - notice verbosity $ "Uploading " ++ path ++ "... " - case fmap takeFileName (stripExtensions ["tar", "gz"] path) of - Just pkgid -> handlePackage transport verbosity uploadURI - (packageURI pkgid) auth isCandidate path - -- This case shouldn't really happen, since we check in Main that we - -- only pass tar.gz files to upload. - Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path - -uploadDoc :: Verbosity -> RepoContext - -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath - -> IO () -uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do - let repos = repoContextRepos repoCtxt - transport <- repoContextGetTransport repoCtxt - targetRepo <- - case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." - (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) - let targetRepoURI = remoteRepoURI targetRepo - domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI - rootIfEmpty x = if null x then "/" else x - uploadURI = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - , "/docs" - ] - } - packageUri = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - ] - } - (reverseSuffix, reversePkgid) = break (== '-') - (reverse (takeFileName path)) - pkgid = reverse $ Unsafe.tail reversePkgid - when (reverse reverseSuffix /= "docs.tar.gz" - || null reversePkgid || Unsafe.head reversePkgid /= '-') $ - die' verbosity "Expected a file name matching the pattern -docs.tar.gz" - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword - - let auth = Just (username,password) - headers = - [ Header HdrContentType "application/x-tar" - , Header HdrContentEncoding "gzip" - ] - notice verbosity $ "Uploading documentation " ++ path ++ "... " - resp <- putHttpFile transport verbosity uploadURI path auth headers - case resp of - -- Hackage responds with 204 No Content when docs are uploaded - -- successfully. - (code,_) | code `elem` [200,204] -> do - notice verbosity $ okMessage packageUri - (code,err) -> do - notice verbosity $ "Error uploading documentation " - ++ path ++ ": " - ++ "http code " ++ show code ++ "\n" - ++ err - exitFailure - where - okMessage packageUri = case isCandidate of - IsCandidate -> - "Documentation successfully uploaded for package candidate. " - ++ "You can now preview the result at '" ++ show packageUri - ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'." - IsPublished -> - "Package documentation successfully published. You can now view it at '" - ++ show packageUri ++ "'." - - -promptUsername :: String -> IO Username -promptUsername domain = do - putStr $ domain ++ " username: " - hFlush stdout - fmap Username getLine - -promptPassword :: String -> IO Password -promptPassword domain = do - putStr $ domain ++ " password: " - hFlush stdout - -- save/restore the terminal echoing status (no echoing for entering the password) - passwd <- withoutInputEcho $ fmap Password getLine - putStrLn "" - return passwd - -report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO () -report verbosity repoCtxt mUsername mPassword = do - let repos = repoContextRepos repoCtxt - remoteRepos = mapMaybe maybeRepoRemote repos - for_ remoteRepos $ \remoteRepo -> do - let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo) - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword - let auth = (username, password) - - dotCabal <- getCabalDir - let srcDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) - -- We don't want to bomb out just because we haven't built any packages - -- from this repo yet. - srcExists <- doesDirectoryExist srcDir - when srcExists $ do - contents <- getDirectoryContents srcDir - for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> - do inp <- readFile (srcDir logFile) - let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse - case parseBuildReport (toUTF8BS reportStr) of - Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME - Right report' -> - do info verbosity $ "Uploading report for " - ++ prettyShow (BuildReport.package report') - BuildReport.uploadReports verbosity repoCtxt auth - (remoteRepoURI remoteRepo) [(report', Just buildLog)] - return () - -handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth - -> IsCandidate -> FilePath -> IO () -handlePackage transport verbosity uri packageUri auth isCandidate path = - do resp <- postHttpFile transport verbosity uri path auth - case resp of - (code,warnings) | code `elem` [200, 204] -> - notice verbosity $ okMessage isCandidate ++ - if null warnings then "" else "\n" ++ formatWarnings (trim warnings) - (code,err) -> do - notice verbosity $ "Error uploading " ++ path ++ ": " - ++ "http code " ++ show code ++ "\n" - ++ err - exitFailure - where - okMessage IsCandidate = - "Package successfully uploaded as candidate. " - ++ "You can now preview the result at '" ++ show packageUri - ++ "'. To publish the candidate, use 'cabal upload --publish'." - okMessage IsPublished = - "Package successfully published. You can now view it at '" - ++ show packageUri ++ "'." - -formatWarnings :: String -> String -formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x - --- Trim -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs deleted file mode 100644 --- a/Distribution/Client/Utils.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} - -module Distribution.Client.Utils ( MergeResult(..) - , mergeBy, duplicates, duplicatesBy - , readMaybe - , inDir, withEnv, withEnvOverrides - , logDirChange, withExtraPathEnv - , determineNumJobs, numberOfProcessors - , removeExistingFile - , withTempFileName - , makeAbsoluteToCwd - , makeRelativeToCwd, makeRelativeToDir - , makeRelativeCanonical - , filePathToByteString - , byteStringToFilePath, tryCanonicalizePath - , canonicalizePathNoThrow - , moreRecentFile, existsAndIsMoreRecentThan - , tryFindAddSourcePackageDesc - , tryFindPackageDesc - , relaxEncodingErrors - , ProgressPhase (..) - , progressMessage - , cabalInstallVersion) - where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Compat.Environment -import Distribution.Compat.Time ( getModTime ) -import Distribution.Simple.Setup ( Flag(..) ) -import Distribution.Version -import Distribution.Simple.Utils ( die', findPackageDesc, noticeNoWrap ) -import qualified Data.ByteString.Lazy as BS -import Data.Bits - ( (.|.), shiftL, shiftR ) -import System.FilePath -import Control.Monad - ( zipWithM_ ) -import Data.List - ( groupBy ) -import Foreign.C.Types ( CInt(..) ) -import qualified Control.Exception as Exception - ( finally, bracket ) -import System.Directory - ( canonicalizePath, doesFileExist, getCurrentDirectory - , removeFile, setCurrentDirectory ) -import System.IO - ( Handle, hClose, openTempFile - , hGetEncoding, hSetEncoding - ) -import System.IO.Unsafe ( unsafePerformIO ) - -import GHC.IO.Encoding - ( recover, TextEncoding(TextEncoding) ) -import GHC.IO.Encoding.Failure - ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) - -#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) -import qualified System.Directory as Dir -import qualified System.IO.Error as IOError -#endif - -#ifndef __DOCTEST__ -import qualified Paths_cabal_install (version) -#endif - --- | Generic merging utility. For sorted input lists this is a full outer join. --- -mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] -mergeBy cmp = merge - where - merge [] ys = [ OnlyInRight y | y <- ys] - merge xs [] = [ OnlyInLeft x | x <- xs] - merge (x:xs) (y:ys) = - case x `cmp` y of - GT -> OnlyInRight y : merge (x:xs) ys - EQ -> InBoth x y : merge xs ys - LT -> OnlyInLeft x : merge xs (y:ys) - -data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b - -duplicates :: Ord a => [a] -> [[a]] -duplicates = duplicatesBy compare - -duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] -duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp - where - eq a b = case cmp a b of - EQ -> True - _ -> False - moreThanOne (_:_:_) = True - moreThanOne _ = False - --- | Like 'removeFile', but does not throw an exception when the file does not --- exist. -removeExistingFile :: FilePath -> IO () -removeExistingFile path = do - exists <- doesFileExist path - when exists $ - removeFile path - --- | A variant of 'withTempFile' that only gives us the file name, and while --- it will clean up the file afterwards, it's lenient if the file is --- moved\/deleted. --- -withTempFileName :: FilePath - -> String - -> (FilePath -> IO a) -> IO a -withTempFileName tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, _) -> removeExistingFile name) - (\(name, h) -> hClose h >> action name) - --- | Executes the action in the specified directory. --- --- Warning: This operation is NOT thread-safe, because current --- working directory is a process-global concept. -inDir :: Maybe FilePath -> IO a -> IO a -inDir Nothing m = m -inDir (Just d) m = do - old <- getCurrentDirectory - setCurrentDirectory d - m `Exception.finally` setCurrentDirectory old - --- | Executes the action with an environment variable set to some --- value. --- --- Warning: This operation is NOT thread-safe, because current --- environment is a process-global concept. -withEnv :: String -> String -> IO a -> IO a -withEnv k v m = do - mb_old <- lookupEnv k - setEnv k v - m `Exception.finally` (case mb_old of - Nothing -> unsetEnv k - Just old -> setEnv k old) - --- | Executes the action with a list of environment variables and --- corresponding overrides, where --- --- * @'Just' v@ means \"set the environment variable's value to @v@\". --- * 'Nothing' means \"unset the environment variable\". --- --- Warning: This operation is NOT thread-safe, because current --- environment is a process-global concept. -withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a -withEnvOverrides overrides m = do - mb_olds <- traverse lookupEnv envVars - traverse_ (uncurry update) overrides - m `Exception.finally` zipWithM_ update envVars mb_olds - where - envVars :: [String] - envVars = map fst overrides - - update :: String -> Maybe FilePath -> IO () - update var Nothing = unsetEnv var - update var (Just val) = setEnv var val - --- | Executes the action, increasing the PATH environment --- in some way --- --- Warning: This operation is NOT thread-safe, because the --- environment variables are a process-global concept. -withExtraPathEnv :: [FilePath] -> IO a -> IO a -withExtraPathEnv paths m = do - oldPathSplit <- getSearchPath - let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) - oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit - -- TODO: This is a horrible hack to work around the fact that - -- setEnv can't take empty values as an argument - mungePath p | p == "" = "/dev/null" - | otherwise = p - setEnv "PATH" newPath - m `Exception.finally` setEnv "PATH" oldPath - --- | Log directory change in 'make' compatible syntax -logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a -logDirChange _ Nothing m = m -logDirChange l (Just d) m = do - l $ "cabal: Entering directory '" ++ d ++ "'\n" - m `Exception.finally` - (l $ "cabal: Leaving directory '" ++ d ++ "'\n") - -foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt - --- The number of processors is not going to change during the duration of the --- program, so unsafePerformIO is safe here. -numberOfProcessors :: Int -numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors - --- | Determine the number of jobs to use given the value of the '-j' flag. -determineNumJobs :: Flag (Maybe Int) -> Int -determineNumJobs numJobsFlag = - case numJobsFlag of - NoFlag -> 1 - Flag Nothing -> numberOfProcessors - Flag (Just n) -> n - --- | Given a relative path, make it absolute relative to the current --- directory. Absolute paths are returned unmodified. -makeAbsoluteToCwd :: FilePath -> IO FilePath -makeAbsoluteToCwd path | isAbsolute path = return path - | otherwise = do cwd <- getCurrentDirectory - return $! cwd path - --- | Given a path (relative or absolute), make it relative to the current --- directory, including using @../..@ if necessary. -makeRelativeToCwd :: FilePath -> IO FilePath -makeRelativeToCwd path = - makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory - --- | Given a path (relative or absolute), make it relative to the given --- directory, including using @../..@ if necessary. -makeRelativeToDir :: FilePath -> FilePath -> IO FilePath -makeRelativeToDir path dir = - makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir - --- | Given a canonical absolute path and canonical absolute dir, make the path --- relative to the directory, including using @../..@ if necessary. Returns --- the original absolute path if it is not on the same drive as the given dir. -makeRelativeCanonical :: FilePath -> FilePath -> FilePath -makeRelativeCanonical path dir - | takeDrive path /= takeDrive dir = path - | otherwise = go (splitPath path) (splitPath dir) - where - go (p:ps) (d:ds) | p == d = go ps ds - go [] [] = "./" - go ps ds = joinPath (replicate (length ds) ".." ++ ps) - --- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is --- encoded as a little-endian 'Word32'. -filePathToByteString :: FilePath -> BS.ByteString -filePathToByteString p = - BS.pack $ foldr conv [] codepts - where - codepts :: [Word32] - codepts = map (fromIntegral . ord) p - - conv :: Word32 -> [Word8] -> [Word8] - conv w32 rest = b0:b1:b2:b3:rest - where - b0 = fromIntegral $ w32 - b1 = fromIntegral $ w32 `shiftR` 8 - b2 = fromIntegral $ w32 `shiftR` 16 - b3 = fromIntegral $ w32 `shiftR` 24 - --- | Reverse operation to 'filePathToByteString'. -byteStringToFilePath :: BS.ByteString -> FilePath -byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected - | otherwise = go 0 - where - unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected" - bslen = BS.length bs - - go i | i == bslen = [] - | otherwise = (chr . fromIntegral $ w32) : go (i+4) - where - w32 :: Word32 - w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) - b0 = fromIntegral $ BS.index bs i - b1 = fromIntegral $ BS.index bs (i + 1) - b2 = fromIntegral $ BS.index bs (i + 2) - b3 = fromIntegral $ BS.index bs (i + 3) - --- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always --- throws an error if the path refers to a non-existent file. -tryCanonicalizePath :: FilePath -> IO FilePath -tryCanonicalizePath path = do - ret <- canonicalizePath path -#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) - exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret) - unless exists $ - IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath" - Nothing (Just ret) -#endif - return ret - --- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws --- an exception, returns the path argument unmodified. -canonicalizePathNoThrow :: FilePath -> IO FilePath -canonicalizePathNoThrow path = do - canonicalizePath path `catchIO` (\_ -> return path) - --------------------- --- Modification time - --- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead --- of getModificationTime for higher precision. We can't merge the two because --- Distribution.Client.Time uses MIN_VERSION macros. -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModTime b - ta <- getModTime a - return (ta > tb) - --- | Like 'moreRecentFile', but also checks that the first file exists. -existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool -existsAndIsMoreRecentThan a b = do - exists <- doesFileExist a - if not exists - then return False - else a `moreRecentFile` b - --- | Sets the handler for encoding errors to one that transliterates invalid --- characters into one present in the encoding (i.e., \'?\'). --- This is opposed to the default behavior, which is to throw an exception on --- error. This function will ignore file handles that have a Unicode encoding --- set. It's a no-op for versions of `base` less than 4.4. -relaxEncodingErrors :: Handle -> IO () -relaxEncodingErrors handle = do - maybeEncoding <- hGetEncoding handle - case maybeEncoding of - Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) -> - let relax x = x { recover = recoverEncode TransliterateCodingFailure } - in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder)) - _ -> - return () - --- |Like 'tryFindPackageDesc', but with error specific to add-source deps. -tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath -tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $ - err ++ "\n" ++ "Failed to read cabal file of add-source dependency: " - ++ depPath - --- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be --- found, with @err@ prefixing the error message. This function simply allows --- us to give a more descriptive error than that provided by @findPackageDesc@. -tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath -tryFindPackageDesc verbosity depPath err = do - errOrCabalFile <- findPackageDesc depPath - case errOrCabalFile of - Right file -> return file - Left _ -> die' verbosity err - --- | Phase of building a dependency. Represents current status of package --- dependency processing. See #4040 for details. -data ProgressPhase - = ProgressDownloading - | ProgressDownloaded - | ProgressStarting - | ProgressBuilding - | ProgressHaddock - | ProgressInstalling - | ProgressCompleted - -progressMessage :: Verbosity -> ProgressPhase -> String -> IO () -progressMessage verbosity phase subject = do - noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n" - where - phaseStr = case phase of - ProgressDownloading -> "Downloading " - ProgressDownloaded -> "Downloaded " - ProgressStarting -> "Starting " - ProgressBuilding -> "Building " - ProgressHaddock -> "Haddock " - ProgressInstalling -> "Installing " - ProgressCompleted -> "Completed " - -cabalInstallVersion :: Version -#ifdef __DOCTEST__ -cabalInstallVersion = mkVersion [3,3] -#else -cabalInstallVersion = mkVersion' Paths_cabal_install.version -#endif diff --git a/Distribution/Client/Utils/Assertion.hs b/Distribution/Client/Utils/Assertion.hs deleted file mode 100644 --- a/Distribution/Client/Utils/Assertion.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Client.Utils.Assertion (expensiveAssert) where - - -#ifdef DEBUG_EXPENSIVE_ASSERTIONS -import Prelude (Bool) -import Control.Exception (assert) -import Distribution.Compat.Stack -#else -import Prelude (Bool, id) -#endif - --- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This --- function can be used for expensive assertions that should only be turned on --- during testing or debugging. -#ifdef DEBUG_EXPENSIVE_ASSERTIONS -expensiveAssert :: WithCallStack (Bool -> a -> a) -expensiveAssert = assert -#else -expensiveAssert :: Bool -> a -> a -expensiveAssert _ = id -#endif diff --git a/Distribution/Client/Utils/Json.hs b/Distribution/Client/Utils/Json.hs deleted file mode 100644 --- a/Distribution/Client/Utils/Json.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Minimal JSON / RFC 7159 support --- --- The API is heavily inspired by @aeson@'s API but puts emphasis on --- simplicity rather than performance. The 'ToJSON' instances are --- intended to have an encoding compatible with @aeson@'s encoding. --- -module Distribution.Client.Utils.Json - ( Value(..) - , Object, object, Pair, (.=) - , encodeToString - , encodeToBuilder - , ToJSON(toJSON) - ) - where - -import Distribution.Client.Compat.Prelude - -import Data.Char (intToDigit) - -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BB - --- TODO: We may want to replace 'String' with 'Text' or 'ByteString' - --- | A JSON value represented as a Haskell value. -data Value = Object !Object - | Array [Value] - | String String - | Number !Double - | Bool !Bool - | Null - deriving (Eq, Read, Show) - --- | A key\/value pair for an 'Object' -type Pair = (String, Value) - --- | A JSON \"object\" (key/value map). -type Object = [Pair] - -infixr 8 .= - --- | A key-value pair for encoding a JSON object. -(.=) :: ToJSON v => String -> v -> Pair -k .= v = (k, toJSON v) - --- | Create a 'Value' from a list of name\/value 'Pair's. -object :: [Pair] -> Value -object = Object - -instance IsString Value where - fromString = String - - --- | A type that can be converted to JSON. -class ToJSON a where - -- | Convert a Haskell value to a JSON-friendly intermediate type. - toJSON :: a -> Value - -instance ToJSON () where - toJSON () = Array [] - -instance ToJSON Value where - toJSON = id - -instance ToJSON Bool where - toJSON = Bool - -instance ToJSON a => ToJSON [a] where - toJSON = Array . map toJSON - -instance ToJSON a => ToJSON (Maybe a) where - toJSON Nothing = Null - toJSON (Just a) = toJSON a - -instance (ToJSON a,ToJSON b) => ToJSON (a,b) where - toJSON (a,b) = Array [toJSON a, toJSON b] - -instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where - toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] - -instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where - toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] - -instance ToJSON Float where - toJSON = Number . realToFrac - -instance ToJSON Double where - toJSON = Number - -instance ToJSON Int where toJSON = Number . realToFrac -instance ToJSON Int8 where toJSON = Number . realToFrac -instance ToJSON Int16 where toJSON = Number . realToFrac -instance ToJSON Int32 where toJSON = Number . realToFrac - -instance ToJSON Word where toJSON = Number . realToFrac -instance ToJSON Word8 where toJSON = Number . realToFrac -instance ToJSON Word16 where toJSON = Number . realToFrac -instance ToJSON Word32 where toJSON = Number . realToFrac - --- | Possibly lossy due to conversion to 'Double' -instance ToJSON Int64 where toJSON = Number . realToFrac - --- | Possibly lossy due to conversion to 'Double' -instance ToJSON Word64 where toJSON = Number . realToFrac - --- | Possibly lossy due to conversion to 'Double' -instance ToJSON Integer where toJSON = Number . fromInteger - ------------------------------------------------------------------------------- --- 'BB.Builder'-based encoding - --- | Serialise value as JSON/UTF8-encoded 'Builder' -encodeToBuilder :: ToJSON a => a -> Builder -encodeToBuilder = encodeValueBB . toJSON - -encodeValueBB :: Value -> Builder -encodeValueBB jv = case jv of - Bool True -> "true" - Bool False -> "false" - Null -> "null" - Number n - | isNaN n || isInfinite n -> encodeValueBB Null - | Just i <- doubleToInt64 n -> BB.int64Dec i - | otherwise -> BB.doubleDec n - Array a -> encodeArrayBB a - String s -> encodeStringBB s - Object o -> encodeObjectBB o - -encodeArrayBB :: [Value] -> Builder -encodeArrayBB [] = "[]" -encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']' - where - go = mconcat . intersperse (BB.char8 ',') . map encodeValueBB - -encodeObjectBB :: Object -> Builder -encodeObjectBB [] = "{}" -encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' - where - go = mconcat . intersperse (BB.char8 ',') . map encPair - encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x - -encodeStringBB :: String -> Builder -encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' - where - go = BB.stringUtf8 . escapeString - ------------------------------------------------------------------------------- --- 'String'-based encoding - --- | Serialise value as JSON-encoded Unicode 'String' -encodeToString :: ToJSON a => a -> String -encodeToString jv = encodeValue (toJSON jv) [] - -encodeValue :: Value -> ShowS -encodeValue jv = case jv of - Bool b -> showString (if b then "true" else "false") - Null -> showString "null" - Number n - | isNaN n || isInfinite n -> encodeValue Null - | Just i <- doubleToInt64 n -> shows i - | otherwise -> shows n - Array a -> encodeArray a - String s -> encodeString s - Object o -> encodeObject o - -encodeArray :: [Value] -> ShowS -encodeArray [] = showString "[]" -encodeArray jvs = ('[':) . go jvs . (']':) - where - go [] = id - go [x] = encodeValue x - go (x:xs) = encodeValue x . (',':) . go xs - -encodeObject :: Object -> ShowS -encodeObject [] = showString "{}" -encodeObject jvs = ('{':) . go jvs . ('}':) - where - go [] = id - go [(l,x)] = encodeString l . (':':) . encodeValue x - go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs - -encodeString :: String -> ShowS -encodeString str = ('"':) . showString (escapeString str) . ('"':) - ------------------------------------------------------------------------------- --- helpers - --- | Try to convert 'Double' into 'Int64', return 'Nothing' if not --- representable loss-free as integral 'Int64' value. -doubleToInt64 :: Double -> Maybe Int64 -doubleToInt64 x - | fromInteger x' == x - , x' <= toInteger (maxBound :: Int64) - , x' >= toInteger (minBound :: Int64) - = Just (fromIntegral x') - | otherwise = Nothing - where - x' = round x - --- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings" -escapeString :: String -> String -escapeString s - | not (any needsEscape s) = s - | otherwise = escape s - where - escape [] = [] - escape (x:xs) = case x of - '\\' -> '\\':'\\':escape xs - '"' -> '\\':'"':escape xs - '\b' -> '\\':'b':escape xs - '\f' -> '\\':'f':escape xs - '\n' -> '\\':'n':escape xs - '\r' -> '\\':'r':escape xs - '\t' -> '\\':'t':escape xs - c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs - | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs - | otherwise -> c : escape xs - - -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF - needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] diff --git a/Distribution/Client/Utils/Parsec.hs b/Distribution/Client/Utils/Parsec.hs deleted file mode 100644 --- a/Distribution/Client/Utils/Parsec.hs +++ /dev/null @@ -1,102 +0,0 @@ -module Distribution.Client.Utils.Parsec ( - renderParseError, - ) where - -import Distribution.Client.Compat.Prelude -import Prelude () -import System.FilePath (normalise) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 - -import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) -import Distribution.Simple.Utils (fromUTF8BS) - --- | Render parse error highlighting the part of the input file. -renderParseError - :: FilePath - -> BS.ByteString - -> NonEmpty PError - -> [PWarning] - -> String -renderParseError filepath contents errors warnings = unlines $ - [ "Errors encountered when parsing cabal file " <> filepath <> ":" - ] - ++ renderedErrors - ++ renderedWarnings - where - filepath' = normalise filepath - - -- lines of the input file. 'lines' is taken, so they are called rows - -- contents, line number, whether it's empty line - rows :: [(String, Int, Bool)] - rows = zipWith f (BS8.lines contents) [1..] where - f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s) - - rowsZipper = listToZipper rows - - isEmptyOrComment :: String -> Bool - isEmptyOrComment s = case dropWhile (== ' ') s of - "" -> True -- empty - ('-':'-':_) -> True -- comment - _ -> False - - renderedErrors = concatMap renderError errors - renderedWarnings = concatMap renderWarning warnings - - renderError :: PError -> [String] - renderError (PError pos@(Position row col) msg) - -- if position is 0:0, then it doesn't make sense to show input - -- looks like, Parsec errors have line-feed in them - | pos == zeroPos = msgs - | otherwise = msgs ++ formatInput row col - where - msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ] - - renderWarning :: PWarning -> [String] - renderWarning (PWarning _ pos@(Position row col) msg) - | pos == zeroPos = msgs - | otherwise = msgs ++ formatInput row col - where - msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ] - - -- sometimes there are (especially trailing) newlines. - trimLF :: String -> String - trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse - - -- format line: prepend the given line number - formatInput :: Int -> Int -> [String] - formatInput row col = case advance (row - 1) rowsZipper of - Zipper xs ys -> before ++ after where - before = case span (\(_, _, b) -> b) xs of - (_, []) -> [] - (zs, z : _) -> map formatInputLine $ z : reverse zs - - after = case ys of - [] -> [] - (z : _zs) -> - [ formatInputLine z -- error line - , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^ - ] - -- do we need rows after? - -- ++ map formatInputLine (take 1 zs) -- one row after - - formatInputLine :: (String, Int, Bool) -> String - formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str - - -- hopefully we don't need to work with over 99999 lines .cabal files - -- at that point small glitches in error messages are hopefully fine. - leftPadShow :: Int -> String - leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s - -data Zipper a = Zipper [a] [a] - -listToZipper :: [a] -> Zipper a -listToZipper = Zipper [] - -advance :: Int -> Zipper a -> Zipper a -advance n z@(Zipper xs ys) - | n <= 0 = z - | otherwise = case ys of - [] -> z - (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys' diff --git a/Distribution/Client/VCS.hs b/Distribution/Client/VCS.hs deleted file mode 100644 --- a/Distribution/Client/VCS.hs +++ /dev/null @@ -1,641 +0,0 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} -module Distribution.Client.VCS ( - -- * VCS driver type - VCS, - vcsRepoType, - vcsProgram, - -- ** Type re-exports - RepoType, - Program, - ConfiguredProgram, - - -- * Validating 'SourceRepo's and configuring VCS drivers - validatePDSourceRepo, - validateSourceRepo, - validateSourceRepos, - SourceRepoProblem(..), - configureVCS, - configureVCSs, - - -- * Running the VCS driver - cloneSourceRepo, - syncSourceRepos, - - -- * The individual VCS drivers - knownVCSs, - vcsBzr, - vcsDarcs, - vcsGit, - vcsHg, - vcsSvn, - vcsPijul, - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Types.SourceRepo - ( RepoType(..), KnownRepoType (..) ) -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) -import Distribution.Client.RebuildMonad - ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) -import Distribution.Verbosity as Verbosity - ( normal ) -import Distribution.Simple.Program - ( Program(programFindVersion) - , ConfiguredProgram(programVersion) - , simpleProgram, findProgramVersion - , ProgramInvocation(..), programInvocation, runProgramInvocation - , emptyProgramDb, requireProgram ) -import Distribution.Version - ( mkVersion ) -import qualified Distribution.PackageDescription as PD - -import Control.Monad.Trans - ( liftIO ) -import qualified Data.Char as Char -import qualified Data.Map as Map -import System.FilePath - ( takeDirectory ) -import System.Directory - ( doesDirectoryExist ) - - --- | A driver for a version control system, e.g. git, darcs etc. --- -data VCS program = VCS { - -- | The type of repository this driver is for. - vcsRepoType :: RepoType, - - -- | The vcs program itself. - -- This is used at type 'Program' and 'ConfiguredProgram'. - vcsProgram :: program, - - -- | The program invocation(s) to get\/clone a repository into a fresh - -- local directory. - vcsCloneRepo :: forall f. Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath -- Source URI - -> FilePath -- Destination directory - -> [ProgramInvocation], - - -- | The program invocation(s) to synchronise a whole set of /related/ - -- repositories with corresponding local directories. Also returns the - -- files that the command depends on, for change monitoring. - vcsSyncRepos :: forall f. Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - } - - --- ------------------------------------------------------------ --- * Selecting repos and drivers --- ------------------------------------------------------------ - -data SourceRepoProblem = SourceRepoRepoTypeUnspecified - | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType - | SourceRepoLocationUnspecified - deriving Show - --- | Validates that the 'SourceRepo' specifies a location URI and a repository --- type that is supported by a VCS driver. --- --- | It also returns the 'VCS' driver we should use to work with it. --- -validateSourceRepo - :: SourceRepositoryPackage f - -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) -validateSourceRepo = \repo -> do - let rtype = srpType repo - vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype - let uri = srpLocation repo - return (repo, uri, rtype, vcs) - where - a ?! e = maybe (Left e) Right a - -validatePDSourceRepo - :: PD.SourceRepo - -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) -validatePDSourceRepo repo = do - rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified - uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified - validateSourceRepo SourceRepositoryPackage - { srpType = rtype - , srpLocation = uri - , srpTag = PD.repoTag repo - , srpBranch = PD.repoBranch repo - , srpSubdir = PD.repoSubdir repo - } - where - a ?! e = maybe (Left e) Right a - - - --- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return --- things in a convenient form to pass to 'configureVCSs', or to report --- problems. --- -validateSourceRepos :: [SourceRepositoryPackage f] - -> Either [(SourceRepositoryPackage f, SourceRepoProblem)] - [(SourceRepositoryPackage f, String, RepoType, VCS Program)] -validateSourceRepos rs = - case partitionEithers (map validateSourceRepo' rs) of - (problems@(_:_), _) -> Left problems - ([], vcss) -> Right vcss - where - validateSourceRepo' r = either (Left . (,) r) Right - (validateSourceRepo r) - - -configureVCS :: Verbosity - -> VCS Program - -> IO (VCS ConfiguredProgram) -configureVCS verbosity vcs@VCS{vcsProgram = prog} = - asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb - where - asVcsConfigured (prog', _) = vcs { vcsProgram = prog' } - -configureVCSs :: Verbosity - -> Map RepoType (VCS Program) - -> IO (Map RepoType (VCS ConfiguredProgram)) -configureVCSs verbosity = traverse (configureVCS verbosity) - - --- ------------------------------------------------------------ --- * Running the driver --- ------------------------------------------------------------ - --- | Clone a single source repo into a fresh directory, using a configured VCS. --- --- This is for making a new copy, not synchronising an existing copy. It will --- fail if the destination directory already exists. --- --- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first. --- - -cloneSourceRepo - :: Verbosity - -> VCS ConfiguredProgram - -> SourceRepositoryPackage f - -> [Char] - -> IO () -cloneSourceRepo verbosity vcs - repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir = - traverse_ (runProgramInvocation verbosity) invocations - where - invocations = vcsCloneRepo vcs verbosity - (vcsProgram vcs) repo - srcuri destdir - - --- | Syncronise a set of 'SourceRepo's referring to the same repository with --- corresponding local directories. The local directories may or may not --- already exist. --- --- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos', --- or used across a series of invocations with any local directory must refer --- to the /same/ repository. That means it must be the same location but they --- can differ in the branch, or tag or subdir. --- --- The reason to allow multiple related 'SourceRepo's is to allow for the --- network or storage to be shared between different checkouts of the repo. --- For example if a single repo contains multiple packages in different subdirs --- and in some project it may make sense to use a different state of the repo --- for one subdir compared to another. --- -syncSourceRepos :: Verbosity - -> VCS ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> Rebuild () -syncSourceRepos verbosity vcs repos = do - files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos - monitorFiles files - - --- ------------------------------------------------------------ --- * The various VCS drivers --- ------------------------------------------------------------ - --- | The set of all supported VCS drivers, organised by 'RepoType'. --- -knownVCSs :: Map RepoType (VCS Program) -knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ] - where - vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ] - - --- | VCS driver for Bazaar. --- -vcsBzr :: VCS Program -vcsBzr = - VCS { - vcsRepoType = KnownRepoType Bazaar, - vcsProgram = bzrProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog - ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ] - where - -- The @get@ command was deprecated in version 2.4 in favour of - -- the alias @branch@ - branchCmd | programVersion prog >= Just (mkVersion [2,4]) - = "branch" - | otherwise = "get" - - tagArgs = case srpTag repo of - Nothing -> [] - Just tag -> ["-r", "tag:" ++ tag] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - - vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" - -bzrProgram :: Program -bzrProgram = (simpleProgram "bzr") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff" - (_:_:ver:_) -> ver - _ -> "" - } - - --- | VCS driver for Darcs. --- -vcsDarcs :: VCS Program -vcsDarcs = - VCS { - vcsRepoType = KnownRepoType Darcs, - vcsProgram = darcsProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] - where - cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg - -- At some point the @clone@ command was introduced as an alias for - -- @get@, and @clone@ seems to be the recommended one now. - cloneCmd | programVersion prog >= Just (mkVersion [2,8]) - = "clone" - | otherwise = "get" - tagArgs = case srpTag repo of - Nothing -> [] - Just tag -> ["-t", tag] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - - vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs" - -darcsProgram :: Program -darcsProgram = (simpleProgram "darcs") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "2.8.5 (release)" - (ver:_) -> ver - _ -> "" - } - - --- | VCS driver for Git. --- -vcsGit :: VCS Program -vcsGit = - VCS { - vcsRepoType = KnownRepoType Git, - vcsProgram = gitProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] - -- And if there's a tag, we have to do that in a second step: - ++ [ (programInvocation prog (checkoutArgs tag)) { - progInvokeCwd = Just destdir - } - | tag <- maybeToList (srpTag repo) ] - where - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs ++ verboseArg - branchArgs = case srpBranch repo of - Just b -> ["--branch", b] - Nothing -> [] - checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - vcsSyncRepos _ _ [] = return [] - vcsSyncRepos verbosity gitProg - ((primaryRepo, primaryLocalDir) : secondaryRepos) = do - - vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing - sequence_ - [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) - | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir - | dir <- (primaryLocalDir : map snd secondaryRepos) ] - - vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do - exists <- doesDirectoryExist localDir - if exists - then git localDir ["fetch"] - else git (takeDirectory localDir) cloneArgs - git localDir checkoutArgs - where - git :: FilePath -> [String] -> IO () - git cwd args = runProgramInvocation verbosity $ - (programInvocation gitProg args) { - progInvokeCwd = Just cwd - } - - cloneArgs = ["clone", "--no-checkout", loc, localDir] - ++ case peer of - Nothing -> [] - Just peerLocalDir -> ["--reference", peerLocalDir] - ++ verboseArg - where loc = srpLocation - checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force" - , checkoutTarget, "--" ] - checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - -gitProgram :: Program -gitProgram = (simpleProgram "git") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "git version 2.5.5" - (_:_:ver:_) | all isTypical ver -> ver - - -- or annoyingly "git version 2.17.1.windows.2" yes, really - (_:_:ver:_) -> intercalate "." - . takeWhile (all isNum) - . split - $ ver - _ -> "" - } - where - isNum c = c >= '0' && c <= '9' - isTypical c = isNum c || c == '.' - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest - --- | VCS driver for Mercurial. --- -vcsHg :: VCS Program -vcsHg = - VCS { - vcsRepoType = KnownRepoType Mercurial, - vcsProgram = hgProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] - where - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs ++ tagArgs ++ verboseArg - branchArgs = case srpBranch repo of - Just b -> ["--branch", b] - Nothing -> [] - tagArgs = case srpTag repo of - Just t -> ["--rev", t] - Nothing -> [] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg" - -hgProgram :: Program -hgProgram = (simpleProgram "hg") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- Mercurial Distributed SCM (version 3.5.2)\n ... long message - (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver - _ -> "" - } - - --- | VCS driver for Subversion. --- -vcsSvn :: VCS Program -vcsSvn = - VCS { - vcsRepoType = KnownRepoType SVN, - vcsProgram = svnProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo verbosity prog _repo srcuri destdir = - [ programInvocation prog checkoutArgs ] - where - checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - --TODO: branch or tag? - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn" - -svnProgram :: Program -svnProgram = (simpleProgram "svn") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- svn, version 1.9.4 (r1740329)\n ... long message - (_:_:ver:_) -> ver - _ -> "" - } - - --- | VCS driver for Pijul. --- Documentation for Pijul can be found at --- --- 2020-04-09 Oleg: --- --- As far as I understand pijul, there are branches and "tags" in pijul, --- but there aren't a "commit hash" identifying an arbitrary state. --- --- One can create `a pijul tag`, which will make a patch hash, --- which depends on everything currently in the repository. --- I guess if you try to apply that patch, you'll be forced to apply --- all the dependencies too. In other words, there are no named tags. --- --- It's not clear to me whether there is an option to --- "apply this patch *and* all of its dependencies". --- And relatedly, whether how to make sure that there are no other --- patches applied. --- --- With branches it's easier, as you can `pull` and `checkout` them, --- and they seem to be similar enough. Yet, pijul documentations says --- --- > Note that the purpose of branches in Pijul is quite different from Git, --- since Git's "feature branches" can usually be implemented by just --- patches. --- --- I guess it means that indeed instead of creating a branch and making PR --- in "GitHub" workflow, you'd just create a patch and offer it. --- You can do that with `git` too. Push (a branch with) commit to remote --- and ask other to cherry-pick that commit. Yet, in git identity of commit --- changes when it applied to other trees, where patches in pijul have --- will continue to have the same hash. --- --- Unfortunately pijul doesn't talk about conflict resolution. --- It seems that you get something like: --- --- % pijul status --- On branch merge --- --- Unresolved conflicts: --- (fix conflicts and record the resolution with "pijul record ...") --- --- foo --- --- % cat foo --- first line --- >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>> --- branch BBB --- ================================ --- branch AAA --- <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< --- last line --- --- And then the `pijul dependencies` would draw you a graph like --- --- --- -----> foo on branch B -----> --- resolve confict Initial patch --- -----> foo on branch A -----> --- --- Which is seems reasonable. --- --- So currently, pijul support is very experimental, and most likely --- won't work, even the basics are in place. Tests are also written --- but disabled, as the branching model differs from `git` one, --- for which tests are written. --- -vcsPijul :: VCS Program -vcsPijul = - VCS { - vcsRepoType = KnownRepoType Pijul, - vcsProgram = pijulProgram, - vcsCloneRepo, - vcsSyncRepos - } - where - vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] - vcsCloneRepo _verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] - -- And if there's a tag, we have to do that in a second step: - ++ [ (programInvocation prog (checkoutArgs tag)) { - progInvokeCwd = Just destdir - } - | tag <- maybeToList (srpTag repo) ] - where - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs - branchArgs = case srpBranch repo of - Just b -> ["--from-branch", b] - Nothing -> [] - checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - vcsSyncRepos _ _ [] = return [] - vcsSyncRepos verbosity pijulProg - ((primaryRepo, primaryLocalDir) : secondaryRepos) = do - - vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing - sequence_ - [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir) - | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir - | dir <- (primaryLocalDir : map snd secondaryRepos) ] - - vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do - exists <- doesDirectoryExist localDir - if exists - then pijul localDir ["pull"] -- TODO: this probably doesn't work. - else pijul (takeDirectory localDir) cloneArgs - pijul localDir checkoutArgs - where - pijul :: FilePath -> [String] -> IO () - pijul cwd args = runProgramInvocation verbosity $ - (programInvocation pijulProg args) { - progInvokeCwd = Just cwd - } - - cloneArgs = ["clone", loc, localDir] - ++ case peer of - Nothing -> [] - Just peerLocalDir -> [peerLocalDir] - where loc = srpLocation - checkoutArgs = "checkout" : ["--force", checkoutTarget, "--" ] - checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong. - -pijulProgram :: Program -pijulProgram = (simpleProgram "pijul") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "pijul 0.12.2 - (_:ver:_) | all isTypical ver -> ver - _ -> "" - } - where - isNum c = c >= '0' && c <= '9' - isTypical c = isNum c || c == '.' diff --git a/Distribution/Client/Win32SelfUpgrade.hs b/Distribution/Client/Win32SelfUpgrade.hs deleted file mode 100644 --- a/Distribution/Client/Win32SelfUpgrade.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Win32SelfUpgrade --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Support for self-upgrading executables on Windows platforms. ------------------------------------------------------------------------------ -module Distribution.Client.Win32SelfUpgrade ( --- * Explanation --- --- | Windows inherited a design choice from DOS that while initially innocuous --- has rather unfortunate consequences. It maintains the invariant that every --- open file has a corresponding name on disk. One positive consequence of this --- is that an executable can always find its own executable file. The downside --- is that a program cannot be deleted or upgraded while it is running without --- hideous workarounds. This module implements one such hideous workaround. --- --- The basic idea is: --- --- * Move our own exe file to a new name --- * Copy a new exe file to the previous name --- * Run the new exe file, passing our own PID and new path --- * Wait for the new process to start --- * Close the new exe file --- * Exit old process --- --- Then in the new process: --- --- * Inform the old process that we've started --- * Wait for the old process to die --- * Delete the old exe file --- * Exit new process --- - - possibleSelfUpgrade, - deleteOldExeFile, - ) where - -import Distribution.Client.Compat.Prelude hiding (log) -import Prelude () - -#ifdef mingw32_HOST_OS - -import qualified System.Win32 as Win32 -import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) -import Foreign.Ptr (Ptr, nullPtr) -import System.Process (runProcess) -import System.Directory (canonicalizePath) -import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) - -import Distribution.Verbosity as Verbosity (showForCabal) -import Distribution.Simple.Utils (debug, info) - - --- | If one of the given files is our own exe file then we arrange things such --- that the nested action can replace our own exe file. --- --- We require that the new process accepts a command line invocation that --- calls 'deleteOldExeFile', passing in the PID and exe file. --- -possibleSelfUpgrade :: Verbosity - -> [FilePath] - -> IO a -> IO a -possibleSelfUpgrade verbosity newPaths action = do - dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE - - newPaths' <- traverse canonicalizePath newPaths - let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' - - if not doingSelfUpgrade - then action - else do - info verbosity $ "cabal-install does the replace-own-exe-file dance..." - tmpPath <- moveOurExeOutOfTheWay verbosity - result <- action - scheduleOurDemise verbosity dstPath tmpPath - (\pid path -> ["win32selfupgrade", pid, path - ,"--verbose=" ++ Verbosity.showForCabal verbosity]) - return result - --- | The name of a Win32 Event object that we use to synchronise between the --- old and new processes. We need to synchronise to make sure that the old --- process has not yet terminated by the time the new one starts up and looks --- for the old process. Otherwise the old one might have already terminated --- and we could not wait on it terminating reliably (eg the PID might get --- re-used). --- -syncEventName :: String -syncEventName = "Local\\cabal-install-upgrade" - --- | The first part of allowing our exe file to be replaced is to move the --- existing exe file out of the way. Although we cannot delete our exe file --- while we're still running, fortunately we can rename it, at least within --- the same directory. --- -moveOurExeOutOfTheWay :: Verbosity -> IO FilePath -moveOurExeOutOfTheWay verbosity = do - ourPID <- getCurrentProcessId - dstPath <- Win32.getModuleFileName Win32.nullHANDLE - - let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) - - debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath - Win32.moveFile dstPath tmpPath - return tmpPath - --- | Assuming we've now installed the new exe file in the right place, we --- launch it and ask it to delete our exe file when we eventually terminate. --- -scheduleOurDemise :: Verbosity -> FilePath -> FilePath - -> (String -> FilePath -> [String]) -> IO () -scheduleOurDemise verbosity dstPath tmpPath mkArgs = do - ourPID <- getCurrentProcessId - event <- createEvent syncEventName - - let args = mkArgs (show ourPID) tmpPath - log $ "launching child " ++ unwords (dstPath : map show args) - _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing - - log $ "waiting for the child to start up" - waitForSingleObject event (10*1000) -- wait at most 10 sec - log $ "child started ok" - - where - log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) - --- | Assuming we're now in the new child process, we've been asked by the old --- process to wait for it to terminate and then we can remove the old exe file --- that it renamed itself to. --- -deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile verbosity oldPID tmpPath = do - log $ "process started. Will delete exe file of process " - ++ show oldPID ++ " at path " ++ tmpPath - - log $ "getting handle of parent process " ++ show oldPID - oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID) - - log $ "synchronising with parent" - event <- openEvent syncEventName - setEvent event - - log $ "waiting for parent process to terminate" - waitForSingleObject oldPHANDLE Win32.iNFINITE - log $ "parent process terminated" - - log $ "deleting parent's old .exe file" - Win32.deleteFile tmpPath - - where - log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) - ------------------------- --- Win32 foreign imports --- - --- A bunch of functions sadly not provided by the Win32 package. - -#ifdef x86_64_HOST_ARCH -#define CALLCONV ccall -#else -#define CALLCONV stdcall -#endif - -foreign import CALLCONV unsafe "windows.h GetCurrentProcessId" - getCurrentProcessId :: IO DWORD - -foreign import CALLCONV unsafe "windows.h WaitForSingleObject" - waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD - -waitForSingleObject :: HANDLE -> DWORD -> IO () -waitForSingleObject handle timeout = - Win32.failIf_ bad "WaitForSingleObject" $ - waitForSingleObject_ handle timeout - where - bad result = not (result == 0 || result == wAIT_TIMEOUT) - wAIT_TIMEOUT = 0x00000102 - -foreign import CALLCONV unsafe "windows.h CreateEventW" - createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE - -createEvent :: String -> IO HANDLE -createEvent name = do - Win32.failIfNull "CreateEvent" $ - Win32.withTString name $ - createEvent_ nullPtr False False - -foreign import CALLCONV unsafe "windows.h OpenEventW" - openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE - -openEvent :: String -> IO HANDLE -openEvent name = do - Win32.failIfNull "OpenEvent" $ - Win32.withTString name $ - openEvent_ eVENT_MODIFY_STATE False - where - eVENT_MODIFY_STATE :: DWORD - eVENT_MODIFY_STATE = 0x0002 - -foreign import CALLCONV unsafe "windows.h SetEvent" - setEvent_ :: HANDLE -> IO BOOL - -setEvent :: HANDLE -> IO () -setEvent handle = - Win32.failIfFalse_ "SetEvent" $ - setEvent_ handle - -#else - -import Distribution.Simple.Utils (die') - -possibleSelfUpgrade :: Verbosity - -> [FilePath] - -> IO a -> IO a -possibleSelfUpgrade _ _ action = action - -deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32" - -#endif diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs deleted file mode 100644 --- a/Distribution/Client/World.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.World --- Copyright : (c) Peter Robinson 2009 --- License : BSD-like --- --- Maintainer : thaldyron@gmail.com --- Stability : provisional --- Portability : portable --- --- Interface to the world-file that contains a list of explicitly --- requested packages. Meant to be imported qualified. --- --- A world file entry stores the package-name, package-version, and --- user flags. --- For example, the entry generated by --- # cabal install stm-io-hooks --flags="-debug" --- looks like this: --- # stm-io-hooks -any --flags="-debug" --- To rebuild/upgrade the packages in world (e.g. when updating the compiler) --- use --- # cabal install world --- ------------------------------------------------------------------------------ -module Distribution.Client.World ( - WorldPkgInfo(..), - insert, - delete, - getContents, - ) where - -import Prelude (sequence) -import Distribution.Client.Compat.Prelude hiding (getContents) - -import Distribution.Types.Dependency -import Distribution.Types.Flag - ( FlagAssignment, unFlagAssignment - , unFlagName, parsecFlagAssignmentNonEmpty ) -import Distribution.Simple.Utils - ( die', info, chattyTry, writeFileAtomic ) -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Data.List - ( unionBy, deleteFirstsBy ) -import System.IO.Error - ( isDoesNotExistError ) -import qualified Data.ByteString.Lazy.Char8 as B - - -data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment - deriving (Show,Eq, Generic) - --- | Adds packages to the world file; creates the file if it doesn't --- exist yet. Version constraints and flag assignments for a package are --- updated if already present. IO errors are non-fatal. -insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () -insert = modifyWorld $ unionBy equalUDep - --- | Removes packages from the world file. --- Note: Currently unused as there is no mechanism in Cabal (yet) to --- handle uninstalls. IO errors are non-fatal. -delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () -delete = modifyWorld $ flip (deleteFirstsBy equalUDep) - --- | WorldPkgInfo values are considered equal if they refer to --- the same package, i.e., we don't care about differing versions or flags. -equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool -equalUDep (WorldPkgInfo (Dependency pkg1 _ _) _) - (WorldPkgInfo (Dependency pkg2 _ _) _) = pkg1 == pkg2 - --- | Modifies the world file by applying an update-function ('unionBy' --- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of --- packages. IO errors are considered non-fatal. -modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo] - -> [WorldPkgInfo]) - -- ^ Function that defines how - -- the list of user packages are merged with - -- existing world packages. - -> Verbosity - -> FilePath -- ^ Location of the world file - -> [WorldPkgInfo] -- ^ list of user supplied packages - -> IO () -modifyWorld _ _ _ [] = return () -modifyWorld f verbosity world pkgs = - chattyTry "Error while updating world-file. " $ do - pkgsOldWorld <- getContents verbosity world - -- Filter out packages that are not in the world file: - let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld - -- 'Dependency' is not an Ord instance, so we need to check for - -- equivalence the awkward way: - if not (all (`elem` pkgsOldWorld) pkgsNewWorld && - all (`elem` pkgsNewWorld) pkgsOldWorld) - then do - info verbosity "Updating world file..." - writeFileAtomic world . B.pack $ unlines - [ (prettyShow pkg) | pkg <- pkgsNewWorld] - else - info verbosity "World file is already up to date." - - --- | Returns the content of the world file as a list -getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo] -getContents verbosity world = do - content <- safelyReadFile world - let result = map simpleParsec (lines $ B.unpack content) - case sequence result of - Nothing -> die' verbosity "Could not parse world file." - Just xs -> return xs - where - safelyReadFile :: FilePath -> IO B.ByteString - safelyReadFile file = B.readFile file `catchIO` handler - where - handler e | isDoesNotExistError e = return B.empty - | otherwise = ioError e - - -instance Pretty WorldPkgInfo where - pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags) - where - dispFlags [] = Disp.empty - dispFlags fs = Disp.text "--flags=" - <<>> Disp.doubleQuotes (flagAssToDoc fs) - flagAssToDoc = foldr (\(fname,val) flagAssDoc -> - (if not val then Disp.char '-' - else Disp.char '+') - <<>> Disp.text (unFlagName fname) - Disp.<+> flagAssDoc) - Disp.empty - -instance Parsec WorldPkgInfo where - parsec = do - dep <- parsec - P.spaces - flagAss <- P.option mempty parseFlagAssignment - return $ WorldPkgInfo dep flagAss - where - parseFlagAssignment :: CabalParsing m => m FlagAssignment - parseFlagAssignment = do - _ <- P.string "--flags=" - inDoubleQuotes parsecFlagAssignmentNonEmpty - where - inDoubleQuotes = P.between (P.char '"') (P.char '"') diff --git a/Distribution/Deprecated/ParseUtils.hs b/Distribution/Deprecated/ParseUtils.hs deleted file mode 100644 --- a/Distribution/Deprecated/ParseUtils.hs +++ /dev/null @@ -1,563 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Deprecated.ParseUtils --- Copyright : (c) The University of Glasgow 2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. --- --- The @.cabal@ file format is not trivial, especially with the introduction --- of configurations and the section syntax that goes with that. This module --- has a bunch of parsing functions that is used by the @.cabal@ parser and a --- couple others. It has the parsing framework code and also little parsers for --- many of the formats we get in various @.cabal@ file fields, like module --- names, comma separated lists etc. - --- This module is meant to be local-only to Distribution... - -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE Rank2Types #-} -module Distribution.Deprecated.ParseUtils ( - LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, - runP, runE, ParseResult(..), parseFail, showPWarning, - Field(..), lineNo, - FieldDescr(..), readFields, readFieldsFlat, - parseHaskellString, parseFilePathQ, parseTokenQ, - parseOptCommaList, - showFilePath, showToken, showFreeText, - field, simpleField, listField, listFieldWithSep, spaceListField, - newLineListField, - liftField, - readPToMaybe, - - fieldParsec, simpleFieldParsec, - listFieldParsec, - commaListFieldParsec, - commaNewLineListFieldParsec, - - UnrecFieldParser, - ) where - -import Distribution.Client.Compat.Prelude hiding (get) -import Prelude () - -import Distribution.Deprecated.ReadP as ReadP hiding (get) - -import Distribution.Pretty -import Distribution.ReadE -import Distribution.Utils.Generic - -import Data.Tree as Tree (Tree (..), flatten) -import System.FilePath (normalise) -import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep) -import qualified Text.Read as Read - -import qualified Control.Monad.Fail as Fail -import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList) - --- ----------------------------------------------------------------------------- - -type LineNo = Int - -data PError = AmbiguousParse String LineNo - | NoParse String LineNo - | TabsError LineNo - | FromString String (Maybe LineNo) - deriving (Eq, Show) - -data PWarning = PWarning String - | UTFWarning LineNo String - deriving (Eq, Show) - -showPWarning :: FilePath -> PWarning -> String -showPWarning fpath (PWarning msg) = - normalise fpath ++ ": " ++ msg -showPWarning fpath (UTFWarning line fname) = - normalise fpath ++ ":" ++ show line - ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." - -data ParseResult a = ParseFailed PError | ParseOk [PWarning] a - deriving Show - -instance Functor ParseResult where - fmap _ (ParseFailed err) = ParseFailed err - fmap f (ParseOk ws x) = ParseOk ws $ f x - -instance Applicative ParseResult where - pure = ParseOk [] - (<*>) = ap - - -instance Monad ParseResult where - return = pure - ParseFailed err >>= _ = ParseFailed err - ParseOk ws x >>= f = case f x of - ParseFailed err -> ParseFailed err - ParseOk ws' x' -> ParseOk (ws'++ws) x' - -#if !(MIN_VERSION_base(4,9,0)) - fail = parseResultFail -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance Fail.MonadFail ParseResult where - fail = parseResultFail - -parseResultFail :: String -> ParseResult a -parseResultFail s = parseFail (FromString s Nothing) - -parseFail :: PError -> ParseResult a -parseFail = ParseFailed - -runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a -runP line fieldname p s = - case [ x | (x,"") <- results ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - --TODO: what is this double parse thing all about? - -- Can't we just do the all isSpace test the first time? - [] -> case [ x | (x,ys) <- results, all isSpace ys ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - [] -> ParseFailed (NoParse fieldname line) - _ -> ParseFailed (AmbiguousParse fieldname line) - _ -> ParseFailed (AmbiguousParse fieldname line) - where results = readP_to_S p s - -runE :: LineNo -> String -> ReadE a -> String -> ParseResult a -runE line fieldname p s = - case runReadE p s of - Right a -> ParseOk (utf8Warnings line fieldname s) a - Left e -> syntaxError line $ - "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s - -utf8Warnings :: LineNo -> String -> String -> [PWarning] -utf8Warnings line fieldname s = - take 1 [ UTFWarning n fieldname - | (n,l) <- zip [line..] (lines s) - , '\xfffd' `elem` l ] - -locatedErrorMsg :: PError -> (Maybe LineNo, String) -locatedErrorMsg (AmbiguousParse f n) = (Just n, - "Ambiguous parse in field '"++f++"'.") -locatedErrorMsg (NoParse f n) = (Just n, - "Parse of field '"++f++"' failed.") -locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") -locatedErrorMsg (FromString s n) = (n, s) - -syntaxError :: LineNo -> String -> ParseResult a -syntaxError n s = ParseFailed $ FromString s (Just n) - -tabsError :: LineNo -> ParseResult a -tabsError ln = ParseFailed $ TabsError ln - -warning :: String -> ParseResult () -warning s = ParseOk [PWarning s] () - --- | Field descriptor. The parameter @a@ parameterizes over where the field's --- value is stored in. -data FieldDescr a - = FieldDescr - { fieldName :: String - , fieldGet :: a -> Doc - , fieldSet :: LineNo -> String -> a -> ParseResult a - -- ^ @fieldSet n str x@ Parses the field value from the given input - -- string @str@ and stores the result in @x@ if the parse was - -- successful. Otherwise, reports an error on line number @n@. - } - -field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a -field name showF readF = - FieldDescr name showF (\line val _st -> runP line name readF val) - -fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a -fieldParsec name showF readF = - FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of - Left err -> ParseFailed (FromString err (Just line)) - Right x -> ParseOk [] x - --- Lift a field descriptor storing into an 'a' to a field descriptor storing --- into a 'b'. -liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b -liftField get set (FieldDescr name showF parseF) - = FieldDescr name (showF . get) - (\line str b -> do - a <- parseF line str (get b) - return (set a b)) - --- Parser combinator for simple fields. Takes a field name, a pretty printer, --- a parser function, an accessor, and a setter, returns a FieldDescr over the --- compoid structure. -simpleField :: String -> (a -> Doc) -> ReadP a a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -simpleField name showF readF get set - = liftField get set $ field name showF readF - -simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -simpleFieldParsec name showF readF get set - = liftField get set $ fieldParsec name showF readF - -commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListFieldWithSepParsec separator name showF readF get set = - liftField get set' $ - fieldParsec name showF' (parsecLeadingCommaList readF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . punctuate comma . map showF - -commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListFieldParsec = commaListFieldWithSepParsec fsep - -commaNewLineListFieldParsec - :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaNewLineListFieldParsec = commaListFieldWithSepParsec sep - -spaceListField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -spaceListField name showF readF get set = - liftField get set' $ - field name showF' (parseSpaceList readF) - where - set' xs b = set (get b ++ xs) b - showF' = fsep . map showF - --- this is a different definition from listField, like --- commaNewLineListField it pretty prints on multiple lines -newLineListField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -newLineListField = listFieldWithSep sep - -listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listFieldWithSep separator name showF readF get set = - liftField get set' $ - field name showF' (parseOptCommaList readF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . map showF - -listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listFieldWithSepParsec separator name showF readF get set = - liftField get set' $ - fieldParsec name showF' (parsecLeadingOptCommaList readF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . map showF - -listField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listField = listFieldWithSep fsep - -listFieldParsec - :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listFieldParsec = listFieldWithSepParsec fsep - --- | The type of a function which, given a name-value pair of an --- unrecognized field, and the current structure being built, --- decides whether to incorporate the unrecognized field --- (by returning Just x, where x is a possibly modified version --- of the structure being built), or not (by returning Nothing). -type UnrecFieldParser a = (String,String) -> a -> Maybe a - ------------------------------------------------------------------------------- - --- The data type for our three syntactic categories -data Field - = F LineNo String String - -- ^ A regular @: @ field - | Section LineNo String String [Field] - -- ^ A section with a name and possible parameter. The syntactic - -- structure is: - -- - -- @ - -- { - -- * - -- } - -- @ - | IfBlock LineNo String [Field] [Field] - -- ^ A conditional block with an optional else branch: - -- - -- @ - -- if { - -- * - -- } else { - -- * - -- } - -- @ - deriving (Show - ,Eq) -- for testing - -lineNo :: Field -> LineNo -lineNo (F n _ _) = n -lineNo (Section n _ _ _) = n -lineNo (IfBlock n _ _ _) = n - -readFields :: String -> ParseResult [Field] -readFields input = ifelse - =<< traverse (mkField 0) - =<< mkTree tokens - - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLine . trimLines) ls - -readFieldsFlat :: String -> ParseResult [Field] -readFieldsFlat input = traverse (mkField 0) - =<< mkTree tokens - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLineFlat . trimLines) ls - --- attach line number and determine indentation -trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] -trimLines ls = [ (lineno, indent, hastabs, trimTrailing l') - | (lineno, l) <- zip [1..] ls - , let (sps, l') = span isSpace l - indent = length sps - hastabs = '\t' `elem` sps - , validLine l' ] - where validLine ('-':'-':_) = False -- Comment - validLine [] = False -- blank line - validLine _ = True - --- | We parse generically based on indent level and braces '{' '}'. To do that --- we split into lines and then '{' '}' tokens and other spans within a line. -data Token = - -- | The 'Line' token is for bits that /start/ a line, eg: - -- - -- > "\n blah blah { blah" - -- - -- tokenises to: - -- - -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] - -- - -- so lines are the only ones that can have nested layout, since they - -- have a known indentation level. - -- - -- eg: we can't have this: - -- - -- > if ... { - -- > } else - -- > other - -- - -- because other cannot nest under else, since else doesn't start a line - -- so cannot have nested layout. It'd have to be: - -- - -- > if ... { - -- > } - -- > else - -- > other - -- - -- but that's not so common, people would normally use layout or - -- brackets not both in a single @if else@ construct. - -- - -- > if ... { foo : bar } - -- > else - -- > other - -- - -- this is OK - Line LineNo Indent HasTabs String - | Span LineNo String -- ^ span in a line, following brackets - | OpenBracket LineNo | CloseBracket LineNo - -type Indent = Int -type HasTabs = Bool - --- | Tokenise a single line, splitting on '{' '}' and the spans in between. --- Also trims leading & trailing space on those spans within the line. -tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] -tokeniseLine (n0, i, t, l) = case split n0 l of - (Span _ l':ss) -> Line n0 i t l' :ss - cs -> cs - where split _ "" = [] - split n s = case span (\c -> c /='}' && c /= '{') s of - ("", '{' : s') -> OpenBracket n : split n s' - (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') - ("", '}' : s') -> CloseBracket n : split n s' - (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') - (w , _) -> mkspan n w [] - - mkspan n s ss | null s' = ss - | otherwise = Span n s' : ss - where s' = trimTrailing (trimLeading s) - -tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] -tokeniseLineFlat (n0, i, t, l) - | null l' = [] - | otherwise = [Line n0 i t l'] - where - l' = trimTrailing (trimLeading l) - -trimLeading, trimTrailing :: String -> String -trimLeading = dropWhile isSpace -trimTrailing = dropWhileEndLE isSpace - - -type SyntaxTree = Tree (LineNo, HasTabs, String) - --- | Parse the stream of tokens into a tree of them, based on indent \/ layout -mkTree :: [Token] -> ParseResult [SyntaxTree] -mkTree toks = - layout 0 [] toks >>= \(trees, trailing) -> case trailing of - [] -> return trees - OpenBracket n:_ -> syntaxError n "mismatched brackets, unexpected {" - CloseBracket n:_ -> syntaxError n "mismatched brackets, unexpected }" - -- the following two should never happen: - Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l - Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l - - --- | Parse the stream of tokens into a tree of them, based on indent --- This parse state expect to be in a layout context, though possibly --- nested within a braces context so we may still encounter closing braces. -layout :: Indent -- ^ indent level of the parent\/previous line - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree], [Token]) - -- ^ collected trees on this level and trailing tokens -layout _ a [] = return (reverse a, []) -layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) -layout i a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,t,l) sub:a) ss' - -layout i a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,False,l) sub:a) ss' - --- look ahead to see if following lines are more indented, giving a sub-tree -layout i a (Line n i' t l:ss) = do - lookahead <- layout (i'+1) [] ss - case lookahead of - ([], _) -> layout i (Node (n,t,l) [] :a) ss - (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' - -layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'" -layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) -layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " - ++ show l - --- | Parse the stream of tokens into a tree of them, based on explicit braces --- This parse state expects to find a closing bracket. -braces :: LineNo -- ^ line of the '{', used for error messages - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree],[Token]) - -- ^ collected trees on this level and trailing tokens -braces m a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,t,l) sub:a) ss' - -braces m a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,False,l) sub:a) ss' - -braces m a (Line n i t l:ss) = do - lookahead <- layout (i+1) [] ss - case lookahead of - ([], _) -> braces m (Node (n,t,l) [] :a) ss - (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' - -braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss -braces _ a (CloseBracket _:ss) = return (reverse a, ss) -braces n _ [] = syntaxError n $ "opening brace '{'" - ++ "has no matching closing brace '}'" -braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" - --- | Convert the parse tree into the Field AST --- Also check for dodgy uses of tabs in indentation. -mkField :: Int -> SyntaxTree -> ParseResult Field -mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n -mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of - ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l - (name, rest) -> case trimLeading rest of - (':':rest') -> do let followingLines = concatMap Tree.flatten ts - tabs = not (null [()| (_,True,_) <- followingLines ]) - if tabs && d >= 1 - then tabsError n - else return $ F n (map toLower name) - (fieldValue rest' followingLines) - rest' -> do ts' <- traverse (mkField (d+1)) ts - return (Section n (map toLower name) rest' ts') - where fieldValue firstLine followingLines = - let firstLine' = trimLeading firstLine - followingLines' = map (\(_,_,s) -> stripDot s) followingLines - allLines | null firstLine' = followingLines' - | otherwise = firstLine' : followingLines' - in intercalate "\n" allLines - stripDot "." = "" - stripDot s = s - --- | Convert if/then/else 'Section's to 'IfBlock's -ifelse :: [Field] -> ParseResult [Field] -ifelse [] = return [] -ifelse (Section n "if" cond thenpart - :Section _ "else" as elsepart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | not (null as) = syntaxError n "'else' takes no arguments" - | null elsepart = syntaxError n "'else' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - ep <- ifelse elsepart - fs' <- ifelse fs - return (IfBlock n cond tp ep:fs') -ifelse (Section n "if" cond thenpart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - fs' <- ifelse fs - return (IfBlock n cond tp []:fs') -ifelse (Section n "else" _ _:_) = syntaxError n - "stray 'else' with no preceding 'if'" -ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' - fs''' <- ifelse fs - return (Section n s a fs'' : fs''') -ifelse (f:fs) = do fs' <- ifelse fs - return (f : fs') - ------------------------------------------------------------------------------- - -parseFilePathQ :: ReadP r FilePath -parseFilePathQ = parseTokenQ - -- removed until normalise is no longer broken, was: - -- liftM normalise parseTokenQ - --- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a --- because the "compat" version of ReadP isn't quite powerful enough. In --- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a --- Hence the trick above to make 'lic' polymorphic. - --- Different than the naive version. it turns out Read instance for String accepts --- the ['a', 'b'] syntax, which we do not want. In particular it messes --- up any token starting with []. -parseHaskellString :: ReadP r String -parseHaskellString = - readS_to_P $ - Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0 - -parseTokenQ :: ReadP r String -parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') - -parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseSpaceList p = sepBy p skipSpaces - --- This version avoid parse ambiguity for list element parsers --- that have multiple valid parses of prefixes. -parseOptCommaList :: ReadP r a -> ReadP r [a] -parseOptCommaList p = sepBy p localSep - where - -- The separator must not be empty or it introduces ambiguity - localSep = (skipSpaces >> char ',' >> skipSpaces) - +++ (satisfy isSpace >> skipSpaces) - -readPToMaybe :: ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str - , all isSpace s ] diff --git a/Distribution/Deprecated/ReadP.hs b/Distribution/Deprecated/ReadP.hs deleted file mode 100644 --- a/Distribution/Deprecated/ReadP.hs +++ /dev/null @@ -1,480 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- | --- --- Module : Distribution.Deprecated.ReadP --- Copyright : (c) The University of Glasgow 2002 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This is a library of parser combinators, originally written by Koen Claessen. --- It parses all alternatives in parallel, so it never keeps hold of --- the beginning of the input string, a common source of space leaks with --- other parsers. The '(+++)' choice combinator is genuinely commutative; --- it makes no difference which branch is \"shorter\". --- --- See also Koen's paper /Parallel Parsing Processes/ --- (). --- --- This version of ReadP has been locally hacked to make it H98, by --- Martin Sjögren --- --- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by --- Mark Lentczner ------------------------------------------------------------------------------ - -module Distribution.Deprecated.ReadP - ( - -- * The 'ReadP' type - ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus - - -- * Primitive operations - get, -- :: ReadP Char - look, -- :: ReadP String - (+++), -- :: ReadP a -> ReadP a -> ReadP a - (<++), -- :: ReadP a -> ReadP a -> ReadP a - gather, -- :: ReadP a -> ReadP (String, a) - - -- * Other operations - pfail, -- :: ReadP a - eof, -- :: ReadP () - satisfy, -- :: (Char -> Bool) -> ReadP Char - char, -- :: Char -> ReadP Char - string, -- :: String -> ReadP String - munch, -- :: (Char -> Bool) -> ReadP String - munch1, -- :: (Char -> Bool) -> ReadP String - skipSpaces, -- :: ReadP () - skipSpaces1,-- :: ReadP () - choice, -- :: [ReadP a] -> ReadP a - count, -- :: Int -> ReadP a -> ReadP [a] - between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a - option, -- :: a -> ReadP a -> ReadP a - optional, -- :: ReadP a -> ReadP () - many, -- :: ReadP a -> ReadP [a] - many1, -- :: ReadP a -> ReadP [a] - skipMany, -- :: ReadP a -> ReadP () - skipMany1, -- :: ReadP a -> ReadP () - sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] - - -- * Running a parser - ReadS, -- :: *; = String -> [(a,String)] - readP_to_S, -- :: ReadP a -> ReadS a - readS_to_P, -- :: ReadS a -> ReadP a - readP_to_E, - - -- ** Internal - Parser, - ) - where - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (many, get) - -import Control.Monad( replicateM, (>=>) ) - -import qualified Control.Monad.Fail as Fail - -import Distribution.CabalSpecVersion (cabalSpecLatest) -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Parsec as P - -import Distribution.ReadE (ReadE (..)) - -infixr 5 +++, <++ - --- --------------------------------------------------------------------------- --- The P type --- is representation type -- should be kept abstract - -data P s a - = Get (s -> P s a) - | Look ([s] -> P s a) - | Fail - | Result a (P s a) - | Final [(a,[s])] -- invariant: list is non-empty! - --- Monad, MonadPlus - -instance Functor (P s) where - fmap = liftM - -instance Applicative (P s) where - pure x = Result x Fail - (<*>) = ap - -instance Monad (P s) where - return = pure - - (Get f) >>= k = Get (f >=> k) - (Look f) >>= k = Look (f >=> k) - Fail >>= _ = Fail - (Result x p) >>= k = k x `mplus` (p >>= k) - (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] - -#if !(MIN_VERSION_base(4,9,0)) - fail _ = Fail -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance Fail.MonadFail (P s) where - fail _ = Fail - -instance Alternative (P s) where - empty = mzero - (<|>) = mplus - -instance MonadPlus (P s) where - mzero = Fail - - -- most common case: two gets are combined - Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) - - -- results are delivered as soon as possible - Result x p `mplus` q = Result x (p `mplus` q) - p `mplus` Result x q = Result x (p `mplus` q) - - -- fail disappears - Fail `mplus` p = p - p `mplus` Fail = p - - -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final - Final r `mplus` Final t = Final (r ++ t) - Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) - Final r `mplus` p = Look (\s -> Final (r ++ run p s)) - Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) - p `mplus` Final r = Look (\s -> Final (run p s ++ r)) - - -- two looks are combined (=optimization) - -- look + sthg else floats upwards - Look f `mplus` Look g = Look (\s -> f s `mplus` g s) - Look f `mplus` p = Look (\s -> f s `mplus` p) - p `mplus` Look f = Look (\s -> p `mplus` f s) - --- --------------------------------------------------------------------------- --- The ReadP type - -newtype Parser r s a = R ((a -> P s r) -> P s r) -type ReadP r a = Parser r Char a - --- Functor, Monad, MonadPlus - -instance Functor (Parser r s) where - fmap h (R f) = R (\k -> f (k . h)) - -instance Applicative (Parser r s) where - pure x = R (\k -> k x) - (<*>) = ap - -instance s ~ Char => Alternative (Parser r s) where - empty = pfail - (<|>) = (+++) - -instance Monad (Parser r s) where - return = pure - R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) - -#if !(MIN_VERSION_base(4,9,0)) - fail _ = R (const Fail) -#elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance Fail.MonadFail (Parser r s) where - fail _ = R (const Fail) - -instance s ~ Char => MonadPlus (Parser r s) where - mzero = pfail - mplus = (+++) - --- --------------------------------------------------------------------------- --- Operations over P - -final :: [(a,[s])] -> P s a --- Maintains invariant for Final constructor -final [] = Fail -final r = Final r - -run :: P c a -> ([c] -> [(a, [c])]) -run (Get f) (c:s) = run (f c) s -run (Look f) s = run (f s) s -run (Result x p) s = (x,s) : run p s -run (Final r) _ = r -run _ _ = [] - --- --------------------------------------------------------------------------- --- Operations over ReadP - -get :: ReadP r Char --- ^ Consumes and returns the next character. --- Fails if there is no input left. -get = R Get - -look :: ReadP r String --- ^ Look-ahead: returns the part of the input that is left, without --- consuming it. -look = R Look - -pfail :: ReadP r a --- ^ Always fails. -pfail = R (const Fail) - -eof :: ReadP r () --- ^ Succeeds iff we are at the end of input -eof = do { s <- look - ; if null s then return () - else pfail } - -(+++) :: ReadP r a -> ReadP r a -> ReadP r a --- ^ Symmetric choice. -R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) - -(<++) :: ReadP a a -> ReadP r a -> ReadP r a --- ^ Local, exclusive, left-biased choice: If left parser --- locally produces any result at all, then right parser is --- not used. -R f <++ q = - do s <- look - probe (f return) s 0 - where - probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) - probe (Look f') s n = probe (f' s) s n - probe p@(Result _ _) _ n = discard n >> R (p >>=) - probe (Final r) _ _ = R (Final r >>=) - probe _ _ _ = q - - discard 0 = return () - discard n = get >> discard (n-1 :: Int) - -gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) --- ^ Transforms a parser into one that does the same, but --- in addition returns the exact characters read. --- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument --- is built using any occurrences of readS_to_P. -gather (R m) = - R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) - where - gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) - gath _ Fail = Fail - gath l (Look f) = Look (gath l . f) - gath l (Result k p) = k (l []) `mplus` gath l p - gath _ (Final _) = error "do not use readS_to_P in gather!" - --- --------------------------------------------------------------------------- --- Derived operations - -satisfy :: (Char -> Bool) -> ReadP r Char --- ^ Consumes and returns the next character, if it satisfies the --- specified predicate. -satisfy p = do c <- get; if p c then return c else pfail - -char :: Char -> ReadP r Char --- ^ Parses and returns the specified character. -char c = satisfy (c ==) - -string :: String -> ReadP r String --- ^ Parses and returns the specified string. -string this = do s <- look; scan this s - where - scan [] _ = return this - scan (x:xs) (y:ys) | x == y = get >> scan xs ys - scan _ _ = pfail - -munch :: (Char -> Bool) -> ReadP r String --- ^ Parses the first zero or more characters satisfying the predicate. -munch p = - do s <- look - scan s - where - scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) - scan _ = do return "" - -munch1 :: (Char -> Bool) -> ReadP r String --- ^ Parses the first one or more characters satisfying the predicate. -munch1 p = - do c <- get - if p c then do s <- munch p; return (c:s) - else pfail - -choice :: [ReadP r a] -> ReadP r a --- ^ Combines all parsers in the specified list. -choice [] = pfail -choice [p] = p -choice (p:ps) = p +++ choice ps - -skipSpaces :: ReadP r () --- ^ Skips all whitespace. -skipSpaces = - do s <- look - skip s - where - skip (c:s) | isSpace c = do _ <- get; skip s - skip _ = do return () - -skipSpaces1 :: ReadP r () --- ^ Like 'skipSpaces' but succeeds only if there is at least one --- whitespace character to skip. -skipSpaces1 = satisfy isSpace >> skipSpaces - -count :: Int -> ReadP r a -> ReadP r [a] --- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of --- results is returned. -count n p = replicateM n p - -between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a --- ^ @ between open close p @ parses @open@, followed by @p@ and finally --- @close@. Only the value of @p@ is returned. -between open close p = do _ <- open - x <- p - _ <- close - return x - -option :: a -> ReadP r a -> ReadP r a --- ^ @option x p@ will either parse @p@ or return @x@ without consuming --- any input. -option x p = p +++ return x - -optional :: ReadP r a -> ReadP r () --- ^ @optional p@ optionally parses @p@ and always returns @()@. -optional p = (p >> return ()) +++ return () - -many :: ReadP r a -> ReadP r [a] --- ^ Parses zero or more occurrences of the given parser. -many p = return [] +++ many1 p - -many1 :: ReadP r a -> ReadP r [a] --- ^ Parses one or more occurrences of the given parser. -many1 p = liftM2 (:) p (many p) - -skipMany :: ReadP r a -> ReadP r () --- ^ Like 'many', but discards the result. -skipMany p = many p >> return () - -skipMany1 :: ReadP r a -> ReadP r () --- ^ Like 'many1', but discards the result. -skipMany1 p = p >> skipMany p - -sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. --- Returns a list of values returned by @p@. -sepBy p sep = sepBy1 p sep +++ return [] - -sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. --- Returns a list of values returned by @p@. -sepBy1 p sep = liftM2 (:) p (many (sep >> p)) - -endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended --- by @sep@. -endBy p sep = many (do x <- p ; _ <- sep ; return x) - -endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended --- by @sep@. -endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) - -chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a --- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. --- Returns a value produced by a /right/ associative application of all --- functions returned by @op@. If there are no occurrences of @p@, @x@ is --- returned. -chainr p op x = chainr1 p op +++ return x - -chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a --- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. --- Returns a value produced by a /left/ associative application of all --- functions returned by @op@. If there are no occurrences of @p@, @x@ is --- returned. -chainl p op x = chainl1 p op +++ return x - -chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a --- ^ Like 'chainr', but parses one or more occurrences of @p@. -chainr1 p op = scan - where scan = p >>= rest - rest x = do f <- op - y <- scan - return (f x y) - +++ return x - -chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a --- ^ Like 'chainl', but parses one or more occurrences of @p@. -chainl1 p op = p >>= rest - where rest x = do f <- op - y <- p - rest (f x y) - +++ return x - -manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] --- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ --- succeeds. Returns a list of values returned by @p@. -manyTill p end = scan - where scan = (end >> return []) <++ (liftM2 (:) p scan) - --- --------------------------------------------------------------------------- --- Converting between ReadP and Read - -readP_to_S :: ReadP a a -> ReadS a --- ^ Converts a parser into a Haskell ReadS-style function. --- This is the main way in which you can \"run\" a 'ReadP' parser: --- the expanded type is --- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ -readP_to_S (R f) = run (f return) - -readS_to_P :: ReadS a -> ReadP r a --- ^ Converts a Haskell ReadS-style function into a parser. --- Warning: This introduces local backtracking in the resulting --- parser, and therefore a possible inefficiency. -readS_to_P r = - R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance t ~ Char => P.Parsing (Parser r t) where - try = id - () = const - skipMany = skipMany - skipSome = skipMany1 - unexpected = const pfail - eof = eof - - -- TODO: we would like to have <++ here - notFollowedBy p = ((Just <$> p) +++ pure Nothing) - >>= maybe (pure ()) (P.unexpected . show) - -instance t ~ Char => P.CharParsing (Parser r t) where - satisfy = satisfy - char = char - notChar c = satisfy (/= c) - anyChar = get - string = string - -instance t ~ Char => P.CabalParsing (Parser r t) where - parsecWarning _ _ = pure () - askCabalSpecVersion = pure cabalSpecLatest - -------------------------------------------------------------------------------- --- ReadE -------------------------------------------------------------------------------- - -readP_to_E :: (String -> String) -> ReadP a a -> ReadE a -readP_to_E err r = - ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt - , all isSpace s ] - of [] -> Left (err txt) - (p:_) -> Right p diff --git a/Distribution/Deprecated/ViewAsFieldDescr.hs b/Distribution/Deprecated/ViewAsFieldDescr.hs deleted file mode 100644 --- a/Distribution/Deprecated/ViewAsFieldDescr.hs +++ /dev/null @@ -1,84 +0,0 @@ -module Distribution.Deprecated.ViewAsFieldDescr ( - viewAsFieldDescr - ) where - -import Distribution.Client.Compat.Prelude hiding (get) -import Prelude () - -import qualified Data.List.NonEmpty as NE -import Distribution.ReadE (parsecToReadE) -import Distribution.Simple.Command -import Text.PrettyPrint (cat, comma, punctuate, text) -import Text.PrettyPrint as PP (empty) - -import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError) - --- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > --- Choice > Opt) and consider only the first one. -viewAsFieldDescr :: OptionField a -> FieldDescr a -viewAsFieldDescr (OptionField _n []) = - error "Distribution.command.viewAsFieldDescr: unexpected" -viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set - - where - optDescr = head $ NE.sortBy cmp (d:|dd) - - cmp :: OptDescr a -> OptDescr a -> Ordering - ReqArg{} `cmp` ReqArg{} = EQ - ReqArg{} `cmp` _ = GT - BoolOpt{} `cmp` ReqArg{} = LT - BoolOpt{} `cmp` BoolOpt{} = EQ - BoolOpt{} `cmp` _ = GT - ChoiceOpt{} `cmp` ReqArg{} = LT - ChoiceOpt{} `cmp` BoolOpt{} = LT - ChoiceOpt{} `cmp` ChoiceOpt{} = EQ - ChoiceOpt{} `cmp` _ = GT - OptArg{} `cmp` OptArg{} = EQ - OptArg{} `cmp` _ = LT - --- get :: a -> Doc - get t = case optDescr of - ReqArg _ _ _ _ ppr -> - (cat . punctuate comma . map text . ppr) t - - OptArg _ _ _ _ _ ppr -> - case ppr t of [] -> PP.empty - (Nothing : _) -> text "True" - (Just a : _) -> text a - - ChoiceOpt alts -> - fromMaybe PP.empty $ listToMaybe - [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] - - BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t - --- set :: LineNo -> String -> a -> ParseResult a - set line val a = - case optDescr of - ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val - -- We parse for a single value instead of a - -- list, as one can't really implement - -- parseList :: ReadE a -> ReadE [a] with - -- the current ReadE definition - ChoiceOpt{} -> - case getChoiceByLongFlag optDescr val of - Just f -> return (f a) - _ -> syntaxError line val - - BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("" ++) parsec) val - - OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val - -- Optional arguments are parsed just like - -- required arguments here; we don't - -- provide a method to set an OptArg field - -- to the default value. - -getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a) -getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe - [ set | (_,(_sf,lf:_), set, _) <- alts - , lf == val] - -getChoiceByLongFlag _ _ = - error "Distribution.command.getChoiceByLongFlag: expected a choice option" - - diff --git a/Distribution/Solver/Compat/Prelude.hs b/Distribution/Solver/Compat/Prelude.hs deleted file mode 100644 --- a/Distribution/Solver/Compat/Prelude.hs +++ /dev/null @@ -1,19 +0,0 @@ --- to suppress WARNING in "Distribution.Compat.Prelude.Internal" -{-# OPTIONS_GHC -fno-warn-deprecations #-} - --- | This module does two things: --- --- * Acts as a compatibility layer, like @base-compat@. --- --- * Provides commonly used imports. --- --- This module is a superset of "Distribution.Compat.Prelude" (which --- this module re-exports) --- -module Distribution.Solver.Compat.Prelude - ( module Distribution.Compat.Prelude.Internal - , Prelude.IO - ) where - -import Prelude (IO) -import Distribution.Compat.Prelude.Internal hiding (IO) diff --git a/Distribution/Solver/Modular.hs b/Distribution/Solver/Modular.hs deleted file mode 100644 --- a/Distribution/Solver/Modular.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Solver.Modular - ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where - --- Here, we try to map between the external cabal-install solver --- interface and the internal interface that the solver actually --- expects. There are a number of type conversions to perform: we --- have to convert the package indices to the uniform index used --- by the solver; we also have to convert the initial constraints; --- and finally, we have to convert back the resulting install --- plan. - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import qualified Data.Map as M -import Data.Set (isSubsetOf) -import Distribution.Compat.Graph - ( IsNode(..) ) -import Distribution.Compiler - ( CompilerInfo ) -import Distribution.Solver.Modular.Assignment - ( Assignment, toCPs ) -import Distribution.Solver.Modular.ConfiguredConversion - ( convCP ) -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.IndexConversion - ( convPIs ) -import Distribution.Solver.Modular.Log - ( SolverFailure(..), displayLogMessages ) -import Distribution.Solver.Modular.Package - ( PN ) -import Distribution.Solver.Modular.RetryLog -import Distribution.Solver.Modular.Solver - ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) -import Distribution.Solver.Types.DependencyResolver -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb ) -import Distribution.Solver.Types.Progress -import Distribution.Solver.Types.Variable -import Distribution.System - ( Platform(..) ) -import Distribution.Simple.Setup - ( BooleanFlag(..) ) -import Distribution.Simple.Utils - ( ordNubBy ) -import Distribution.Verbosity - - --- | Ties the two worlds together: classic cabal-install vs. the modular --- solver. Performs the necessary translations before and after. -modularResolver :: SolverConfig -> DependencyResolver loc -modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = - fmap (uncurry postprocess) $ -- convert install plan - solve' sc cinfo idx pkgConfigDB pprefs gcs pns - where - -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx - -- Constraints have to be converted into a finite map indexed by PN. - gcs = M.fromListWith (++) (map pair pcs) - where - pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) - - -- Results have to be converted into an install plan. 'convCP' removes - -- package qualifiers, which means that linked packages become duplicates - -- and can be removed. - postprocess a rdm = ordNubBy nodeKey $ - map (convCP iidx sidx) (toCPs a rdm) - - -- Helper function to extract the PN from a constraint. - pcName :: PackageConstraint -> PN - pcName (PackageConstraint scope _) = scopeToPackageName scope - --- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display --- in the error case. --- --- When there is no solution, we produce the error message by rerunning the --- solver but making it prefer the goals from the final conflict set from the --- first run (or a subset of the final conflict set with --- --minimize-conflict-set). We also set the backjump limit to 0, so that the --- log stops at the first backjump and is relatively short. Preferring goals --- from the final conflict set increases the probability that the log to the --- first backjump contains package, flag, and stanza choices that are relevant --- to the final failure. The solver shouldn't need to choose any packages that --- aren't in the final conflict set. (For every variable in the final conflict --- set, the final conflict set should also contain the variable that introduced --- that variable. The solver can then follow that chain of variables in reverse --- order from the user target to the conflict.) However, it is possible that the --- conflict set contains unnecessary variables. --- --- Producing an error message when the solver reaches the backjump limit is more --- complicated. There is no final conflict set, so we create one for the minimal --- subtree containing the path that the solver took to the first backjump. This --- conflict set helps explain why the solver reached the backjump limit, because --- the first backjump contributes to reaching the backjump limit. Additionally, --- the solver is much more likely to be able to finish traversing this subtree --- before the backjump limit, since its size is linear (not exponential) in the --- number of goal choices. We create it by pruning all children after the first --- successful child under each node in the original tree, so that there is at --- most one valid choice at each level. Then we use the final conflict set from --- that run to generate an error message, as in the case where the solver found --- that there was no solution. --- --- Using the full log from a rerun of the solver ensures that the log is --- complete, i.e., it shows the whole chain of dependencies from the user --- targets to the conflicting packages. -solve' :: SolverConfig - -> CompilerInfo - -> Index - -> PkgConfigDb - -> (PN -> PackagePreferences) - -> Map PN [LabeledPackageConstraint] - -> Set PN - -> Progress String String (Assignment, RevDepMap) -solve' sc cinfo idx pkgConfigDB pprefs gcs pns = - toProgress $ retry (runSolver printFullLog sc) createErrorMsg - where - runSolver :: Bool -> SolverConfig - -> RetryLog String SolverFailure (Assignment, RevDepMap) - runSolver keepLog sc' = - displayLogMessages keepLog $ - solve sc' cinfo idx pkgConfigDB pprefs gcs pns - - createErrorMsg :: SolverFailure - -> RetryLog String String (Assignment, RevDepMap) - createErrorMsg failure@(ExhaustiveSearch cs cm) = - if asBool $ minimizeConflictSet sc - then continueWith ("Found no solution after exhaustively searching the " - ++ "dependency tree. Rerunning the dependency solver " - ++ "to minimize the conflict set ({" - ++ showConflictSet cs ++ "}).") $ - retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $ - \case - ExhaustiveSearch cs' cm' -> - fromProgress $ Fail $ - rerunSolverForErrorMsg cs' - ++ finalErrorMsg sc (ExhaustiveSearch cs' cm') - BackjumpLimitReached -> - fromProgress $ Fail $ - "Reached backjump limit while trying to minimize the " - ++ "conflict set to create a better error message. " - ++ "Original error message:\n" - ++ rerunSolverForErrorMsg cs - ++ finalErrorMsg sc failure - else fromProgress $ Fail $ - rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure - createErrorMsg failure@BackjumpLimitReached = - continueWith - ("Backjump limit reached. Rerunning dependency solver to generate " - ++ "a final conflict set for the search tree containing the " - ++ "first backjump.") $ - retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $ - \case - ExhaustiveSearch cs _ -> - fromProgress $ Fail $ - rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure - BackjumpLimitReached -> - -- This case is possible when the number of goals involved in - -- conflicts is greater than the backjump limit. - fromProgress $ Fail $ finalErrorMsg sc failure - ++ "Failed to generate a summarized dependency solver " - ++ "log due to low backjump limit." - - rerunSolverForErrorMsg :: ConflictSet -> String - rerunSolverForErrorMsg cs = - let sc' = sc { - goalOrder = Just goalOrder' - , maxBackjumps = Just 0 - } - - -- Preferring goals from the conflict set takes precedence over the - -- original goal order. - goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) - - in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc'))) - - printFullLog = solverVerbosity sc >= verbose - - messages :: Progress step fail done -> [step] - messages = foldProgress (:) (const []) (const []) - --- | Try to remove variables from the given conflict set to create a minimal --- conflict set. --- --- Minimal means that no proper subset of the conflict set is also a conflict --- set, though there may be other possible conflict sets with fewer variables. --- This function minimizes the input by trying to remove one variable at a time. --- It only makes one pass over the variables, so it runs the solver at most N --- times when given a conflict set of size N. Only one pass is necessary, --- because every superset of a conflict set is also a conflict set, meaning that --- failing to remove variable X from a conflict set in one step means that X --- cannot be removed from any subset of that conflict set in a subsequent step. --- --- Example steps: --- --- Start with {A, B, C}. --- Try to remove A from {A, B, C} and fail. --- Try to remove B from {A, B, C} and succeed. --- Try to remove C from {A, C} and fail. --- Return {A, C} --- --- This function can fail for two reasons: --- --- 1. The solver can reach the backjump limit on any run. In this case the --- returned RetryLog ends with BackjumpLimitReached. --- TODO: Consider applying the backjump limit to all solver runs combined, --- instead of each individual run. For example, 10 runs with 10 backjumps --- each should count as 100 backjumps. --- 2. Since this function works by rerunning the solver, it is possible for the --- solver to add new unnecessary variables to the conflict set. This function --- discards the result from any run that adds new variables to the conflict --- set, but the end result may not be completely minimized. -tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a) - -> SolverConfig - -> ConflictSet - -> ConflictMap - -> RetryLog String SolverFailure a -tryToMinimizeConflictSet runSolver sc cs cm = - foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v) - (fromProgress $ Fail $ ExhaustiveSearch cs cm) - (CS.toList cs) - where - -- This function runs the solver and makes it prefer goals in the following - -- order: - -- - -- 1. variables in 'smallestKnownCS', excluding 'v' - -- 2. 'v' - -- 3. all other variables - -- - -- If 'v' is not necessary, then the solver will find that there is no - -- solution before starting to solve for 'v', and the new final conflict set - -- will be very likely to not contain 'v'. If 'v' is necessary, the solver - -- will most likely need to try solving for 'v' before finding that there is - -- no solution, and the new final conflict set will still contain 'v'. - -- However, this method isn't perfect, because it is possible for the solver - -- to add new unnecessary variables to the conflict set on any run. This - -- function prevents the conflict set from growing by checking that the new - -- conflict set is a subset of the old one and falling back to using the old - -- conflict set when that check fails. - tryToRemoveOneVar :: Var QPN - -> ConflictSet - -> ConflictMap - -> RetryLog String SolverFailure a - tryToRemoveOneVar v smallestKnownCS smallestKnownCM - -- Check whether v is still present, because it may have already been - -- removed in a previous solver rerun. - | not (v `CS.member` smallestKnownCS) = - fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM - | otherwise = - continueWith ("Trying to remove variable " ++ varStr ++ " from the " - ++ "conflict set.") $ - retry (runSolver sc') $ \case - err@(ExhaustiveSearch cs' _) - | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS -> - let msg = if not $ CS.member v cs' - then "Successfully removed " ++ varStr ++ " from " - ++ "the conflict set." - else "Failed to remove " ++ varStr ++ " from the " - ++ "conflict set." - in -- Use the new conflict set, even if v wasn't removed, - -- because other variables may have been removed. - failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err - | otherwise -> - failWith ("Failed to find a smaller conflict set. The new " - ++ "conflict set is not a subset of the previous " - ++ "conflict set: " ++ showCS cs') $ - ExhaustiveSearch smallestKnownCS smallestKnownCM - BackjumpLimitReached -> - failWith ("Reached backjump limit while minimizing conflict set.") - BackjumpLimitReached - where - varStr = "\"" ++ showVar v ++ "\"" - showCS cs' = "{" ++ showConflictSet cs' ++ "}" - - sc' = sc { goalOrder = Just goalOrder' } - - goalOrder' = - preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS) - <> preferGoal v - <> fromMaybe mempty (goalOrder sc) - - -- Like 'retry', except that it only applies the input function when the - -- backjump limit has not been reached. - retryNoSolution :: RetryLog step SolverFailure done - -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done) - -> RetryLog step SolverFailure done - retryNoSolution lg f = retry lg $ \case - ExhaustiveSearch cs' cm' -> f cs' cm' - BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached) - --- | Goal ordering that chooses goals contained in the conflict set before --- other goals. -preferGoalsFromConflictSet :: ConflictSet - -> Variable QPN -> Variable QPN -> Ordering -preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs - --- | Goal ordering that chooses the given goal first. -preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering -preferGoal preferred = comparing $ \v -> toVar v /= preferred - -toVar :: Variable QPN -> Var QPN -toVar (PackageVar qpn) = P qpn -toVar (FlagVar qpn fn) = F (FN qpn fn) -toVar (StanzaVar qpn sn) = S (SN qpn sn) - -finalErrorMsg :: SolverConfig -> SolverFailure -> String -finalErrorMsg sc failure = - case failure of - ExhaustiveSearch cs cm -> - "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: " - ++ showCS cm cs - ++ flagSuggestion - where - showCS = if solverVerbosity sc > normal - then CS.showCSWithFrequency - else CS.showCSSortedByFrequency - flagSuggestion = - -- Don't suggest --minimize-conflict-set if the conflict set is - -- already small, because it is unlikely to be reduced further. - if CS.size cs > 3 && not (asBool (minimizeConflictSet sc)) - then "\nTry running with --minimize-conflict-set to improve the " - ++ "error message." - else "" - BackjumpLimitReached -> - "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++ - "change with --max-backjumps or try to run with --reorder-goals).\n" - where currlimit (Just n) = "currently " ++ show n ++ ", " - currlimit Nothing = "" diff --git a/Distribution/Solver/Modular/Assignment.hs b/Distribution/Solver/Modular/Assignment.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Assignment.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Distribution.Solver.Modular.Assignment - ( Assignment(..) - , PAssignment - , FAssignment - , SAssignment - , toCPs - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude hiding (pi) - -import qualified Data.Array as A -import qualified Data.List as L -import qualified Data.Map as M - -import Data.Maybe (fromJust) - -import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal - -import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackagePath - -import Distribution.Solver.Modular.Configured -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.LabeledGraph -import Distribution.Solver.Modular.Package - --- | A (partial) package assignment. Qualified package names --- are associated with instances. -type PAssignment = Map QPN I - -type FAssignment = Map QFN Bool -type SAssignment = Map QSN Bool - --- | A (partial) assignment of variables. -data Assignment = A PAssignment FAssignment SAssignment - deriving (Show, Eq) - --- | Delivers an ordered list of fully configured packages. --- --- TODO: This function is (sort of) ok. However, there's an open bug --- w.r.t. unqualification. There might be several different instances --- of one package version chosen by the solver, which will lead to --- clashes. -toCPs :: Assignment -> RevDepMap -> [CP QPN] -toCPs (A pa fa sa) rdm = - let - -- get hold of the graph - g :: Graph Component - vm :: Vertex -> ((), QPN, [(Component, QPN)]) - cvm :: QPN -> Maybe Vertex - -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. - (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) - (M.toList rdm)) - tg :: Graph Component - tg = transposeG g - -- Topsort the dependency graph, yielding a list of pkgs in the right order. - -- The graph will still contain all the installed packages, and it might - -- contain duplicates, because several variables might actually resolve to - -- the same package in the presence of qualified package names. - ps :: [PI QPN] - ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ - topSort g - -- Determine the flags per package, by walking over and regrouping the - -- complete flag assignment by package. - fapp :: Map QPN FlagAssignment - fapp = M.fromListWith mappend $ - L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ - M.toList $ - fa - -- Stanzas per package. - sapp :: Map QPN [OptionalStanza] - sapp = M.fromListWith (++) $ - L.map (\ ((SN qpn sn), b) -> (qpn, if b then [sn] else [])) $ - M.toList $ - sa - -- Dependencies per package. - depp :: QPN -> [(Component, PI QPN)] - depp qpn = let v :: Vertex - v = fromJust (cvm qpn) -- TODO: why this is safe? - dvs :: [(Component, Vertex)] - dvs = tg A.! v - in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs - -- Translated to PackageDeps - depp' :: QPN -> ComponentDeps [PI QPN] - depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp - in - L.map (\ pi@(PI qpn _) -> CP pi - (M.findWithDefault mempty qpn fapp) - (M.findWithDefault mempty qpn sapp) - (depp' qpn)) - ps diff --git a/Distribution/Solver/Modular/Builder.hs b/Distribution/Solver/Modular/Builder.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Builder.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.Builder ( - buildTree - , splits -- for testing - ) where - --- Building the search tree. --- --- In this phase, we build a search tree that is too large, i.e, it contains --- invalid solutions. We keep track of the open goals at each point. We --- nondeterministically pick an open goal (via a goal choice node), create --- subtrees according to the index and the available solutions, and extend the --- set of open goals by superficially looking at the dependencies recorded in --- the index. --- --- For each goal, we keep track of all the *reasons* why it is being --- introduced. These are for debugging and error messages, mainly. A little bit --- of care has to be taken due to the way we treat flags. If a package has --- flag-guarded dependencies, we cannot introduce them immediately. Instead, we --- store the entire dependency. - -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Set as S -import Prelude - -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package -import qualified Distribution.Solver.Modular.PSQ as P -import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.WeightedPSQ as W - -import Distribution.Solver.Types.ComponentDeps -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings - --- | All state needed to build and link the search tree. It has a type variable --- because the linking phase doesn't need to know about the state used to build --- the tree. -data Linker a = Linker { - buildState :: a, - linkingState :: LinkingState -} - --- | The state needed to build the search tree without creating any linked nodes. -data BuildState = BS { - index :: Index, -- ^ information about packages and their dependencies - rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies - open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) - next :: BuildType, -- ^ kind of node to generate next - qualifyOptions :: QualifyOptions -- ^ qualification options -} - --- | Map of available linking targets. -type LinkingState = M.Map (PN, I) [PackagePath] - --- | Extend the set of open goals with the new goals listed. --- --- We also adjust the map of overall goals, and keep track of the --- reverse dependencies of each of the goals. -extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState -extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs - where - go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState - go g o [] = s { rdeps = g, open = o } - go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = - go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs - -- Note: for 'Flagged' goals, we always insert, so later additions win. - -- This is important, because in general, if a goal is inserted twice, - -- the later addition will have better dependency information. - go g o ((Stanza sn@(SN qpn _) t) : ngs) = - go g (StanzaGoal sn t (flagGR qpn) : o) ngs - go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs) - | qpn == qpn' = - -- We currently only add a self-dependency to the graph if it is - -- between a package and its setup script. The edge creates a cycle - -- and causes the solver to backtrack and choose a different - -- instance for the setup script. We may need to track other - -- self-dependencies once we implement component-based solving. - case c of - ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs - _ -> go g o ngs - | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs - | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs - -- code above is correct; insert/adjust have different arg order - go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs - - addIfAbsent :: Eq a => a -> [a] -> [a] - addIfAbsent x xs = if x `elem` xs then xs else x : xs - - -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by - -- its containing package. - flagGR :: qpn -> GoalReason qpn - flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) - --- | Given the current scope, qualify all the package names in the given set of --- dependencies and then extend the set of open goals accordingly. -scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> - BuildState -> BuildState -scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s - where - -- Qualify all package names - qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps - -- Introduce all package flags - qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs - -- Combine new package and flag goals - gs = qfdefs ++ qfdeps - -- NOTE: - -- - -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially - -- multiple times, both via the flag declaration and via dependencies. - --- | Datatype that encodes what to build next -data BuildType = - Goals -- ^ build a goal choice node - | OneGoal OpenGoal -- ^ build a node for this goal - | Instance QPN PInfo -- ^ build a tree for a concrete instance - -build :: Linker BuildState -> Tree () QGoalReason -build = ana go - where - go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) - go s = addLinking (linkingState s) $ addChildren (buildState s) - -addChildren :: BuildState -> TreeF () QGoalReason BuildState - --- If we have a choice between many goals, we just record the choice in --- the tree. We select each open goal in turn, and before we descend, remove --- it from the queue of open goals. -addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) - | L.null gs = DoneF rdm () - | otherwise = GoalChoiceF rdm $ P.fromList - $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) - $ splits gs - --- If we have already picked a goal, then the choice depends on the kind --- of goal. --- --- For a package, we look up the instances available in the global info, --- and then handle each instance in turn. -addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = - case M.lookup pn idx of - Nothing -> FailF - (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) - UnknownPackage - Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> - ([], POption i Nothing, bs { next = Instance qpn info })) - (M.toList pis))) - -- TODO: data structure conversion is rather ugly here - --- For a flag, we create only two subtrees, and we create them in the order --- that is indicated by the flag default. -addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = - FChoiceF qfn rdm gr weak m b (W.fromList - [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), - ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) - where - trivial = L.null t && L.null f - weak = WeakOrTrivial $ unWeakOrTrivial w || trivial - --- For a stanza, we also create only two subtrees. The order is initially --- False, True. This can be changed later by constraints (force enabling --- the stanza by replacing the False branch with failure) or preferences --- (try enabling the stanza if possible by moving the True branch first). - -addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = - SChoiceF qsn rdm gr trivial (W.fromList - [([0], False, bs { next = Goals }), - ([1], True, (extendOpen qpn t bs) { next = Goals })]) - where - trivial = WeakOrTrivial (L.null t) - --- For a particular instance, we change the state: we update the scope, --- and furthermore we update the set of goals. --- --- TODO: We could inline this above. -addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = - addChildren ((scopedExtendOpen qpn fdeps fdefs bs) - { next = Goals }) - -{------------------------------------------------------------------------------- - Add linking --------------------------------------------------------------------------------} - --- | Introduce link nodes into the tree --- --- Linking is a phase that adapts package choice nodes and adds the option to --- link wherever appropriate: Package goals are called "related" if they are for --- the same instance of the same package (but have different prefixes). A link --- option is available in a package choice node whenever we can choose an --- instance that has already been chosen for a related goal at a higher position --- in the tree. We only create link options for related goals that are not --- themselves linked, because the choice to link to a linked goal is the same as --- the choice to link to the target of that goal's linking. --- --- The code here proceeds by maintaining a finite map recording choices that --- have been made at higher positions in the tree. For each pair of package name --- and instance, it stores the prefixes at which we have made a choice for this --- package instance. Whenever we make an unlinked choice, we extend the map. --- Whenever we find a choice, we look into the map in order to find out what --- link options we have to add. --- --- A separate tree traversal would be simpler. However, 'addLinking' creates --- linked nodes from existing unlinked nodes, which leads to sharing between the --- nodes. If we copied the nodes when they were full trees of type --- 'Tree () QGoalReason', then the sharing would cause a space leak during --- exploration of the tree. Instead, we only copy the 'BuildState', which is --- relatively small, while the tree is being constructed. See --- https://github.com/haskell/cabal/issues/2899 -addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a) --- The only nodes of interest are package nodes -addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) = - let linkedCs = fmap (\bs -> Linker bs ls) $ - W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs) - unlinkedCs = W.mapWithKey goP cs - allCs = unlinkedCs `W.union` linkedCs - - -- Recurse underneath package choices. Here we just need to make sure - -- that we record the package choice so that it is available below - goP :: POption -> a -> Linker a - goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls - goP _ _ = alreadyLinked - in PChoiceF qpn rdm gr allCs -addLinking ls t = fmap (\bs -> Linker bs ls) t - -linkChoices :: forall a w . LinkingState - -> QPN - -> (w, POption, a) - -> [(w, POption, a)] -linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = - L.map aux (M.findWithDefault [] (pn, i) related) - where - aux :: PackagePath -> (w, POption, a) - aux pp = (weight, POption i (Just pp), subtree) -linkChoices _ _ (_, POption _ (Just _), _) = - alreadyLinked - -alreadyLinked :: a -alreadyLinked = error "addLinking called on tree that already contains linked nodes" - -------------------------------------------------------------------------------- - --- | Interface to the tree builder. Just takes an index and a list of package names, --- and computes the initial state and then the tree from there. -buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason -buildTree idx (IndependentGoals ind) igs = - build Linker { - buildState = BS { - index = idx - , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) - , open = L.map topLevelGoal qpns - , next = Goals - , qualifyOptions = defaultQualifyOptions idx - } - , linkingState = M.empty - } - where - topLevelGoal qpn = PkgGoal qpn UserGoal - - qpns | ind = L.map makeIndependent igs - | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs - -{------------------------------------------------------------------------------- - Goals --------------------------------------------------------------------------------} - --- | Information needed about a dependency before it is converted into a Goal. -data OpenGoal = - FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason - | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason - | PkgGoal QPN QGoalReason - --- | Closes a goal, i.e., removes all the extraneous information that we --- need only during the build phase. -close :: OpenGoal -> Goal QPN -close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr -close (StanzaGoal qsn _ gr) = Goal (S qsn) gr -close (PkgGoal qpn gr) = Goal (P qpn) gr - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - --- | Pairs each element of a list with the list resulting from removal of that --- element from the original list. -splits :: [a] -> [(a, [a])] -splits = go id - where - go :: ([a] -> [a]) -> [a] -> [(a, [a])] - go _ [] = [] - go f (x : xs) = (x, f xs) : go (f . (x :)) xs diff --git a/Distribution/Solver/Modular/Configured.hs b/Distribution/Solver/Modular/Configured.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Configured.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Distribution.Solver.Modular.Configured - ( CP(..) - ) where - -import Distribution.PackageDescription (FlagAssignment) - -import Distribution.Solver.Modular.Package -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.OptionalStanza - --- | A configured package is a package instance together with --- a flag assignment and complete dependencies. -data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn]) diff --git a/Distribution/Solver/Modular/ConfiguredConversion.hs b/Distribution/Solver/Modular/ConfiguredConversion.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/ConfiguredConversion.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Distribution.Solver.Modular.ConfiguredConversion - ( convCP - ) where - -import Data.Maybe -import Prelude hiding (pi) -import Data.Either (partitionEithers) - -import Distribution.Package (UnitId, packageId) - -import qualified Distribution.Simple.PackageIndex as SI - -import Distribution.Solver.Modular.Configured -import Distribution.Solver.Modular.Package - -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import qualified Distribution.Solver.Types.PackageIndex as CI -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SourcePackage - --- | Converts from the solver specific result @CP QPN@ into --- a 'ResolverPackage', which can then be converted into --- the install plan. -convCP :: SI.InstalledPackageIndex -> - CI.PackageIndex (SourcePackage loc) -> - CP QPN -> ResolverPackage loc -convCP iidx sidx (CP qpi fa es ds) = - case convPI qpi of - Left pi -> PreExisting $ - InstSolverPackage { - instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, - instSolverPkgLibDeps = fmap fst ds', - instSolverPkgExeDeps = fmap snd ds' - } - Right pi -> Configured $ - SolverPackage { - solverPkgSource = srcpkg, - solverPkgFlags = fa, - solverPkgStanzas = es, - solverPkgLibDeps = fmap fst ds', - solverPkgExeDeps = fmap snd ds' - } - where - srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi - where - ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) - ds' = fmap (partitionEithers . map convConfId) ds - -convPI :: PI QPN -> Either UnitId PackageId -convPI (PI _ (I _ (Inst pi))) = Left pi -convPI pi = Right (packageId (either id id (convConfId pi))) - -convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} -convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = - case loc of - Inst pi -> Left (PreExistingId sourceId pi) - _otherwise - | QualExe _ pn' <- q - -- NB: the dependencies of the executable are also - -- qualified. So the way to tell if this is an executable - -- dependency is to make sure the qualifier is pointing - -- at the actual thing. Fortunately for us, I was - -- silly and didn't allow arbitrarily nested build-tools - -- dependencies, so a shallow check works. - , pn == pn' -> Right (PlannedId sourceId) - | otherwise -> Left (PlannedId sourceId) - where - sourceId = PackageIdentifier pn v diff --git a/Distribution/Solver/Modular/ConflictSet.hs b/Distribution/Solver/Modular/ConflictSet.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/ConflictSet.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef DEBUG_CONFLICT_SETS -{-# LANGUAGE ImplicitParams #-} -#endif --- | Conflict sets --- --- Intended for double import --- --- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) --- > import qualified Distribution.Solver.Modular.ConflictSet as CS -module Distribution.Solver.Modular.ConflictSet ( - ConflictSet -- opaque - , Conflict(..) - , ConflictMap - , OrderedVersionRange(..) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin -#endif - , showConflictSet - , showCSSortedByFrequency - , showCSWithFrequency - -- Set-like operations - , toSet - , toList - , union - , unions - , insert - , delete - , empty - , singleton - , singletonWithConflict - , size - , member - , lookup - , filter - , fromList - ) where - -import Prelude hiding (lookup) -import Data.List (intercalate, sortBy) -import Data.Map (Map) -import Data.Set (Set) -import Data.Function (on) -import qualified Data.Map.Strict as M -import qualified Data.Set as S - -#ifdef DEBUG_CONFLICT_SETS -import Data.Tree -import GHC.Stack -#endif - -import Distribution.Solver.Modular.Var -import Distribution.Solver.Modular.Version -import Distribution.Solver.Types.PackagePath - --- | The set of variables involved in a solver conflict, each paired with --- details about the conflict. -data ConflictSet = CS { - -- | The set of variables involved in the conflict - conflictSetToMap :: !(Map (Var QPN) (Set Conflict)) - -#ifdef DEBUG_CONFLICT_SETS - -- | The origin of the conflict set - -- - -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@, - -- we record the origin of every conflict set. For new conflict sets - -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations - -- that construct new conflict sets from existing conflict sets ('union', - -- 'filter', ..) we record the 'CallStack' to the call to the combinator - -- as well as the 'CallStack's of the input conflict sets. - -- - -- Requires @GHC >= 7.10@. - , conflictSetOrigin :: Tree CallStack -#endif - } - deriving (Show) - --- | More detailed information about how a conflict set variable caused a --- conflict. This information can be used to determine whether a second value --- for that variable would lead to the same conflict. --- --- TODO: Handle dependencies under flags or stanzas. -data Conflict = - - -- | The conflict set variable represents a package which depends on the - -- specified problematic package. For example, the conflict set entry - -- '(P x, GoalConflict y)' means that package x introduced package y, and y - -- led to a conflict. - GoalConflict QPN - - -- | The conflict set variable represents a package with a constraint that - -- excluded the specified package and version. For example, the conflict set - -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that - -- package x's constraint on y excluded y-2.0. - | VersionConstraintConflict QPN Ver - - -- | The conflict set variable represents a package that was excluded by a - -- constraint from the specified package. For example, the conflict set - -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))' - -- means that package y's constraint 'x >= 2.0' excluded some version of x. - | VersionConflict QPN OrderedVersionRange - - -- | Any other conflict. - | OtherConflict - deriving (Eq, Ord, Show) - --- | Version range with an 'Ord' instance. -newtype OrderedVersionRange = OrderedVersionRange VR - deriving (Eq, Show) - --- TODO: Avoid converting the version ranges to strings. -instance Ord OrderedVersionRange where - compare = compare `on` show - -instance Eq ConflictSet where - (==) = (==) `on` conflictSetToMap - -instance Ord ConflictSet where - compare = compare `on` conflictSetToMap - -showConflictSet :: ConflictSet -> String -showConflictSet = intercalate ", " . map showVar . toList - -showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String -showCSSortedByFrequency = showCS False - -showCSWithFrequency :: ConflictMap -> ConflictSet -> String -showCSWithFrequency = showCS True - -showCS :: Bool -> ConflictMap -> ConflictSet -> String -showCS showCount cm = - intercalate ", " . map showWithFrequency . indexByFrequency - where - indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList - showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of - Just frequency - | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" - _ -> showVar conflict - -{------------------------------------------------------------------------------- - Set-like operations --------------------------------------------------------------------------------} - -toSet :: ConflictSet -> Set (Var QPN) -toSet = M.keysSet . conflictSetToMap - -toList :: ConflictSet -> [Var QPN] -toList = M.keys . conflictSetToMap - -union :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - ConflictSet -> ConflictSet -> ConflictSet -union cs cs' = CS { - conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) -#endif - } - -unions :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - [ConflictSet] -> ConflictSet -unions css = CS { - conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) -#endif - } - -insert :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - Var QPN -> ConflictSet -> ConflictSet -insert var cs = CS { - conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] -#endif - } - -delete :: Var QPN -> ConflictSet -> ConflictSet -delete var cs = CS { - conflictSetToMap = M.delete var (conflictSetToMap cs) - } - -empty :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - ConflictSet -empty = CS { - conflictSetToMap = M.empty -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [] -#endif - } - -singleton :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - Var QPN -> ConflictSet -singleton var = singletonWithConflict var OtherConflict - -singletonWithConflict :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - Var QPN -> Conflict -> ConflictSet -singletonWithConflict var conflict = CS { - conflictSetToMap = M.singleton var (S.singleton conflict) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [] -#endif - } - -size :: ConflictSet -> Int -size = M.size . conflictSetToMap - -member :: Var QPN -> ConflictSet -> Bool -member var = M.member var . conflictSetToMap - -lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict) -lookup var = M.lookup var . conflictSetToMap - -fromList :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - [Var QPN] -> ConflictSet -fromList vars = CS { - conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [] -#endif - } - -type ConflictMap = Map (Var QPN) Int - diff --git a/Distribution/Solver/Modular/Cycles.hs b/Distribution/Solver/Modular/Cycles.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Cycles.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Distribution.Solver.Modular.Cycles ( - detectCyclesPhase - ) where - -import Prelude hiding (cycle) -import qualified Data.Map as M -import qualified Data.Set as S - -import qualified Distribution.Compat.Graph as G -import Distribution.Simple.Utils (ordNub) -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Types.ComponentDeps (Component) -import Distribution.Solver.Types.PackagePath - --- | Find and reject any nodes with cyclic dependencies -detectCyclesPhase :: Tree d c -> Tree d c -detectCyclesPhase = cata go - where - -- Only check children of choice nodes. - go :: TreeF d c (Tree d c) -> Tree d c - go (PChoiceF qpn rdm gr cs) = - PChoice qpn rdm gr $ fmap (checkChild qpn) cs - go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) = - FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs - go (SChoiceF qsn@(SN qpn _) rdm gr w cs) = - SChoice qsn rdm gr w $ fmap (checkChild qpn) cs - go x = inn x - - checkChild :: QPN -> Tree d c -> Tree d c - checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x - checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x - checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x - checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x - checkChild _ x@(Fail _ _) = x - checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x - - failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c - failIfCycle qpn rdm x = - case findCycles qpn rdm of - Nothing -> x - Just relSet -> Fail relSet CyclicDependencies - --- | Given the reverse dependency map from a node in the tree, check --- if the solution is cyclic. If it is, return the conflict set containing --- all decisions that could potentially break the cycle. --- --- TODO: The conflict set should also contain flag and stanza variables. -findCycles :: QPN -> RevDepMap -> Maybe ConflictSet -findCycles pkg rdm = - -- This function has two parts: a faster cycle check that is called at every - -- step and a slower calculation of the conflict set. - -- - -- 'hasCycle' checks for cycles incrementally by only looking for cycles - -- containing the current package, 'pkg'. It searches for cycles in the - -- 'RevDepMap', which is the data structure used to store reverse - -- dependencies in the search tree. We store the reverse dependencies in a - -- map, because Data.Map is smaller and/or has better sharing than - -- Distribution.Compat.Graph. - -- - -- If there is a cycle, we call G.cycles to find a strongly connected - -- component. Then we choose one cycle from the component to use for the - -- conflict set. Choosing only one cycle can lead to a smaller conflict set, - -- such as when a choice to enable testing introduces many cycles at once. - -- In that case, all cycles contain the current package and are in one large - -- strongly connected component. - -- - if hasCycle - then let scc :: G.Graph RevDepMapNode - scc = case G.cycles $ revDepMapToGraph rdm of - [] -> findCyclesError "cannot find a strongly connected component" - c : _ -> G.fromDistinctList c - - next :: QPN -> QPN - next p = case G.neighbors scc p of - Just (n : _) -> G.nodeKey n - _ -> findCyclesError "cannot find next node in the cycle" - - -- This function also assumes that all cycles contain 'pkg'. - oneCycle :: [QPN] - oneCycle = case iterate next pkg of - [] -> findCyclesError "empty cycle" - x : xs -> x : takeWhile (/= x) xs - in Just $ CS.fromList $ map P oneCycle - else Nothing - where - hasCycle :: Bool - hasCycle = pkg `S.member` closure (neighbors pkg) - - closure :: [QPN] -> S.Set QPN - closure = foldl go S.empty - where - go :: S.Set QPN -> QPN -> S.Set QPN - go s x = - if x `S.member` s - then s - else foldl go (S.insert x s) $ neighbors x - - neighbors :: QPN -> [QPN] - neighbors x = case x `M.lookup` rdm of - Nothing -> findCyclesError "cannot find node" - Just xs -> map snd xs - - findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++) - -data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)] - -instance G.IsNode RevDepMapNode where - type Key RevDepMapNode = QPN - nodeKey (RevDepMapNode qpn _) = qpn - nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns - -revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode -revDepMapToGraph rdm = G.fromDistinctList - [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/Distribution/Solver/Modular/Dependency.hs b/Distribution/Solver/Modular/Dependency.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Dependency.hs +++ /dev/null @@ -1,358 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Solver.Modular.Dependency ( - -- * Variables - Var(..) - , showVar - , varPN - -- * Conflict sets - , ConflictSet - , ConflictMap - , CS.showConflictSet - -- * Constrained instances - , CI(..) - -- * Flagged dependencies - , FlaggedDeps - , FlaggedDep(..) - , LDep(..) - , Dep(..) - , PkgComponent(..) - , ExposedComponent(..) - , DependencyReason(..) - , showDependencyReason - , flattenFlaggedDeps - , QualifyOptions(..) - , qualifyDeps - , unqualifyDeps - -- * Reverse dependency map - , RevDepMap - -- * Goals - , Goal(..) - , GoalReason(..) - , QGoalReason - , goalToVar - , varToConflictSet - , goalReasonToConflictSet - , goalReasonToConflictSetWithConflict - , dependencyReasonToConflictSet - , dependencyReasonToConflictSetWithVersionConstraintConflict - , dependencyReasonToConflictSetWithVersionConflict - ) where - -import Prelude () -import qualified Data.Map as M -import qualified Data.Set as S -import Distribution.Solver.Compat.Prelude hiding (pi) - -import Language.Haskell.Extension (Extension(..), Language(..)) - -import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Var -import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.ConflictSet as CS - -import Distribution.Solver.Types.ComponentDeps (Component(..)) -import Distribution.Solver.Types.PackagePath -import Distribution.Types.LibraryName -import Distribution.Types.PkgconfigVersionRange -import Distribution.Types.UnqualComponentName - -{------------------------------------------------------------------------------- - Constrained instances --------------------------------------------------------------------------------} - --- | Constrained instance. It represents the allowed instances for a package, --- which can be either a fixed instance or a version range. -data CI = Fixed I | Constrained VR - deriving (Eq, Show) - -{------------------------------------------------------------------------------- - Flagged dependencies --------------------------------------------------------------------------------} - --- | Flagged dependencies --- --- 'FlaggedDeps' is the modular solver's view of a packages dependencies: --- rather than having the dependencies indexed by component, each dependency --- defines what component it is in. --- --- Note that each dependency is associated with a Component. We must know what --- component the dependencies belong to, or else we won't be able to construct --- fine-grained reverse dependencies. -type FlaggedDeps qpn = [FlaggedDep qpn] - --- | Flagged dependencies can either be plain dependency constraints, --- or flag-dependent dependency trees. -data FlaggedDep qpn = - -- | Dependencies which are conditional on a flag choice. - Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) - -- | Dependencies which are conditional on whether or not a stanza - -- (e.g., a test suite or benchmark) is enabled. - | Stanza (SN qpn) (TrueFlaggedDeps qpn) - -- | Dependencies which are always enabled, for the component 'comp'. - | Simple (LDep qpn) Component - --- | Conversatively flatten out flagged dependencies --- --- NOTE: We do not filter out duplicates. -flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)] -flattenFlaggedDeps = concatMap aux - where - aux :: FlaggedDep qpn -> [(LDep qpn, Component)] - aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f - aux (Stanza _ t) = flattenFlaggedDeps t - aux (Simple d c) = [(d, c)] - -type TrueFlaggedDeps qpn = FlaggedDeps qpn -type FalseFlaggedDeps qpn = FlaggedDeps qpn - --- | A 'Dep' labeled with the reason it was introduced. --- --- 'LDep' intentionally has no 'Functor' instance because the type variable --- is used both to record the dependencies as well as who's doing the --- depending; having a 'Functor' instance makes bugs where we don't distinguish --- these two far too likely. (By rights 'LDep' ought to have two type variables.) -data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) - --- | A dependency (constraint) associates a package name with a constrained --- instance. It can also represent other types of dependencies, such as --- dependencies on language extensions. -data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component - | Ext Extension -- ^ dependency on a language extension - | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package - deriving Functor - --- | An exposed component within a package. This type is used to represent --- build-depends and build-tool-depends dependencies. -data PkgComponent qpn = PkgComponent qpn ExposedComponent - deriving (Eq, Ord, Functor, Show) - --- | A component that can be depended upon by another package, i.e., a library --- or an executable. -data ExposedComponent = - ExposedLib LibraryName - | ExposedExe UnqualComponentName - deriving (Eq, Ord, Show) - --- | The reason that a dependency is active. It identifies the package and any --- flag and stanza choices that introduced the dependency. It contains --- everything needed for creating ConflictSets or describing conflicts in solver --- log messages. -data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza) - deriving (Functor, Eq, Show) - --- | Print the reason that a dependency was introduced. -showDependencyReason :: DependencyReason QPN -> String -showDependencyReason (DependencyReason qpn flags stanzas) = - intercalate " " $ - showQPN qpn - : map (uncurry showFlagValue) (M.toList flags) - ++ map (\s -> showSBool s True) (S.toList stanzas) - --- | Options for goal qualification (used in 'qualifyDeps') --- --- See also 'defaultQualifyOptions' -data QualifyOptions = QO { - -- | Do we have a version of base relying on another version of base? - qoBaseShim :: Bool - - -- Should dependencies of the setup script be treated as independent? - , qoSetupIndependent :: Bool - } - deriving Show - --- | Apply built-in rules for package qualifiers --- --- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions', --- it is important that these 'QualifyOptions' are _static_. Qualification --- does NOT depend on flag assignment; in other words, it behaves the same no --- matter which choices the solver makes (modulo the global 'QualifyOptions'); --- we rely on this in 'linkDeps' (see comment there). --- --- NOTE: It's the _dependencies_ of a package that may or may not be independent --- from the package itself. Package flag choices must of course be consistent. -qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN -qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go - where - go :: FlaggedDeps PN -> FlaggedDeps QPN - go = map go1 - - go1 :: FlaggedDep PN -> FlaggedDep QPN - go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) - go1 (Simple dep comp) = Simple (goLDep dep comp) comp - - -- Suppose package B has a setup dependency on package A. - -- This will be recorded as something like - -- - -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion)) - -- - -- Observe that when we qualify this dependency, we need to turn that - -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier - -- to the DependencyReason. - goLDep :: LDep PN -> Component -> LDep QPN - goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) - - goD :: Dep PN -> Component -> Dep QPN - goD (Ext ext) _ = Ext ext - goD (Lang lang) _ = Lang lang - goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = - Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci - goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp - | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci - | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci - | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci - - -- If P has a setup dependency on Q, and Q has a regular dependency on R, then - -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup - -- dependency on R. We do not do this for the base qualifier however. - -- - -- The inherited qualifier is only used for regular dependencies; for setup - -- and base deppendencies we override the existing qualifier. See #3160 for - -- a detailed discussion. - inheritedQ :: Qualifier - inheritedQ = case q of - QualSetup _ -> q - QualExe _ _ -> q - QualToplevel -> q - QualBase _ -> QualToplevel - - -- Should we qualify this goal with the 'Base' package path? - qBase :: PN -> Bool - qBase dep = qoBaseShim && unPackageName dep == "base" - - -- Should we qualify this goal with the 'Setup' package path? - qSetup :: Component -> Bool - qSetup comp = qoSetupIndependent && comp == ComponentSetup - --- | Remove qualifiers from set of dependencies --- --- This is used during link validation: when we link package @Q.A@ to @Q'.A@, --- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute --- what to link these dependencies to, we need to requalify @Q.B@ to become --- @Q'.B@; we do this by first removing all qualifiers and then calling --- 'qualifyDeps' again. -unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN -unqualifyDeps = go - where - go :: FlaggedDeps QPN -> FlaggedDeps PN - go = map go1 - - go1 :: FlaggedDep QPN -> FlaggedDep PN - go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) - go1 (Simple dep comp) = Simple (goLDep dep) comp - - goLDep :: LDep QPN -> LDep PN - goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) - - unq :: QPN -> PN - unq (Q _ pn) = pn - -{------------------------------------------------------------------------------- - Reverse dependency map --------------------------------------------------------------------------------} - --- | A map containing reverse dependencies between qualified --- package names. -type RevDepMap = Map QPN [(Component, QPN)] - -{------------------------------------------------------------------------------- - Goals --------------------------------------------------------------------------------} - --- | A goal is just a solver variable paired with a reason. --- The reason is only used for tracing. -data Goal qpn = Goal (Var qpn) (GoalReason qpn) - deriving (Eq, Show, Functor) - --- | Reason why a goal is being added to a goal set. -data GoalReason qpn = - UserGoal -- introduced by a build target - | DependencyGoal (DependencyReason qpn) -- introduced by a package - deriving (Eq, Show, Functor) - -type QGoalReason = GoalReason QPN - -goalToVar :: Goal a -> Var a -goalToVar (Goal v _) = v - --- | Compute a singleton conflict set from a 'Var' -varToConflictSet :: Var QPN -> ConflictSet -varToConflictSet = CS.singleton - --- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal --- leads to a conflict. -goalReasonToConflictSet :: GoalReason QPN -> ConflictSet -goalReasonToConflictSet UserGoal = CS.empty -goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr - --- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the --- conflict occurred, namely the conflict set variables caused a conflict by --- introducing the given package goal. See the documentation for 'GoalConflict'. --- --- This function currently only specifies the reason for the conflict in the --- simple case where the 'GoalReason' does not involve any flags or stanzas. --- Otherwise, it falls back to calling 'goalReasonToConflictSet'. -goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet -goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal -goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr - --- | This function returns the solver variables responsible for the dependency. --- It drops the values chosen for flag and stanza variables, which are only --- needed for log messages. -dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet -dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = - CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) - where - -- Filter out any flags that introduced the dependency with both values. - -- They don't need to be included in the conflict set, because changing the - -- flag value can't remove the dependency. - flagVars :: [Var QPN] - flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth] - - stanzaToVar :: Stanza -> Var QPN - stanzaToVar = S . SN qpn - --- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the --- conflict occurred because the conflict set variables introduced a problematic --- version constraint. See the documentation for 'VersionConstraintConflict'. --- --- This function currently only specifies the reason for the conflict in the --- simple case where the 'DependencyReason' does not involve any flags or --- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. -dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN - -> Ver - -> DependencyReason QPN - -> ConflictSet -dependencyReasonToConflictSetWithVersionConstraintConflict - dependency excludedVersion dr@(DependencyReason qpn flags stanzas) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ - CS.VersionConstraintConflict dependency excludedVersion - | otherwise = dependencyReasonToConflictSet dr - --- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the --- conflict occurred because the conflict set variables introduced a version of --- a package that was excluded by a version constraint. See the documentation --- for 'VersionConflict'. --- --- This function currently only specifies the reason for the conflict in the --- simple case where the 'DependencyReason' does not involve any flags or --- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. -dependencyReasonToConflictSetWithVersionConflict :: QPN - -> CS.OrderedVersionRange - -> DependencyReason QPN - -> ConflictSet -dependencyReasonToConflictSetWithVersionConflict - pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ - CS.VersionConflict pkgWithVersionConstraint constraint - | otherwise = dependencyReasonToConflictSet dr diff --git a/Distribution/Solver/Modular/Explore.hs b/Distribution/Solver/Modular/Explore.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Explore.hs +++ /dev/null @@ -1,367 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.Explore (backjumpAndExplore) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import qualified Distribution.Solver.Types.Progress as P - -import qualified Data.List as L (foldl') -import qualified Data.Map.Strict as M -import qualified Data.Set as S - -import Distribution.Simple.Setup (asBool) - -import Distribution.Solver.Modular.Assignment -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Log -import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.Package -import qualified Distribution.Solver.Modular.PSQ as P -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.RetryLog -import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings - (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..)) -import Distribution.Types.VersionRange (anyVersion) - --- | This function takes the variable we're currently considering, a --- last conflict set and a list of children's logs. Each log yields --- either a solution or a conflict set. The result is a combined log for --- the parent node that has explored a prefix of the children. --- --- We can stop traversing the children's logs if we find an individual --- conflict set that does not contain the current variable. In this --- case, we can just lift the conflict set to the current level, --- because the current level cannot possibly have contributed to this --- conflict, so no other choice at the current level would avoid the --- conflict. --- --- If any of the children might contain a successful solution, we can --- return it immediately. If all children contain conflict sets, we can --- take the union as the combined conflict set. --- --- The last conflict set corresponds to the justification that we --- have to choose this goal at all. There is a reason why we have --- introduced the goal in the first place, and this reason is in conflict --- with the (virtual) option not to choose anything for the current --- variable. See also the comments for 'avoidSet'. --- --- We can also skip a child if it does not resolve any of the conflicts paired --- with the current variable in the previous child's conflict set. 'backjump' --- takes a function to determine whether a child can be skipped. If the child --- can be skipped, the function returns a new conflict set to be merged with the --- previous conflict set. --- -backjump :: forall w k a . Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - - -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) - -- ^ Function that determines whether the given choice could resolve - -- the given conflict. It indicates false by returning 'Just', - -- with the new conflicts to be added to the conflict set. - - -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) - -- ^ Function that logs the given choice that was skipped. - - -> Var QPN -- ^ The current variable. - - -> ConflictSet -- ^ Conflict set representing the reason that the goal - -- was introduced. - - -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) - -- ^ List of children's logs. - - -> ExploreState -> ConflictSetLog a -backjump mbj enableBj fineGrainedConflicts couldResolveConflicts - logSkippedChoice var lastCS xs = - foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing - where - combine :: (k, ExploreState -> ConflictSetLog a) - -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) - -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a - combine (k, x) f csAcc mPreviousCS es = - case (asBool fineGrainedConflicts, mPreviousCS) of - (True, Just previousCS) -> - case CS.lookup var previousCS of - Just conflicts -> - case couldResolveConflicts k conflicts of - Nothing -> retryNoSolution (x es) next - Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) - _ -> skipChoice previousCS - _ -> retryNoSolution (x es) next - where - next :: ConflictSet -> ExploreState -> ConflictSetLog a - next !cs es' = if asBool enableBj && not (var `CS.member` cs) - then skipLoggingBackjump cs es' - else f (csAcc `CS.union` cs) (Just cs) es' - - -- This function is for skipping the choice when it cannot resolve any - -- of the previous conflicts. - skipChoice :: ConflictSet -> ConflictSetLog a - skipChoice newCS = - retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' -> - f (csAcc `CS.union` cs') (Just cs') $ - - -- Update the conflict map with the conflict set, to make up for - -- skipping the whole subtree. - es' { esConflictMap = updateCM cs' (esConflictMap es') } - - -- This function represents the option to not choose a value for this goal. - avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a - avoidGoal cs _mPreviousCS !es = - logBackjump mbj (cs `CS.union` lastCS) $ - - -- Use 'lastCS' below instead of 'cs' since we do not want to - -- double-count the additionally accumulated conflicts. - es { esConflictMap = updateCM lastCS (esConflictMap es) } - - -- The solver does not count or log backjumps at levels where the conflict - -- set does not contain the current variable. Otherwise, there would be many - -- consecutive log messages about backjumping with the same conflict set. - skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a - skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) - --- | Creates a failing ConflictSetLog representing a backjump. It inserts a --- "backjumping" message, checks whether the backjump limit has been reached, --- and increments the backjump count. -logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a -logBackjump mbj cs es = - failWith (Failure cs Backjump) $ - if reachedBjLimit (esBackjumps es) - then BackjumpLimit - else NoSolution cs es { esBackjumps = esBackjumps es + 1 } - where - reachedBjLimit = case mbj of - Nothing -> const False - Just limit -> (>= limit) - --- | Like 'retry', except that it only applies the input function when the --- backjump limit has not been reached. -retryNoSolution :: ConflictSetLog a - -> (ConflictSet -> ExploreState -> ConflictSetLog a) - -> ConflictSetLog a -retryNoSolution lg f = retry lg $ \case - BackjumpLimit -> fromProgress (P.Fail BackjumpLimit) - NoSolution cs es -> f cs es - --- | The state that is read and written while exploring the search tree. -data ExploreState = ES { - esConflictMap :: !ConflictMap - , esBackjumps :: !Int - } - -data IntermediateFailure = - NoSolution ConflictSet ExploreState - | BackjumpLimit - -type ConflictSetLog = RetryLog Message IntermediateFailure - -getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) -getBestGoal cm = - P.maximumBy - ( flip (M.findWithDefault 0) cm - . (\ (Goal v _) -> v) - ) - -getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a) -getFirstGoal ts = - P.casePSQ ts - (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error - (\ k v _xs -> (k, v)) -- commit to the first goal choice - -updateCM :: ConflictSet -> ConflictMap -> ConflictMap -updateCM cs cm = - L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs) - --- | Record complete assignments on 'Done' nodes. -assign :: Tree d c -> Tree Assignment c -assign tree = cata go tree $ A M.empty M.empty M.empty - where - go :: TreeF d c (Assignment -> Tree Assignment c) - -> (Assignment -> Tree Assignment c) - go (FailF c fr) _ = Fail c fr - go (DoneF rdm _) a = Done rdm a - go (PChoiceF qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f ts - where f (POption k _) r = r (A (M.insert qpn k pa) fa sa) - go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts - where f k r = r (A pa (M.insert qfn k fa) sa) - go (SChoiceF qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f ts - where f k r = r (A pa fa (M.insert qsn k sa)) - go (GoalChoiceF rdm ts) a = GoalChoice rdm $ fmap ($ a) ts - --- | A tree traversal that simultaneously propagates conflict sets up --- the tree from the leaves and creates a log. -exploreLog :: Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - -> CountConflicts - -> Index - -> Tree Assignment QGoalReason - -> ConflictSetLog (Assignment, RevDepMap) -exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t = - para go t initES - where - getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) - getBestGoal' - | asBool countConflicts = \ ts cm -> getBestGoal cm ts - | otherwise = \ ts _ -> getFirstGoal ts - - go :: TreeF Assignment QGoalReason - (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) - -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) - go (FailF c fr) = \ !es -> - let es' = es { esConflictMap = updateCM c (esConflictMap es) } - in failWith (Failure c fr) (NoSolution c es') - go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) - go (PChoiceF qpn _ gr ts) = - backjump mbj enableBj fineGrainedConflicts - (couldResolveConflicts qpn) - (logSkippedPackage qpn) - (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryP qpn k) (r es)) - (fmap fst ts) - go (FChoiceF qfn _ gr _ _ _ ts) = - backjump mbj enableBj fineGrainedConflicts - (\_ _ -> Nothing) - (const logSkippedChoiceSimple) - (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryF qfn k) (r es)) - (fmap fst ts) - go (SChoiceF qsn _ gr _ ts) = - backjump mbj enableBj fineGrainedConflicts - (\_ _ -> Nothing) - (const logSkippedChoiceSimple) - (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryS qsn k) (r es)) - (fmap fst ts) - go (GoalChoiceF _ ts) = \ es -> - let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) - in continueWith (Next k) $ - -- Goal choice nodes are normally not counted as backjumps, since the - -- solver always explores exactly one choice, which means that the - -- backjump from the goal choice would be redundant with the backjump - -- from the PChoice, FChoice, or SChoice below. The one case where the - -- backjump is not redundant is when the chosen goal is a failure node, - -- so we log a backjump in that case. - case tree of - Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj - _ -> v es - - initES = ES { - esConflictMap = M.empty - , esBackjumps = 0 - } - - -- Is it possible for this package instance (QPN and POption) to resolve any - -- of the conflicts that were caused by the previous instance? The default - -- is true, because it is always safe to explore a package instance. - -- Skipping it is an optimization. If false, it returns a new conflict set - -- to be merged with the previous one. - couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet - couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = - let (PInfo deps _ _ _) = idx M.! pn M.! i - qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps - - couldBeResolved :: CS.Conflict -> Maybe ConflictSet - couldBeResolved CS.OtherConflict = Nothing - couldBeResolved (CS.GoalConflict conflictingDep) = - -- Check whether this package instance also has 'conflictingDep' - -- as a dependency (ignoring flag and stanza choices). - if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] - then Nothing - else Just CS.empty - couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) = - -- Check whether this package instance also excludes version - -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). - let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ] - vrIntersection = L.foldl' (.&&.) anyVersion vrs - in if checkVR vrIntersection excludedVersion - then Nothing - else -- If we skip this package instance, we need to update the - -- conflict set to say that 'dep' was also excluded by - -- this package instance's constraint. - Just $ CS.singletonWithConflict (P dep) $ - CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) - couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) = - -- Check whether this package instance's version is also excluded - -- by 'excludingVR'. - if checkVR excludingVR v - then Nothing - else -- If we skip this version, we need to update the conflict - -- set to say that the reverse dependency also excluded this - -- version. - Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) - in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) - - logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a - logSkippedPackage qpn pOption cs es = - tryWith (TryP qpn pOption) $ - failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $ - NoSolution cs es - - -- This function is used for flag and stanza choices, but it should not be - -- called, because there is currently no way to skip a value for a flag or - -- stanza. - logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a - logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es - --- | Build a conflict set corresponding to the (virtual) option not to --- choose a solution for a goal at all. --- --- In the solver, the set of goals is not statically determined, but depends --- on the choices we make. Therefore, when dealing with conflict sets, we --- always have to consider that we could perhaps make choices that would --- avoid the existence of the goal completely. --- --- Whenever we actually introduce a choice in the tree, we have already established --- that the goal cannot be avoided. This is tracked in the "goal reason". --- The choice to avoid the goal therefore is a conflict between the goal itself --- and its goal reason. We build this set here, and pass it to the 'backjump' --- function as the last conflict set. --- --- This has two effects: --- --- - In a situation where there are no choices available at all (this happens --- if an unknown package is requested), the last conflict set becomes the --- actual conflict set. --- --- - In a situation where all of the children's conflict sets contain the --- current variable, the goal reason of the current node will be added to the --- conflict set. --- -avoidSet :: Var QPN -> QGoalReason -> ConflictSet -avoidSet var@(P qpn) gr = - CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr) -avoidSet var gr = - CS.union (CS.singleton var) (goalReasonToConflictSet gr) - --- | Interface. --- --- Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing', --- then infinitely many backjumps are allowed. If the limit is 'Just 0', --- backtracking is completely disabled. -backjumpAndExplore :: Maybe Int - -> EnableBackjumping - -> FineGrainedConflicts - -> CountConflicts - -> Index - -> Tree d QGoalReason - -> RetryLog Message SolverFailure (Assignment, RevDepMap) -backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx = - mapFailure convertFailure - . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx - . assign - where - convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) - convertFailure BackjumpLimit = BackjumpLimitReached diff --git a/Distribution/Solver/Modular/Flag.hs b/Distribution/Solver/Modular/Flag.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Flag.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Solver.Modular.Flag - ( FInfo(..) - , Flag - , FlagInfo - , FN(..) - , QFN - , QSN - , Stanza - , SN(..) - , WeakOrTrivial(..) - , FlagValue(..) - , mkFlag - , showQFN - , showQFNBool - , showFlagValue - , showQSN - , showQSNBool - , showSBool - ) where - -import Data.Map as M -import Prelude hiding (pi) - -import qualified Distribution.PackageDescription as P -- from Cabal - -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackagePath - --- | Flag name. Consists of a package instance and the flag identifier itself. -data FN qpn = FN qpn Flag - deriving (Eq, Ord, Show, Functor) - --- | Flag identifier. Just a string. -type Flag = P.FlagName - --- | Stanza identifier. -type Stanza = OptionalStanza - -unFlag :: Flag -> String -unFlag = P.unFlagName - -mkFlag :: String -> Flag -mkFlag = P.mkFlagName - --- | Flag info. Default value, whether the flag is manual, and --- whether the flag is weak. Manual flags can only be set explicitly. --- Weak flags are typically deferred by the solver. -data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } - deriving (Eq, Show) - --- | Flag defaults. -type FlagInfo = Map Flag FInfo - --- | Qualified flag name. -type QFN = FN QPN - --- | Stanza name. Paired with a package name, much like a flag. -data SN qpn = SN qpn Stanza - deriving (Eq, Ord, Show, Functor) - --- | Qualified stanza name. -type QSN = SN QPN - --- | A property of flag and stanza choices that determines whether the --- choice should be deferred in the solving process. --- --- A choice is called weak if we do want to defer it. This is the --- case for flags that should be implied by what's currently installed on --- the system, as opposed to flags that are used to explicitly enable or --- disable some functionality. --- --- A choice is called trivial if it clearly does not matter. The --- special case of triviality we actually consider is if there are no new --- dependencies introduced by the choice. -newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } - deriving (Eq, Ord, Show) - --- | Value shown for a flag in a solver log message. The message can refer to --- only the true choice, only the false choice, or both choices. -data FlagValue = FlagTrue | FlagFalse | FlagBoth - deriving (Eq, Show) - -showQFNBool :: QFN -> Bool -> String -showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b - -showQSNBool :: QSN -> Bool -> String -showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b - -showFBool :: FN qpn -> Bool -> String -showFBool (FN _ f) v = P.showFlagValue (f, v) - --- | String representation of a flag-value pair. -showFlagValue :: P.FlagName -> FlagValue -> String -showFlagValue f FlagTrue = '+' : unFlag f -showFlagValue f FlagFalse = '-' : unFlag f -showFlagValue f FlagBoth = "+/-" ++ unFlag f - -showSBool :: Stanza -> Bool -> String -showSBool s True = "*" ++ showStanza s -showSBool s False = "!" ++ showStanza s - -showQFN :: QFN -> String -showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f - -showQSN :: QSN -> String -showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s diff --git a/Distribution/Solver/Modular/Index.hs b/Distribution/Solver/Modular/Index.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Index.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Distribution.Solver.Modular.Index - ( Index - , PInfo(..) - , ComponentInfo(..) - , IsVisible(..) - , IsBuildable(..) - , defaultQualifyOptions - , mkIndex - ) where - -import Prelude hiding (pi) - -import Data.Map (Map) -import qualified Data.List as L -import qualified Data.Map as M - -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree - --- | An index contains information about package instances. This is a nested --- dictionary. Package names are mapped to instances, which in turn is mapped --- to info. -type Index = Map PN (Map I PInfo) - --- | Info associated with a package instance. --- Currently, dependencies, component names, flags and failure reasons. --- The component map records whether any components are unbuildable in the --- current environment (compiler, os, arch, and global flag constraints). --- Packages that have a failure reason recorded for them are disabled --- globally, for reasons external to the solver. We currently use this --- for shadowing which essentially is a GHC limitation, and for --- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps PN) - (Map ExposedComponent ComponentInfo) - FlagInfo - (Maybe FailReason) - --- | Info associated with each library and executable in a package instance. -data ComponentInfo = ComponentInfo { - compIsVisible :: IsVisible - , compIsBuildable :: IsBuildable - } - deriving Show - --- | Whether a component is visible in the current environment. -newtype IsVisible = IsVisible Bool - deriving (Eq, Show) - --- | Whether a component is made unbuildable by a "buildable: False" field. -newtype IsBuildable = IsBuildable Bool - deriving (Eq, Show) - -mkIndex :: [(PN, I, PInfo)] -> Index -mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) - -groupMap :: Ord a => [(a, b)] -> Map a [b] -groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) - -defaultQualifyOptions :: Index -> QualifyOptions -defaultQualifyOptions idx = QO { - qoBaseShim = or [ dep == base - | -- Find all versions of base .. - Just is <- [M.lookup base idx] - -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is - -- .. and flatten all their dependencies .. - , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps - ] - , qoSetupIndependent = True - } - where - base = mkPackageName "base" diff --git a/Distribution/Solver/Modular/IndexConversion.hs b/Distribution/Solver/Modular/IndexConversion.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/IndexConversion.hs +++ /dev/null @@ -1,562 +0,0 @@ -module Distribution.Solver.Modular.IndexConversion - ( convPIs - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import qualified Data.List as L -import qualified Data.Map.Strict as M -import qualified Distribution.Compat.NonEmptySet as NonEmptySet -import qualified Data.Set as S - -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Compiler -import Distribution.Package -- from Cabal -import Distribution.Simple.BuildToolDepends -- from Cabal -import Distribution.Types.ExeDependency -- from Cabal -import Distribution.Types.PkgconfigDependency -- from Cabal -import Distribution.Types.ComponentName -- from Cabal -import Distribution.Types.CondTree -- from Cabal -import Distribution.Types.MungedPackageId -- from Cabal -import Distribution.Types.MungedPackageName -- from Cabal -import Distribution.PackageDescription -- from Cabal -import Distribution.PackageDescription.Configuration -import qualified Distribution.Simple.PackageIndex as SI -import Distribution.System - -import Distribution.Solver.Types.ComponentDeps - ( Component(..), componentNameToComponent ) -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import qualified Distribution.Solver.Types.PackageIndex as CI -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SourcePackage - -import Distribution.Solver.Modular.Dependency as D -import Distribution.Solver.Modular.Flag as F -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version - --- | Convert both the installed package index and the source package --- index into one uniform solver index. --- --- We use 'allPackagesBySourcePackageId' for the installed package index --- because that returns us several instances of the same package and version --- in order of preference. This allows us in principle to \"shadow\" --- packages if there are several installed packages of the same version. --- There are currently some shortcomings in both GHC and Cabal in --- resolving these situations. However, the right thing to do is to --- fix the problem there, so for now, shadowing is only activated if --- explicitly requested. -convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> ShadowPkgs -> StrongFlags -> SolveExecutables - -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) - -> Index -convPIs os arch comp constraints sip strfl solveExes iidx sidx = - mkIndex $ - convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx - --- | Convert a Cabal installed package index to the simpler, --- more uniform index format of the solver. -convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] -convIPI' (ShadowPkgs sip) idx = - -- apply shadowing whenever there are multiple installed packages with - -- the same version - [ maybeShadow (convIP idx pkg) - -- IMPORTANT to get internal libraries. See - -- Note [Index conversion with internal libraries] - | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx - , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] - where - - -- shadowing is recorded in the package info - shadow (pn, i, PInfo fdeps comps fds _) - | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed)) - shadow x = x - --- | Extract/recover the package ID from an installed package info, and convert it to a solver's I. -convId :: IPI.InstalledPackageInfo -> (PN, I) -convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) - where MungedPackageId mpn ver = mungedId ipi - -- HACK. See Note [Index conversion with internal libraries] - pn = encodeCompatPackageName mpn - --- | Convert a single installed package into the solver-specific format. -convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) -convIP idx ipi = - case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of - Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) - Right fds -> (pn, i, PInfo fds components M.empty Nothing) - where - -- TODO: Handle sub-libraries and visibility. - components = - M.singleton (ExposedLib LMainLibName) - ComponentInfo { - compIsVisible = IsVisible True - , compIsBuildable = IsBuildable True - } - - (pn, i) = convId ipi - - -- 'sourceLibName' is unreliable, but for now we only really use this for - -- primary libs anyways - comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi --- TODO: Installed packages should also store their encapsulations! - --- Note [Index conversion with internal libraries] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Something very interesting happens when we have internal libraries --- in our index. In this case, we maybe have p-0.1, which itself --- depends on the internal library p-internal ALSO from p-0.1. --- Here's the danger: --- --- - If we treat both of these packages as having PN "p", --- then the solver will try to pick one or the other, --- but never both. --- --- - If we drop the internal packages, now p-0.1 has a --- dangling dependency on an "installed" package we know --- nothing about. Oops. --- --- An expedient hack is to put p-internal into cabal-install's --- index as a MUNGED package name, so that it doesn't conflict --- with anyone else (except other instances of itself). But --- yet, we ought NOT to say that PNs in the solver are munged --- package names, because they're not; for source packages, --- we really will never see munged package names. --- --- The tension here is that the installed package index is actually --- per library, but the solver is per package. We need to smooth --- it over, and munging the package names is a pretty good way to --- do it. - --- | Convert dependencies specified by an installed package id into --- flagged dependencies of the solver. --- --- May return Nothing if the package can't be found in the index. That --- indicates that the original package having this dependency is broken --- and should be ignored. -convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) -convIPId dr comp idx ipid = - case SI.lookupUnitId idx ipid of - Nothing -> Left ipid - Just ipi -> let (pn, i) = convId ipi - name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. - in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) - -- NB: something we pick up from the - -- InstalledPackageIndex is NEVER an executable - --- | Convert a cabal-install source package index to the simpler, --- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables - -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] -convSPI' os arch cinfo constraints strfl solveExes = - L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages - --- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) -convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = - let i = I pv InRepo - pkgConstraints = fromMaybe [] $ M.lookup pn constraints - in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) - --- We do not use 'flattenPackageDescription' or 'finalizePD' --- from 'Distribution.PackageDescription.Configuration' here, because we --- want to keep the condition tree, but simplify much of the test. - --- | Convert a generic package description to a solver-specific 'PInfo'. -convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription - -> PInfo -convGPD os arch cinfo constraints strfl solveExes pn - (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) = - let - fds = flagInfo strfl flags - - - conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN -> - CondTree ConfVar [Dependency] a -> FlaggedDeps PN - conv comp getInfo dr = - convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes . - addBuildableCondition getInfo - - initDR = DependencyReason pn M.empty S.empty - - flagged_deps - = concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) - ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs - ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs - ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes - ++ prefix (Stanza (SN pn TestStanzas)) - (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) - tests) - ++ prefix (Stanza (SN pn BenchStanzas)) - (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) - benchs) - ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) - - addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn - addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) - - -- | A too-new specVersion is turned into a global 'FailReason' - -- which prevents the solver from selecting this release (and if - -- forced to, emit a meaningful solver error message). - fr = case scannedVersion of - Just ver -> Just (UnsupportedSpecVer ver) - Nothing -> Nothing - - components :: Map ExposedComponent ComponentInfo - components = M.fromList $ libComps ++ subLibComps ++ exeComps - where - libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib) - | lib <- maybeToList mlib ] - subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib) - | (name, lib) <- sub_libs ] - exeComps = [ ( ExposedExe name - , ComponentInfo { - compIsVisible = IsVisible True - , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False - } - ) - | (name, exe) <- exes ] - - libToComponentInfo lib = - ComponentInfo { - compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True - , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False - } - - testCondition = testConditionForComponent os arch cinfo constraints - - isPrivate LibraryVisibilityPrivate = True - isPrivate LibraryVisibilityPublic = False - - in PInfo flagged_deps components fds fr - --- | Applies the given predicate (for example, testing buildability or --- visibility) to the given component and environment. Values are combined with --- AND. This function returns 'Nothing' when the result cannot be determined --- before dependency solving. Additionally, this function only considers flags --- that are set by unqualified flag constraints, and it doesn't check the --- intra-package dependencies of a component. -testConditionForComponent :: OS - -> Arch - -> CompilerInfo - -> [LabeledPackageConstraint] - -> (a -> Bool) - -> CondTree ConfVar [Dependency] a - -> Maybe Bool -testConditionForComponent os arch cinfo constraints p tree = - case go $ extractCondition p tree of - Lit True -> Just True - Lit False -> Just False - _ -> Nothing - where - flagAssignment :: [(FlagName, Bool)] - flagAssignment = - mconcat [ unFlagAssignment fa - | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) - <- L.map unlabelPackageConstraint constraints] - - -- Simplify the condition, using the current environment. Most of this - -- function was copied from convBranch and - -- Distribution.Types.Condition.simplifyCondition. - go :: Condition ConfVar -> Condition ConfVar - go (Var (OS os')) = Lit (os == os') - go (Var (Arch arch')) = Lit (arch == arch') - go (Var (Impl cf cvr)) - | matchImpl (compilerInfoId cinfo) || - -- fixme: Nothing should be treated as unknown, rather than empty - -- list. This code should eventually be changed to either - -- support partial resolution of compiler flags or to - -- complain about incompletely configured compilers. - any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True - | otherwise = Lit False - where - matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv - go (Var (PackageFlag f)) - | Just b <- L.lookup f flagAssignment = Lit b - go (Var v) = Var v - go (Lit b) = Lit b - go (CNot c) = - case go c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' - go (COr c d) = - case (go c, go d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c', d') -> COr c' d' - go (CAnd c d) = - case (go c, go d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c', d') -> CAnd c' d' - --- | Create a flagged dependency tree from a list @fds@ of flagged --- dependencies, using @f@ to form the tree node (@f@ will be --- something like @Stanza sn@). -prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) - -> [FlaggedDeps qpn] -> FlaggedDeps qpn -prefix _ [] = [] -prefix f fds = [f (concat fds)] - --- | Convert flag information. Automatic flags are now considered weak --- unless strong flags have been selected explicitly. -flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo -flagInfo (StrongFlags strfl) = - M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) - where - weak m = WeakOrTrivial $ not (strfl || m) - flagType m = if m then Manual else Automatic - --- | Convert condition trees to flagged dependencies. Mutually --- recursive with 'convBranch'. See 'convBranch' for an explanation --- of all arguments preceding the input 'CondTree'. -convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> - Component -> - (a -> BuildInfo) -> - SolveExecutables -> - CondTree ConfVar [Dependency] a -> FlaggedDeps PN -convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) = - -- Merge all library and build-tool dependencies at every level in - -- the tree of flagged dependencies. Otherwise 'extractCommon' - -- could create duplicate dependencies, and the number of - -- duplicates could grow exponentially from the leaves to the root - -- of the tree. - mergeSimpleDeps $ - [ D.Simple singleDep comp - | dep <- ds - , singleDep <- convLibDeps dr dep ] -- unconditional package dependencies - - ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies - ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages bi) -- unconditional language dependencies - ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies - ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches - -- build-tools dependencies - -- NB: Only include these dependencies if SolveExecutables - -- is True. It might be false in the legacy solver - -- codepath, in which case there won't be any record of - -- an executable we need. - ++ [ D.Simple (convExeDep dr exeDep) comp - | solveExes' - , exeDep <- getAllToolDependencies pkg bi - , not $ isInternal pkg exeDep - ] - where - bi = getInfo info - -data SimpleFlaggedDepKey qpn = - SimpleFlaggedDepKey (PkgComponent qpn) Component - deriving (Eq, Ord) - -data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR - --- | Merge 'Simple' dependencies that apply to the same library or build-tool. --- This function should be able to merge any two dependencies that can be merged --- by extractCommon, in order to prevent the exponential growth of dependencies. --- --- Note that this function can merge dependencies that have different --- DependencyReasons, which can make the DependencyReasons less precise. This --- loss of precision only affects performance and log messages, not correctness. --- However, when 'mergeSimpleDeps' is only called on dependencies at a single --- location in the dependency tree, the only difference between --- DependencyReasons should be flags that have value FlagBoth. Adding extra --- flags with value FlagBoth should not affect performance, since they are not --- added to the conflict set. The only downside is the possibility of the log --- incorrectly saying that the flag contributed to excluding a specific version --- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB --- introduces pkg <5, the merged dependency would mean that --- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply --- that +/-flagA excludes pkg-6. -mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn -mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged - where - (merged, unmerged) = L.foldl' f (M.empty, []) deps - where - f :: Ord qpn - => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) - -> FlaggedDep qpn - -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) - f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) = - ( M.insertWith mergeValues - (SimpleFlaggedDepKey dep comp) - (SimpleFlaggedDepValue dr vr) - merged' - , unmerged') - f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged') - - mergeValues :: SimpleFlaggedDepValue qpn - -> SimpleFlaggedDepValue qpn - -> SimpleFlaggedDepValue qpn - mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) = - SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2) - - toFlaggedDep :: SimpleFlaggedDepKey qpn - -> SimpleFlaggedDepValue qpn - -> FlaggedDep qpn - toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) = - D.Simple (LDep dr (Dep dep (Constrained vr))) comp - --- | Branch interpreter. Mutually recursive with 'convCondTree'. --- --- Here, we try to simplify one of Cabal's condition tree branches into the --- solver's flagged dependency format, which is weaker. Condition trees can --- contain complex logical expression composed from flag choices and special --- flags (such as architecture, or compiler flavour). We try to evaluate the --- special flags and subsequently simplify to a tree that only depends on --- simple flag choices. --- --- This function takes a number of arguments: --- --- 1. A map of flag values that have already been chosen. It allows --- convBranch to avoid creating nested FlaggedDeps that are --- controlled by the same flag and avoid creating DependencyReasons with --- conflicting values for the same flag. --- --- 2. The DependencyReason calculated at this point in the tree of --- conditionals. The flag values in the DependencyReason are similar to --- the values in the map above, except for the use of FlagBoth. --- --- 3. Some pre dependency-solving known information ('OS', 'Arch', --- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, --- --- 4. The package name @'PN'@ which this condition tree --- came from, so that we can correctly associate @flag()@ --- variables with the correct package name qualifier, --- --- 5. The flag defaults 'FlagInfo' so that we can populate --- 'Flagged' dependencies with 'FInfo', --- --- 6. The name of the component 'Component' so we can record where --- the fine-grained information about where the component came --- from (see 'convCondTree'), and --- --- 7. A selector to extract the 'BuildInfo' from the leaves of --- the 'CondTree' (which actually contains the needed --- dependency information.) --- --- 8. The set of package names which should be considered internal --- dependencies, and thus not handled as dependencies. -convBranch :: Map FlagName Bool - -> DependencyReason PN - -> PackageDescription - -> OS - -> Arch - -> CompilerInfo - -> PN - -> FlagInfo - -> Component - -> (a -> BuildInfo) - -> SolveExecutables - -> CondBranch ConfVar [Dependency] a - -> FlaggedDeps PN -convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') = - go c' - (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes t') - (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf') - flags dr - where - go :: Condition ConfVar - -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) - -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) - -> Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN - go (Lit True) t _ = t - go (Lit False) _ f = f - go (CNot c) t f = go c f t - go (CAnd c d) t f = go c (go d t f) f - go (COr c d) t f = go c t (go d t f) - go (Var (PackageFlag fn)) t f = \flags' -> - case M.lookup fn flags' of - Just True -> t flags' - Just False -> f flags' - Nothing -> \dr' -> - -- Add each flag to the DependencyReason for all dependencies below, - -- including any extracted dependencies. Extracted dependencies are - -- introduced by both flag values (FlagBoth). Note that we don't - -- actually need to add the flag to the extracted dependencies for - -- correct backjumping; the information only improves log messages - -- by giving the user the full reason for each dependency. - let addFlagValue v = addFlagToDependencyReason fn v dr' - addFlag v = M.insert fn v flags' - in extractCommon (t (addFlag True) (addFlagValue FlagBoth)) - (f (addFlag False) (addFlagValue FlagBoth)) - ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True) (addFlagValue FlagTrue)) - (f (addFlag False) (addFlagValue FlagFalse)) ] - go (Var (OS os')) t f - | os == os' = t - | otherwise = f - go (Var (Arch arch')) t f - | arch == arch' = t - | otherwise = f - go (Var (Impl cf cvr)) t f - | matchImpl (compilerInfoId cinfo) || - -- fixme: Nothing should be treated as unknown, rather than empty - -- list. This code should eventually be changed to either - -- support partial resolution of compiler flags or to - -- complain about incompletely configured compilers. - any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t - | otherwise = f - where - matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv - - addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn - addFlagToDependencyReason fn v (DependencyReason pn' fs ss) = - DependencyReason pn' (M.insert fn v fs) ss - - -- If both branches contain the same package as a simple dep, we lift it to - -- the next higher-level, but with the union of version ranges. This - -- heuristic together with deferring flag choices will then usually first - -- resolve this package, and try an already installed version before imposing - -- a default flag choice that might not be what we want. - -- - -- Note that we make assumptions here on the form of the dependencies that - -- can occur at this point. In particular, no occurrences of Fixed, as all - -- dependencies below this point have been generated using 'convLibDep'. - -- - -- WARNING: This is quadratic! - extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn - extractCommon ps ps' = - -- Union the DependencyReasons, because the extracted dependency can be - -- avoided by removing the dependency from either side of the - -- conditional. - [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp - | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps - , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps' - , dep1 == dep2 - ] - --- | Merge DependencyReasons by unioning their variables. -unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn -unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = - DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) - --- | Convert a Cabal dependency on a set of library components (from a single --- package) to solver-specific dependencies. -convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN] -convLibDeps dr (Dependency pn vr libs) = - [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr) - | lib <- NonEmptySet.toList libs ] - --- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. -convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN -convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr) - --- | Convert setup dependencies -convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN -convSetupBuildInfo pn nfo = - [ D.Simple singleDep ComponentSetup - | dep <- setupDepends nfo - , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ] diff --git a/Distribution/Solver/Modular/LabeledGraph.hs b/Distribution/Solver/Modular/LabeledGraph.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/LabeledGraph.hs +++ /dev/null @@ -1,117 +0,0 @@ --- | Wrapper around Data.Graph with support for edge labels -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.LabeledGraph ( - -- * Graphs - Graph - , Vertex - -- ** Building graphs - , graphFromEdges - , graphFromEdges' - , buildG - , transposeG - -- ** Graph properties - , vertices - , edges - -- ** Operations on the underlying unlabeled graph - , forgetLabels - , topSort - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Data.Array -import Data.Graph (Vertex, Bounds) -import qualified Data.Graph as G - -{------------------------------------------------------------------------------- - Types --------------------------------------------------------------------------------} - -type Graph e = Array Vertex [(e, Vertex)] -type Edge e = (Vertex, e, Vertex) - -{------------------------------------------------------------------------------- - Building graphs --------------------------------------------------------------------------------} - --- | Construct an edge-labeled graph --- --- This is a simple adaptation of the definition in Data.Graph -graphFromEdges :: forall key node edge. Ord key - => [ (node, key, [(edge, key)]) ] - -> ( Graph edge - , Vertex -> (node, key, [(edge, key)]) - , key -> Maybe Vertex - ) -graphFromEdges edges0 = - (graph, \v -> vertex_map ! v, key_vertex) - where - max_v = length edges0 - 1 - bounds0 = (0, max_v) :: (Vertex, Vertex) - sorted_edges = sortBy lt edges0 - edges1 = zip [0..] sorted_edges - - graph = array bounds0 [(v, (mapMaybe mk_edge ks)) - | (v, (_, _, ks)) <- edges1] - key_map = array bounds0 [(v, k ) - | (v, (_, k, _ )) <- edges1] - vertex_map = array bounds0 edges1 - - (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 - - mk_edge :: (edge, key) -> Maybe (edge, Vertex) - mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v) - - -- returns Nothing for non-interesting vertices - key_vertex :: key -> Maybe Vertex - key_vertex k = findVertex 0 max_v - where - findVertex a b - | a > b = Nothing - | otherwise = case compare k (key_map ! mid) of - LT -> findVertex a (mid-1) - EQ -> Just mid - GT -> findVertex (mid+1) b - where - mid = a + (b - a) `div` 2 - -graphFromEdges' :: Ord key - => [ (node, key, [(edge, key)]) ] - -> ( Graph edge - , Vertex -> (node, key, [(edge, key)]) - ) -graphFromEdges' x = (a,b) - where - (a,b,_) = graphFromEdges x - -transposeG :: Graph e -> Graph e -transposeG g = buildG (bounds g) (reverseE g) - -buildG :: Bounds -> [Edge e] -> Graph e -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where - reassoc (v, e, w) = (v, (e, w)) - -reverseE :: Graph e -> [Edge e] -reverseE g = [ (w, e, v) | (v, e, w) <- edges g ] - -{------------------------------------------------------------------------------- - Graph properties --------------------------------------------------------------------------------} - -vertices :: Graph e -> [Vertex] -vertices = indices - -edges :: Graph e -> [Edge e] -edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ] - -{------------------------------------------------------------------------------- - Operations on the underlying unlabelled graph --------------------------------------------------------------------------------} - -forgetLabels :: Graph e -> G.Graph -forgetLabels = fmap (map snd) - -topSort :: Graph e -> [Vertex] -topSort = G.topSort . forgetLabels diff --git a/Distribution/Solver/Modular/Linking.hs b/Distribution/Solver/Modular/Linking.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Linking.hs +++ /dev/null @@ -1,519 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- TODO: remove this -{-# OPTIONS -fno-warn-incomplete-uni-patterns #-} -module Distribution.Solver.Modular.Linking ( - validateLinking - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude hiding (get,put) - -import Control.Exception (assert) -import Control.Monad.Reader -import Control.Monad.State -import Data.Map ((!)) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Traversable as T - -import Distribution.Client.Utils.Assertion -import Distribution.Solver.Modular.Assignment -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.ConflictSet as CS -import qualified Distribution.Solver.Modular.WeightedPSQ as W - -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackagePath -import Distribution.Types.Flag (unFlagName) - -{------------------------------------------------------------------------------- - Validation - - Validation of links is a separate pass that's performed after normal - validation. Validation of links checks that if the tree indicates that a - package is linked, then everything underneath that choice really matches the - package we have linked to. - - This is interesting because it isn't unidirectional. Consider that we've - chosen a.foo to be version 1 and later decide that b.foo should link to a.foo. - Now foo depends on bar. Because a.foo and b.foo are linked, it's required that - a.bar and b.bar are also linked. However, it's not required that we actually - choose a.bar before b.bar. Goal choice order is relatively free. It's possible - that we choose a.bar first, but also possible that we choose b.bar first. In - both cases, we have to recognize that we have freedom of choice for the first - of the two, but no freedom of choice for the second. - - This is what LinkGroups are all about. Using LinkGroup, we can record (in the - situation above) that a.bar and b.bar need to be linked even if we haven't - chosen either of them yet. --------------------------------------------------------------------------------} - -data ValidateState = VS { - vsIndex :: Index - , vsLinks :: Map QPN LinkGroup - , vsFlags :: FAssignment - , vsStanzas :: SAssignment - , vsQualifyOptions :: QualifyOptions - - -- Saved qualified dependencies. Every time 'validateLinking' makes a - -- package choice, it qualifies the package's dependencies and saves them in - -- this map. Then the qualified dependencies are available for subsequent - -- flag and stanza choices for the same package. - , vsSaved :: Map QPN (FlaggedDeps QPN) - } - -type Validate = Reader ValidateState - --- | Validate linked packages --- --- Verify that linked packages have --- --- * Linked dependencies, --- * Equal flag assignments --- * Equal stanza assignments -validateLinking :: Index -> Tree d c -> Tree d c -validateLinking index = (`runReader` initVS) . cata go - where - go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) - - go (PChoiceF qpn rdm gr cs) = - PChoice qpn rdm gr <$> T.sequence (W.mapWithKey (goP qpn) cs) - go (FChoiceF qfn rdm gr t m d cs) = - FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs) - go (SChoiceF qsn rdm gr t cs) = - SChoice qsn rdm gr t <$> T.sequence (W.mapWithKey (goS qsn) cs) - - -- For the other nodes we just recurse - go (GoalChoiceF rdm cs) = GoalChoice rdm <$> T.sequence cs - go (DoneF revDepMap s) = return $ Done revDepMap s - go (FailF conflictSet failReason) = return $ Fail conflictSet failReason - - -- Package choices - goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) - goP qpn@(Q _pp pn) opt@(POption i _) r = do - vs <- ask - let PInfo deps _ _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps - newSaved = M.insert qpn qdeps (vsSaved vs) - case execUpdateState (pickPOption qpn opt qdeps) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs' { vsSaved = newSaved }) r - - -- Flag choices - goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goF qfn b r = do - vs <- ask - case execUpdateState (pickFlag qfn b) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r - - -- Stanza choices (much the same as flag choices) - goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goS qsn b r = do - vs <- ask - case execUpdateState (pickStanza qsn b) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r - - initVS :: ValidateState - initVS = VS { - vsIndex = index - , vsLinks = M.empty - , vsFlags = M.empty - , vsStanzas = M.empty - , vsQualifyOptions = defaultQualifyOptions index - , vsSaved = M.empty - } - -{------------------------------------------------------------------------------- - Updating the validation state --------------------------------------------------------------------------------} - -type Conflict = (ConflictSet, String) - -newtype UpdateState a = UpdateState { - unUpdateState :: StateT ValidateState (Either Conflict) a - } - deriving (Functor, Applicative, Monad) - -instance MonadState ValidateState UpdateState where - get = UpdateState $ get - put st = UpdateState $ do - expensiveAssert (lgInvariant $ vsLinks st) $ return () - put st - -lift' :: Either Conflict a -> UpdateState a -lift' = UpdateState . lift - -conflict :: Conflict -> UpdateState a -conflict = lift' . Left - -execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState -execUpdateState = execStateT . unUpdateState - -pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () -pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i -pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps - -pickConcrete :: QPN -> I -> UpdateState () -pickConcrete qpn@(Q pp _) i = do - vs <- get - case M.lookup qpn (vsLinks vs) of - -- Package is not yet in a LinkGroup. Create a new singleton link group. - Nothing -> do - let lg = lgSingleton qpn (Just $ PI pp i) - updateLinkGroup lg - - -- Package is already in a link group. Since we are picking a concrete - -- instance here, it must by definition be the canonical package. - Just lg -> - makeCanonical lg qpn i - -pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () -pickLink qpn@(Q _pp pn) i pp' deps = do - vs <- get - - -- The package might already be in a link group - -- (because one of its reverse dependencies is) - let lgSource = case M.lookup qpn (vsLinks vs) of - Nothing -> lgSingleton qpn Nothing - Just lg -> lg - - -- Find the link group for the package we are linking to - -- - -- Since the builder never links to a package without having first picked a - -- concrete instance for that package, and since we create singleton link - -- groups for concrete instances, this link group must exist (and must - -- in fact already have a canonical member). - let target = Q pp' pn - lgTarget = vsLinks vs ! target - - -- Verify here that the member we add is in fact for the same package and - -- matches the version of the canonical instance. However, violations of - -- these checks would indicate a bug in the linker, not a true conflict. - let sanityCheck :: Maybe (PI PackagePath) -> Bool - sanityCheck Nothing = False - sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI - assert (sanityCheck (lgCanon lgTarget)) $ return () - - -- Merge the two link groups (updateLinkGroup will propagate the change) - lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget - updateLinkGroup lgTarget' - - -- Make sure all dependencies are linked as well - linkDeps target deps - -makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () -makeCanonical lg qpn@(Q pp _) i = - case lgCanon lg of - -- There is already a canonical member. Fail. - Just _ -> - conflict ( CS.insert (P qpn) (lgConflictSet lg) - , "cannot make " ++ showQPN qpn - ++ " canonical member of " ++ showLinkGroup lg - ) - Nothing -> do - let lg' = lg { lgCanon = Just (PI pp i) } - updateLinkGroup lg' - --- | Link the dependencies of linked parents. --- --- When we decide to link one package against another we walk through the --- package's direct depedencies and make sure that they're all linked to each --- other by merging their link groups (or creating new singleton link groups if --- they don't have link groups yet). We do not need to do this recursively, --- because having the direct dependencies in a link group means that we must --- have already made or will make sooner or later a link choice for one of these --- as well, and cover their dependencies at that point. -linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState () -linkDeps target = \deps -> do - -- linkDeps is called in two places: when we first link one package to - -- another, and when we discover more dependencies of an already linked - -- package after doing some flag assignment. It is therefore important that - -- flag assignments cannot influence _how_ dependencies are qualified; - -- fortunately this is a documented property of 'qualifyDeps'. - rdeps <- requalify deps - go deps rdeps - where - go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState () - go = zipWithM_ go1 - - go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () - go1 dep rdep = case (dep, rdep) of - (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do - vs <- get - let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs - lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs - lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' - updateLinkGroup lg'' - (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do - vs <- get - case M.lookup fn (vsFlags vs) of - Nothing -> return () -- flag assignment not yet known - Just True -> go t t' - Just False -> go f f' - (Stanza sn t, ~(Stanza _ t')) -> do - vs <- get - case M.lookup sn (vsStanzas vs) of - Nothing -> return () -- stanza assignment not yet known - Just True -> go t t' - Just False -> return () -- stanza not enabled; no new deps - -- For extensions and language dependencies, there is nothing to do. - -- No choice is involved, just checking, so there is nothing to link. - -- The same goes for pkg-config constraints. - (Simple (LDep _ (Ext _)) _, _) -> return () - (Simple (LDep _ (Lang _)) _, _) -> return () - (Simple (LDep _ (Pkg _ _)) _, _) -> return () - - requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) - requalify deps = do - vs <- get - return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) - -pickFlag :: QFN -> Bool -> UpdateState () -pickFlag qfn b = do - modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) } - verifyFlag qfn - linkNewDeps (F qfn) b - -pickStanza :: QSN -> Bool -> UpdateState () -pickStanza qsn b = do - modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) } - verifyStanza qsn - linkNewDeps (S qsn) b - --- | Link dependencies that we discover after making a flag or stanza choice. --- --- When we make a flag choice for a package, then new dependencies for that --- package might become available. If the package under consideration is in a --- non-trivial link group, then these new dependencies have to be linked as --- well. In linkNewDeps, we compute such new dependencies and make sure they are --- linked. -linkNewDeps :: Var QPN -> Bool -> UpdateState () -linkNewDeps var b = do - vs <- get - let qpn@(Q pp pn) = varPN var - qdeps = vsSaved vs ! qpn - lg = vsLinks vs ! qpn - newDeps = findNewDeps vs qdeps - linkedTo = S.delete pp (lgMembers lg) - forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps - where - findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN - findNewDeps vs = concatMap (findNewDeps' vs) - - findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN - findNewDeps' _ (Simple _ _) = [] - findNewDeps' vs (Flagged qfn _ t f) = - case (F qfn == var, M.lookup qfn (vsFlags vs)) of - (True, _) -> if b then t else f - (_, Nothing) -> [] -- not yet known - (_, Just b') -> findNewDeps vs (if b' then t else f) - findNewDeps' vs (Stanza qsn t) = - case (S qsn == var, M.lookup qsn (vsStanzas vs)) of - (True, _) -> if b then t else [] - (_, Nothing) -> [] -- not yet known - (_, Just b') -> findNewDeps vs (if b' then t else []) - -updateLinkGroup :: LinkGroup -> UpdateState () -updateLinkGroup lg = do - verifyLinkGroup lg - modify $ \vs -> vs { - vsLinks = M.fromList (map aux (S.toList (lgMembers lg))) - `M.union` vsLinks vs - } - where - aux pp = (Q pp (lgPackage lg), lg) - -{------------------------------------------------------------------------------- - Verification --------------------------------------------------------------------------------} - -verifyLinkGroup :: LinkGroup -> UpdateState () -verifyLinkGroup lg = - case lgInstance lg of - -- No instance picked yet. Nothing to verify - Nothing -> - return () - - -- We picked an instance. Verify flags and stanzas - -- TODO: The enumeration of OptionalStanza names is very brittle; - -- if a constructor is added to the datatype we won't notice it here - Just i -> do - vs <- get - let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i - flags = M.keys finfo - stanzas = [TestStanzas, BenchStanzas] - forM_ flags $ \fn -> do - let flag = FN (lgPackage lg) fn - verifyFlag' flag lg - forM_ stanzas $ \sn -> do - let stanza = SN (lgPackage lg) sn - verifyStanza' stanza lg - -verifyFlag :: QFN -> UpdateState () -verifyFlag (FN qpn@(Q _pp pn) fn) = do - vs <- get - -- We can only pick a flag after picking an instance; link group must exist - verifyFlag' (FN pn fn) (vsLinks vs ! qpn) - -verifyStanza :: QSN -> UpdateState () -verifyStanza (SN qpn@(Q _pp pn) sn) = do - vs <- get - -- We can only pick a stanza after picking an instance; link group must exist - verifyStanza' (SN pn sn) (vsLinks vs ! qpn) - --- | Verify that all packages in the link group agree on flag assignments --- --- For the given flag and the link group, obtain all assignments for the flag --- that have already been made for link group members, and check that they are --- equal. -verifyFlag' :: FN PN -> LinkGroup -> UpdateState () -verifyFlag' (FN pn fn) lg = do - vs <- get - let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) - vals = map (`M.lookup` vsFlags vs) flags - if allEqual (catMaybes vals) -- We ignore not-yet assigned flags - then return () - else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg - , "flag \"" ++ unFlagName fn ++ "\" incompatible" - ) - --- | Verify that all packages in the link group agree on stanza assignments --- --- For the given stanza and the link group, obtain all assignments for the --- stanza that have already been made for link group members, and check that --- they are equal. --- --- This function closely mirrors 'verifyFlag''. -verifyStanza' :: SN PN -> LinkGroup -> UpdateState () -verifyStanza' (SN pn sn) lg = do - vs <- get - let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) - vals = map (`M.lookup` vsStanzas vs) stanzas - if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas - then return () - else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg - , "stanza \"" ++ showStanza sn ++ "\" incompatible" - ) - -{------------------------------------------------------------------------------- - Link groups --------------------------------------------------------------------------------} - --- | Set of packages that must be linked together --- --- A LinkGroup is between several qualified package names. In the validation --- state, we maintain a map vsLinks from qualified package names to link groups. --- There is an invariant that for all members of a link group, vsLinks must map --- to the same link group. The function updateLinkGroup can be used to --- re-establish this invariant after creating or expanding a LinkGroup. -data LinkGroup = LinkGroup { - -- | The name of the package of this link group - lgPackage :: PN - - -- | The canonical member of this link group (the one where we picked - -- a concrete instance). Once we have picked a canonical member, all - -- other packages must link to this one. - -- - -- We may not know this yet (if we are constructing link groups - -- for dependencies) - , lgCanon :: Maybe (PI PackagePath) - - -- | The members of the link group - , lgMembers :: Set PackagePath - - -- | The set of variables that should be added to the conflict set if - -- something goes wrong with this link set (in addition to the members - -- of the link group itself) - , lgBlame :: ConflictSet - } - deriving (Show, Eq) - --- | Invariant for the set of link groups: every element in the link group --- must be pointing to the /same/ link group -lgInvariant :: Map QPN LinkGroup -> Bool -lgInvariant links = all invGroup (M.elems links) - where - invGroup :: LinkGroup -> Bool - invGroup lg = allEqual $ map (`M.lookup` links) members - where - members :: [QPN] - members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg) - --- | Package version of this group --- --- This is only known once we have picked a canonical element. -lgInstance :: LinkGroup -> Maybe I -lgInstance = fmap (\(PI _ i) -> i) . lgCanon - -showLinkGroup :: LinkGroup -> String -showLinkGroup lg = - "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" - where - showMember :: PackagePath -> String - showMember pp = case lgCanon lg of - Just (PI pp' _i) | pp == pp' -> "*" - _otherwise -> "" - ++ case lgInstance lg of - Nothing -> showQPN (qpn pp) - Just i -> showPI (PI (qpn pp) i) - - qpn :: PackagePath -> QPN - qpn pp = Q pp (lgPackage lg) - --- | Creates a link group that contains a single member. -lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup -lgSingleton (Q pp pn) canon = LinkGroup { - lgPackage = pn - , lgCanon = canon - , lgMembers = S.singleton pp - , lgBlame = CS.empty - } - -lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup -lgMerge blame lg lg' = do - canon <- pick (lgCanon lg) (lgCanon lg') - return LinkGroup { - lgPackage = lgPackage lg - , lgCanon = canon - , lgMembers = lgMembers lg `S.union` lgMembers lg' - , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] - } - where - pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) - pick Nothing Nothing = Right Nothing - pick (Just x) Nothing = Right $ Just x - pick Nothing (Just y) = Right $ Just y - pick (Just x) (Just y) = - if x == y then Right $ Just x - else Left ( CS.unions [ - blame - , lgConflictSet lg - , lgConflictSet lg' - ] - , "cannot merge " ++ showLinkGroup lg - ++ " and " ++ showLinkGroup lg' - ) - -lgConflictSet :: LinkGroup -> ConflictSet -lgConflictSet lg = - CS.fromList (map aux (S.toList (lgMembers lg))) - `CS.union` lgBlame lg - where - aux pp = P (Q pp (lgPackage lg)) - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -allEqual :: Eq a => [a] -> Bool -allEqual [] = True -allEqual [_] = True -allEqual (x:y:ys) = x == y && allEqual (y:ys) diff --git a/Distribution/Solver/Modular/Log.hs b/Distribution/Solver/Modular/Log.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Log.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Distribution.Solver.Modular.Log - ( displayLogMessages - , SolverFailure(..) - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import Distribution.Solver.Types.Progress - -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.RetryLog - --- | Information about a dependency solver failure. -data SolverFailure = - ExhaustiveSearch ConflictSet ConflictMap - | BackjumpLimitReached - --- | Postprocesses a log file. This function discards all log messages and --- avoids calling 'showMessages' if the log isn't needed (specified by --- 'keepLog'), for efficiency. -displayLogMessages :: Bool - -> RetryLog Message SolverFailure a - -> RetryLog String SolverFailure a -displayLogMessages keepLog lg = fromProgress $ - if keepLog - then showMessages progress - else foldProgress (const id) Fail Done progress - where - progress = toProgress lg diff --git a/Distribution/Solver/Modular/Message.hs b/Distribution/Solver/Modular/Message.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Message.hs +++ /dev/null @@ -1,271 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Distribution.Solver.Modular.Message ( - Message(..), - showMessages - ) where - -import qualified Data.List as L -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Maybe (catMaybes, mapMaybe) -import Prelude hiding (pi) - -import Distribution.Pretty (prettyShow) -- from Cabal - -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree - ( FailReason(..), POption(..), ConflictingDep(..) ) -import Distribution.Solver.Modular.Version -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Progress -import Distribution.Types.LibraryName -import Distribution.Types.UnqualComponentName - -data Message = - Enter -- ^ increase indentation level - | Leave -- ^ decrease indentation level - | TryP QPN POption - | TryF QFN Bool - | TryS QSN Bool - | Next (Goal QPN) - | Skip (Set CS.Conflict) - | Success - | Failure ConflictSet FailReason - --- | Transforms the structured message type to actual messages (strings). --- --- The log contains level numbers, which are useful for any trace that involves --- backtracking, because only the level numbers will allow to keep track of --- backjumps. -showMessages :: Progress Message a b -> Progress String a b -showMessages = go 0 - where - -- 'go' increments the level for a recursive call when it encounters - -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'. - go :: Int -> Progress Message a b -> Progress String a b - go !_ (Done x) = Done x - go !_ (Fail x) = Fail x - -- complex patterns - go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - goPReject l qpn [i] c fr ms - go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) = - goPSkip l qpn [i] conflicts ms - go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms) - go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) - go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = - (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) - go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) = - (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms - -- standard display - go !l (Step Enter ms) = go (l+1) ms - go !l (Step Leave ms) = go (l-1) ms - go !l (Step (TryP qpn i) ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms) - go !l (Step (TryF qfn b) ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms) - go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms) - go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms) - go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log - go !l (Step (Skip conflicts) ms) = - -- 'Skip' should always be handled by 'goPSkip' in the case above. - (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms) - go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms) - go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms) - - showPackageGoal :: QPN -> QGoalReason -> String - showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr - - showFailure :: ConflictSet -> FailReason -> String - showFailure c fr = "fail" ++ showFR c fr - - -- special handler for many subsequent package rejections - goPReject :: Int - -> QPN - -> [POption] - -> ConflictSet - -> FailReason - -> Progress Message a b - -> Progress String a b - goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) - | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms - goPReject l qpn is c fr ms = - (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) - - -- Handle many subsequent skipped package instances. - goPSkip :: Int - -> QPN - -> [POption] - -> Set CS.Conflict - -> Progress Message a b - -> Progress String a b - goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms)))) - | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms - goPSkip l qpn is conflicts ms = - let msg = "skipping: " - ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) - ++ showConflicts conflicts - in atLevel l msg (go l ms) - - -- write a message with the current level number - atLevel :: Int -> String -> Progress String a b -> Progress String a b - atLevel l x xs = - let s = show l - in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs - --- | Display the set of 'Conflicts' for a skipped package version. -showConflicts :: Set CS.Conflict -> String -showConflicts conflicts = - " (has the same characteristics that caused the previous version to fail: " - ++ conflictMsg ++ ")" - where - conflictMsg :: String - conflictMsg = - if S.member CS.OtherConflict conflicts - then - -- This case shouldn't happen, because an unknown conflict should not - -- cause a version to be skipped. - "unknown conflict" - else let mergedConflicts = - [ showConflict qpn conflict - | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ] - in if L.null mergedConflicts - then - -- This case shouldn't happen unless backjumping is turned off. - "none" - else L.intercalate "; " mergedConflicts - - -- Merge conflicts to simplify the log message. - mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict - mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList - where - mergeConflict :: MergedPackageConflict - -> MergedPackageConflict - -> MergedPackageConflict - mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict { - isGoalConflict = - isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 - , versionConstraintConflict = - L.nub $ versionConstraintConflict mergedConflict1 - ++ versionConstraintConflict mergedConflict2 - , versionConflict = - mergeVersionConflicts (versionConflict mergedConflict1) - (versionConflict mergedConflict2) - } - where - mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2) - mergeVersionConflicts (Just vr1) Nothing = Just vr1 - mergeVersionConflicts Nothing (Just vr2) = Just vr2 - mergeVersionConflicts Nothing Nothing = Nothing - - toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict) - toMergedConflict (CS.GoalConflict qpn) = - Just (qpn, MergedPackageConflict True [] Nothing) - toMergedConflict (CS.VersionConstraintConflict qpn v) = - Just (qpn, MergedPackageConflict False [v] Nothing) - toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) = - Just (qpn, MergedPackageConflict False [] (Just vr)) - toMergedConflict CS.OtherConflict = Nothing - - showConflict :: QPN -> MergedPackageConflict -> String - showConflict qpn mergedConflict = L.intercalate "; " conflictStrings - where - conflictStrings = catMaybes [ - case () of - () | isGoalConflict mergedConflict -> Just $ - "depends on '" ++ showQPN qpn ++ "'" ++ - (if null (versionConstraintConflict mergedConflict) - then "" - else " but excludes " - ++ showVersions (versionConstraintConflict mergedConflict)) - | not $ L.null (versionConstraintConflict mergedConflict) -> Just $ - "excludes '" ++ showQPN qpn - ++ "' " ++ showVersions (versionConstraintConflict mergedConflict) - | otherwise -> Nothing - , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") - <$> versionConflict mergedConflict - ] - - showVersions [] = "no versions" - showVersions [v] = "version " ++ showVer v - showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) - --- | All conflicts related to one package, used for simplifying the display of --- a 'Set CS.Conflict'. -data MergedPackageConflict = MergedPackageConflict { - isGoalConflict :: Bool - , versionConstraintConflict :: [Ver] - , versionConflict :: Maybe VR - } - -showQPNPOpt :: QPN -> POption -> String -showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = - case linkedTo of - Nothing -> showPI (PI qpn i) -- Consistent with prior to POption - Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) - -showGR :: QGoalReason -> String -showGR UserGoal = " (user goal)" -showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" - -showFR :: ConflictSet -> FailReason -> String -showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ prettyShow ext ++ ")" -showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ prettyShow lang ++ ")" -showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)" -showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" -showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" -showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" -showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")" -showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" -showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)" -showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)" -showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" -showFR _ CannotInstall = " (only already installed instances can be used)" -showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" -showFR _ NotExplicit = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)" -showFR _ Shadowed = " (shadowed by another installed package with same version)" -showFR _ (Broken u) = " (package is broken, missing depenedency " ++ prettyShow u ++ ")" -showFR _ UnknownPackage = " (unknown package)" -showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" -showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" -showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" -showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" -showFR _ ManualFlag = " (manual flag can only be changed explicitly)" -showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" -showFR _ MultipleInstances = " (multiple instances)" -showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" -showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" -showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ prettyShow ver ++ ")" --- The following are internal failures. They should not occur. In the --- interest of not crashing unnecessarily, we still just print an error --- message though. -showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" -showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" -showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" - -showExposedComponent :: ExposedComponent -> String -showExposedComponent (ExposedLib LMainLibName) = "library" -showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'" -showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" - -constraintSource :: ConstraintSource -> String -constraintSource src = "constraint from " ++ showConstraintSource src - -showConflictingDep :: ConflictingDep -> String -showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = - let DependencyReason qpn' _ _ = dr - componentStr = case comp of - ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" - ExposedLib LMainLibName -> "" - ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")" - in case ci of - Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ - showQPN qpn ++ componentStr ++ "==" ++ showI i - Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ - componentStr ++ showVR vr diff --git a/Distribution/Solver/Modular/PSQ.hs b/Distribution/Solver/Modular/PSQ.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/PSQ.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -module Distribution.Solver.Modular.PSQ - ( PSQ(..) -- Unit test needs constructor access - , casePSQ - , cons - , length - , lookup - , filter - , filterIfAny - , filterIfAnyByKeys - , filterKeys - , firstOnly - , fromList - , isZeroOrOne - , keys - , map - , mapKeys - , mapWithKey - , maximumBy - , minimumBy - , null - , prefer - , preferByKeys - , snoc - , sortBy - , sortByKeys - , toList - , union - ) where - --- Priority search queues. --- --- I am not yet sure what exactly is needed. But we need a data structure with --- key-based lookup that can be sorted. We're using a sequence right now with --- (inefficiently implemented) lookup, because I think that queue-based --- operations and sorting turn out to be more efficiency-critical in practice. - -import Control.Arrow (first, second) - -import qualified Data.Foldable as F -import Data.Function -import qualified Data.List as S -import Data.Ord (comparing) -import Data.Traversable -import Prelude hiding (foldr, length, lookup, filter, null, map) - -newtype PSQ k v = PSQ [(k, v)] - deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP - -keys :: PSQ k v -> [k] -keys (PSQ xs) = fmap fst xs - -lookup :: Eq k => k -> PSQ k v -> Maybe v -lookup k (PSQ xs) = S.lookup k xs - -map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 -map f (PSQ xs) = PSQ (fmap (second f) xs) - -mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v -mapKeys f (PSQ xs) = PSQ (fmap (first f) xs) - -mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b -mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) - -fromList :: [(k, a)] -> PSQ k a -fromList = PSQ - -cons :: k -> a -> PSQ k a -> PSQ k a -cons k x (PSQ xs) = PSQ ((k, x) : xs) - -snoc :: PSQ k a -> k -> a -> PSQ k a -snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) - -casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r -casePSQ (PSQ xs) n c = - case xs of - [] -> n - (k, v) : ys -> c k v (PSQ ys) - -sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a -sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) - -sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a -sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) - -maximumBy :: (k -> Int) -> PSQ k a -> (k, a) -maximumBy sel (PSQ xs) = - S.minimumBy (flip (comparing (sel . fst))) xs - -minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a -minimumBy sel (PSQ xs) = - PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] - --- | Sort the list so that values satisfying the predicate are first. -prefer :: (a -> Bool) -> PSQ k a -> PSQ k a -prefer p = sortBy $ flip (comparing p) - --- | Sort the list so that keys satisfying the predicate are first. -preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -preferByKeys p = sortByKeys $ flip (comparing p) - --- | Will partition the list according to the predicate. If --- there is any element that satisfies the precidate, then only --- the elements satisfying the predicate are returned. --- Otherwise, the rest is returned. --- -filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a -filterIfAny p (PSQ xs) = - let - (pro, con) = S.partition (p . snd) xs - in - if S.null pro then PSQ con else PSQ pro - --- | Variant of 'filterIfAny' that takes a predicate on the keys --- rather than on the values. --- -filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -filterIfAnyByKeys p (PSQ xs) = - let - (pro, con) = S.partition (p . fst) xs - in - if S.null pro then PSQ con else PSQ pro - -filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) - -filter :: (a -> Bool) -> PSQ k a -> PSQ k a -filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) - -length :: PSQ k a -> Int -length (PSQ xs) = S.length xs - -null :: PSQ k a -> Bool -null (PSQ xs) = S.null xs - -isZeroOrOne :: PSQ k a -> Bool -isZeroOrOne (PSQ []) = True -isZeroOrOne (PSQ [_]) = True -isZeroOrOne _ = False - -firstOnly :: PSQ k a -> PSQ k a -firstOnly (PSQ []) = PSQ [] -firstOnly (PSQ (x : _)) = PSQ [x] - -toList :: PSQ k a -> [(k, a)] -toList (PSQ xs) = xs - -union :: PSQ k a -> PSQ k a -> PSQ k a -union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys) diff --git a/Distribution/Solver/Modular/Package.hs b/Distribution/Solver/Modular/Package.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Package.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Solver.Modular.Package - ( I(..) - , Loc(..) - , PackageId - , PackageIdentifier(..) - , PackageName, mkPackageName, unPackageName - , PkgconfigName, mkPkgconfigName, unPkgconfigName - , PI(..) - , PN - , QPV - , instI - , makeIndependent - , primaryPP - , setupPP - , showI - , showPI - , unPN - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import Distribution.Package -- from Cabal -import Distribution.Pretty (prettyShow) - -import Distribution.Solver.Modular.Version -import Distribution.Solver.Types.PackagePath - --- | A package name. -type PN = PackageName - --- | Unpacking a package name. -unPN :: PN -> String -unPN = unPackageName - --- | Package version. A package name plus a version number. -type PV = PackageId - --- | Qualified package version. -type QPV = Qualified PV - --- | Package id. Currently just a black-box string. -type PId = UnitId - --- | Location. Info about whether a package is installed or not, and where --- exactly it is located. For installed packages, uniquely identifies the --- package instance via its 'PId'. --- --- TODO: More information is needed about the repo. -data Loc = Inst PId | InRepo - deriving (Eq, Ord, Show) - --- | Instance. A version number and a location. -data I = I Ver Loc - deriving (Eq, Ord, Show) - --- | String representation of an instance. -showI :: I -> String -showI (I v InRepo) = showVer v -showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid - where - extractPackageAbiHash xs = - case first reverse $ break (=='-') $ reverse (prettyShow xs) of - (ys, []) -> ys - (ys, _) -> '-' : ys - --- | Package instance. A package name and an instance. -data PI qpn = PI qpn I - deriving (Eq, Ord, Show, Functor) - --- | String representation of a package instance. -showPI :: PI QPN -> String -showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i - -instI :: I -> Bool -instI (I _ (Inst _)) = True -instI _ = False - --- | Is the package in the primary group of packages. This is used to --- determine (1) if we should try to establish stanza preferences --- for this goal, and (2) whether or not a user specified @--constraint@ --- should apply to this dependency (grep 'primaryPP' to see the --- use sites). In particular this does not include packages pulled in --- as setup deps. --- -primaryPP :: PackagePath -> Bool -primaryPP (PackagePath _ns q) = go q - where - go QualToplevel = True - go (QualBase _) = True - go (QualSetup _) = False - go (QualExe _ _) = False - --- | Is the package a dependency of a setup script. This is used to --- establish whether or not certain constraints should apply to this --- dependency (grep 'setupPP' to see the use sites). --- -setupPP :: PackagePath -> Bool -setupPP (PackagePath _ns (QualSetup _)) = True -setupPP (PackagePath _ns _) = False - --- | Qualify a target package with its own name so that its dependencies are not --- required to be consistent with other targets. -makeIndependent :: PN -> QPN -makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn diff --git a/Distribution/Solver/Modular/Preference.hs b/Distribution/Solver/Modular/Preference.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Preference.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- | Reordering or pruning the tree in order to prefer or make certain choices. -module Distribution.Solver.Modular.Preference - ( avoidReinstalls - , deferSetupChoices - , deferWeakFlagChoices - , enforceManualFlags - , enforcePackageConstraints - , enforceSingleInstanceRestriction - , firstGoal - , preferBaseGoalChoice - , preferLinked - , preferPackagePreferences - , preferReallyEasyGoalChoices - , requireInstalled - , onlyConstrained - , sortGoals - , pruneAfterFirstSuccess - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import qualified Data.List as L -import qualified Data.Map as M -import Control.Monad.Trans.Reader (Reader, runReader, ask, local) - -import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal - -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.InstalledPreference -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.Variable - -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import qualified Distribution.Solver.Modular.PSQ as P -import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.ConflictSet as CS -import qualified Distribution.Solver.Modular.WeightedPSQ as W - --- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a --- list of weight-calculating functions in order to avoid sorting the package --- choices multiple times. Each function takes the package name, sorted list of --- children's versions, and package option. 'addWeights' prepends the new --- weights to the existing weights, which gives precedence to preferences that --- are applied later. -addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c -addWeights fs = trav go - where - go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c) - go (PChoiceF qpn@(Q _ pn) rdm x cs) = - let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs) - weights k = [f pn sortedVersions k | f <- fs] - - elemsToWhnf :: [a] -> () - elemsToWhnf = foldr seq () - in PChoiceF qpn rdm x - -- Evaluate the children's versions before evaluating any of the - -- subtrees, so that 'sortedVersions' doesn't hold onto all of the - -- subtrees (referenced by cs) and cause a space leak. - (elemsToWhnf sortedVersions `seq` - W.mapWeightsWithKey (\k w -> weights k ++ w) cs) - go x = x - -addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c -addWeight f = addWeights [f] - -version :: POption -> Ver -version (POption (I v _) _) = v - --- | Prefer to link packages whenever possible. -preferLinked :: Tree d c -> Tree d c -preferLinked = addWeight (const (const linked)) - where - linked (POption _ Nothing) = 1 - linked (POption _ (Just _)) = 0 - --- Works by setting weights on choice nodes. Also applies stanza preferences. -preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c -preferPackagePreferences pcs = - preferPackageStanzaPreferences pcs . - addWeights [ - \pn _ opt -> preferred pn opt - - -- Note that we always rank installed before uninstalled, and later - -- versions before earlier, but we can change the priority of the - -- two orderings. - , \pn vs opt -> case preference pn of - PreferInstalled -> installed opt - PreferLatest -> latest vs opt - , \pn vs opt -> case preference pn of - PreferInstalled -> latest vs opt - PreferLatest -> installed opt - ] - where - -- Prefer packages with higher version numbers over packages with - -- lower version numbers. - latest :: [Ver] -> POption -> Weight - latest sortedVersions opt = - let l = length sortedVersions - index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions - in fromIntegral index / fromIntegral l - - preference :: PN -> InstalledPreference - preference pn = - let PackagePreferences _ ipref _ = pcs pn - in ipref - - -- | Prefer versions satisfying more preferred version ranges. - preferred :: PN -> POption -> Weight - preferred pn opt = - let PackagePreferences vrs _ _ = pcs pn - in fromIntegral . negate . L.length $ - L.filter (flip checkVR (version opt)) vrs - - -- Prefer installed packages over non-installed packages. - installed :: POption -> Weight - installed (POption (I _ (Inst _)) _) = 0 - installed _ = 1 - --- | Traversal that tries to establish package stanza enable\/disable --- preferences. Works by reordering the branches of stanza choices. -preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c -preferPackageStanzaPreferences pcs = trav go - where - go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts) - | primaryPP pp && enableStanzaPref pn s = - -- move True case first to try enabling the stanza - let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts - weight k = if k then 0 else 1 - -- defer the choice by setting it to weak - in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' - go x = x - - enableStanzaPref :: PN -> OptionalStanza -> Bool - enableStanzaPref pn s = - let PackagePreferences _ _ spref = pcs pn - in s `elem` spref - --- | Helper function that tries to enforce a single package constraint on a --- given instance for a P-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintP :: forall d c. QPN - -> ConflictSet - -> I - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c -processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn - then go i prop - else r - where - go :: I -> PackageProperty -> Tree d c - go (I v _) (PackagePropertyVersion vr) - | checkVR vr v = r - | otherwise = Fail c (GlobalConstraintVersion vr src) - go _ PackagePropertyInstalled - | instI i = r - | otherwise = Fail c (GlobalConstraintInstalled src) - go _ PackagePropertySource - | not (instI i) = r - | otherwise = Fail c (GlobalConstraintSource src) - go _ _ = r - --- | Helper function that tries to enforce a single package constraint on a --- given flag setting for an F-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintF :: forall d c. QPN - -> Flag - -> ConflictSet - -> Bool - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c -processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn - then go prop - else r - where - go :: PackageProperty -> Tree d c - go (PackagePropertyFlags fa) = - case lookupFlagAssignment f fa of - Nothing -> r - Just b | b == b' -> r - | otherwise -> Fail c (GlobalConstraintFlag src) - go _ = r - --- | Helper function that tries to enforce a single package constraint on a --- given flag setting for an F-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintS :: forall d c. QPN - -> OptionalStanza - -> ConflictSet - -> Bool - -> LabeledPackageConstraint - -> Tree d c - -> Tree d c -processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = - if constraintScopeMatches scope qpn - then go prop - else r - where - go :: PackageProperty -> Tree d c - go (PackagePropertyStanzas ss) = - if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) - else r - go _ = r - --- | Traversal that tries to establish various kinds of user constraints. Works --- by selectively disabling choices that have been ruled out by global user --- constraints. -enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] - -> Tree d c - -> Tree d c -enforcePackageConstraints pcs = trav go - where - go (PChoiceF qpn@(Q _ pn) rdm gr ts) = - let c = varToConflictSet (P qpn) - -- compose the transformation functions for each of the relevant constraint - g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc) - id - (M.findWithDefault [] pn pcs) - in PChoiceF qpn rdm gr (W.mapWithKey g ts) - go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) = - let c = varToConflictSet (F qfn) - -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) - id - (M.findWithDefault [] pn pcs) - in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) - go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = - let c = varToConflictSet (S qsn) - -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) - id - (M.findWithDefault [] pn pcs) - in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) - go x = x - --- | Transformation that tries to enforce the rule that manual flags can only be --- set by the user. --- --- If there are no constraints on a manual flag, this function prunes all but --- the default value. If there are constraints, then the flag is allowed to have --- the values specified by the constraints. Note that the type used for flag --- values doesn't need to be Bool. --- --- This function makes an exception for the case where there are multiple goals --- for a single package (with different qualifiers), and flag constraints for --- manual flag x only apply to some of those goals. In that case, we allow the --- unconstrained goals to use the default value for x OR any of the values in --- the constraints on x (even though the constraints don't apply), in order to --- allow the unconstrained goals to be linked to the constrained goals. See --- https://github.com/haskell/cabal/issues/4299. Removing the single instance --- restriction (SIR) would also fix #4299, so we may want to remove this --- exception and only let the user toggle manual flags if we remove the SIR. --- --- This function does not enforce any of the constraints, since that is done by --- 'enforcePackageConstraints'. -enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c -enforceManualFlags pcs = trav go - where - go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) = - FChoiceF qfn rdm gr tr Manual d $ - let -- A list of all values specified by constraints on 'fn'. - -- We ignore the constraint scope in order to handle issue #4299. - flagConstraintValues :: [Bool] - flagConstraintValues = - [ flagVal - | let lpcs = M.findWithDefault [] pn pcs - , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs - , (fn', flagVal) <- unFlagAssignment fa - , fn' == fn ] - - -- Prune flag values that are not the default and do not match any - -- of the constraints. - restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c - restrictToggling flagDefault constraintVals flagVal r = - if flagVal `elem` constraintVals || flagVal == flagDefault - then r - else Fail (varToConflictSet (F qfn)) ManualFlag - - in W.mapWithKey (restrictToggling d flagConstraintValues) ts - go x = x - --- | Require installed packages. -requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c -requireInstalled p = trav go - where - go (PChoiceF v@(Q _ pn) rdm gr cs) - | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) - | otherwise = PChoiceF v rdm gr cs - where - installed (POption (I _ (Inst _)) _) x = x - installed _ _ = Fail (varToConflictSet (P v)) CannotInstall - go x = x - --- | Avoid reinstalls. --- --- This is a tricky strategy. If a package version is installed already and the --- same version is available from a repo, the repo version will never be chosen. --- This would result in a reinstall (either destructively, or potentially, --- shadowing). The old instance won't be visible or even present anymore, but --- other packages might have depended on it. --- --- TODO: It would be better to actually check the reverse dependencies of installed --- packages. If they're not depended on, then reinstalling should be fine. Even if --- they are, perhaps this should just result in trying to reinstall those other --- packages as well. However, doing this all neatly in one pass would require to --- change the builder, or at least to change the goal set after building. -avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c -avoidReinstalls p = trav go - where - go (PChoiceF qpn@(Q _ pn) rdm gr cs) - | p pn = PChoiceF qpn rdm gr disableReinstalls - | otherwise = PChoiceF qpn rdm gr cs - where - disableReinstalls = - let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] - in W.mapWithKey (notReinstall installed) cs - - notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = - Fail (varToConflictSet (P qpn)) CannotReinstall - notReinstall _ _ x = - x - go x = x - --- | Require all packages to be mentioned in a constraint or as a goal. -onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason -onlyConstrained p = trav go - where - go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) - = FailF - (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) - NotExplicit - go x - = x - --- | Sort all goals using the provided function. -sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c -sortGoals variableOrder = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) - go x = x - - goalOrder :: Goal QPN -> Goal QPN -> Ordering - goalOrder = variableOrder `on` (varToVariable . goalToVar) - - varToVariable :: Var QPN -> Variable QPN - varToVariable (P qpn) = PackageVar qpn - varToVariable (F (FN qpn fn)) = FlagVar qpn fn - varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza - --- | Reduce the branching degree of the search tree by removing all choices --- after the first successful choice at each level. The returned tree is the --- minimal subtree containing the path to the first backjump. -pruneAfterFirstSuccess :: Tree d c -> Tree d c -pruneAfterFirstSuccess = trav go - where - go (PChoiceF qpn rdm gr ts) = PChoiceF qpn rdm gr (W.takeUntil active ts) - go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts) - go (SChoiceF qsn rdm gr w ts) = SChoiceF qsn rdm gr w (W.takeUntil active ts) - go x = x - --- | Always choose the first goal in the list next, abandoning all --- other choices. --- --- This is unnecessary for the default search strategy, because --- it descends only into the first goal choice anyway, --- but may still make sense to just reduce the tree size a bit. -firstGoal :: Tree d c -> Tree d c -firstGoal = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) - go x = x - -- Note that we keep empty choice nodes, because they mean success. - --- | Transformation that tries to make a decision on base as early as --- possible by pruning all other goals when base is available. In nearly --- all cases, there's a single choice for the base package. Also, fixing --- base early should lead to better error messages. -preferBaseGoalChoice :: Tree d c -> Tree d c -preferBaseGoalChoice = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) - go x = x - - isBase :: Goal QPN -> Bool - isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" - isBase _ = False - --- | Deal with setup dependencies after regular dependencies, so that we can --- will link setup dependencies against package dependencies when possible -deferSetupChoices :: Tree d c -> Tree d c -deferSetupChoices = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetup xs) - go x = x - - noSetup :: Goal QPN -> Bool - noSetup (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False - noSetup _ = True - --- | Transformation that tries to avoid making weak flag choices early. --- Weak flags are trivial flags (not influencing dependencies) or such --- flags that are explicitly declared to be weak in the index. -deferWeakFlagChoices :: Tree d c -> Tree d c -deferWeakFlagChoices = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) - go x = x - - noWeakStanza :: Tree d c -> Bool - noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False - noWeakStanza _ = True - - noWeakFlag :: Tree d c -> Bool - noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False - noWeakFlag _ = True - --- | Transformation that prefers goals with lower branching degrees. --- --- When a goal choice node has at least one goal with zero or one children, this --- function prunes all other goals. This transformation can help the solver find --- a solution in fewer steps by allowing it to backtrack sooner when it is --- exploring a subtree with no solutions. However, each step is more expensive. -preferReallyEasyGoalChoices :: Tree d c -> Tree d c -preferReallyEasyGoalChoices = trav go - where - go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) - go x = x - --- | Monad used internally in enforceSingleInstanceRestriction --- --- For each package instance we record the goal for which we picked a concrete --- instance. The SIR means that for any package instance there can only be one. -type EnforceSIR = Reader (Map (PI PN) QPN) - --- | Enforce ghc's single instance restriction --- --- From the solver's perspective, this means that for any package instance --- (that is, package name + package version) there can be at most one qualified --- goal resolving to that instance (there may be other goals _linking_ to that --- instance however). -enforceSingleInstanceRestriction :: Tree d c -> Tree d c -enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go - where - go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c) - - -- We just verify package choices. - go (PChoiceF qpn rdm gr cs) = - PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) cs) - go _otherwise = - innM _otherwise - - -- The check proper - goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c) - goP qpn@(Q _ pn) (POption i linkedTo) r = do - let inst = PI pn i - env <- ask - case (linkedTo, M.lookup inst env) of - (Just _, _) -> - -- For linked nodes we don't check anything - r - (Nothing, Nothing) -> - -- Not linked, not already used - local (M.insert inst qpn) r - (Nothing, Just qpn') -> do - -- Not linked, already used. This is an error - return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances diff --git a/Distribution/Solver/Modular/RetryLog.hs b/Distribution/Solver/Modular/RetryLog.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/RetryLog.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -module Distribution.Solver.Modular.RetryLog - ( RetryLog - , toProgress - , fromProgress - , mapFailure - , retry - , failWith - , succeedWith - , continueWith - , tryWith - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Solver.Modular.Message -import Distribution.Solver.Types.Progress - --- | 'Progress' as a difference list that allows efficient appends at failures. -newtype RetryLog step fail done = RetryLog { - unRetryLog :: forall fail2 . (fail -> Progress step fail2 done) - -> Progress step fail2 done - } - --- | /O(1)/. Convert a 'RetryLog' to a 'Progress'. -toProgress :: RetryLog step fail done -> Progress step fail done -toProgress (RetryLog f) = f Fail - --- | /O(N)/. Convert a 'Progress' to a 'RetryLog'. -fromProgress :: Progress step fail done -> RetryLog step fail done -fromProgress l = RetryLog $ \f -> go f l - where - go :: (fail1 -> Progress step fail2 done) - -> Progress step fail1 done - -> Progress step fail2 done - go _ (Done d) = Done d - go f (Fail failure) = f failure - go f (Step m ms) = Step m (go f ms) - --- | /O(1)/. Apply a function to the failure value in a log. -mapFailure :: (fail1 -> fail2) - -> RetryLog step fail1 done - -> RetryLog step fail2 done -mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure) - --- | /O(1)/. If the first log leads to failure, continue with the second. -retry :: RetryLog step fail1 done - -> (fail1 -> RetryLog step fail2 done) - -> RetryLog step fail2 done -retry (RetryLog f) g = - RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog - --- | /O(1)/. Create a log with one message before a failure. -failWith :: step -> fail -> RetryLog step fail done -failWith m failure = RetryLog $ \f -> Step m (f failure) - --- | /O(1)/. Create a log with one message before a success. -succeedWith :: step -> done -> RetryLog step fail done -succeedWith m d = RetryLog $ const $ Step m (Done d) - --- | /O(1)/. Prepend a message to a log. -continueWith :: step - -> RetryLog step fail done - -> RetryLog step fail done -continueWith m (RetryLog f) = RetryLog $ Step m . f - --- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert --- 'Leave' before the failure if the log fails. -tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done -tryWith m f = - RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave)) diff --git a/Distribution/Solver/Modular/Solver.hs b/Distribution/Solver/Modular/Solver.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Solver.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef DEBUG_TRACETREE -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -#endif -module Distribution.Solver.Modular.Solver - ( SolverConfig(..) - , solve - , PruneAfterFirstSuccess(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import qualified Data.Map as M -import qualified Data.List as L -import qualified Data.Set as S -import Distribution.Verbosity - -import Distribution.Compiler (CompilerInfo) - -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.Variable - -import Distribution.Solver.Modular.Assignment -import Distribution.Solver.Modular.Builder -import Distribution.Solver.Modular.Cycles -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Explore -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Log -import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.Package -import qualified Distribution.Solver.Modular.Preference as P -import Distribution.Solver.Modular.Validate -import Distribution.Solver.Modular.Linking -import Distribution.Solver.Modular.PSQ (PSQ) -import Distribution.Solver.Modular.RetryLog -import Distribution.Solver.Modular.Tree -import qualified Distribution.Solver.Modular.PSQ as PSQ - -import Distribution.Simple.Setup (BooleanFlag(..)) - -#ifdef DEBUG_TRACETREE -import qualified Distribution.Solver.Modular.ConflictSet as CS -import qualified Distribution.Solver.Modular.WeightedPSQ as W -import qualified Distribution.Deprecated.Text as T - -import Debug.Trace.Tree (gtraceJson) -import Debug.Trace.Tree.Simple -import Debug.Trace.Tree.Generic -import Debug.Trace.Tree.Assoc (Assoc(..)) -#endif - --- | Various options for the modular solver. -data SolverConfig = SolverConfig { - reorderGoals :: ReorderGoals, - countConflicts :: CountConflicts, - fineGrainedConflicts :: FineGrainedConflicts, - minimizeConflictSet :: MinimizeConflictSet, - independentGoals :: IndependentGoals, - avoidReinstalls :: AvoidReinstalls, - shadowPkgs :: ShadowPkgs, - strongFlags :: StrongFlags, - allowBootLibInstalls :: AllowBootLibInstalls, - onlyConstrained :: OnlyConstrained, - maxBackjumps :: Maybe Int, - enableBackjumping :: EnableBackjumping, - solveExecutables :: SolveExecutables, - goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), - solverVerbosity :: Verbosity, - pruneAfterFirstSuccess :: PruneAfterFirstSuccess -} - --- | Whether to remove all choices after the first successful choice at each --- level in the search tree. -newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool - --- | Run all solver phases. --- --- In principle, we have a valid tree after 'validationPhase', which --- means that every 'Done' node should correspond to valid solution. --- --- There is one exception, though, and that is cycle detection, which --- has been added relatively recently. Cycles are only removed directly --- before exploration. --- -solve :: SolverConfig -- ^ solver parameters - -> CompilerInfo - -> Index -- ^ all available packages as an index - -> PkgConfigDb -- ^ available pkg-config pkgs - -> (PN -> PackagePreferences) -- ^ preferences - -> M.Map PN [LabeledPackageConstraint] -- ^ global constraints - -> S.Set PN -- ^ global goals - -> RetryLog Message SolverFailure (Assignment, RevDepMap) -solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = - explorePhase $ - detectCycles $ - heuristicsPhase $ - preferencesPhase $ - validationPhase $ - prunePhase $ - buildPhase - where - explorePhase = backjumpAndExplore (maxBackjumps sc) - (enableBackjumping sc) - (fineGrainedConflicts sc) - (countConflicts sc) - idx - detectCycles = traceTree "cycles.json" id . detectCyclesPhase - heuristicsPhase = - let heuristicsTree = traceTree "heuristics.json" id - sortGoals = case goalOrder sc of - Nothing -> goalChoiceHeuristics . - heuristicsTree . - P.deferSetupChoices . - P.deferWeakFlagChoices . - P.preferBaseGoalChoice - Just order -> P.firstGoal . - heuristicsTree . - P.sortGoals order - PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc - in sortGoals . - (if prune then P.pruneAfterFirstSuccess else id) - preferencesPhase = P.preferLinked . - P.preferPackagePreferences userPrefs - validationPhase = traceTree "validated.json" id . - P.enforcePackageConstraints userConstraints . - P.enforceManualFlags userConstraints . - P.enforceSingleInstanceRestriction . - validateLinking idx . - validateTree cinfo idx pkgConfigDB - prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . - (if asBool (allowBootLibInstalls sc) - then id - else P.requireInstalled (`elem` nonInstallable)) . - (case onlyConstrained sc of - OnlyConstrainedAll -> - P.onlyConstrained pkgIsExplicit - OnlyConstrainedNone -> - id) - buildPhase = traceTree "build.json" id - $ buildTree idx (independentGoals sc) (S.toList userGoals) - - allExplicit = M.keysSet userConstraints `S.union` userGoals - - pkgIsExplicit :: PN -> Bool - pkgIsExplicit pn = S.member pn allExplicit - - -- packages that can never be installed or upgraded - -- If you change this enumeration, make sure to update the list in - -- "Distribution.Client.Dependency" as well - nonInstallable :: [PackageName] - nonInstallable = - L.map mkPackageName - [ "base" - , "ghc-prim" - , "integer-gmp" - , "integer-simple" - , "template-haskell" - ] - - -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which - -- prefers (keeps) goals only if the have 0 or 1 enabled choice. - -- - -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes - -- to just a single option. This was a way to work around a space leak that was - -- unnecessary and is now fixed, so we no longer do it. - -- - -- If --count-conflicts is active, it will then choose among the remaining goals - -- the one that has been responsible for the most conflicts so far. - -- - -- Otherwise, we simply choose the first remaining goal. - -- - goalChoiceHeuristics - | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices - | otherwise = id {- P.firstGoal -} - --- | Dump solver tree to a file (in debugging mode) --- --- This only does something if the @debug-tracetree@ configure argument was --- given; otherwise this is just the identity function. -traceTree :: -#ifdef DEBUG_TRACETREE - GSimpleTree a => -#endif - FilePath -- ^ Output file - -> (a -> a) -- ^ Function to summarize the tree before dumping - -> a -> a -#ifdef DEBUG_TRACETREE -traceTree = gtraceJson -#else -traceTree _ _ = id -#endif - -#ifdef DEBUG_TRACETREE -instance GSimpleTree (Tree d c) where - fromGeneric = go - where - go :: Tree d c -> SimpleTree - go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq - go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq - go (Done _rdm _s) = Node "D" $ Assoc [] - go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] - - psqToList :: W.WeightedPSQ w k v -> [(k, v)] - psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList - - -- Show package choice - goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) - goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) - goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) - - -- Show flag or stanza choice - goFS :: Bool -> Tree d c -> (String, SimpleTree) - goFS val subtree = (show val, go subtree) - - -- Show goal choice - goG :: Goal QPN -> Tree d c -> (String, SimpleTree) - goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) - - -- Variation on 'showGR' that produces shorter strings - -- (Actually, QGoalReason records more info than necessary: we only need - -- to know the variable that introduced the goal, not the value assigned - -- to that variable) - shortGR :: QGoalReason -> String - shortGR UserGoal = "user" - shortGR (DependencyGoal dr) = showDependencyReason dr - - -- Show conflict set - goCS :: ConflictSet -> String - goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" -#endif - --- | Replace all goal reasons with a dummy goal reason in the tree --- --- This is useful for debugging (when experimenting with the impact of GRs) -_removeGR :: Tree d c -> Tree d QGoalReason -_removeGR = trav go - where - go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) - go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq - go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq - go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq - go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) - go (DoneF rdm s) = DoneF rdm s - go (FailF cs reason) = FailF cs reason - - goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) - goG = PSQ.fromList - . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree)) - . PSQ.toList - - dummy :: QGoalReason - dummy = - DependencyGoal $ - DependencyReason - (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) - M.empty S.empty diff --git a/Distribution/Solver/Modular/Tree.hs b/Distribution/Solver/Modular/Tree.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Tree.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -module Distribution.Solver.Modular.Tree - ( POption(..) - , Tree(..) - , TreeF(..) - , Weight - , FailReason(..) - , ConflictingDep(..) - , ana - , cata - , inn - , innM - , para - , trav - , zeroOrOneChoices - , active - ) where - -import Control.Monad hiding (mapM, sequence) -import Data.Foldable -import Data.Traversable -import Prelude hiding (foldr, mapM, sequence) - -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.PSQ (PSQ) -import Distribution.Solver.Modular.Version -import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ) -import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.PackagePath -import Distribution.Types.PkgconfigVersionRange -import Distribution.Types.UnitId (UnitId) -import Language.Haskell.Extension (Extension, Language) - -type Weight = Double - --- | Type of the search tree. Inlining the choice nodes for now. Weights on --- package, flag, and stanza choices control the traversal order. --- --- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes --- (type 'c'). For example, during the final traversal, choice nodes contain the --- variables that introduced the choices, and 'Done' nodes contain the --- assignments for all variables. --- --- TODO: The weight type should be changed from [Double] to Double to avoid --- giving too much weight to preferences that are applied later. -data Tree d c = - -- | Choose a version for a package (or choose to link) - PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) - - -- | Choose a value for a flag - -- - -- The Bool is the default value. - | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) - - -- | Choose whether or not to enable a stanza - | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) - - -- | Choose which choice to make next - -- - -- Invariants: - -- - -- * PSQ should never be empty - -- * For each choice we additionally record the 'QGoalReason' why we are - -- introducing that goal into tree. Note that most of the time we are - -- working with @Tree QGoalReason@; in that case, we must have the - -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' - -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason - -- recorded on that 'GoalChoice' node. - | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) - - -- | We're done -- we found a solution! - | Done RevDepMap d - - -- | We failed to find a solution in this path through the tree - | Fail ConflictSet FailReason - --- | A package option is a package instance with an optional linking annotation --- --- The modular solver has a number of package goals to solve for, and can only --- pick a single package version for a single goal. In order to allow to --- install multiple versions of the same package as part of a single solution --- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both --- be qualified goals for @P@, allowing to pick a difference version of package --- @P@ for @0.P@ and @1.P@. --- --- Linking is an essential part of this story. In addition to picking a specific --- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or --- vice versa). It means that @1.P@ and @0.P@ really must be the very same package --- (and hence must have the same build time configuration, and their --- dependencies must also be the exact same). --- --- See for details. -data POption = POption I (Maybe PackagePath) - deriving (Eq, Show) - -data FailReason = UnsupportedExtension Extension - | UnsupportedLanguage Language - | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange - | NewPackageDoesNotMatchExistingConstraint ConflictingDep - | ConflictingConstraints ConflictingDep ConflictingDep - | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) - | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN) - | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) - | PackageRequiresMissingComponent QPN ExposedComponent - | PackageRequiresPrivateComponent QPN ExposedComponent - | PackageRequiresUnbuildableComponent QPN ExposedComponent - | CannotInstall - | CannotReinstall - | NotExplicit - | Shadowed - | Broken UnitId - | UnknownPackage - | GlobalConstraintVersion VR ConstraintSource - | GlobalConstraintInstalled ConstraintSource - | GlobalConstraintSource ConstraintSource - | GlobalConstraintFlag ConstraintSource - | ManualFlag - | MalformedFlagChoice QFN - | MalformedStanzaChoice QSN - | EmptyGoalChoice - | Backjump - | MultipleInstances - | DependenciesNotLinked String - | CyclicDependencies - | UnsupportedSpecVer Ver - deriving (Eq, Show) - --- | Information about a dependency involved in a conflict, for error messages. -data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI - deriving (Eq, Show) - --- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' --- have the same meaning as in 'Tree'. -data TreeF d c a = - PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) - | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) - | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) - | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) - | DoneF RevDepMap d - | FailF ConflictSet FailReason - deriving (Functor, Foldable, Traversable) - -out :: Tree d c -> TreeF d c (Tree d c) -out (PChoice p s i ts) = PChoiceF p s i ts -out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts -out (SChoice p s i b ts) = SChoiceF p s i b ts -out (GoalChoice s ts) = GoalChoiceF s ts -out (Done x s ) = DoneF x s -out (Fail c x ) = FailF c x - -inn :: TreeF d c (Tree d c) -> Tree d c -inn (PChoiceF p s i ts) = PChoice p s i ts -inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts -inn (SChoiceF p s i b ts) = SChoice p s i b ts -inn (GoalChoiceF s ts) = GoalChoice s ts -inn (DoneF x s ) = Done x s -inn (FailF c x ) = Fail c x - -innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c) -innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts) -innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts) -innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts) -innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts) -innM (DoneF x s ) = return $ Done x s -innM (FailF c x ) = return $ Fail c x - --- | Determines whether a tree is active, i.e., isn't a failure node. -active :: Tree d c -> Bool -active (Fail _ _) = False -active _ = True - --- | Approximates the number of active choices that are available in a node. --- Note that we count goal choices as having one choice, always. -zeroOrOneChoices :: Tree d c -> Bool -zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (GoalChoice _ _ ) = True -zeroOrOneChoices (Done _ _ ) = True -zeroOrOneChoices (Fail _ _ ) = True - --- | Catamorphism on trees. -cata :: (TreeF d c a -> a) -> Tree d c -> a -cata phi x = (phi . fmap (cata phi) . out) x - -trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a -trav psi x = cata (inn . psi) x - --- | Paramorphism on trees. -para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a -para phi = phi . fmap (\ x -> (para phi x, x)) . out - --- | Anamorphism on trees. -ana :: (a -> TreeF d c a) -> a -> Tree d c -ana psi = inn . fmap (ana psi) . psi diff --git a/Distribution/Solver/Modular/Validate.hs b/Distribution/Solver/Modular/Validate.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Validate.hs +++ /dev/null @@ -1,593 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} -#ifdef DEBUG_CONFLICT_SETS -{-# LANGUAGE ImplicitParams #-} -#endif -module Distribution.Solver.Modular.Validate (validateTree) where - --- Validation of the tree. --- --- The task here is to make sure all constraints hold. After validation, any --- assignment returned by exploration of the tree should be a complete valid --- assignment, i.e., actually constitute a solution. - -import Control.Applicative -import Control.Monad.Reader hiding (sequence) -import Data.Either (lefts) -import Data.Function (on) -import Data.Traversable -import Prelude hiding (sequence) - -import qualified Data.List as L -import qualified Data.Set as S - -import Language.Haskell.Extension (Extension, Language) - -import Data.Map.Strict as M -import Distribution.Compiler (CompilerInfo(..)) - -import Distribution.Solver.Modular.Assignment -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Modular.Dependency -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Index -import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.WeightedPSQ as W - -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) -import Distribution.Types.LibraryName -import Distribution.Types.PkgconfigVersionRange - -#ifdef DEBUG_CONFLICT_SETS -import GHC.Stack (CallStack) -#endif - --- In practice, most constraints are implication constraints (IF we have made --- a number of choices, THEN we also have to ensure that). We call constraints --- that for which the preconditions are fulfilled ACTIVE. We maintain a set --- of currently active constraints that we pass down the node. --- --- We aim at detecting inconsistent states as early as possible. --- --- Whenever we make a choice, there are two things that need to happen: --- --- (1) We must check that the choice is consistent with the currently --- active constraints. --- --- (2) The choice increases the set of active constraints. For the new --- active constraints, we must check that they are consistent with --- the current state. --- --- We can actually merge (1) and (2) by saying the current choice is --- a new active constraint, fixing the choice. --- --- If a test fails, we have detected an inconsistent state. We can --- disable the current subtree and do not have to traverse it any further. --- --- We need a good way to represent the current state, i.e., the current --- set of active constraints. Since the main situation where we have to --- search in it is (1), it seems best to store the state by package: for --- every package, we store which versions are still allowed. If for any --- package, we have inconsistent active constraints, we can also stop. --- This is a particular way to read task (2): --- --- (2, weak) We only check if the new constraints are consistent with --- the choices we've already made, and add them to the active set. --- --- (2, strong) We check if the new constraints are consistent with the --- choices we've already made, and the constraints we already have. --- --- It currently seems as if we're implementing the weak variant. However, --- when used together with 'preferEasyGoalChoices', we will find an --- inconsistent state in the very next step. --- --- What do we do about flags? --- --- Like for packages, we store the flag choices we have already made. --- Now, regarding (1), we only have to test whether we've decided the --- current flag before. Regarding (2), the interesting bit is in discovering --- the new active constraints. To this end, we look up the constraints for --- the package the flag belongs to, and traverse its flagged dependencies. --- Wherever we find the flag in question, we start recording dependencies --- underneath as new active dependencies. If we encounter other flags, we --- check if we've chosen them already and either proceed or stop. - --- | The state needed during validation. -data ValidateState = VS { - supportedExt :: Extension -> Bool, - supportedLang :: Language -> Bool, - presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool, - index :: Index, - - -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, - -- it qualifies the package's dependencies and saves them in this map. Then - -- the qualified dependencies are available for subsequent flag and stanza - -- choices for the same package. - saved :: Map QPN (FlaggedDeps QPN), - - pa :: PreAssignment, - - -- Map from package name to the components that are provided by the chosen - -- instance of that package, and whether those components are visible and - -- buildable. - availableComponents :: Map QPN (Map ExposedComponent ComponentInfo), - - -- Map from package name to the components that are required from that - -- package. - requiredComponents :: Map QPN ComponentDependencyReasons, - - qualifyOptions :: QualifyOptions -} - -newtype Validate a = Validate (Reader ValidateState a) - deriving (Functor, Applicative, Monad, MonadReader ValidateState) - -runValidate :: Validate a -> ValidateState -> a -runValidate (Validate r) = runReader r - --- | A preassignment comprises knowledge about variables, but not --- necessarily fixed values. -data PreAssignment = PA PPreAssignment FAssignment SAssignment - --- | A (partial) package preassignment. Qualified package names --- are associated with MergedPkgDeps. -type PPreAssignment = Map QPN MergedPkgDep - --- | A dependency on a component, including its DependencyReason. -data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI - --- | Map from component name to one of the reasons that the component is --- required. -type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN) - --- | MergedPkgDep records constraints about the instances that can still be --- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a --- list of version ranges paired with the goals / variables that introduced --- them. It also records whether a package is a build-tool dependency, for each --- reason that it was introduced. --- --- It is important to store the component name with the version constraint, for --- error messages, because whether something is a build-tool dependency affects --- its qualifier, which affects which constraint is applied. -data MergedPkgDep = - MergedDepFixed ExposedComponent (DependencyReason QPN) I - | MergedDepConstrained [VROrigin] - --- | Version ranges paired with origins. -type VROrigin = (VR, ExposedComponent, DependencyReason QPN) - --- | The information needed to create a 'Fail' node. -type Conflict = (ConflictSet, FailReason) - -validate :: Tree d c -> Validate (Tree d c) -validate = cata go - where - go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) - - go (PChoiceF qpn rdm gr ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts) - go (FChoiceF qfn rdm gr b m d ts) = - do - -- Flag choices may occur repeatedly (because they can introduce new constraints - -- in various places). However, subsequent choices must be consistent. We thereby - -- collapse repeated flag choice nodes. - PA _ pfa _ <- asks pa -- obtain current flag-preassignment - case M.lookup qfn pfa of - Just rb -> -- flag has already been assigned; collapse choice to the correct branch - case W.lookup rb ts of - Just t -> goF qfn rb t - Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) - Nothing -> -- flag choice is new, follow both branches - FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts) - go (SChoiceF qsn rdm gr b ts) = - do - -- Optional stanza choices are very similar to flag choices. - PA _ _ psa <- asks pa -- obtain current stanza-preassignment - case M.lookup qsn psa of - Just rb -> -- stanza choice has already been made; collapse choice to the correct branch - case W.lookup rb ts of - Just t -> goS qsn rb t - Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) - Nothing -> -- stanza choice is new, follow both branches - SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts) - - -- We don't need to do anything for goal choices or failure nodes. - go (GoalChoiceF rdm ts) = GoalChoice rdm <$> sequence ts - go (DoneF rdm s ) = pure (Done rdm s) - go (FailF c fr ) = pure (Fail c fr) - - -- What to do for package nodes ... - goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) - goP qpn@(Q _pp pn) (POption i _) r = do - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - idx <- asks index -- obtain the index - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents - qo <- asks qualifyOptions - -- obtain dependencies and index-dictated exclusions introduced by the choice - let (PInfo deps comps _ mfr) = idx ! pn ! i - -- qualify the deps in the current scope - let qdeps = qualifyDeps qo qpn deps - -- the new active constraints are given by the instance we have chosen, - -- plus the dependency information we have for that instance - let newactives = extractAllDeps pfa psa qdeps - -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported pkgPresent newactives - =<< extendWithPackageChoice (PI qpn i) ppa - -- In case we continue, we save the scoped dependencies - let nsvd = M.insert qpn qdeps svd - case mfr of - Just fr -> -- The index marks this as an invalid choice. We can stop. - return (Fail (varToConflictSet (P qpn)) fr) - Nothing -> - let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons) - newDeps = do - nppa <- mnppa - rComps' <- extendRequiredComponents qpn aComps rComps newactives - checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps - return (nppa, rComps') - in case newDeps of - Left (c, fr) -> -- We have an inconsistency. We can stop. - return (Fail c fr) - Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation. - local (\ s -> s { pa = PA nppa pfa psa - , saved = nsvd - , availableComponents = M.insert qpn comps aComps - , requiredComponents = rComps' - }) r - - -- What to do for flag nodes ... - goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goF qfn@(FN qpn _f) b r = do - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents - -- Note that there should be saved dependencies for the package in question, - -- because while building, we do not choose flags before we see the packages - -- that define them. - let qdeps = svd ! qpn - -- We take the *saved* dependencies, because these have been qualified in the - -- correct scope. - -- - -- Extend the flag assignment - let npfa = M.insert qfn b pfa - -- We now try to get the new active dependencies we might learn about because - -- we have chosen a new flag. - let newactives = extractNewDeps (F qfn) b npfa psa qdeps - mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives - -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa - case liftM2 (,) mnppa mNewRequiredComps of - Left (c, fr) -> return (Fail c fr) -- inconsistency found - Right (nppa, rComps') -> - local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r - - -- What to do for stanza nodes (similar to flag nodes) ... - goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goS qsn@(SN qpn _f) b r = do - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies - aComps <- asks availableComponents - rComps <- asks requiredComponents - -- Note that there should be saved dependencies for the package in question, - -- because while building, we do not choose flags before we see the packages - -- that define them. - let qdeps = svd ! qpn - -- We take the *saved* dependencies, because these have been qualified in the - -- correct scope. - -- - -- Extend the flag assignment - let npsa = M.insert qsn b psa - -- We now try to get the new active dependencies we might learn about because - -- we have chosen a new flag. - let newactives = extractNewDeps (S qsn) b pfa npsa qdeps - mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives - -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa - case liftM2 (,) mnppa mNewRequiredComps of - Left (c, fr) -> return (Fail c fr) -- inconsistency found - Right (nppa, rComps') -> - local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r - --- | Check that a newly chosen package instance contains all components that --- are required from that package so far. The components must also be visible --- and buildable. -checkComponentsInNewPackage :: ComponentDependencyReasons - -> QPN - -> Map ExposedComponent ComponentInfo - -> Either Conflict () -checkComponentsInNewPackage required qpn providedComps = - case M.toList $ deleteKeys (M.keys providedComps) required of - (missingComp, dr) : _ -> - Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent - [] -> - let failures = lefts - [ case () of - _ | compIsVisible compInfo == IsVisible False -> - Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent - | compIsBuildable compInfo == IsBuildable False -> - Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent - | otherwise -> Right () - | let merged = M.intersectionWith (,) required providedComps - , (comp, (dr, compInfo)) <- M.toList merged ] - in case failures of - failure : _ -> Left failure - [] -> Right () - where - mkConflict :: ExposedComponent - -> DependencyReason QPN - -> (ExposedComponent -> DependencyReason QPN -> FailReason) - -> Conflict - mkConflict comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) - - deleteKeys :: Ord k => [k] -> Map k v -> Map k v - deleteKeys ks m = L.foldr M.delete m ks - --- | We try to extract as many concrete dependencies from the given flagged --- dependencies as possible. We make use of all the flag knowledge we have --- already acquired. -extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] -extractAllDeps fa sa deps = do - d <- deps - case d of - Simple sd _ -> return sd - Flagged qfn _ td fd -> case M.lookup qfn fa of - Nothing -> mzero - Just True -> extractAllDeps fa sa td - Just False -> extractAllDeps fa sa fd - Stanza qsn td -> case M.lookup qsn sa of - Nothing -> mzero - Just True -> extractAllDeps fa sa td - Just False -> [] - --- | We try to find new dependencies that become available due to the given --- flag or stanza choice. We therefore look for the choice in question, and then call --- 'extractAllDeps' for everything underneath. -extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] -extractNewDeps v b fa sa = go - where - go :: FlaggedDeps QPN -> [LDep QPN] - go deps = do - d <- deps - case d of - Simple _ _ -> mzero - Flagged qfn' _ td fd - | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd - | otherwise -> case M.lookup qfn' fa of - Nothing -> mzero - Just True -> go td - Just False -> go fd - Stanza qsn' td - | v == S qsn' -> if b then extractAllDeps fa sa td else [] - | otherwise -> case M.lookup qsn' sa of - Nothing -> mzero - Just True -> go td - Just False -> [] - --- | Extend a package preassignment. --- --- Takes the variable that causes the new constraints, a current preassignment --- and a set of new dependency constraints. --- --- We're trying to extend the preassignment with each dependency one by one. --- Each dependency is for a particular variable. We check if we already have --- constraints for that variable in the current preassignment. If so, we're --- trying to merge the constraints. --- --- Either returns a witness of the conflict that would arise during the merge, --- or the successfully extended assignment. -extend :: (Extension -> Bool) -- ^ is a given extension supported - -> (Language -> Bool) -- ^ is a given language supported - -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable - -> [LDep QPN] - -> PPreAssignment - -> Either Conflict PPreAssignment -extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives - where - - extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment - extendSingle a (LDep dr (Ext ext )) = - if extSupported ext then Right a - else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) - extendSingle a (LDep dr (Lang lang)) = - if langSupported lang then Right a - else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) - extendSingle a (LDep dr (Pkg pn vr)) = - if pkgPresent pn vr then Right a - else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) - extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = - let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a - in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of - Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') - Right x -> Right x - --- | Extend a package preassignment with a package choice. For example, when --- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. --- --- TODO: The new constraint is implemented as a dependency from foo to foo's --- main library. That isn't correct, because foo might only be needed as a build --- tool dependency. The implemention may need to change when we support --- component-based dependency solving. -extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment -extendWithPackageChoice (PI qpn i) ppa = - let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa - newChoice = PkgDep (DependencyReason qpn M.empty S.empty) - (PkgComponent qpn (ExposedLib LMainLibName)) - (Fixed i) - in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of - Left (c, (d, _d')) -> -- Don't include the package choice in the - -- FailReason, because it is redundant. - Left (c, NewPackageDoesNotMatchExistingConstraint d) - Right x -> Right x - --- | Merge constrained instances. We currently adopt a lazy strategy for --- merging, i.e., we only perform actual checking if one of the two choices --- is fixed. If the merge fails, we return a conflict set indicating the --- variables responsible for the failure, as well as the two conflicting --- fragments. --- --- Note that while there may be more than one conflicting pair of version --- ranges, we only return the first we find. --- --- The ConflictingDeps are returned in order, i.e., the first describes the --- conflicting part of the MergedPkgDep, and the second describes the PkgDep. --- --- TODO: Different pairs might have different conflict sets. We're --- obviously interested to return a conflict that has a "better" conflict --- set in the sense the it contains variables that allow us to backjump --- further. We might apply some heuristics here, such as to change the --- order in which we check the constraints. -merge :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep -merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) - | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 - | otherwise = - Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 - , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) - , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) - -merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) - | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i - | otherwise = - Left ( createConflictSetForVersionConflict p v vs1 vr vs2 - , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) - , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) - -merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) = - go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... - where - go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep - go [] = Right (MergedDepFixed comp2 vs2 i) - go ((vr, comp1, vs1) : vros) - | checkVR vr v = go vros - | otherwise = - Left ( createConflictSetForVersionConflict p v vs2 vr vs1 - , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) - , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) - -merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) = - Right (MergedDepConstrained $ - - -- TODO: This line appends the new version range, to preserve the order used - -- before a refactoring. Consider prepending the version range, if there is - -- no negative performance impact. - vrOrigins ++ [(vr, comp2, vs2)]) - --- | Creates a conflict set representing a conflict between a version constraint --- and the fixed version chosen for a package. -createConflictSetForVersionConflict :: QPN - -> Ver - -> DependencyReason QPN - -> VR - -> DependencyReason QPN - -> ConflictSet -createConflictSetForVersionConflict pkg - conflictingVersion - versionDR@(DependencyReason p1 _ _) - conflictingVersionRange - versionRangeDR@(DependencyReason p2 _ _) = - let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) - in - -- The solver currently only optimizes the case where there is a conflict - -- between the version chosen for a package and a version constraint that - -- is not under any flags or stanzas. Here is how we check for this case: - -- - -- (1) Choosing a specific version for a package foo is implemented as - -- adding a dependency from foo to that version of foo (See - -- extendWithPackageChoice), so we check that the DependencyReason - -- contains the current package and no flag or stanza choices. - -- - -- (2) We check that the DependencyReason for the version constraint also - -- contains no flag or stanza choices. - -- - -- When these criteria are not met, we fall back to calling - -- dependencyReasonToConflictSet. - if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) - then let cs1 = dependencyReasonToConflictSetWithVersionConflict - p2 - (CS.OrderedVersionRange conflictingVersionRange) - versionDR - cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict - pkg conflictingVersion versionRangeDR - in cs1 `CS.union` cs2 - else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR - --- | Takes a list of new dependencies and uses it to try to update the map of --- known component dependencies. It returns a failure when a new dependency --- requires a component that is missing, private, or unbuildable in a previously --- chosen package. -extendRequiredComponents :: QPN -- ^ package we extend - -> Map QPN (Map ExposedComponent ComponentInfo) - -> Map QPN ComponentDependencyReasons - -> [LDep QPN] - -> Either Conflict (Map QPN ComponentDependencyReasons) -extendRequiredComponents eqpn available = foldM extendSingle - where - extendSingle :: Map QPN ComponentDependencyReasons - -> LDep QPN - -> Either Conflict (Map QPN ComponentDependencyReasons) - extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) = - let compDeps = M.findWithDefault M.empty qpn required - success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required - in -- Only check for the existence of the component if its package has - -- already been chosen. - case M.lookup qpn available of - Just comps -> - case M.lookup comp comps of - Nothing -> - Left $ mkConflict qpn comp dr PackageRequiresMissingComponent - Just compInfo - | compIsVisible compInfo == IsVisible False - , eqpn /= qpn -- package components can depend on other components - -> - Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent - | compIsBuildable compInfo == IsBuildable False -> - Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent - | otherwise -> success - Nothing -> success - extendSingle required _ = Right required - - mkConflict :: QPN - -> ExposedComponent - -> DependencyReason QPN - -> (QPN -> ExposedComponent -> FailReason) - -> Conflict - mkConflict qpn comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) - - --- | Interface. -validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c -validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { - supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported - (\ es -> let s = S.fromList es in \ x -> S.member x s) - (compilerInfoExtensions cinfo) - , supportedLang = maybe (const True) - (flip L.elem) -- use list lookup because language list is small and no Ord instance - (compilerInfoLanguages cinfo) - , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb - , index = idx - , saved = M.empty - , pa = PA M.empty M.empty M.empty - , availableComponents = M.empty - , requiredComponents = M.empty - , qualifyOptions = defaultQualifyOptions idx - } diff --git a/Distribution/Solver/Modular/Var.hs b/Distribution/Solver/Modular/Var.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Var.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Solver.Modular.Var ( - Var(..) - , showVar - , varPN - ) where - -import Prelude hiding (pi) - -import Distribution.Solver.Modular.Flag -import Distribution.Solver.Types.PackagePath - -{------------------------------------------------------------------------------- - Variables --------------------------------------------------------------------------------} - --- | The type of variables that play a role in the solver. --- Note that the tree currently does not use this type directly, --- and rather has separate tree nodes for the different types of --- variables. This fits better with the fact that in most cases, --- these have to be treated differently. -data Var qpn = P qpn | F (FN qpn) | S (SN qpn) - deriving (Eq, Ord, Show, Functor) - -showVar :: Var QPN -> String -showVar (P qpn) = showQPN qpn -showVar (F qfn) = showQFN qfn -showVar (S qsn) = showQSN qsn - --- | Extract the package name from a Var -varPN :: Var qpn -> qpn -varPN (P qpn) = qpn -varPN (F (FN qpn _)) = qpn -varPN (S (SN qpn _)) = qpn diff --git a/Distribution/Solver/Modular/Version.hs b/Distribution/Solver/Modular/Version.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/Version.hs +++ /dev/null @@ -1,56 +0,0 @@ -module Distribution.Solver.Modular.Version - ( Ver - , VR - , anyVR - , checkVR - , eqVR - , showVer - , showVR - , simplifyVR - , (.&&.) - , (.||.) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import qualified Distribution.Version as CV -- from Cabal -import Distribution.Pretty (prettyShow) - --- | Preliminary type for versions. -type Ver = CV.Version - --- | String representation of a version. -showVer :: Ver -> String -showVer = prettyShow - --- | Version range. Consists of a lower and upper bound. -type VR = CV.VersionRange - --- | String representation of a version range. -showVR :: VR -> String -showVR = prettyShow - --- | Unconstrained version range. -anyVR :: VR -anyVR = CV.anyVersion - --- | Version range fixing a single version. -eqVR :: Ver -> VR -eqVR = CV.thisVersion - --- | Intersect two version ranges. -(.&&.) :: VR -> VR -> VR -v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2 - --- | Union of two version ranges. -(.||.) :: VR -> VR -> VR -v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2 - --- | Simplify a version range. -simplifyVR :: VR -> VR -simplifyVR = CV.simplifyVersionRange - --- | Checking a version against a version range. -checkVR :: VR -> Ver -> Bool -checkVR = flip CV.withinRange diff --git a/Distribution/Solver/Modular/WeightedPSQ.hs b/Distribution/Solver/Modular/WeightedPSQ.hs deleted file mode 100644 --- a/Distribution/Solver/Modular/WeightedPSQ.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.WeightedPSQ ( - WeightedPSQ - , fromList - , toList - , keys - , weights - , isZeroOrOne - , filter - , lookup - , mapWithKey - , mapWeightsWithKey - , union - , takeUntil - ) where - -import qualified Data.Foldable as F -import qualified Data.List as L -import Data.Ord (comparing) -import qualified Data.Traversable as T -import Prelude hiding (filter, lookup) - --- | An association list that is sorted by weight. --- --- Each element has a key ('k'), value ('v'), and weight ('w'). All operations --- that add elements or modify weights stably sort the elements by weight. -newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)] - deriving (Eq, Show, Functor, F.Foldable, T.Traversable) - --- | /O(N)/. -filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v -filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs) - --- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements. -isZeroOrOne :: WeightedPSQ w k v -> Bool -isZeroOrOne (WeightedPSQ []) = True -isZeroOrOne (WeightedPSQ [_]) = True -isZeroOrOne _ = False - --- | /O(1)/. Return the elements in order. -toList :: WeightedPSQ w k v -> [(w, k, v)] -toList (WeightedPSQ xs) = xs - --- | /O(N log N)/. -fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v -fromList = WeightedPSQ . L.sortBy (comparing triple_1) - --- | /O(N)/. Return the weights in order. -weights :: WeightedPSQ w k v -> [w] -weights (WeightedPSQ xs) = L.map triple_1 xs - --- | /O(N)/. Return the keys in order. -keys :: WeightedPSQ w k v -> [k] -keys (WeightedPSQ xs) = L.map triple_2 xs - --- | /O(N)/. Return the value associated with the first occurrence of the give --- key, if it exists. -lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v -lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs - --- | /O(N log N)/. Update the weights. -mapWeightsWithKey :: Ord w2 - => (k -> w1 -> w2) - -> WeightedPSQ w1 k v - -> WeightedPSQ w2 k v -mapWeightsWithKey f (WeightedPSQ xs) = fromList $ - L.map (\ (w, k, v) -> (f k w, k, v)) xs - --- | /O(N)/. Update the values. -mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2 -mapWithKey f (WeightedPSQ xs) = WeightedPSQ $ - L.map (\ (w, k, v) -> (w, k, f k v)) xs - --- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all --- elements. Elements from the first @WeightedPSQ@ come before elements in the --- second when they have the same weight. -union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v -union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys) - --- | /O(N)/. Return the prefix of values ending with the first element that --- satisfies p, or all elements if none satisfy p. -takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v -takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs) - where - go :: [(w, k, v)] -> [(w, k, v)] - go [] = [] - go (y : ys) = y : if p (triple_3 y) then [] else go ys - -triple_1 :: (x, y, z) -> x -triple_1 (x, _, _) = x - -triple_2 :: (x, y, z) -> y -triple_2 (_, y, _) = y - -triple_3 :: (x, y, z) -> z -triple_3 (_, _, z) = z diff --git a/Distribution/Solver/Types/ComponentDeps.hs b/Distribution/Solver/Types/ComponentDeps.hs deleted file mode 100644 --- a/Distribution/Solver/Types/ComponentDeps.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} - --- | Fine-grained package dependencies --- --- Like many others, this module is meant to be "double-imported": --- --- > import Distribution.Solver.Types.ComponentDeps ( --- > Component --- > , ComponentDep --- > , ComponentDeps --- > ) --- > import qualified Distribution.Solver.Types.ComponentDeps as CD -module Distribution.Solver.Types.ComponentDeps ( - -- * Fine-grained package dependencies - Component(..) - , componentNameToComponent - , ComponentDep - , ComponentDeps -- opaque - -- ** Constructing ComponentDeps - , empty - , fromList - , singleton - , insert - , zip - , filterDeps - , fromLibraryDeps - , fromSetupDeps - , fromInstalled - -- ** Deconstructing ComponentDeps - , toList - , flatDeps - , nonSetupDeps - , libraryDeps - , setupDeps - , select - , components - ) where - -import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) - -import qualified Data.Map as Map -import Data.Foldable (fold) - -import Distribution.Pretty (Pretty (..)) -import qualified Distribution.Types.ComponentName as CN -import qualified Distribution.Types.LibraryName as LN -import qualified Text.PrettyPrint as PP - - -{------------------------------------------------------------------------------- - Types --------------------------------------------------------------------------------} - --- | Component of a package. -data Component = - ComponentLib - | ComponentSubLib UnqualComponentName - | ComponentFLib UnqualComponentName - | ComponentExe UnqualComponentName - | ComponentTest UnqualComponentName - | ComponentBench UnqualComponentName - | ComponentSetup - deriving (Show, Eq, Ord, Generic) - -instance Binary Component -instance Structured Component - -instance Pretty Component where - pretty ComponentLib = PP.text "lib" - pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n - pretty (ComponentFLib n) = PP.text "flib:" <<>> pretty n - pretty (ComponentExe n) = PP.text "exe:" <<>> pretty n - pretty (ComponentTest n) = PP.text "test:" <<>> pretty n - pretty (ComponentBench n) = PP.text "bench:" <<>> pretty n - pretty ComponentSetup = PP.text "setup" - --- | Dependency for a single component. -type ComponentDep a = (Component, a) - --- | Fine-grained dependencies for a package. --- --- Typically used as @ComponentDeps [Dependency]@, to represent the list of --- dependencies for each named component within a package. --- -newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } - deriving (Show, Functor, Eq, Ord, Generic) - -instance Semigroup a => Monoid (ComponentDeps a) where - mempty = ComponentDeps Map.empty - mappend = (<>) - -instance Semigroup a => Semigroup (ComponentDeps a) where - ComponentDeps d <> ComponentDeps d' = - ComponentDeps (Map.unionWith (<>) d d') - -instance Foldable ComponentDeps where - foldMap f = foldMap f . unComponentDeps - -instance Traversable ComponentDeps where - traverse f = fmap ComponentDeps . traverse f . unComponentDeps - -instance Binary a => Binary (ComponentDeps a) -instance Structured a => Structured (ComponentDeps a) - -componentNameToComponent :: CN.ComponentName -> Component -componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib -componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s -componentNameToComponent (CN.CFLibName s) = ComponentFLib s -componentNameToComponent (CN.CExeName s) = ComponentExe s -componentNameToComponent (CN.CTestName s) = ComponentTest s -componentNameToComponent (CN.CBenchName s) = ComponentBench s - -{------------------------------------------------------------------------------- - Construction --------------------------------------------------------------------------------} - -empty :: ComponentDeps a -empty = ComponentDeps $ Map.empty - -fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a -fromList = ComponentDeps . Map.fromListWith mappend - -singleton :: Component -> a -> ComponentDeps a -singleton comp = ComponentDeps . Map.singleton comp - -insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a -insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps - where - aux Nothing = Just a - aux (Just a') = Just $ a `mappend` a' - --- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' --- as the neutral element when a 'Component' is present only in one. -zip - :: (Monoid a, Monoid b) - => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) -zip (ComponentDeps d1) (ComponentDeps d2) = - ComponentDeps $ - Map.mergeWithKey - (\_ a b -> Just (a,b)) - (fmap (\a -> (a, mempty))) - (fmap (\b -> (mempty, b))) - d1 d2 - --- | Keep only selected components (and their associated deps info). -filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a -filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps - --- | ComponentDeps containing library dependencies only -fromLibraryDeps :: a -> ComponentDeps a -fromLibraryDeps = singleton ComponentLib - --- | ComponentDeps containing setup dependencies only. -fromSetupDeps :: a -> ComponentDeps a -fromSetupDeps = singleton ComponentSetup - --- | ComponentDeps for installed packages. --- --- We assume that installed packages only record their library dependencies. -fromInstalled :: a -> ComponentDeps a -fromInstalled = fromLibraryDeps - -{------------------------------------------------------------------------------- - Deconstruction --------------------------------------------------------------------------------} - -toList :: ComponentDeps a -> [ComponentDep a] -toList = Map.toList . unComponentDeps - --- | All dependencies of a package. --- --- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more --- obvious than a use of 'fold', and moreover this avoids introducing lots of --- @#ifdef@s for 7.10 just for the use of 'fold'. -flatDeps :: Monoid a => ComponentDeps a -> a -flatDeps = fold - --- | All dependencies except the setup dependencies. --- --- Prior to the introduction of setup dependencies in version 1.24 this --- would have been _all_ dependencies. -nonSetupDeps :: Monoid a => ComponentDeps a -> a -nonSetupDeps = select (/= ComponentSetup) - --- | Library dependencies proper only. (Includes dependencies --- of internal libraries.) -libraryDeps :: Monoid a => ComponentDeps a -> a -libraryDeps = select (\c -> case c of ComponentSubLib _ -> True - ComponentLib -> True - _ -> False) - --- | List components -components :: ComponentDeps a -> Set Component -components = Map.keysSet . unComponentDeps - --- | Setup dependencies. -setupDeps :: Monoid a => ComponentDeps a -> a -setupDeps = select (== ComponentSetup) - --- | Select dependencies satisfying a given predicate. -select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a -select p = foldMap snd . filter (p . fst) . toList diff --git a/Distribution/Solver/Types/ConstraintSource.hs b/Distribution/Solver/Types/ConstraintSource.hs deleted file mode 100644 --- a/Distribution/Solver/Types/ConstraintSource.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(..) - , showConstraintSource - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - --- | Source of a 'PackageConstraint'. -data ConstraintSource = - - -- | Main config file, which is ~/.cabal/config by default. - ConstraintSourceMainConfig FilePath - - -- | Local cabal.project file - | ConstraintSourceProjectConfig FilePath - - -- | Sandbox config file, which is ./cabal.sandbox.config by default. - | ConstraintSourceSandboxConfig FilePath - - -- | User config file, which is ./cabal.config by default. - | ConstraintSourceUserConfig FilePath - - -- | Flag specified on the command line. - | ConstraintSourceCommandlineFlag - - -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ - -- implies @package==0.1.0.0@. - | ConstraintSourceUserTarget - - -- | Internal requirement to use installed versions of packages like ghc-prim. - | ConstraintSourceNonUpgradeablePackage - - -- | Internal requirement to use the add-source version of a package when that - -- version is installed and the source is modified. - | ConstraintSourceModifiedAddSourceDep - - -- | Internal constraint used by @cabal freeze@. - | ConstraintSourceFreeze - - -- | Constraint specified by a config file, a command line flag, or a user - -- target, when a more specific source is not known. - | ConstraintSourceConfigFlagOrTarget - - -- | The source of the constraint is not specified. - | ConstraintSourceUnknown - - -- | An internal constraint due to compatibility issues with the Setup.hs - -- command line interface requires a minimum lower bound on Cabal - | ConstraintSetupCabalMinVersion - - -- | An internal constraint due to compatibility issues with the Setup.hs - -- command line interface requires a maximum upper bound on Cabal - | ConstraintSetupCabalMaxVersion - deriving (Eq, Show, Generic) - -instance Binary ConstraintSource -instance Structured ConstraintSource - --- | Description of a 'ConstraintSource'. -showConstraintSource :: ConstraintSource -> String -showConstraintSource (ConstraintSourceMainConfig path) = - "main config " ++ path -showConstraintSource (ConstraintSourceProjectConfig path) = - "project config " ++ path -showConstraintSource (ConstraintSourceSandboxConfig path) = - "sandbox config " ++ path -showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path -showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" -showConstraintSource ConstraintSourceUserTarget = "user target" -showConstraintSource ConstraintSourceNonUpgradeablePackage = - "non-upgradeable package" -showConstraintSource ConstraintSourceModifiedAddSourceDep = - "modified add-source dependency" -showConstraintSource ConstraintSourceFreeze = "cabal freeze" -showConstraintSource ConstraintSourceConfigFlagOrTarget = - "config file, command line flag, or user target" -showConstraintSource ConstraintSourceUnknown = "unknown source" -showConstraintSource ConstraintSetupCabalMinVersion = - "minimum version of Cabal used by Setup.hs" -showConstraintSource ConstraintSetupCabalMaxVersion = - "maximum version of Cabal used by Setup.hs" diff --git a/Distribution/Solver/Types/DependencyResolver.hs b/Distribution/Solver/Types/DependencyResolver.hs deleted file mode 100644 --- a/Distribution/Solver/Types/DependencyResolver.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Distribution.Solver.Types.DependencyResolver - ( DependencyResolver - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) -import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.PackageIndex ( PackageIndex ) -import Distribution.Solver.Types.Progress -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SourcePackage - -import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) -import Distribution.Package ( PackageName ) -import Distribution.Compiler ( CompilerInfo ) -import Distribution.System ( Platform ) - --- | A dependency resolver is a function that works out an installation plan --- given the set of installed and available packages and a set of deps to --- solve for. --- --- The reason for this interface is because there are dozens of approaches to --- solving the package dependency problem and we want to make it easy to swap --- in alternatives. --- -type DependencyResolver loc = Platform - -> CompilerInfo - -> InstalledPackageIndex - -> PackageIndex (SourcePackage loc) - -> PkgConfigDb - -> (PackageName -> PackagePreferences) - -> [LabeledPackageConstraint] - -> Set PackageName - -> Progress String String [ResolverPackage loc] diff --git a/Distribution/Solver/Types/Flag.hs b/Distribution/Solver/Types/Flag.hs deleted file mode 100644 --- a/Distribution/Solver/Types/Flag.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Distribution.Solver.Types.Flag - ( FlagType(..) - ) where - -import Prelude (Eq, Show) - -data FlagType = Manual | Automatic - deriving (Eq, Show) diff --git a/Distribution/Solver/Types/InstSolverPackage.hs b/Distribution/Solver/Types/InstSolverPackage.hs deleted file mode 100644 --- a/Distribution/Solver/Types/InstSolverPackage.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.InstSolverPackage - ( InstSolverPackage(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) -import Distribution.Solver.Types.SolverId -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.MungedPackageName -import Distribution.InstalledPackageInfo (InstalledPackageInfo) - --- | An 'InstSolverPackage' is a pre-existing installed package --- specified by the dependency solver. -data InstSolverPackage = InstSolverPackage { - instSolverPkgIPI :: InstalledPackageInfo, - instSolverPkgLibDeps :: ComponentDeps [SolverId], - instSolverPkgExeDeps :: ComponentDeps [SolverId] - } - deriving (Eq, Show, Generic) - -instance Binary InstSolverPackage -instance Structured InstSolverPackage - -instance Package InstSolverPackage where - packageId i = - -- HACK! See Note [Index conversion with internal libraries] - let MungedPackageId mpn v = mungedId i - in PackageIdentifier (encodeCompatPackageName mpn) v - -instance HasMungedPackageId InstSolverPackage where - mungedId = mungedId . instSolverPkgIPI - -instance HasUnitId InstSolverPackage where - installedUnitId = installedUnitId . instSolverPkgIPI diff --git a/Distribution/Solver/Types/InstalledPreference.hs b/Distribution/Solver/Types/InstalledPreference.hs deleted file mode 100644 --- a/Distribution/Solver/Types/InstalledPreference.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Distribution.Solver.Types.InstalledPreference - ( InstalledPreference(..), - ) where - -import Prelude (Show) - --- | Whether we prefer an installed version of a package or simply the latest --- version. --- -data InstalledPreference = PreferInstalled | PreferLatest - deriving Show diff --git a/Distribution/Solver/Types/LabeledPackageConstraint.hs b/Distribution/Solver/Types/LabeledPackageConstraint.hs deleted file mode 100644 --- a/Distribution/Solver/Types/LabeledPackageConstraint.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Distribution.Solver.Types.LabeledPackageConstraint - ( LabeledPackageConstraint(..) - , unlabelPackageConstraint - ) where - -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.PackageConstraint - --- | 'PackageConstraint' labeled with its source. -data LabeledPackageConstraint - = LabeledPackageConstraint PackageConstraint ConstraintSource - -unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint -unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc diff --git a/Distribution/Solver/Types/OptionalStanza.hs b/Distribution/Solver/Types/OptionalStanza.hs deleted file mode 100644 --- a/Distribution/Solver/Types/OptionalStanza.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Solver.Types.OptionalStanza - ( OptionalStanza(..) - , showStanza - , enableStanzas - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () -import Distribution.Types.ComponentRequestedSpec - (ComponentRequestedSpec(..), defaultComponentRequestedSpec) - -data OptionalStanza - = TestStanzas - | BenchStanzas - deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) - --- | String representation of an OptionalStanza. -showStanza :: OptionalStanza -> String -showStanza TestStanzas = "test" -showStanza BenchStanzas = "bench" - --- | Convert a list of 'OptionalStanza' into the corresponding --- 'ComponentRequestedSpec' which records what components are enabled. -enableStanzas :: [OptionalStanza] -> ComponentRequestedSpec -enableStanzas = foldl' addStanza defaultComponentRequestedSpec - where - addStanza enabled TestStanzas = enabled { testsRequested = True } - addStanza enabled BenchStanzas = enabled { benchmarksRequested = True } - -instance Binary OptionalStanza -instance Structured OptionalStanza diff --git a/Distribution/Solver/Types/PackageConstraint.hs b/Distribution/Solver/Types/PackageConstraint.hs deleted file mode 100644 --- a/Distribution/Solver/Types/PackageConstraint.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - --- | Per-package constraints. Package constraints must be respected by the --- solver. Multiple constraints for each package can be given, though obviously --- it is possible to construct conflicting constraints (eg impossible version --- range or inconsistent flag assignment). --- -module Distribution.Solver.Types.PackageConstraint ( - ConstraintScope(..), - scopeToplevel, - scopeToPackageName, - constraintScopeMatches, - PackageProperty(..), - dispPackageProperty, - PackageConstraint(..), - dispPackageConstraint, - showPackageConstraint, - packageConstraintToDependency - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package (PackageName) -import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) -import Distribution.Pretty (flatStyle, pretty) -import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) -import Distribution.Version (VersionRange, simplifyVersionRange) - -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackagePath - -import qualified Text.PrettyPrint as Disp - - --- | Determines to what packages and in what contexts a --- constraint applies. -data ConstraintScope - -- | A scope that applies when the given package is used as a build target. - -- In other words, the scope applies iff a goal has a top-level qualifier - -- and its namespace matches the given package name. A namespace is - -- considered to match a package name when it is either the default - -- namespace (for --no-independent-goals) or it is an independent namespace - -- with the given package name (for --independent-goals). - - -- TODO: Try to generalize the ConstraintScopes once component-based - -- solving is implemented, and remove this special case for targets. - = ScopeTarget PackageName - -- | The package with the specified name and qualifier. - | ScopeQualified Qualifier PackageName - -- | The package with the specified name when it has a - -- setup qualifier. - | ScopeAnySetupQualifier PackageName - -- | The package with the specified name regardless of - -- qualifier. - | ScopeAnyQualifier PackageName - deriving (Eq, Show) - --- | Constructor for a common use case: the constraint applies to --- the package with the specified name when that package is a --- top-level dependency in the default namespace. -scopeToplevel :: PackageName -> ConstraintScope -scopeToplevel = ScopeQualified QualToplevel - --- | Returns the package name associated with a constraint scope. -scopeToPackageName :: ConstraintScope -> PackageName -scopeToPackageName (ScopeTarget pn) = pn -scopeToPackageName (ScopeQualified _ pn) = pn -scopeToPackageName (ScopeAnySetupQualifier pn) = pn -scopeToPackageName (ScopeAnyQualifier pn) = pn - -constraintScopeMatches :: ConstraintScope -> QPN -> Bool -constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = - let namespaceMatches DefaultNamespace = True - namespaceMatches (Independent namespacePn) = pn == namespacePn - in namespaceMatches ns && q == QualToplevel && pn == pn' -constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = - q == q' && pn == pn' -constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = - let setup (PackagePath _ (QualSetup _)) = True - setup _ = False - in setup pp && pn == pn' -constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' - --- | Pretty-prints a constraint scope. -dispConstraintScope :: ConstraintScope -> Disp.Doc -dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn -dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn -dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn -dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn - --- | A package property is a logical predicate on packages. -data PackageProperty - = PackagePropertyVersion VersionRange - | PackagePropertyInstalled - | PackagePropertySource - | PackagePropertyFlags FlagAssignment - | PackagePropertyStanzas [OptionalStanza] - deriving (Eq, Show, Generic) - -instance Binary PackageProperty -instance Structured PackageProperty - --- | Pretty-prints a package property. -dispPackageProperty :: PackageProperty -> Disp.Doc -dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange -dispPackageProperty PackagePropertyInstalled = Disp.text "installed" -dispPackageProperty PackagePropertySource = Disp.text "source" -dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags -dispPackageProperty (PackagePropertyStanzas stanzas) = - Disp.hsep $ map (Disp.text . showStanza) stanzas - --- | A package constraint consists of a scope plus a property --- that must hold for all packages within that scope. -data PackageConstraint = PackageConstraint ConstraintScope PackageProperty - deriving (Eq, Show) - --- | Pretty-prints a package constraint. -dispPackageConstraint :: PackageConstraint -> Disp.Doc -dispPackageConstraint (PackageConstraint scope prop) = - dispConstraintScope scope <+> dispPackageProperty prop - --- | Alternative textual representation of a package constraint --- for debugging purposes (slightly more verbose than that --- produced by 'dispPackageConstraint'). --- -showPackageConstraint :: PackageConstraint -> String -showPackageConstraint pc@(PackageConstraint scope prop) = - Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 - where - pc2 = case prop of - PackagePropertyVersion vr -> - PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr) - _ -> pc - postprocess = case prop of - PackagePropertyFlags _ -> (Disp.text "flags" <+>) - PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) - _ -> id - --- | Lossily convert a 'PackageConstraint' to a 'Dependency'. -packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint -packageConstraintToDependency (PackageConstraint scope prop) = toDep prop - where - toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr - toDep (PackagePropertyInstalled) = Nothing - toDep (PackagePropertySource) = Nothing - toDep (PackagePropertyFlags _) = Nothing - toDep (PackagePropertyStanzas _) = Nothing diff --git a/Distribution/Solver/Types/PackageFixedDeps.hs b/Distribution/Solver/Types/PackageFixedDeps.hs deleted file mode 100644 --- a/Distribution/Solver/Types/PackageFixedDeps.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Distribution.Solver.Types.PackageFixedDeps - ( PackageFixedDeps(..) - ) where - -import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) -import Distribution.Package - ( Package(..), UnitId, installedDepends) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) -import qualified Distribution.Solver.Types.ComponentDeps as CD - --- | Subclass of packages that have specific versioned dependencies. --- --- So for example a not-yet-configured package has dependencies on version --- ranges, not specific versions. A configured or an already installed package --- depends on exact versions. Some operations or data structures (like --- dependency graphs) only make sense on this subclass of package types. --- -class Package pkg => PackageFixedDeps pkg where - depends :: pkg -> ComponentDeps [UnitId] - -instance PackageFixedDeps InstalledPackageInfo where - depends pkg = CD.fromInstalled (installedDepends pkg) - diff --git a/Distribution/Solver/Types/PackageIndex.hs b/Distribution/Solver/Types/PackageIndex.hs deleted file mode 100644 --- a/Distribution/Solver/Types/PackageIndex.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Solver.Types.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- An index of packages. --- -module Distribution.Solver.Types.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - override, - insert, - deletePackageName, - deletePackageId, - deleteDependency, - - -- * Queries - - -- ** Precise lookups - elemByPackageId, - elemByPackageName, - lookupPackageName, - lookupPackageId, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - searchWithPredicate, - - -- ** Bulk queries - allPackages, - allPackagesByName, - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude hiding (lookup) - -import Control.Exception (assert) -import qualified Data.Map as Map -import Data.List (isInfixOf) -import qualified Data.List.NonEmpty as NE - -import Distribution.Package - ( PackageName, unPackageName, PackageIdentifier(..) - , Package(..), packageName, packageVersion ) -import Distribution.Version - ( VersionRange, withinRange ) -import Distribution.Simple.Utils - ( lowercase ) - -import qualified Prelude (foldr1) - --- | The collection of information about packages from one or more 'PackageDB's. --- --- It can be searched efficiently by package name and version. --- -newtype PackageIndex pkg = PackageIndex - -- This index package names to all the package records matching that package - -- name case-sensitively. It includes all versions. - -- - -- This allows us to find all versions satisfying a dependency. - -- Most queries are a map lookup followed by a linear scan of the bucket. - -- - (Map PackageName [pkg]) - - deriving (Eq, Show, Read, Functor, Generic) ---FIXME: the Functor instance here relies on no package id changes - -instance Package pkg => Semigroup (PackageIndex pkg) where - (<>) = merge - -instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex Map.empty - mappend = (<>) - --save one mappend with empty in the common case: - mconcat [] = mempty - mconcat xs = Prelude.foldr1 mappend xs - -instance Binary pkg => Binary (PackageIndex pkg) - -invariant :: Package pkg => PackageIndex pkg -> Bool -invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) - where - goodBucket _ [] = False - goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 - where - check pkgid [] = packageName pkgid == name - check pkgid (pkg':pkgs) = packageName pkgid == name - && pkgid < pkgid' - && check pkgid' pkgs - where pkgid' = packageId pkg' - --- --- * Internal helpers --- - -mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg -mkPackageIndex index = assert (invariant (PackageIndex index)) - (PackageIndex index) - -internalError :: String -> a -internalError name = error ("PackageIndex." ++ name ++ ": internal error") - --- | Lookup a name in the index to get all packages that match that name --- case-sensitively. --- -lookup :: PackageIndex pkg -> PackageName -> [pkg] -lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m - --- --- * Construction --- - --- | Build an index out of a bunch of packages. --- --- If there are duplicates, later ones mask earlier ones. --- -fromList :: Package pkg => [pkg] -> PackageIndex pkg -fromList pkgs = mkPackageIndex - . Map.map fixBucket - . Map.fromListWith (++) - $ [ (packageName pkg, [pkg]) - | pkg <- pkgs ] - where - fixBucket = -- out of groups of duplicates, later ones mask earlier ones - -- but Map.fromListWith (++) constructs groups in reverse order - map NE.head - -- Eq instance for PackageIdentifier is wrong, so use Ord: - . NE.groupBy (\a b -> EQ == comparing packageId a b) - -- relies on sortBy being a stable sort so we - -- can pick consistently among duplicates - . sortBy (comparing packageId) - --- --- * Updates --- - --- | Merge two indexes. --- --- Packages from the second mask packages of the same exact name --- (case-sensitively) from the first. --- -merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg -merge i1@(PackageIndex m1) i2@(PackageIndex m2) = - assert (invariant i1 && invariant i2) $ - mkPackageIndex (Map.unionWith mergeBuckets m1 m2) - - --- | Elements in the second list mask those in the first. -mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] -mergeBuckets [] ys = ys -mergeBuckets xs [] = xs -mergeBuckets xs@(x:xs') ys@(y:ys') = - case packageId x `compare` packageId y of - GT -> y : mergeBuckets xs ys' - EQ -> y : mergeBuckets xs' ys' - LT -> x : mergeBuckets xs' ys - --- | Override-merge oftwo indexes. --- --- Packages from the second mask packages of the same exact name --- (case-sensitively) from the first. --- -override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg -override i1@(PackageIndex m1) i2@(PackageIndex m2) = - assert (invariant i1 && invariant i2) $ - mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2) - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg -insert pkg (PackageIndex index) = mkPackageIndex $ - Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index - where - pkgid = packageId pkg - insertNoDup [] = [pkg] - insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of - LT -> pkg : pkgs - EQ -> pkg : pkgs' - GT -> pkg' : insertNoDup pkgs' - --- | Internal delete helper. --- -delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg - -> PackageIndex pkg -delete name p (PackageIndex index) = mkPackageIndex $ - Map.update filterBucket name index - where - filterBucket = deleteEmptyBucket - . filter (not . p) - deleteEmptyBucket [] = Nothing - deleteEmptyBucket remaining = Just remaining - --- | Removes a single package from the index. --- -deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg - -> PackageIndex pkg -deletePackageId pkgid = - delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) - --- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: Package pkg => PackageName -> PackageIndex pkg - -> PackageIndex pkg -deletePackageName name = - delete name (\pkg -> packageName pkg == name) - --- | Removes all packages satisfying this dependency from the index. -deleteDependency :: Package pkg - => PackageName -> VersionRange -> PackageIndex pkg - -> PackageIndex pkg -deleteDependency name verstionRange = - delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) - --- --- * Bulk queries --- - --- | Get all the packages from the index. --- -allPackages :: PackageIndex pkg -> [pkg] -allPackages (PackageIndex m) = concat (Map.elems m) - --- | Get all the packages from the index. --- --- They are grouped by package name, case-sensitively. --- -allPackagesByName :: PackageIndex pkg -> [[pkg]] -allPackagesByName (PackageIndex m) = Map.elems m - --- --- * Lookups --- - -elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool -elemByPackageId index = isJust . lookupPackageId index - -elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool -elemByPackageName index = not . null . lookupPackageName index - - --- | Does a lookup by package id (name & version). --- --- Since multiple package DBs mask each other case-sensitively by package name, --- then we get back at most one package. --- -lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier - -> Maybe pkg -lookupPackageId index pkgid = - case [ pkg | pkg <- lookup index (packageName pkgid) - , packageId pkg == pkgid ] of - [] -> Nothing - [pkg] -> Just pkg - _ -> internalError "lookupPackageIdentifier" - --- | Does a case-sensitive search by package name. --- -lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] -lookupPackageName index name = - [ pkg | pkg <- lookup index name - , packageName pkg == name ] - --- | Does a case-sensitive search by package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- -lookupDependency :: Package pkg - => PackageIndex pkg - -> PackageName -> VersionRange - -> [pkg] -lookupDependency index name versionRange = - [ pkg | pkg <- lookup index name - , packageName pkg == name - , packageVersion pkg `withinRange` versionRange ] - --- --- * Case insensitive name lookups --- - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insensitively to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insensitively but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insensitively and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. --- -searchByName :: PackageIndex pkg - -> String -> [(PackageName, [pkg])] -searchByName (PackageIndex m) name = - [ pkgs - | pkgs@(pname,_) <- Map.toList m - , lowercase (unPackageName pname) == lname ] - where - lname = lowercase name - -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: PackageIndex pkg - -> String -> [(PackageName, [pkg])] -searchByNameSubstring index searchterm = - searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) - where lsearchterm = lowercase searchterm - -searchWithPredicate :: PackageIndex pkg - -> (String -> Bool) -> [(PackageName, [pkg])] -searchWithPredicate (PackageIndex m) predicate = - [ pkgs - | pkgs@(pname, _) <- Map.toList m - , predicate (unPackageName pname) - ] diff --git a/Distribution/Solver/Types/PackagePath.hs b/Distribution/Solver/Types/PackagePath.hs deleted file mode 100644 --- a/Distribution/Solver/Types/PackagePath.hs +++ /dev/null @@ -1,102 +0,0 @@ -module Distribution.Solver.Types.PackagePath - ( PackagePath(..) - , Namespace(..) - , Qualifier(..) - , dispQualifier - , Qualified(..) - , QPN - , dispQPN - , showQPN - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () -import Distribution.Package (PackageName) -import Distribution.Pretty (pretty, flatStyle) -import qualified Text.PrettyPrint as Disp - --- | A package path consists of a namespace and a package path inside that --- namespace. -data PackagePath = PackagePath Namespace Qualifier - deriving (Eq, Ord, Show) - --- | Top-level namespace --- --- Package choices in different namespaces are considered completely independent --- by the solver. -data Namespace = - -- | The default namespace - DefaultNamespace - - -- | A namespace for a specific build target - | Independent PackageName - deriving (Eq, Ord, Show) - --- | Pretty-prints a namespace. The result is either empty or --- ends in a period, so it can be prepended onto a qualifier. -dispNamespace :: Namespace -> Disp.Doc -dispNamespace DefaultNamespace = Disp.empty -dispNamespace (Independent i) = pretty i <<>> Disp.text "." - --- | Qualifier of a package within a namespace (see 'PackagePath') -data Qualifier = - -- | Top-level dependency in this namespace - QualToplevel - - -- | Any dependency on base is considered independent - -- - -- This makes it possible to have base shims. - | QualBase PackageName - - -- | Setup dependency - -- - -- By rights setup dependencies ought to be nestable; after all, the setup - -- dependencies of a package might themselves have setup dependencies, which - -- are independent from everything else. However, this very quickly leads to - -- infinite search trees in the solver. Therefore we limit ourselves to - -- a single qualifier (within a given namespace). - | QualSetup PackageName - - -- | If we depend on an executable from a package (via - -- @build-tools@), we should solve for the dependencies of that - -- package separately (since we're not going to actually try to - -- link it.) We qualify for EACH package separately; e.g., - -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on - -- @pn2@ from package @pn1@. (If we tracked only @pn1@, that - -- would require a consistent dependency resolution for all - -- of the depended upon executables from a package; if we - -- tracked only @pn2@, that would require us to pick only one - -- version of an executable over the entire install plan.) - | QualExe PackageName PackageName - deriving (Eq, Ord, Show) - --- | Pretty-prints a qualifier. The result is either empty or --- ends in a period, so it can be prepended onto a package name. --- --- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is --- there to make sure different dependencies on base are all independent. --- So we want to print something like @"A.base"@, where the @"A."@ part --- is the qualifier and @"base"@ is the actual dependency (which, for the --- 'Base' qualifier, will always be @base@). -dispQualifier :: Qualifier -> Disp.Doc -dispQualifier QualToplevel = Disp.empty -dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." -dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> - pretty pn2 <<>> Disp.text ":exe." -dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." - --- | A qualified entity. Pairs a package path with the entity. -data Qualified a = Q PackagePath a - deriving (Eq, Ord, Show) - --- | Qualified package name. -type QPN = Qualified PackageName - --- | Pretty-prints a qualified package name. -dispQPN :: QPN -> Disp.Doc -dispQPN (Q (PackagePath ns qual) pn) = - dispNamespace ns <<>> dispQualifier qual <<>> pretty pn - --- | String representation of a qualified package name. -showQPN :: QPN -> String -showQPN = Disp.renderStyle flatStyle . dispQPN diff --git a/Distribution/Solver/Types/PackagePreferences.hs b/Distribution/Solver/Types/PackagePreferences.hs deleted file mode 100644 --- a/Distribution/Solver/Types/PackagePreferences.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Distribution.Solver.Types.PackagePreferences - ( PackagePreferences(..) - ) where - -import Distribution.Solver.Types.InstalledPreference -import Distribution.Solver.Types.OptionalStanza -import Distribution.Version (VersionRange) - --- | Per-package preferences on the version. It is a soft constraint that the --- 'DependencyResolver' should try to respect where possible. It consists of --- an 'InstalledPreference' which says if we prefer versions of packages --- that are already installed. It also has (possibly multiple) --- 'PackageVersionPreference's which are suggested constraints on the version --- number. The resolver should try to use package versions that satisfy --- the maximum number of the suggested version constraints. --- --- It is not specified if preferences on some packages are more important than --- others. --- -data PackagePreferences = PackagePreferences [VersionRange] - InstalledPreference - [OptionalStanza] diff --git a/Distribution/Solver/Types/PkgConfigDb.hs b/Distribution/Solver/Types/PkgConfigDb.hs deleted file mode 100644 --- a/Distribution/Solver/Types/PkgConfigDb.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Solver.Types.PkgConfigDb --- Copyright : (c) Iñaki García Etxebarria 2016 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Read the list of packages available to pkg-config. ------------------------------------------------------------------------------ -module Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb - , readPkgConfigDb - , pkgConfigDbFromList - , pkgConfigPkgIsPresent - , pkgConfigDbPkgVersion - , getPkgConfigDbDirs - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Control.Exception (handle) -import qualified Data.Map as M -import System.FilePath (splitSearchPath) - -import Distribution.Compat.Environment (lookupEnv) -import Distribution.Package (PkgconfigName, mkPkgconfigName) -import Distribution.Parsec -import Distribution.Simple.Program - (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram) -import Distribution.Simple.Utils (info) -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PkgconfigVersionRange -import Distribution.Verbosity (Verbosity) - --- | The list of packages installed in the system visible to --- @pkg-config@. This is an opaque datatype, to be constructed with --- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. -data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) - -- ^ If an entry is `Nothing`, this means that the - -- package seems to be present, but we don't know the - -- exact version (because parsing of the version - -- number failed). - | NoPkgConfigDb - -- ^ For when we could not run pkg-config successfully. - deriving (Show, Generic, Typeable) - -instance Binary PkgConfigDb -instance Structured PkgConfigDb - --- | Query pkg-config for the list of installed packages, together --- with their versions. Return a `PkgConfigDb` encapsulating this --- information. -readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb -readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do - mpkgConfig <- needProgram verbosity pkgConfigProgram progdb - case mpkgConfig of - Nothing -> noPkgConfig "Cannot find pkg-config program" - Just (pkgConfig, _) -> do - pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] - -- The output of @pkg-config --list-all@ also includes a description - -- for each package, which we do not need. - let pkgNames = map (takeWhile (not . isSpace)) pkgList - pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig - ("--modversion" : pkgNames) - (return . pkgConfigDbFromList . zip pkgNames) pkgVersions - where - -- For when pkg-config invocation fails (possibly because of a - -- too long command line). - noPkgConfig extra = do - info verbosity ("Failed to query pkg-config, Cabal will continue" - ++ " without solving for pkg-config constraints: " - ++ extra) - return NoPkgConfigDb - - ioErrorHandler :: IOException -> IO PkgConfigDb - ioErrorHandler e = noPkgConfig (show e) - --- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. -pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb -pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs - where - convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion) - convert (n,vs) = (mkPkgconfigName n, simpleParsec vs) - --- | Check whether a given package range is satisfiable in the given --- @pkg-config@ database. -pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool -pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = - case M.lookup pn db of - Nothing -> False -- Package not present in the DB. - Just Nothing -> True -- Package present, but version unknown. - Just (Just v) -> withinPkgconfigVersionRange v vr --- If we could not read the pkg-config database successfully we allow --- the check to succeed. The plan found by the solver may fail to be --- executed later on, but we have no grounds for rejecting the plan at --- this stage. -pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True - - --- | Query the version of a package in the @pkg-config@ database. --- @Nothing@ indicates the package is not in the database, while --- @Just Nothing@ indicates that the package is in the database, --- but its version is not known. -pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion) -pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db --- NB: Since the solver allows solving to succeed if there is --- NoPkgConfigDb, we should report that we *guess* that there --- is a matching pkg-config configuration, but that we just --- don't know about it. -pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing - - --- | Query pkg-config for the locations of pkg-config's package files. Use this --- to monitor for changes in the pkg-config DB. --- -getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath] -getPkgConfigDbDirs verbosity progdb = - (++) <$> getEnvPath <*> getDefPath - where - -- According to @man pkg-config@: - -- - -- PKG_CONFIG_PATH - -- A colon-separated (on Windows, semicolon-separated) list of directories - -- to search for .pc files. The default directory will always be searched - -- after searching the path - -- - getEnvPath = maybe [] parseSearchPath - <$> lookupEnv "PKG_CONFIG_PATH" - - -- Again according to @man pkg-config@: - -- - -- pkg-config can be used to query itself for the default search path, - -- version number and other information, for instance using: - -- - -- > pkg-config --variable pc_path pkg-config - -- - getDefPath = handle ioErrorHandler $ do - mpkgConfig <- needProgram verbosity pkgConfigProgram progdb - case mpkgConfig of - Nothing -> return [] - Just (pkgConfig, _) -> parseSearchPath <$> - getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] - - parseSearchPath str = - case lines str of - [p] | not (null p) -> splitSearchPath p - _ -> [] - - ioErrorHandler :: IOException -> IO [FilePath] - ioErrorHandler _e = return [] diff --git a/Distribution/Solver/Types/Progress.hs b/Distribution/Solver/Types/Progress.hs deleted file mode 100644 --- a/Distribution/Solver/Types/Progress.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Distribution.Solver.Types.Progress - ( Progress(..) - , foldProgress - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude hiding (fail) - --- | A type to represent the unfolding of an expensive long running --- calculation that may fail. We may get intermediate steps before the final --- result which may be used to indicate progress and\/or logging messages. --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done - --- This Functor instance works around a bug in GHC 7.6.3. --- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637. --- The derived functor instance caused a space leak in the solver. -instance Functor (Progress step fail) where - fmap f (Step s p) = Step s (fmap f p) - fmap _ (Fail x) = Fail x - fmap f (Done r) = Done (f r) - --- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two --- base cases, one for a final result and one for failure. --- --- Eg to convert into a simple 'Either' result use: --- --- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a -foldProgress step fail done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = fail f - fold (Done r) = done r - -instance Monad (Progress step fail) where - return = pure - p >>= f = foldProgress Step Fail f p - -instance Applicative (Progress step fail) where - pure a = Done a - p <*> x = foldProgress Step Fail (flip fmap x) p - -instance Monoid fail => Alternative (Progress step fail) where - empty = Fail mempty - p <|> q = foldProgress Step (const q) Done p diff --git a/Distribution/Solver/Types/ResolverPackage.hs b/Distribution/Solver/Types/ResolverPackage.hs deleted file mode 100644 --- a/Distribution/Solver/Types/ResolverPackage.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.ResolverPackage - ( ResolverPackage(..) - , resolverPackageLibDeps - , resolverPackageExeDeps - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import qualified Distribution.Solver.Types.ComponentDeps as CD - -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Package (Package(..), HasUnitId(..)) -import Distribution.Simple.Utils (ordNub) - --- | The dependency resolver picks either pre-existing installed packages --- or it picks source packages along with package configuration. --- --- This is like the 'InstallPlan.PlanPackage' but with fewer cases. --- -data ResolverPackage loc = PreExisting InstSolverPackage - | Configured (SolverPackage loc) - deriving (Eq, Show, Generic) - -instance Binary loc => Binary (ResolverPackage loc) -instance Structured loc => Structured (ResolverPackage loc) - -instance Package (ResolverPackage loc) where - packageId (PreExisting ipkg) = packageId ipkg - packageId (Configured spkg) = packageId spkg - -resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] -resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg -resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg - -resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] -resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg -resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg - -instance IsNode (ResolverPackage loc) where - type Key (ResolverPackage loc) = SolverId - nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) - nodeKey (Configured spkg) = PlannedId (packageId spkg) - -- Use dependencies for ALL components - nodeNeighbors pkg = - ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ - CD.flatDeps (resolverPackageExeDeps pkg) diff --git a/Distribution/Solver/Types/Settings.hs b/Distribution/Solver/Types/Settings.hs deleted file mode 100644 --- a/Distribution/Solver/Types/Settings.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Solver.Types.Settings - ( ReorderGoals(..) - , IndependentGoals(..) - , MinimizeConflictSet(..) - , AvoidReinstalls(..) - , ShadowPkgs(..) - , StrongFlags(..) - , AllowBootLibInstalls(..) - , OnlyConstrained(..) - , EnableBackjumping(..) - , CountConflicts(..) - , FineGrainedConflicts(..) - , SolveExecutables(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Simple.Setup ( BooleanFlag(..) ) -import Distribution.Pretty ( Pretty(pretty) ) -import Distribution.Parsec ( Parsec(parsec) ) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - -newtype ReorderGoals = ReorderGoals Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype CountConflicts = CountConflicts Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype FineGrainedConflicts = FineGrainedConflicts Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype MinimizeConflictSet = MinimizeConflictSet Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype IndependentGoals = IndependentGoals Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype AvoidReinstalls = AvoidReinstalls Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype ShadowPkgs = ShadowPkgs Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype StrongFlags = StrongFlags Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype AllowBootLibInstalls = AllowBootLibInstalls Bool - deriving (BooleanFlag, Eq, Generic, Show) - --- | Should we consider all packages we know about, or only those that --- have constraints explicitly placed on them or which are goals? -data OnlyConstrained - = OnlyConstrainedNone - | OnlyConstrainedAll - deriving (Eq, Generic, Show) - -newtype EnableBackjumping = EnableBackjumping Bool - deriving (BooleanFlag, Eq, Generic, Show) - -newtype SolveExecutables = SolveExecutables Bool - deriving (BooleanFlag, Eq, Generic, Show) - -instance Binary ReorderGoals -instance Binary CountConflicts -instance Binary FineGrainedConflicts -instance Binary IndependentGoals -instance Binary MinimizeConflictSet -instance Binary AvoidReinstalls -instance Binary ShadowPkgs -instance Binary StrongFlags -instance Binary AllowBootLibInstalls -instance Binary OnlyConstrained -instance Binary SolveExecutables - -instance Structured ReorderGoals -instance Structured CountConflicts -instance Structured FineGrainedConflicts -instance Structured IndependentGoals -instance Structured MinimizeConflictSet -instance Structured AvoidReinstalls -instance Structured ShadowPkgs -instance Structured StrongFlags -instance Structured AllowBootLibInstalls -instance Structured OnlyConstrained -instance Structured SolveExecutables - -instance Pretty OnlyConstrained where - pretty OnlyConstrainedAll = PP.text "all" - pretty OnlyConstrainedNone = PP.text "none" - -instance Parsec OnlyConstrained where - parsec = P.choice - [ P.string "all" >> return OnlyConstrainedAll - , P.string "none" >> return OnlyConstrainedNone - ] - diff --git a/Distribution/Solver/Types/SolverId.hs b/Distribution/Solver/Types/SolverId.hs deleted file mode 100644 --- a/Distribution/Solver/Types/SolverId.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.SolverId - ( SolverId(..) - ) - -where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package (PackageId, Package(..), UnitId) - --- | The solver can produce references to existing packages or --- packages we plan to install. Unlike 'ConfiguredId' we don't --- yet know the 'UnitId' for planned packages, because it's --- not the solver's job to compute them. --- -data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } - | PlannedId { solverSrcId :: PackageId } - deriving (Eq, Ord, Generic) - -instance Binary SolverId -instance Structured SolverId - -instance Show SolverId where - show = show . solverSrcId - -instance Package SolverId where - packageId = solverSrcId diff --git a/Distribution/Solver/Types/SolverPackage.hs b/Distribution/Solver/Types/SolverPackage.hs deleted file mode 100644 --- a/Distribution/Solver/Types/SolverPackage.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Solver.Types.SolverPackage - ( SolverPackage(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package ( Package(..) ) -import Distribution.PackageDescription ( FlagAssignment ) -import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SourcePackage - --- | A 'SolverPackage' is a package specified by the dependency solver. --- It will get elaborated into a 'ConfiguredPackage' or even an --- 'ElaboratedConfiguredPackage'. --- --- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc', --- but for symmetry we have the parameter. (Maybe it can be removed.) --- -data SolverPackage loc = SolverPackage { - solverPkgSource :: SourcePackage loc, - solverPkgFlags :: FlagAssignment, - solverPkgStanzas :: [OptionalStanza], - solverPkgLibDeps :: ComponentDeps [SolverId], - solverPkgExeDeps :: ComponentDeps [SolverId] - } - deriving (Eq, Show, Generic) - -instance Binary loc => Binary (SolverPackage loc) -instance Structured loc => Structured (SolverPackage loc) - -instance Package (SolverPackage loc) where - packageId = packageId . solverPkgSource diff --git a/Distribution/Solver/Types/SourcePackage.hs b/Distribution/Solver/Types/SourcePackage.hs deleted file mode 100644 --- a/Distribution/Solver/Types/SourcePackage.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Solver.Types.SourcePackage - ( PackageDescriptionOverride - , SourcePackage(..) - ) where - -import Distribution.Solver.Compat.Prelude -import Prelude () - -import Distribution.Package - ( PackageId, Package(..) ) -import Distribution.PackageDescription - ( GenericPackageDescription(..) ) - -import Data.ByteString.Lazy (ByteString) - --- | A package description along with the location of the package sources. --- -data SourcePackage loc = SourcePackage - { srcpkgPackageId :: PackageId - , srcpkgDescription :: GenericPackageDescription - -- ^ Note, this field is lazy, e.g. when reading in hackage index - -- we parse only what we need, not whole index. - , srcpkgSource :: loc - , srcpkgDescrOverride :: PackageDescriptionOverride - } - deriving (Eq, Show, Generic, Typeable) - -instance Binary loc => Binary (SourcePackage loc) -instance Structured loc => Structured (SourcePackage loc) - -instance Package (SourcePackage a) where packageId = srcpkgPackageId - --- | We sometimes need to override the .cabal file in the tarball with --- the newer one from the package index. -type PackageDescriptionOverride = Maybe ByteString diff --git a/Distribution/Solver/Types/Variable.hs b/Distribution/Solver/Types/Variable.hs deleted file mode 100644 --- a/Distribution/Solver/Types/Variable.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Distribution.Solver.Types.Variable where - -import Prelude (Eq, Show) - -import Distribution.Solver.Types.OptionalStanza - -import Distribution.PackageDescription (FlagName) - --- | Variables used by the dependency solver. This type is similar to the --- internal 'Var' type. -data Variable qpn = - PackageVar qpn - | FlagVar qpn FlagName - | StanzaVar qpn OptionalStanza - deriving (Eq, Show) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,145 +11,3 @@ [Cabal web site]: http://www.haskell.org/cabal/ [Cabal]: ../Cabal/README.md - -Installing the `cabal` command-line tool -======================================== - -The `cabal-install` package requires a number of other packages, most of -which come with a standard GHC installation. It requires the [network] -package, which is sometimes packaged separately by Linux distributions; -for example, on Debian or Ubuntu, it is located in the -"libghc6-network-dev" package. - -`cabal` requires a few other Haskell packages that are not always -installed. The exact list is specified in the [.cabal] file or in the -[bootstrap.sh] file. All these packages are available from [Hackage]. - -Note that on some Unix systems you may need to install an additional -zlib development package using your system package manager; for example, -on Debian or Ubuntu, it is located in the "zlib1g-dev" package; on -Fedora, it is located in the "zlib-devel" package. It is required -because the Haskell zlib package uses the system zlib C library and -header files. - -The `cabal-install` package is now part of the [Haskell Platform], so you -do not usually need to install it separately. However, if you are -starting from a minimal GHC installation, you need to install -`cabal-install` manually. Since it is an ordinary Cabal package, -`cabal-install` can be built the standard way; to facilitate this, the -process has been partially automated. It is described below. - -[.cabal]: cabal-install.cabal -[network]: http://hackage.haskell.org/package/network -[Haskell Platform]: http://www.haskell.org/platform/ - -Quick start on Unix-like systems --------------------------------- - -As a convenience for users on Unix-like systems, there is a -[bootstrap.sh] script that will download and install each of -`cabal-install`'s dependencies in turn. - - $ ./bootstrap.sh - -It will download and install the dependencies. The script will install the -library packages (vanilla, profiling and shared) into `$HOME/.cabal/` and the -`cabal` program into `$HOME/.cabal/bin/`. If you don't want to install profiling -and shared versions of the libraries, use - - $ EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh - -You then have the choice either to place `$HOME/.cabal/bin` on your -`$PATH` or move the `cabal` program to somewhere on your `$PATH`. Next, -you can get the latest list of packages by running: - - $ cabal update - -This will also create a default configuration file, if it does not -already exist, at `$HOME/.cabal/config`. - -By default, `cabal` will install programs to `$HOME/.cabal/bin`. If you -do not want to add this directory to your `$PATH`, you can change -the setting in the config file; for example, you could use the -following: - - installdir: $HOME/bin - - -Quick start on Windows systems ------------------------------- - -For Windows users, a precompiled program ([cabal.exe]) is provided. -Download and put it somewhere on your `%PATH%` (for example, -`C:\Program Files\Haskell\bin`.) - -Next, you can get the latest list of packages by running: - - $ cabal update - -This will also create a default configuration file (if it does not -already exist) at -`C:\Documents and Settings\%USERNAME%\Application Data\cabal\config`. - -[cabal.exe]: http://www.haskell.org/cabal/release/cabal-install-latest/ - -Using `cabal` -============= - -There are two sets of commands: commands for working with a local -project build tree and those for working with packages distributed -from [Hackage]. - -For the list of the full set of commands and flags for each command, -run: - - $ cabal help - - -Commands for developers for local build trees ---------------------------------------------- - -The commands for local project build trees are almost the same as the -`runghc Setup` command-line interface you may already be familiar with. -In particular, it has the following commands: - - * `cabal configure` - * `cabal build` - * `cabal haddock` - * `cabal clean` - * `cabal sdist` - -The `install` command is somewhat different; it is an all-in-one -operation. If you run `cabal install` in your build tree, it will -configure, build, and install. It takes all the flags that `configure` -takes such as `--global` and `--prefix`. - -In addition, `cabal` will download and install any dependencies that are -not already installed. It can also rebuild packages to ensure a -consistent set of dependencies. - - -Commands for released Hackage packages --------------------------------------- - - $ cabal update - -This command gets the latest list of packages from the [Hackage] server. -On occasion, this command must be run manually--for instance, if you -want to install a newly released package. - - $ cabal install xmonad - -This command installs one or more named packages, and all their -dependencies, from Hackage. By default, it installs the latest available -version; however, you may specify exact versions or version ranges. For -example, `cabal install alex-2.2` or `cabal install parsec < 3`. - - $ cabal list xml - -This does a search of the installed and available packages. It does a -case-insensitive substring match on the package name. - - -[Hackage]: http://hackage.haskell.org -[bootstrap.sh]: bootstrap.sh diff --git a/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs b/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +module Distribution.Client.Utils.Assertion (expensiveAssert) where + + +#ifdef DEBUG_EXPENSIVE_ASSERTIONS +import Prelude (Bool) +import Control.Exception (assert) +import Distribution.Compat.Stack +#else +import Prelude (Bool, id) +#endif + +-- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This +-- function can be used for expensive assertions that should only be turned on +-- during testing or debugging. +#ifdef DEBUG_EXPENSIVE_ASSERTIONS +expensiveAssert :: WithCallStack (Bool -> a -> a) +expensiveAssert = assert +#else +expensiveAssert :: Bool -> a -> a +expensiveAssert _ = id +#endif diff --git a/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs b/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs @@ -0,0 +1,19 @@ +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | This module does two things: +-- +-- * Acts as a compatibility layer, like @base-compat@. +-- +-- * Provides commonly used imports. +-- +-- This module is a superset of "Distribution.Compat.Prelude" (which +-- this module re-exports) +-- +module Distribution.Solver.Compat.Prelude + ( module Distribution.Compat.Prelude.Internal + , Prelude.IO + ) where + +import Prelude (IO) +import Distribution.Compat.Prelude.Internal hiding (IO) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Solver.Modular + ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where + +-- Here, we try to map between the external cabal-install solver +-- interface and the internal interface that the solver actually +-- expects. There are a number of type conversions to perform: we +-- have to convert the package indices to the uniform index used +-- by the solver; we also have to convert the initial constraints; +-- and finally, we have to convert back the resulting install +-- plan. + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import qualified Data.Map as M +import Data.Set (isSubsetOf) +import Distribution.Compat.Graph + ( IsNode(..) ) +import Distribution.Compiler + ( CompilerInfo ) +import Distribution.Solver.Modular.Assignment + ( Assignment, toCPs ) +import Distribution.Solver.Modular.ConfiguredConversion + ( convCP ) +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.IndexConversion + ( convPIs ) +import Distribution.Solver.Modular.Log + ( SolverFailure(..), displayLogMessages ) +import Distribution.Solver.Modular.Package + ( PN ) +import Distribution.Solver.Modular.RetryLog +import Distribution.Solver.Modular.Solver + ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) +import Distribution.Solver.Types.DependencyResolver +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb ) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.Variable +import Distribution.System + ( Platform(..) ) +import Distribution.Simple.Setup + ( BooleanFlag(..) ) +import Distribution.Simple.Utils + ( ordNubBy ) +import Distribution.Verbosity + + +-- | Ties the two worlds together: classic cabal-install vs. the modular +-- solver. Performs the necessary translations before and after. +modularResolver :: SolverConfig -> DependencyResolver loc +modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = + fmap (uncurry postprocess) $ -- convert install plan + solve' sc cinfo idx pkgConfigDB pprefs gcs pns + where + -- Indices have to be converted into solver-specific uniform index. + idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx + -- Constraints have to be converted into a finite map indexed by PN. + gcs = M.fromListWith (++) (map pair pcs) + where + pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) + + -- Results have to be converted into an install plan. 'convCP' removes + -- package qualifiers, which means that linked packages become duplicates + -- and can be removed. + postprocess a rdm = ordNubBy nodeKey $ + map (convCP iidx sidx) (toCPs a rdm) + + -- Helper function to extract the PN from a constraint. + pcName :: PackageConstraint -> PN + pcName (PackageConstraint scope _) = scopeToPackageName scope + +-- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display +-- in the error case. +-- +-- When there is no solution, we produce the error message by rerunning the +-- solver but making it prefer the goals from the final conflict set from the +-- first run (or a subset of the final conflict set with +-- --minimize-conflict-set). We also set the backjump limit to 0, so that the +-- log stops at the first backjump and is relatively short. Preferring goals +-- from the final conflict set increases the probability that the log to the +-- first backjump contains package, flag, and stanza choices that are relevant +-- to the final failure. The solver shouldn't need to choose any packages that +-- aren't in the final conflict set. (For every variable in the final conflict +-- set, the final conflict set should also contain the variable that introduced +-- that variable. The solver can then follow that chain of variables in reverse +-- order from the user target to the conflict.) However, it is possible that the +-- conflict set contains unnecessary variables. +-- +-- Producing an error message when the solver reaches the backjump limit is more +-- complicated. There is no final conflict set, so we create one for the minimal +-- subtree containing the path that the solver took to the first backjump. This +-- conflict set helps explain why the solver reached the backjump limit, because +-- the first backjump contributes to reaching the backjump limit. Additionally, +-- the solver is much more likely to be able to finish traversing this subtree +-- before the backjump limit, since its size is linear (not exponential) in the +-- number of goal choices. We create it by pruning all children after the first +-- successful child under each node in the original tree, so that there is at +-- most one valid choice at each level. Then we use the final conflict set from +-- that run to generate an error message, as in the case where the solver found +-- that there was no solution. +-- +-- Using the full log from a rerun of the solver ensures that the log is +-- complete, i.e., it shows the whole chain of dependencies from the user +-- targets to the conflicting packages. +solve' :: SolverConfig + -> CompilerInfo + -> Index + -> PkgConfigDb + -> (PN -> PackagePreferences) + -> Map PN [LabeledPackageConstraint] + -> Set PN + -> Progress String String (Assignment, RevDepMap) +solve' sc cinfo idx pkgConfigDB pprefs gcs pns = + toProgress $ retry (runSolver printFullLog sc) createErrorMsg + where + runSolver :: Bool -> SolverConfig + -> RetryLog String SolverFailure (Assignment, RevDepMap) + runSolver keepLog sc' = + displayLogMessages keepLog $ + solve sc' cinfo idx pkgConfigDB pprefs gcs pns + + createErrorMsg :: SolverFailure + -> RetryLog String String (Assignment, RevDepMap) + createErrorMsg failure@(ExhaustiveSearch cs cm) = + if asBool $ minimizeConflictSet sc + then continueWith ("Found no solution after exhaustively searching the " + ++ "dependency tree. Rerunning the dependency solver " + ++ "to minimize the conflict set ({" + ++ showConflictSet cs ++ "}).") $ + retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $ + \case + ExhaustiveSearch cs' cm' -> + fromProgress $ Fail $ + rerunSolverForErrorMsg cs' + ++ finalErrorMsg sc (ExhaustiveSearch cs' cm') + BackjumpLimitReached -> + fromProgress $ Fail $ + "Reached backjump limit while trying to minimize the " + ++ "conflict set to create a better error message. " + ++ "Original error message:\n" + ++ rerunSolverForErrorMsg cs + ++ finalErrorMsg sc failure + else fromProgress $ Fail $ + rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure + createErrorMsg failure@BackjumpLimitReached = + continueWith + ("Backjump limit reached. Rerunning dependency solver to generate " + ++ "a final conflict set for the search tree containing the " + ++ "first backjump.") $ + retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $ + \case + ExhaustiveSearch cs _ -> + fromProgress $ Fail $ + rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure + BackjumpLimitReached -> + -- This case is possible when the number of goals involved in + -- conflicts is greater than the backjump limit. + fromProgress $ Fail $ finalErrorMsg sc failure + ++ "Failed to generate a summarized dependency solver " + ++ "log due to low backjump limit." + + rerunSolverForErrorMsg :: ConflictSet -> String + rerunSolverForErrorMsg cs = + let sc' = sc { + goalOrder = Just goalOrder' + , maxBackjumps = Just 0 + } + + -- Preferring goals from the conflict set takes precedence over the + -- original goal order. + goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) + + in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc'))) + + printFullLog = solverVerbosity sc >= verbose + + messages :: Progress step fail done -> [step] + messages = foldProgress (:) (const []) (const []) + +-- | Try to remove variables from the given conflict set to create a minimal +-- conflict set. +-- +-- Minimal means that no proper subset of the conflict set is also a conflict +-- set, though there may be other possible conflict sets with fewer variables. +-- This function minimizes the input by trying to remove one variable at a time. +-- It only makes one pass over the variables, so it runs the solver at most N +-- times when given a conflict set of size N. Only one pass is necessary, +-- because every superset of a conflict set is also a conflict set, meaning that +-- failing to remove variable X from a conflict set in one step means that X +-- cannot be removed from any subset of that conflict set in a subsequent step. +-- +-- Example steps: +-- +-- Start with {A, B, C}. +-- Try to remove A from {A, B, C} and fail. +-- Try to remove B from {A, B, C} and succeed. +-- Try to remove C from {A, C} and fail. +-- Return {A, C} +-- +-- This function can fail for two reasons: +-- +-- 1. The solver can reach the backjump limit on any run. In this case the +-- returned RetryLog ends with BackjumpLimitReached. +-- TODO: Consider applying the backjump limit to all solver runs combined, +-- instead of each individual run. For example, 10 runs with 10 backjumps +-- each should count as 100 backjumps. +-- 2. Since this function works by rerunning the solver, it is possible for the +-- solver to add new unnecessary variables to the conflict set. This function +-- discards the result from any run that adds new variables to the conflict +-- set, but the end result may not be completely minimized. +tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a) + -> SolverConfig + -> ConflictSet + -> ConflictMap + -> RetryLog String SolverFailure a +tryToMinimizeConflictSet runSolver sc cs cm = + foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v) + (fromProgress $ Fail $ ExhaustiveSearch cs cm) + (CS.toList cs) + where + -- This function runs the solver and makes it prefer goals in the following + -- order: + -- + -- 1. variables in 'smallestKnownCS', excluding 'v' + -- 2. 'v' + -- 3. all other variables + -- + -- If 'v' is not necessary, then the solver will find that there is no + -- solution before starting to solve for 'v', and the new final conflict set + -- will be very likely to not contain 'v'. If 'v' is necessary, the solver + -- will most likely need to try solving for 'v' before finding that there is + -- no solution, and the new final conflict set will still contain 'v'. + -- However, this method isn't perfect, because it is possible for the solver + -- to add new unnecessary variables to the conflict set on any run. This + -- function prevents the conflict set from growing by checking that the new + -- conflict set is a subset of the old one and falling back to using the old + -- conflict set when that check fails. + tryToRemoveOneVar :: Var QPN + -> ConflictSet + -> ConflictMap + -> RetryLog String SolverFailure a + tryToRemoveOneVar v smallestKnownCS smallestKnownCM + -- Check whether v is still present, because it may have already been + -- removed in a previous solver rerun. + | not (v `CS.member` smallestKnownCS) = + fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM + | otherwise = + continueWith ("Trying to remove variable " ++ varStr ++ " from the " + ++ "conflict set.") $ + retry (runSolver sc') $ \case + err@(ExhaustiveSearch cs' _) + | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS -> + let msg = if not $ CS.member v cs' + then "Successfully removed " ++ varStr ++ " from " + ++ "the conflict set." + else "Failed to remove " ++ varStr ++ " from the " + ++ "conflict set." + in -- Use the new conflict set, even if v wasn't removed, + -- because other variables may have been removed. + failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err + | otherwise -> + failWith ("Failed to find a smaller conflict set. The new " + ++ "conflict set is not a subset of the previous " + ++ "conflict set: " ++ showCS cs') $ + ExhaustiveSearch smallestKnownCS smallestKnownCM + BackjumpLimitReached -> + failWith ("Reached backjump limit while minimizing conflict set.") + BackjumpLimitReached + where + varStr = "\"" ++ showVar v ++ "\"" + showCS cs' = "{" ++ showConflictSet cs' ++ "}" + + sc' = sc { goalOrder = Just goalOrder' } + + goalOrder' = + preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS) + <> preferGoal v + <> fromMaybe mempty (goalOrder sc) + + -- Like 'retry', except that it only applies the input function when the + -- backjump limit has not been reached. + retryNoSolution :: RetryLog step SolverFailure done + -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done) + -> RetryLog step SolverFailure done + retryNoSolution lg f = retry lg $ \case + ExhaustiveSearch cs' cm' -> f cs' cm' + BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached) + +-- | Goal ordering that chooses goals contained in the conflict set before +-- other goals. +preferGoalsFromConflictSet :: ConflictSet + -> Variable QPN -> Variable QPN -> Ordering +preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs + +-- | Goal ordering that chooses the given goal first. +preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering +preferGoal preferred = comparing $ \v -> toVar v /= preferred + +toVar :: Variable QPN -> Var QPN +toVar (PackageVar qpn) = P qpn +toVar (FlagVar qpn fn) = F (FN qpn fn) +toVar (StanzaVar qpn sn) = S (SN qpn sn) + +finalErrorMsg :: SolverConfig -> SolverFailure -> String +finalErrorMsg sc failure = + case failure of + ExhaustiveSearch cs cm -> + "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: " + ++ showCS cm cs + ++ flagSuggestion + where + showCS = if solverVerbosity sc > normal + then CS.showCSWithFrequency + else CS.showCSSortedByFrequency + flagSuggestion = + -- Don't suggest --minimize-conflict-set if the conflict set is + -- already small, because it is unlikely to be reduced further. + if CS.size cs > 3 && not (asBool (minimizeConflictSet sc)) + then "\nTry running with --minimize-conflict-set to improve the " + ++ "error message." + else "" + BackjumpLimitReached -> + "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++ + "change with --max-backjumps or try to run with --reorder-goals).\n" + where currlimit (Just n) = "currently " ++ show n ++ ", " + currlimit Nothing = "" diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs @@ -0,0 +1,94 @@ +module Distribution.Solver.Modular.Assignment + ( Assignment(..) + , PAssignment + , FAssignment + , SAssignment + , toCPs + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (pi) + +import qualified Data.Array as A +import qualified Data.List as L +import qualified Data.Map as M + +import Data.Maybe (fromJust) + +import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +import Distribution.Solver.Modular.Configured +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.LabeledGraph +import Distribution.Solver.Modular.Package + +-- | A (partial) package assignment. Qualified package names +-- are associated with instances. +type PAssignment = Map QPN I + +type FAssignment = Map QFN Bool +type SAssignment = Map QSN Bool + +-- | A (partial) assignment of variables. +data Assignment = A PAssignment FAssignment SAssignment + deriving (Show, Eq) + +-- | Delivers an ordered list of fully configured packages. +-- +-- TODO: This function is (sort of) ok. However, there's an open bug +-- w.r.t. unqualification. There might be several different instances +-- of one package version chosen by the solver, which will lead to +-- clashes. +toCPs :: Assignment -> RevDepMap -> [CP QPN] +toCPs (A pa fa sa) rdm = + let + -- get hold of the graph + g :: Graph Component + vm :: Vertex -> ((), QPN, [(Component, QPN)]) + cvm :: QPN -> Maybe Vertex + -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. + (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) + (M.toList rdm)) + tg :: Graph Component + tg = transposeG g + -- Topsort the dependency graph, yielding a list of pkgs in the right order. + -- The graph will still contain all the installed packages, and it might + -- contain duplicates, because several variables might actually resolve to + -- the same package in the presence of qualified package names. + ps :: [PI QPN] + ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ + topSort g + -- Determine the flags per package, by walking over and regrouping the + -- complete flag assignment by package. + fapp :: Map QPN FlagAssignment + fapp = M.fromListWith mappend $ + L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ + M.toList $ + fa + -- Stanzas per package. + sapp :: Map QPN OptionalStanzaSet + sapp = M.fromListWith mappend + $ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty)) + $ M.toList sa + -- Dependencies per package. + depp :: QPN -> [(Component, PI QPN)] + depp qpn = let v :: Vertex + v = fromJust (cvm qpn) -- TODO: why this is safe? + dvs :: [(Component, Vertex)] + dvs = tg A.! v + in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs + -- Translated to PackageDeps + depp' :: QPN -> ComponentDeps [PI QPN] + depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp + in + L.map (\ pi@(PI qpn _) -> CP pi + (M.findWithDefault mempty qpn fapp) + (M.findWithDefault mempty qpn sapp) + (depp' qpn)) + ps diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.Builder ( + buildTree + , splits -- for testing + ) where + +-- Building the search tree. +-- +-- In this phase, we build a search tree that is too large, i.e, it contains +-- invalid solutions. We keep track of the open goals at each point. We +-- nondeterministically pick an open goal (via a goal choice node), create +-- subtrees according to the index and the available solutions, and extend the +-- set of open goals by superficially looking at the dependencies recorded in +-- the index. +-- +-- For each goal, we keep track of all the *reasons* why it is being +-- introduced. These are for debugging and error messages, mainly. A little bit +-- of care has to be taken due to the way we treat flags. If a package has +-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we +-- store the entire dependency. + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Prelude + +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.PSQ as P +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.ComponentDeps +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Settings + +-- | All state needed to build and link the search tree. It has a type variable +-- because the linking phase doesn't need to know about the state used to build +-- the tree. +data Linker a = Linker { + buildState :: a, + linkingState :: LinkingState +} + +-- | The state needed to build the search tree without creating any linked nodes. +data BuildState = BS { + index :: Index, -- ^ information about packages and their dependencies + rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies + open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) + next :: BuildType, -- ^ kind of node to generate next + qualifyOptions :: QualifyOptions -- ^ qualification options +} + +-- | Map of available linking targets. +type LinkingState = M.Map (PN, I) [PackagePath] + +-- | Extend the set of open goals with the new goals listed. +-- +-- We also adjust the map of overall goals, and keep track of the +-- reverse dependencies of each of the goals. +extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState +extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs + where + go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState + go g o [] = s { rdeps = g, open = o } + go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = + go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs + -- Note: for 'Flagged' goals, we always insert, so later additions win. + -- This is important, because in general, if a goal is inserted twice, + -- the later addition will have better dependency information. + go g o ((Stanza sn@(SN qpn _) t) : ngs) = + go g (StanzaGoal sn t (flagGR qpn) : o) ngs + go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs) + | qpn == qpn' = + -- We currently only add a self-dependency to the graph if it is + -- between a package and its setup script. The edge creates a cycle + -- and causes the solver to backtrack and choose a different + -- instance for the setup script. We may need to track other + -- self-dependencies once we implement component-based solving. + case c of + ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs + _ -> go g o ngs + | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs + | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs + -- code above is correct; insert/adjust have different arg order + go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs + go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs + go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs + + addIfAbsent :: Eq a => a -> [a] -> [a] + addIfAbsent x xs = if x `elem` xs then xs else x : xs + + -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by + -- its containing package. + flagGR :: qpn -> GoalReason qpn + flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) + +-- | Given the current scope, qualify all the package names in the given set of +-- dependencies and then extend the set of open goals accordingly. +scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> + BuildState -> BuildState +scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s + where + -- Qualify all package names + qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps + -- Introduce all package flags + qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs + -- Combine new package and flag goals + gs = qfdefs ++ qfdeps + -- NOTE: + -- + -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially + -- multiple times, both via the flag declaration and via dependencies. + +-- | Datatype that encodes what to build next +data BuildType = + Goals -- ^ build a goal choice node + | OneGoal OpenGoal -- ^ build a node for this goal + | Instance QPN PInfo -- ^ build a tree for a concrete instance + +build :: Linker BuildState -> Tree () QGoalReason +build = ana go + where + go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) + go s = addLinking (linkingState s) $ addChildren (buildState s) + +addChildren :: BuildState -> TreeF () QGoalReason BuildState + +-- If we have a choice between many goals, we just record the choice in +-- the tree. We select each open goal in turn, and before we descend, remove +-- it from the queue of open goals. +addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) + | L.null gs = DoneF rdm () + | otherwise = GoalChoiceF rdm $ P.fromList + $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) + $ splits gs + +-- If we have already picked a goal, then the choice depends on the kind +-- of goal. +-- +-- For a package, we look up the instances available in the global info, +-- and then handle each instance in turn. +addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = + case M.lookup pn idx of + Nothing -> FailF + (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) + UnknownPackage + Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> + ([], POption i Nothing, bs { next = Instance qpn info })) + (M.toList pis))) + -- TODO: data structure conversion is rather ugly here + +-- For a flag, we create only two subtrees, and we create them in the order +-- that is indicated by the flag default. +addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = + FChoiceF qfn rdm gr weak m b (W.fromList + [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), + ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) + where + trivial = L.null t && L.null f + weak = WeakOrTrivial $ unWeakOrTrivial w || trivial + +-- For a stanza, we also create only two subtrees. The order is initially +-- False, True. This can be changed later by constraints (force enabling +-- the stanza by replacing the False branch with failure) or preferences +-- (try enabling the stanza if possible by moving the True branch first). + +addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = + SChoiceF qsn rdm gr trivial (W.fromList + [([0], False, bs { next = Goals }), + ([1], True, (extendOpen qpn t bs) { next = Goals })]) + where + trivial = WeakOrTrivial (L.null t) + +-- For a particular instance, we change the state: we update the scope, +-- and furthermore we update the set of goals. +-- +-- TODO: We could inline this above. +addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = + addChildren ((scopedExtendOpen qpn fdeps fdefs bs) + { next = Goals }) + +{------------------------------------------------------------------------------- + Add linking +-------------------------------------------------------------------------------} + +-- | Introduce link nodes into the tree +-- +-- Linking is a phase that adapts package choice nodes and adds the option to +-- link wherever appropriate: Package goals are called "related" if they are for +-- the same instance of the same package (but have different prefixes). A link +-- option is available in a package choice node whenever we can choose an +-- instance that has already been chosen for a related goal at a higher position +-- in the tree. We only create link options for related goals that are not +-- themselves linked, because the choice to link to a linked goal is the same as +-- the choice to link to the target of that goal's linking. +-- +-- The code here proceeds by maintaining a finite map recording choices that +-- have been made at higher positions in the tree. For each pair of package name +-- and instance, it stores the prefixes at which we have made a choice for this +-- package instance. Whenever we make an unlinked choice, we extend the map. +-- Whenever we find a choice, we look into the map in order to find out what +-- link options we have to add. +-- +-- A separate tree traversal would be simpler. However, 'addLinking' creates +-- linked nodes from existing unlinked nodes, which leads to sharing between the +-- nodes. If we copied the nodes when they were full trees of type +-- 'Tree () QGoalReason', then the sharing would cause a space leak during +-- exploration of the tree. Instead, we only copy the 'BuildState', which is +-- relatively small, while the tree is being constructed. See +-- https://github.com/haskell/cabal/issues/2899 +addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a) +-- The only nodes of interest are package nodes +addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) = + let linkedCs = fmap (\bs -> Linker bs ls) $ + W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs) + unlinkedCs = W.mapWithKey goP cs + allCs = unlinkedCs `W.union` linkedCs + + -- Recurse underneath package choices. Here we just need to make sure + -- that we record the package choice so that it is available below + goP :: POption -> a -> Linker a + goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls + goP _ _ = alreadyLinked + in PChoiceF qpn rdm gr allCs +addLinking ls t = fmap (\bs -> Linker bs ls) t + +linkChoices :: forall a w . LinkingState + -> QPN + -> (w, POption, a) + -> [(w, POption, a)] +linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = + L.map aux (M.findWithDefault [] (pn, i) related) + where + aux :: PackagePath -> (w, POption, a) + aux pp = (weight, POption i (Just pp), subtree) +linkChoices _ _ (_, POption _ (Just _), _) = + alreadyLinked + +alreadyLinked :: a +alreadyLinked = error "addLinking called on tree that already contains linked nodes" + +------------------------------------------------------------------------------- + +-- | Interface to the tree builder. Just takes an index and a list of package names, +-- and computes the initial state and then the tree from there. +buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason +buildTree idx (IndependentGoals ind) igs = + build Linker { + buildState = BS { + index = idx + , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) + , open = L.map topLevelGoal qpns + , next = Goals + , qualifyOptions = defaultQualifyOptions idx + } + , linkingState = M.empty + } + where + topLevelGoal qpn = PkgGoal qpn UserGoal + + qpns | ind = L.map makeIndependent igs + | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs + +{------------------------------------------------------------------------------- + Goals +-------------------------------------------------------------------------------} + +-- | Information needed about a dependency before it is converted into a Goal. +data OpenGoal = + FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason + | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason + | PkgGoal QPN QGoalReason + +-- | Closes a goal, i.e., removes all the extraneous information that we +-- need only during the build phase. +close :: OpenGoal -> Goal QPN +close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr +close (StanzaGoal qsn _ gr) = Goal (S qsn) gr +close (PkgGoal qpn gr) = Goal (P qpn) gr + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Pairs each element of a list with the list resulting from removal of that +-- element from the original list. +splits :: [a] -> [(a, [a])] +splits = go id + where + go :: ([a] -> [a]) -> [a] -> [(a, [a])] + go _ [] = [] + go f (x : xs) = (x, f xs) : go (f . (x :)) xs diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/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 OptionalStanzaSet (ComponentDeps [PI qpn]) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/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 + srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi + where + ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) + ds' = fmap (partitionEithers . map convConfId) ds + +convPI :: PI QPN -> Either UnitId PackageId +convPI (PI _ (I _ (Inst pi))) = Left pi +convPI pi = Right (packageId (either id id (convConfId pi))) + +convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} +convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = + case loc of + Inst pi -> Left (PreExistingId sourceId pi) + _otherwise + | QualExe _ pn' <- q + -- NB: the dependencies of the executable are also + -- qualified. So the way to tell if this is an executable + -- dependency is to make sure the qualifier is pointing + -- at the actual thing. Fortunately for us, I was + -- silly and didn't allow arbitrarily nested build-tools + -- dependencies, so a shallow check works. + , pn == pn' -> Right (PlannedId sourceId) + | otherwise -> Left (PlannedId sourceId) + where + sourceId = PackageIdentifier pn v diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE CPP #-} +#ifdef DEBUG_CONFLICT_SETS +{-# LANGUAGE ImplicitParams #-} +#endif +-- | Conflict sets +-- +-- Intended for double import +-- +-- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) +-- > import qualified Distribution.Solver.Modular.ConflictSet as CS +module Distribution.Solver.Modular.ConflictSet ( + ConflictSet -- opaque + , Conflict(..) + , ConflictMap + , OrderedVersionRange(..) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin +#endif + , showConflictSet + , showCSSortedByFrequency + , showCSWithFrequency + -- Set-like operations + , toSet + , toList + , union + , unions + , insert + , delete + , empty + , singleton + , singletonWithConflict + , size + , member + , lookup + , filter + , fromList + ) where + +import Prelude hiding (lookup) +import Data.List (intercalate, sortBy) +import Data.Map (Map) +import Data.Set (Set) +import Data.Function (on) +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +#ifdef DEBUG_CONFLICT_SETS +import Data.Tree +import GHC.Stack +#endif + +import Distribution.Solver.Modular.Var +import Distribution.Solver.Modular.Version +import Distribution.Solver.Types.PackagePath + +-- | The set of variables involved in a solver conflict, each paired with +-- details about the conflict. +data ConflictSet = CS { + -- | The set of variables involved in the conflict + conflictSetToMap :: !(Map (Var QPN) (Set Conflict)) + +#ifdef DEBUG_CONFLICT_SETS + -- | The origin of the conflict set + -- + -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@, + -- we record the origin of every conflict set. For new conflict sets + -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations + -- that construct new conflict sets from existing conflict sets ('union', + -- 'filter', ..) we record the 'CallStack' to the call to the combinator + -- as well as the 'CallStack's of the input conflict sets. + -- + -- Requires @GHC >= 7.10@. + , conflictSetOrigin :: Tree CallStack +#endif + } + deriving (Show) + +-- | More detailed information about how a conflict set variable caused a +-- conflict. This information can be used to determine whether a second value +-- for that variable would lead to the same conflict. +-- +-- TODO: Handle dependencies under flags or stanzas. +data Conflict = + + -- | The conflict set variable represents a package which depends on the + -- specified problematic package. For example, the conflict set entry + -- '(P x, GoalConflict y)' means that package x introduced package y, and y + -- led to a conflict. + GoalConflict QPN + + -- | The conflict set variable represents a package with a constraint that + -- excluded the specified package and version. For example, the conflict set + -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that + -- package x's constraint on y excluded y-2.0. + | VersionConstraintConflict QPN Ver + + -- | The conflict set variable represents a package that was excluded by a + -- constraint from the specified package. For example, the conflict set + -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))' + -- means that package y's constraint 'x >= 2.0' excluded some version of x. + | VersionConflict QPN OrderedVersionRange + + -- | Any other conflict. + | OtherConflict + deriving (Eq, Ord, Show) + +-- | Version range with an 'Ord' instance. +newtype OrderedVersionRange = OrderedVersionRange VR + deriving (Eq, Show) + +-- TODO: Avoid converting the version ranges to strings. +instance Ord OrderedVersionRange where + compare = compare `on` show + +instance Eq ConflictSet where + (==) = (==) `on` conflictSetToMap + +instance Ord ConflictSet where + compare = compare `on` conflictSetToMap + +showConflictSet :: ConflictSet -> String +showConflictSet = intercalate ", " . map showVar . toList + +showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String +showCSSortedByFrequency = showCS False + +showCSWithFrequency :: ConflictMap -> ConflictSet -> String +showCSWithFrequency = showCS True + +showCS :: Bool -> ConflictMap -> ConflictSet -> String +showCS showCount cm = + intercalate ", " . map showWithFrequency . indexByFrequency + where + indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList + showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of + Just frequency + | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" + _ -> showVar conflict + +{------------------------------------------------------------------------------- + Set-like operations +-------------------------------------------------------------------------------} + +toSet :: ConflictSet -> Set (Var QPN) +toSet = M.keysSet . conflictSetToMap + +toList :: ConflictSet -> [Var QPN] +toList = M.keys . conflictSetToMap + +union :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + ConflictSet -> ConflictSet -> ConflictSet +union cs cs' = CS { + conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) +#endif + } + +unions :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + [ConflictSet] -> ConflictSet +unions css = CS { + conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) +#endif + } + +insert :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> ConflictSet -> ConflictSet +insert var cs = CS { + conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] +#endif + } + +delete :: Var QPN -> ConflictSet -> ConflictSet +delete var cs = CS { + conflictSetToMap = M.delete var (conflictSetToMap cs) + } + +empty :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + ConflictSet +empty = CS { + conflictSetToMap = M.empty +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +singleton :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> ConflictSet +singleton var = singletonWithConflict var OtherConflict + +singletonWithConflict :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> Conflict -> ConflictSet +singletonWithConflict var conflict = CS { + conflictSetToMap = M.singleton var (S.singleton conflict) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +size :: ConflictSet -> Int +size = M.size . conflictSetToMap + +member :: Var QPN -> ConflictSet -> Bool +member var = M.member var . conflictSetToMap + +lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict) +lookup var = M.lookup var . conflictSetToMap + +fromList :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + [Var QPN] -> ConflictSet +fromList vars = CS { + conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +type ConflictMap = Map (Var QPN) Int + diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE TypeFamilies #-} +module Distribution.Solver.Modular.Cycles ( + detectCyclesPhase + ) where + +import Prelude hiding (cycle) +import qualified Data.Map as M +import qualified Data.Set as S + +import qualified Distribution.Compat.Graph as G +import Distribution.Simple.Utils (ordNub) +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Types.ComponentDeps (Component) +import Distribution.Solver.Types.PackagePath + +-- | Find and reject any nodes with cyclic dependencies +detectCyclesPhase :: Tree d c -> Tree d c +detectCyclesPhase = cata go + where + -- Only check children of choice nodes. + go :: TreeF d c (Tree d c) -> Tree d c + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr $ fmap (checkChild qpn) cs + go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) = + FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs + go (SChoiceF qsn@(SN qpn _) rdm gr w cs) = + SChoice qsn rdm gr w $ fmap (checkChild qpn) cs + go x = inn x + + checkChild :: QPN -> Tree d c -> Tree d c + checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x + checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x + checkChild _ x@(Fail _ _) = x + checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x + + failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c + failIfCycle qpn rdm x = + case findCycles qpn rdm of + Nothing -> x + Just relSet -> Fail relSet CyclicDependencies + +-- | Given the reverse dependency map from a node in the tree, check +-- if the solution is cyclic. If it is, return the conflict set containing +-- all decisions that could potentially break the cycle. +-- +-- TODO: The conflict set should also contain flag and stanza variables. +findCycles :: QPN -> RevDepMap -> Maybe ConflictSet +findCycles pkg rdm = + -- This function has two parts: a faster cycle check that is called at every + -- step and a slower calculation of the conflict set. + -- + -- 'hasCycle' checks for cycles incrementally by only looking for cycles + -- containing the current package, 'pkg'. It searches for cycles in the + -- 'RevDepMap', which is the data structure used to store reverse + -- dependencies in the search tree. We store the reverse dependencies in a + -- map, because Data.Map is smaller and/or has better sharing than + -- Distribution.Compat.Graph. + -- + -- If there is a cycle, we call G.cycles to find a strongly connected + -- component. Then we choose one cycle from the component to use for the + -- conflict set. Choosing only one cycle can lead to a smaller conflict set, + -- such as when a choice to enable testing introduces many cycles at once. + -- In that case, all cycles contain the current package and are in one large + -- strongly connected component. + -- + if hasCycle + then let scc :: G.Graph RevDepMapNode + scc = case G.cycles $ revDepMapToGraph rdm of + [] -> findCyclesError "cannot find a strongly connected component" + c : _ -> G.fromDistinctList c + + next :: QPN -> QPN + next p = case G.neighbors scc p of + Just (n : _) -> G.nodeKey n + _ -> findCyclesError "cannot find next node in the cycle" + + -- This function also assumes that all cycles contain 'pkg'. + oneCycle :: [QPN] + oneCycle = case iterate next pkg of + [] -> findCyclesError "empty cycle" + x : xs -> x : takeWhile (/= x) xs + in Just $ CS.fromList $ map P oneCycle + else Nothing + where + hasCycle :: Bool + hasCycle = pkg `S.member` closure (neighbors pkg) + + closure :: [QPN] -> S.Set QPN + closure = foldl go S.empty + where + go :: S.Set QPN -> QPN -> S.Set QPN + go s x = + if x `S.member` s + then s + else foldl go (S.insert x s) $ neighbors x + + neighbors :: QPN -> [QPN] + neighbors x = case x `M.lookup` rdm of + Nothing -> findCyclesError "cannot find node" + Just xs -> map snd xs + + findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++) + +data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)] + +instance G.IsNode RevDepMapNode where + type Key RevDepMapNode = QPN + nodeKey (RevDepMapNode qpn _) = qpn + nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns + +revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode +revDepMapToGraph rdm = G.fromDistinctList + [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +module Distribution.Solver.Modular.Dependency ( + -- * Variables + Var(..) + , showVar + , varPN + -- * Conflict sets + , ConflictSet + , ConflictMap + , CS.showConflictSet + -- * Constrained instances + , CI(..) + -- * Flagged dependencies + , FlaggedDeps + , FlaggedDep(..) + , LDep(..) + , Dep(..) + , PkgComponent(..) + , ExposedComponent(..) + , DependencyReason(..) + , showDependencyReason + , flattenFlaggedDeps + , QualifyOptions(..) + , qualifyDeps + , unqualifyDeps + -- * Reverse dependency map + , RevDepMap + -- * Goals + , Goal(..) + , GoalReason(..) + , QGoalReason + , goalToVar + , varToConflictSet + , goalReasonToConflictSet + , goalReasonToConflictSetWithConflict + , dependencyReasonToConflictSet + , dependencyReasonToConflictSetWithVersionConstraintConflict + , dependencyReasonToConflictSetWithVersionConflict + ) where + +import Prelude () +import qualified Data.Map as M +import qualified Data.Set as S +import Distribution.Solver.Compat.Prelude hiding (pi) + +import Language.Haskell.Extension (Extension(..), Language(..)) + +import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Var +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.ConflictSet as CS + +import Distribution.Solver.Types.ComponentDeps (Component(..)) +import Distribution.Solver.Types.PackagePath +import Distribution.Types.LibraryName +import Distribution.Types.PkgconfigVersionRange +import Distribution.Types.UnqualComponentName + +{------------------------------------------------------------------------------- + Constrained instances +-------------------------------------------------------------------------------} + +-- | Constrained instance. It represents the allowed instances for a package, +-- which can be either a fixed instance or a version range. +data CI = Fixed I | Constrained VR + deriving (Eq, Show) + +{------------------------------------------------------------------------------- + Flagged dependencies +-------------------------------------------------------------------------------} + +-- | Flagged dependencies +-- +-- 'FlaggedDeps' is the modular solver's view of a packages dependencies: +-- rather than having the dependencies indexed by component, each dependency +-- defines what component it is in. +-- +-- Note that each dependency is associated with a Component. We must know what +-- component the dependencies belong to, or else we won't be able to construct +-- fine-grained reverse dependencies. +type FlaggedDeps qpn = [FlaggedDep qpn] + +-- | Flagged dependencies can either be plain dependency constraints, +-- or flag-dependent dependency trees. +data FlaggedDep qpn = + -- | Dependencies which are conditional on a flag choice. + Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) + -- | Dependencies which are conditional on whether or not a stanza + -- (e.g., a test suite or benchmark) is enabled. + | Stanza (SN qpn) (TrueFlaggedDeps qpn) + -- | Dependencies which are always enabled, for the component 'comp'. + | Simple (LDep qpn) Component + +-- | Conversatively flatten out flagged dependencies +-- +-- NOTE: We do not filter out duplicates. +flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)] +flattenFlaggedDeps = concatMap aux + where + aux :: FlaggedDep qpn -> [(LDep qpn, Component)] + aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f + aux (Stanza _ t) = flattenFlaggedDeps t + aux (Simple d c) = [(d, c)] + +type TrueFlaggedDeps qpn = FlaggedDeps qpn +type FalseFlaggedDeps qpn = FlaggedDeps qpn + +-- | A 'Dep' labeled with the reason it was introduced. +-- +-- 'LDep' intentionally has no 'Functor' instance because the type variable +-- is used both to record the dependencies as well as who's doing the +-- depending; having a 'Functor' instance makes bugs where we don't distinguish +-- these two far too likely. (By rights 'LDep' ought to have two type variables.) +data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) + +-- | A dependency (constraint) associates a package name with a constrained +-- instance. It can also represent other types of dependencies, such as +-- dependencies on language extensions. +data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component + | Ext Extension -- ^ dependency on a language extension + | Lang Language -- ^ dependency on a language version + | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package + deriving Functor + +-- | An exposed component within a package. This type is used to represent +-- build-depends and build-tool-depends dependencies. +data PkgComponent qpn = PkgComponent qpn ExposedComponent + deriving (Eq, Ord, Functor, Show) + +-- | A component that can be depended upon by another package, i.e., a library +-- or an executable. +data ExposedComponent = + ExposedLib LibraryName + | ExposedExe UnqualComponentName + deriving (Eq, Ord, Show) + +-- | The reason that a dependency is active. It identifies the package and any +-- flag and stanza choices that introduced the dependency. It contains +-- everything needed for creating ConflictSets or describing conflicts in solver +-- log messages. +data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza) + deriving (Functor, Eq, Show) + +-- | Print the reason that a dependency was introduced. +showDependencyReason :: DependencyReason QPN -> String +showDependencyReason (DependencyReason qpn flags stanzas) = + intercalate " " $ + showQPN qpn + : map (uncurry showFlagValue) (M.toList flags) + ++ map (\s -> showSBool s True) (S.toList stanzas) + +-- | Options for goal qualification (used in 'qualifyDeps') +-- +-- See also 'defaultQualifyOptions' +data QualifyOptions = QO { + -- | Do we have a version of base relying on another version of base? + qoBaseShim :: Bool + + -- Should dependencies of the setup script be treated as independent? + , qoSetupIndependent :: Bool + } + deriving Show + +-- | Apply built-in rules for package qualifiers +-- +-- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions', +-- it is important that these 'QualifyOptions' are _static_. Qualification +-- does NOT depend on flag assignment; in other words, it behaves the same no +-- matter which choices the solver makes (modulo the global 'QualifyOptions'); +-- we rely on this in 'linkDeps' (see comment there). +-- +-- NOTE: It's the _dependencies_ of a package that may or may not be independent +-- from the package itself. Package flag choices must of course be consistent. +qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN +qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go + where + go :: FlaggedDeps PN -> FlaggedDeps QPN + go = map go1 + + go1 :: FlaggedDep PN -> FlaggedDep QPN + go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) + go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) + go1 (Simple dep comp) = Simple (goLDep dep comp) comp + + -- Suppose package B has a setup dependency on package A. + -- This will be recorded as something like + -- + -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion)) + -- + -- Observe that when we qualify this dependency, we need to turn that + -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier + -- to the DependencyReason. + goLDep :: LDep PN -> Component -> LDep QPN + goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) + + goD :: Dep PN -> Component -> Dep QPN + goD (Ext ext) _ = Ext ext + goD (Lang lang) _ = Lang lang + goD (Pkg pkn vr) _ = Pkg pkn vr + goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = + Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci + goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp + | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci + | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci + | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci + + -- If P has a setup dependency on Q, and Q has a regular dependency on R, then + -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup + -- dependency on R. We do not do this for the base qualifier however. + -- + -- The inherited qualifier is only used for regular dependencies; for setup + -- and base deppendencies we override the existing qualifier. See #3160 for + -- a detailed discussion. + inheritedQ :: Qualifier + inheritedQ = case q of + QualSetup _ -> q + QualExe _ _ -> q + QualToplevel -> q + QualBase _ -> QualToplevel + + -- Should we qualify this goal with the 'Base' package path? + qBase :: PN -> Bool + qBase dep = qoBaseShim && unPackageName dep == "base" + + -- Should we qualify this goal with the 'Setup' package path? + qSetup :: Component -> Bool + qSetup comp = qoSetupIndependent && comp == ComponentSetup + +-- | Remove qualifiers from set of dependencies +-- +-- This is used during link validation: when we link package @Q.A@ to @Q'.A@, +-- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute +-- what to link these dependencies to, we need to requalify @Q.B@ to become +-- @Q'.B@; we do this by first removing all qualifiers and then calling +-- 'qualifyDeps' again. +unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN +unqualifyDeps = go + where + go :: FlaggedDeps QPN -> FlaggedDeps PN + go = map go1 + + go1 :: FlaggedDep QPN -> FlaggedDep PN + go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) + go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) + go1 (Simple dep comp) = Simple (goLDep dep) comp + + goLDep :: LDep QPN -> LDep PN + goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) + + unq :: QPN -> PN + unq (Q _ pn) = pn + +{------------------------------------------------------------------------------- + Reverse dependency map +-------------------------------------------------------------------------------} + +-- | A map containing reverse dependencies between qualified +-- package names. +type RevDepMap = Map QPN [(Component, QPN)] + +{------------------------------------------------------------------------------- + Goals +-------------------------------------------------------------------------------} + +-- | A goal is just a solver variable paired with a reason. +-- The reason is only used for tracing. +data Goal qpn = Goal (Var qpn) (GoalReason qpn) + deriving (Eq, Show, Functor) + +-- | Reason why a goal is being added to a goal set. +data GoalReason qpn = + UserGoal -- introduced by a build target + | DependencyGoal (DependencyReason qpn) -- introduced by a package + deriving (Eq, Show, Functor) + +type QGoalReason = GoalReason QPN + +goalToVar :: Goal a -> Var a +goalToVar (Goal v _) = v + +-- | Compute a singleton conflict set from a 'Var' +varToConflictSet :: Var QPN -> ConflictSet +varToConflictSet = CS.singleton + +-- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal +-- leads to a conflict. +goalReasonToConflictSet :: GoalReason QPN -> ConflictSet +goalReasonToConflictSet UserGoal = CS.empty +goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr + +-- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the +-- conflict occurred, namely the conflict set variables caused a conflict by +-- introducing the given package goal. See the documentation for 'GoalConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'GoalReason' does not involve any flags or stanzas. +-- Otherwise, it falls back to calling 'goalReasonToConflictSet'. +goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet +goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal +goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr + +-- | This function returns the solver variables responsible for the dependency. +-- It drops the values chosen for flag and stanza variables, which are only +-- needed for log messages. +dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet +dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = + CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) + where + -- Filter out any flags that introduced the dependency with both values. + -- They don't need to be included in the conflict set, because changing the + -- flag value can't remove the dependency. + flagVars :: [Var QPN] + flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth] + + stanzaToVar :: Stanza -> Var QPN + stanzaToVar = S . SN qpn + +-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the +-- conflict occurred because the conflict set variables introduced a problematic +-- version constraint. See the documentation for 'VersionConstraintConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'DependencyReason' does not involve any flags or +-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. +dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN + -> Ver + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConstraintConflict + dependency excludedVersion dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConstraintConflict dependency excludedVersion + | otherwise = dependencyReasonToConflictSet dr + +-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the +-- conflict occurred because the conflict set variables introduced a version of +-- a package that was excluded by a version constraint. See the documentation +-- for 'VersionConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'DependencyReason' does not involve any flags or +-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. +dependencyReasonToConflictSetWithVersionConflict :: QPN + -> CS.OrderedVersionRange + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConflict + pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConflict pkgWithVersionConstraint constraint + | otherwise = dependencyReasonToConflictSet dr diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.Explore (backjumpAndExplore) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import qualified Distribution.Solver.Types.Progress as P + +import qualified Data.List as L (foldl') +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +import Distribution.Simple.Setup (asBool) + +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Log +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.PSQ as P +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.RetryLog +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.WeightedPSQ as W +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Settings + (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..)) +import Distribution.Types.VersionRange (anyVersion) + +-- | This function takes the variable we're currently considering, a +-- last conflict set and a list of children's logs. Each log yields +-- either a solution or a conflict set. The result is a combined log for +-- the parent node that has explored a prefix of the children. +-- +-- We can stop traversing the children's logs if we find an individual +-- conflict set that does not contain the current variable. In this +-- case, we can just lift the conflict set to the current level, +-- because the current level cannot possibly have contributed to this +-- conflict, so no other choice at the current level would avoid the +-- conflict. +-- +-- If any of the children might contain a successful solution, we can +-- return it immediately. If all children contain conflict sets, we can +-- take the union as the combined conflict set. +-- +-- The last conflict set corresponds to the justification that we +-- have to choose this goal at all. There is a reason why we have +-- introduced the goal in the first place, and this reason is in conflict +-- with the (virtual) option not to choose anything for the current +-- variable. See also the comments for 'avoidSet'. +-- +-- We can also skip a child if it does not resolve any of the conflicts paired +-- with the current variable in the previous child's conflict set. 'backjump' +-- takes a function to determine whether a child can be skipped. If the child +-- can be skipped, the function returns a new conflict set to be merged with the +-- previous conflict set. +-- +backjump :: forall w k a . Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + + -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) + -- ^ Function that determines whether the given choice could resolve + -- the given conflict. It indicates false by returning 'Just', + -- with the new conflicts to be added to the conflict set. + + -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) + -- ^ Function that logs the given choice that was skipped. + + -> Var QPN -- ^ The current variable. + + -> ConflictSet -- ^ Conflict set representing the reason that the goal + -- was introduced. + + -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) + -- ^ List of children's logs. + + -> ExploreState -> ConflictSetLog a +backjump mbj enableBj fineGrainedConflicts couldResolveConflicts + logSkippedChoice var lastCS xs = + foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing + where + combine :: (k, ExploreState -> ConflictSetLog a) + -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + combine (k, x) f csAcc mPreviousCS es = + case (asBool fineGrainedConflicts, mPreviousCS) of + (True, Just previousCS) -> + case CS.lookup var previousCS of + Just conflicts -> + case couldResolveConflicts k conflicts of + Nothing -> retryNoSolution (x es) next + Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) + _ -> skipChoice previousCS + _ -> retryNoSolution (x es) next + where + next :: ConflictSet -> ExploreState -> ConflictSetLog a + next !cs es' = if asBool enableBj && not (var `CS.member` cs) + then skipLoggingBackjump cs es' + else f (csAcc `CS.union` cs) (Just cs) es' + + -- This function is for skipping the choice when it cannot resolve any + -- of the previous conflicts. + skipChoice :: ConflictSet -> ConflictSetLog a + skipChoice newCS = + retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' -> + f (csAcc `CS.union` cs') (Just cs') $ + + -- Update the conflict map with the conflict set, to make up for + -- skipping the whole subtree. + es' { esConflictMap = updateCM cs' (esConflictMap es') } + + -- This function represents the option to not choose a value for this goal. + avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + avoidGoal cs _mPreviousCS !es = + logBackjump mbj (cs `CS.union` lastCS) $ + + -- Use 'lastCS' below instead of 'cs' since we do not want to + -- double-count the additionally accumulated conflicts. + es { esConflictMap = updateCM lastCS (esConflictMap es) } + + -- The solver does not count or log backjumps at levels where the conflict + -- set does not contain the current variable. Otherwise, there would be many + -- consecutive log messages about backjumping with the same conflict set. + skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a + skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) + +-- | Creates a failing ConflictSetLog representing a backjump. It inserts a +-- "backjumping" message, checks whether the backjump limit has been reached, +-- and increments the backjump count. +logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a +logBackjump mbj cs es = + failWith (Failure cs Backjump) $ + if reachedBjLimit (esBackjumps es) + then BackjumpLimit + else NoSolution cs es { esBackjumps = esBackjumps es + 1 } + where + reachedBjLimit = case mbj of + Nothing -> const False + Just limit -> (>= limit) + +-- | Like 'retry', except that it only applies the input function when the +-- backjump limit has not been reached. +retryNoSolution :: ConflictSetLog a + -> (ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSetLog a +retryNoSolution lg f = retry lg $ \case + BackjumpLimit -> fromProgress (P.Fail BackjumpLimit) + NoSolution cs es -> f cs es + +-- | The state that is read and written while exploring the search tree. +data ExploreState = ES { + esConflictMap :: !ConflictMap + , esBackjumps :: !Int + } + +data IntermediateFailure = + NoSolution ConflictSet ExploreState + | BackjumpLimit + +type ConflictSetLog = RetryLog Message IntermediateFailure + +getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) +getBestGoal cm = + P.maximumBy + ( flip (M.findWithDefault 0) cm + . (\ (Goal v _) -> v) + ) + +getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a) +getFirstGoal ts = + P.casePSQ ts + (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error + (\ k v _xs -> (k, v)) -- commit to the first goal choice + +updateCM :: ConflictSet -> ConflictMap -> ConflictMap +updateCM cs cm = + L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs) + +-- | Record complete assignments on 'Done' nodes. +assign :: Tree d c -> Tree Assignment c +assign tree = cata go tree $ A M.empty M.empty M.empty + where + go :: TreeF d c (Assignment -> Tree Assignment c) + -> (Assignment -> Tree Assignment c) + go (FailF c fr) _ = Fail c fr + go (DoneF rdm _) a = Done rdm a + go (PChoiceF qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f ts + where f (POption k _) r = r (A (M.insert qpn k pa) fa sa) + go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts + where f k r = r (A pa (M.insert qfn k fa) sa) + go (SChoiceF qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f ts + where f k r = r (A pa fa (M.insert qsn k sa)) + go (GoalChoiceF rdm ts) a = GoalChoice rdm $ fmap ($ a) ts + +-- | A tree traversal that simultaneously propagates conflict sets up +-- the tree from the leaves and creates a log. +exploreLog :: Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> CountConflicts + -> Index + -> Tree Assignment QGoalReason + -> ConflictSetLog (Assignment, RevDepMap) +exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t = + para go t initES + where + getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) + getBestGoal' + | asBool countConflicts = \ ts cm -> getBestGoal cm ts + | otherwise = \ ts _ -> getFirstGoal ts + + go :: TreeF Assignment QGoalReason + (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) + -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) + go (FailF c fr) = \ !es -> + let es' = es { esConflictMap = updateCM c (esConflictMap es) } + in failWith (Failure c fr) (NoSolution c es') + go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) + go (PChoiceF qpn _ gr ts) = + backjump mbj enableBj fineGrainedConflicts + (couldResolveConflicts qpn) + (logSkippedPackage qpn) + (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryP qpn k) (r es)) + (fmap fst ts) + go (FChoiceF qfn _ gr _ _ _ ts) = + backjump mbj enableBj fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryF qfn k) (r es)) + (fmap fst ts) + go (SChoiceF qsn _ gr _ ts) = + backjump mbj enableBj fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryS qsn k) (r es)) + (fmap fst ts) + go (GoalChoiceF _ ts) = \ es -> + let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) + in continueWith (Next k) $ + -- Goal choice nodes are normally not counted as backjumps, since the + -- solver always explores exactly one choice, which means that the + -- backjump from the goal choice would be redundant with the backjump + -- from the PChoice, FChoice, or SChoice below. The one case where the + -- backjump is not redundant is when the chosen goal is a failure node, + -- so we log a backjump in that case. + case tree of + Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj + _ -> v es + + initES = ES { + esConflictMap = M.empty + , esBackjumps = 0 + } + + -- Is it possible for this package instance (QPN and POption) to resolve any + -- of the conflicts that were caused by the previous instance? The default + -- is true, because it is always safe to explore a package instance. + -- Skipping it is an optimization. If false, it returns a new conflict set + -- to be merged with the previous one. + couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet + couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = + let (PInfo deps _ _ _) = idx M.! pn M.! i + qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps + + couldBeResolved :: CS.Conflict -> Maybe ConflictSet + couldBeResolved CS.OtherConflict = Nothing + couldBeResolved (CS.GoalConflict conflictingDep) = + -- Check whether this package instance also has 'conflictingDep' + -- as a dependency (ignoring flag and stanza choices). + if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] + then Nothing + else Just CS.empty + couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) = + -- Check whether this package instance also excludes version + -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). + let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ] + vrIntersection = L.foldl' (.&&.) anyVersion vrs + in if checkVR vrIntersection excludedVersion + then Nothing + else -- If we skip this package instance, we need to update the + -- conflict set to say that 'dep' was also excluded by + -- this package instance's constraint. + Just $ CS.singletonWithConflict (P dep) $ + CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) + couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) = + -- Check whether this package instance's version is also excluded + -- by 'excludingVR'. + if checkVR excludingVR v + then Nothing + else -- If we skip this version, we need to update the conflict + -- set to say that the reverse dependency also excluded this + -- version. + Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) + in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) + + logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a + logSkippedPackage qpn pOption cs es = + tryWith (TryP qpn pOption) $ + failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $ + NoSolution cs es + + -- This function is used for flag and stanza choices, but it should not be + -- called, because there is currently no way to skip a value for a flag or + -- stanza. + logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a + logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es + +-- | Build a conflict set corresponding to the (virtual) option not to +-- choose a solution for a goal at all. +-- +-- In the solver, the set of goals is not statically determined, but depends +-- on the choices we make. Therefore, when dealing with conflict sets, we +-- always have to consider that we could perhaps make choices that would +-- avoid the existence of the goal completely. +-- +-- Whenever we actually introduce a choice in the tree, we have already established +-- that the goal cannot be avoided. This is tracked in the "goal reason". +-- The choice to avoid the goal therefore is a conflict between the goal itself +-- and its goal reason. We build this set here, and pass it to the 'backjump' +-- function as the last conflict set. +-- +-- This has two effects: +-- +-- - In a situation where there are no choices available at all (this happens +-- if an unknown package is requested), the last conflict set becomes the +-- actual conflict set. +-- +-- - In a situation where all of the children's conflict sets contain the +-- current variable, the goal reason of the current node will be added to the +-- conflict set. +-- +avoidSet :: Var QPN -> QGoalReason -> ConflictSet +avoidSet var@(P qpn) gr = + CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr) +avoidSet var gr = + CS.union (CS.singleton var) (goalReasonToConflictSet gr) + +-- | Interface. +-- +-- Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing', +-- then infinitely many backjumps are allowed. If the limit is 'Just 0', +-- backtracking is completely disabled. +backjumpAndExplore :: Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> CountConflicts + -> Index + -> Tree d QGoalReason + -> RetryLog Message SolverFailure (Assignment, RevDepMap) +backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx = + mapFailure convertFailure + . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx + . assign + where + convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) + convertFailure BackjumpLimit = BackjumpLimitReached diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Flag + ( FInfo(..) + , Flag + , FlagInfo + , FN(..) + , QFN + , QSN + , Stanza + , SN(..) + , WeakOrTrivial(..) + , FlagValue(..) + , mkFlag + , showQFN + , showQFNBool + , showFlagValue + , showQSN + , showQSNBool + , showSBool + ) where + +import Data.Map as M +import Prelude hiding (pi) + +import qualified Distribution.PackageDescription as P -- from Cabal + +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +-- | Flag name. Consists of a package instance and the flag identifier itself. +data FN qpn = FN qpn Flag + deriving (Eq, Ord, Show, Functor) + +-- | Flag identifier. Just a string. +type Flag = P.FlagName + +-- | Stanza identifier. +type Stanza = OptionalStanza + +unFlag :: Flag -> String +unFlag = P.unFlagName + +mkFlag :: String -> Flag +mkFlag = P.mkFlagName + +-- | Flag info. Default value, whether the flag is manual, and +-- whether the flag is weak. Manual flags can only be set explicitly. +-- Weak flags are typically deferred by the solver. +data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } + deriving (Eq, Show) + +-- | Flag defaults. +type FlagInfo = Map Flag FInfo + +-- | Qualified flag name. +type QFN = FN QPN + +-- | Stanza name. Paired with a package name, much like a flag. +data SN qpn = SN qpn Stanza + deriving (Eq, Ord, Show, Functor) + +-- | Qualified stanza name. +type QSN = SN QPN + +-- | A property of flag and stanza choices that determines whether the +-- choice should be deferred in the solving process. +-- +-- A choice is called weak if we do want to defer it. This is the +-- case for flags that should be implied by what's currently installed on +-- the system, as opposed to flags that are used to explicitly enable or +-- disable some functionality. +-- +-- A choice is called trivial if it clearly does not matter. The +-- special case of triviality we actually consider is if there are no new +-- dependencies introduced by the choice. +newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } + deriving (Eq, Ord, Show) + +-- | Value shown for a flag in a solver log message. The message can refer to +-- only the true choice, only the false choice, or both choices. +data FlagValue = FlagTrue | FlagFalse | FlagBoth + deriving (Eq, Show) + +showQFNBool :: QFN -> Bool -> String +showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b + +showQSNBool :: QSN -> Bool -> String +showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b + +showFBool :: FN qpn -> Bool -> String +showFBool (FN _ f) v = P.showFlagValue (f, v) + +-- | String representation of a flag-value pair. +showFlagValue :: P.FlagName -> FlagValue -> String +showFlagValue f FlagTrue = '+' : unFlag f +showFlagValue f FlagFalse = '-' : unFlag f +showFlagValue f FlagBoth = "+/-" ++ unFlag f + +showSBool :: Stanza -> Bool -> String +showSBool s True = "*" ++ showStanza s +showSBool s False = "!" ++ showStanza s + +showQFN :: QFN -> String +showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f + +showQSN :: QSN -> String +showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -0,0 +1,74 @@ +module Distribution.Solver.Modular.Index + ( Index + , PInfo(..) + , ComponentInfo(..) + , IsVisible(..) + , IsBuildable(..) + , defaultQualifyOptions + , mkIndex + ) where + +import Prelude hiding (pi) + +import Data.Map (Map) +import qualified Data.List as L +import qualified Data.Map as M + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree + +-- | An index contains information about package instances. This is a nested +-- dictionary. Package names are mapped to instances, which in turn is mapped +-- to info. +type Index = Map PN (Map I PInfo) + +-- | Info associated with a package instance. +-- Currently, dependencies, component names, flags and failure reasons. +-- The component map records whether any components are unbuildable in the +-- current environment (compiler, os, arch, and global flag constraints). +-- Packages that have a failure reason recorded for them are disabled +-- globally, for reasons external to the solver. We currently use this +-- for shadowing which essentially is a GHC limitation, and for +-- installed packages that are broken. +data PInfo = PInfo (FlaggedDeps PN) + (Map ExposedComponent ComponentInfo) + FlagInfo + (Maybe FailReason) + +-- | Info associated with each library and executable in a package instance. +data ComponentInfo = ComponentInfo { + compIsVisible :: IsVisible + , compIsBuildable :: IsBuildable + } + deriving Show + +-- | Whether a component is visible in the current environment. +newtype IsVisible = IsVisible Bool + deriving (Eq, Show) + +-- | Whether a component is made unbuildable by a "buildable: False" field. +newtype IsBuildable = IsBuildable Bool + deriving (Eq, Show) + +mkIndex :: [(PN, I, PInfo)] -> Index +mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) + +groupMap :: Ord a => [(a, b)] -> Map a [b] +groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) + +defaultQualifyOptions :: Index -> QualifyOptions +defaultQualifyOptions idx = QO { + qoBaseShim = or [ dep == base + | -- Find all versions of base .. + Just is <- [M.lookup base idx] + -- .. which are installed .. + , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is + -- .. and flatten all their dependencies .. + , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps + ] + , qoSetupIndependent = True + } + where + base = mkPackageName "base" diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -0,0 +1,562 @@ +module Distribution.Solver.Modular.IndexConversion + ( convPIs + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import qualified Data.List as L +import qualified Data.Map.Strict as M +import qualified Distribution.Compat.NonEmptySet as NonEmptySet +import qualified Data.Set as S + +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Compiler +import Distribution.Package -- from Cabal +import Distribution.Simple.BuildToolDepends -- from Cabal +import Distribution.Types.ExeDependency -- from Cabal +import Distribution.Types.PkgconfigDependency -- from Cabal +import Distribution.Types.ComponentName -- from Cabal +import Distribution.Types.CondTree -- from Cabal +import Distribution.Types.MungedPackageId -- from Cabal +import Distribution.Types.MungedPackageName -- from Cabal +import Distribution.PackageDescription -- from Cabal +import Distribution.PackageDescription.Configuration +import qualified Distribution.Simple.PackageIndex as SI +import Distribution.System + +import Distribution.Solver.Types.ComponentDeps + ( Component(..), componentNameToComponent ) +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackageIndex as CI +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SourcePackage + +import Distribution.Solver.Modular.Dependency as D +import Distribution.Solver.Modular.Flag as F +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version + +-- | Convert both the installed package index and the source package +-- index into one uniform solver index. +-- +-- We use 'allPackagesBySourcePackageId' for the installed package index +-- because that returns us several instances of the same package and version +-- in order of preference. This allows us in principle to \"shadow\" +-- packages if there are several installed packages of the same version. +-- There are currently some shortcomings in both GHC and Cabal in +-- resolving these situations. However, the right thing to do is to +-- fix the problem there, so for now, shadowing is only activated if +-- explicitly requested. +convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> ShadowPkgs -> StrongFlags -> SolveExecutables + -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) + -> Index +convPIs os arch comp constraints sip strfl solveExes iidx sidx = + mkIndex $ + convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx + +-- | Convert a Cabal installed package index to the simpler, +-- more uniform index format of the solver. +convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] +convIPI' (ShadowPkgs sip) idx = + -- apply shadowing whenever there are multiple installed packages with + -- the same version + [ maybeShadow (convIP idx pkg) + -- IMPORTANT to get internal libraries. See + -- Note [Index conversion with internal libraries] + | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx + , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] + where + + -- shadowing is recorded in the package info + shadow (pn, i, PInfo fdeps comps fds _) + | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed)) + shadow x = x + +-- | Extract/recover the package ID from an installed package info, and convert it to a solver's I. +convId :: IPI.InstalledPackageInfo -> (PN, I) +convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) + where MungedPackageId mpn ver = mungedId ipi + -- HACK. See Note [Index conversion with internal libraries] + pn = encodeCompatPackageName mpn + +-- | Convert a single installed package into the solver-specific format. +convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) +convIP idx ipi = + case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of + Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) + Right fds -> (pn, i, PInfo fds components M.empty Nothing) + where + -- TODO: Handle sub-libraries and visibility. + components = + M.singleton (ExposedLib LMainLibName) + ComponentInfo { + compIsVisible = IsVisible True + , compIsBuildable = IsBuildable True + } + + (pn, i) = convId ipi + + -- 'sourceLibName' is unreliable, but for now we only really use this for + -- primary libs anyways + comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi +-- TODO: Installed packages should also store their encapsulations! + +-- Note [Index conversion with internal libraries] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Something very interesting happens when we have internal libraries +-- in our index. In this case, we maybe have p-0.1, which itself +-- depends on the internal library p-internal ALSO from p-0.1. +-- Here's the danger: +-- +-- - If we treat both of these packages as having PN "p", +-- then the solver will try to pick one or the other, +-- but never both. +-- +-- - If we drop the internal packages, now p-0.1 has a +-- dangling dependency on an "installed" package we know +-- nothing about. Oops. +-- +-- An expedient hack is to put p-internal into cabal-install's +-- index as a MUNGED package name, so that it doesn't conflict +-- with anyone else (except other instances of itself). But +-- yet, we ought NOT to say that PNs in the solver are munged +-- package names, because they're not; for source packages, +-- we really will never see munged package names. +-- +-- The tension here is that the installed package index is actually +-- per library, but the solver is per package. We need to smooth +-- it over, and munging the package names is a pretty good way to +-- do it. + +-- | Convert dependencies specified by an installed package id into +-- flagged dependencies of the solver. +-- +-- May return Nothing if the package can't be found in the index. That +-- indicates that the original package having this dependency is broken +-- and should be ignored. +convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) +convIPId dr comp idx ipid = + case SI.lookupUnitId idx ipid of + Nothing -> Left ipid + Just ipi -> let (pn, i) = convId ipi + name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. + in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) + -- NB: something we pick up from the + -- InstalledPackageIndex is NEVER an executable + +-- | Convert a cabal-install source package index to the simpler, +-- more uniform index format of the solver. +convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables + -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] +convSPI' os arch cinfo constraints strfl solveExes = + L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages + +-- | Convert a single source package into the solver-specific format. +convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) +convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = + let i = I pv InRepo + pkgConstraints = fromMaybe [] $ M.lookup pn constraints + in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) + +-- We do not use 'flattenPackageDescription' or 'finalizePD' +-- from 'Distribution.PackageDescription.Configuration' here, because we +-- want to keep the condition tree, but simplify much of the test. + +-- | Convert a generic package description to a solver-specific 'PInfo'. +convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription + -> PInfo +convGPD os arch cinfo constraints strfl solveExes pn + (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) = + let + fds = flagInfo strfl flags + + + conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN -> + CondTree ConfVar [Dependency] a -> FlaggedDeps PN + conv comp getInfo dr = + convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes . + addBuildableCondition getInfo + + initDR = DependencyReason pn M.empty S.empty + + flagged_deps + = concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) + ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs + ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs + ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes + ++ prefix (Stanza (SN pn TestStanzas)) + (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) + tests) + ++ prefix (Stanza (SN pn BenchStanzas)) + (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) + benchs) + ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) + + addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn + addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) + + -- | A too-new specVersion is turned into a global 'FailReason' + -- which prevents the solver from selecting this release (and if + -- forced to, emit a meaningful solver error message). + fr = case scannedVersion of + Just ver -> Just (UnsupportedSpecVer ver) + Nothing -> Nothing + + components :: Map ExposedComponent ComponentInfo + components = M.fromList $ libComps ++ subLibComps ++ exeComps + where + libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib) + | lib <- maybeToList mlib ] + subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib) + | (name, lib) <- sub_libs ] + exeComps = [ ( ExposedExe name + , ComponentInfo { + compIsVisible = IsVisible True + , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False + } + ) + | (name, exe) <- exes ] + + libToComponentInfo lib = + ComponentInfo { + compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True + , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False + } + + testCondition = testConditionForComponent os arch cinfo constraints + + isPrivate LibraryVisibilityPrivate = True + isPrivate LibraryVisibilityPublic = False + + in PInfo flagged_deps components fds fr + +-- | Applies the given predicate (for example, testing buildability or +-- visibility) to the given component and environment. Values are combined with +-- AND. This function returns 'Nothing' when the result cannot be determined +-- before dependency solving. Additionally, this function only considers flags +-- that are set by unqualified flag constraints, and it doesn't check the +-- intra-package dependencies of a component. +testConditionForComponent :: OS + -> Arch + -> CompilerInfo + -> [LabeledPackageConstraint] + -> (a -> Bool) + -> CondTree ConfVar [Dependency] a + -> Maybe Bool +testConditionForComponent os arch cinfo constraints p tree = + case go $ extractCondition p tree of + Lit True -> Just True + Lit False -> Just False + _ -> Nothing + where + flagAssignment :: [(FlagName, Bool)] + flagAssignment = + mconcat [ unFlagAssignment fa + | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) + <- L.map unlabelPackageConstraint constraints] + + -- Simplify the condition, using the current environment. Most of this + -- function was copied from convBranch and + -- Distribution.Types.Condition.simplifyCondition. + go :: Condition ConfVar -> Condition ConfVar + go (Var (OS os')) = Lit (os == os') + go (Var (Arch arch')) = Lit (arch == arch') + go (Var (Impl cf cvr)) + | matchImpl (compilerInfoId cinfo) || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True + | otherwise = Lit False + where + matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + go (Var (PackageFlag f)) + | Just b <- L.lookup f flagAssignment = Lit b + go (Var v) = Var v + go (Lit b) = Lit b + go (CNot c) = + case go c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + go (COr c d) = + case (go c, go d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c', d') -> COr c' d' + go (CAnd c d) = + case (go c, go d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c', d') -> CAnd c' d' + +-- | Create a flagged dependency tree from a list @fds@ of flagged +-- dependencies, using @f@ to form the tree node (@f@ will be +-- something like @Stanza sn@). +prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) + -> [FlaggedDeps qpn] -> FlaggedDeps qpn +prefix _ [] = [] +prefix f fds = [f (concat fds)] + +-- | Convert flag information. Automatic flags are now considered weak +-- unless strong flags have been selected explicitly. +flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo +flagInfo (StrongFlags strfl) = + M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) + where + weak m = WeakOrTrivial $ not (strfl || m) + flagType m = if m then Manual else Automatic + +-- | Convert condition trees to flagged dependencies. Mutually +-- recursive with 'convBranch'. See 'convBranch' for an explanation +-- of all arguments preceding the input 'CondTree'. +convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> + Component -> + (a -> BuildInfo) -> + SolveExecutables -> + CondTree ConfVar [Dependency] a -> FlaggedDeps PN +convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) = + -- Merge all library and build-tool dependencies at every level in + -- the tree of flagged dependencies. Otherwise 'extractCommon' + -- could create duplicate dependencies, and the number of + -- duplicates could grow exponentially from the leaves to the root + -- of the tree. + mergeSimpleDeps $ + [ D.Simple singleDep comp + | dep <- ds + , singleDep <- convLibDeps dr dep ] -- unconditional package dependencies + + ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies + ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages bi) -- unconditional language dependencies + ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies + ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches + -- build-tools dependencies + -- NB: Only include these dependencies if SolveExecutables + -- is True. It might be false in the legacy solver + -- codepath, in which case there won't be any record of + -- an executable we need. + ++ [ D.Simple (convExeDep dr exeDep) comp + | solveExes' + , exeDep <- getAllToolDependencies pkg bi + , not $ isInternal pkg exeDep + ] + where + bi = getInfo info + +data SimpleFlaggedDepKey qpn = + SimpleFlaggedDepKey (PkgComponent qpn) Component + deriving (Eq, Ord) + +data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR + +-- | Merge 'Simple' dependencies that apply to the same library or build-tool. +-- This function should be able to merge any two dependencies that can be merged +-- by extractCommon, in order to prevent the exponential growth of dependencies. +-- +-- Note that this function can merge dependencies that have different +-- DependencyReasons, which can make the DependencyReasons less precise. This +-- loss of precision only affects performance and log messages, not correctness. +-- However, when 'mergeSimpleDeps' is only called on dependencies at a single +-- location in the dependency tree, the only difference between +-- DependencyReasons should be flags that have value FlagBoth. Adding extra +-- flags with value FlagBoth should not affect performance, since they are not +-- added to the conflict set. The only downside is the possibility of the log +-- incorrectly saying that the flag contributed to excluding a specific version +-- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB +-- introduces pkg <5, the merged dependency would mean that +-- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply +-- that +/-flagA excludes pkg-6. +mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn +mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged + where + (merged, unmerged) = L.foldl' f (M.empty, []) deps + where + f :: Ord qpn + => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) + -> FlaggedDep qpn + -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) + f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) = + ( M.insertWith mergeValues + (SimpleFlaggedDepKey dep comp) + (SimpleFlaggedDepValue dr vr) + merged' + , unmerged') + f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged') + + mergeValues :: SimpleFlaggedDepValue qpn + -> SimpleFlaggedDepValue qpn + -> SimpleFlaggedDepValue qpn + mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) = + SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2) + + toFlaggedDep :: SimpleFlaggedDepKey qpn + -> SimpleFlaggedDepValue qpn + -> FlaggedDep qpn + toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) = + D.Simple (LDep dr (Dep dep (Constrained vr))) comp + +-- | Branch interpreter. Mutually recursive with 'convCondTree'. +-- +-- Here, we try to simplify one of Cabal's condition tree branches into the +-- solver's flagged dependency format, which is weaker. Condition trees can +-- contain complex logical expression composed from flag choices and special +-- flags (such as architecture, or compiler flavour). We try to evaluate the +-- special flags and subsequently simplify to a tree that only depends on +-- simple flag choices. +-- +-- This function takes a number of arguments: +-- +-- 1. A map of flag values that have already been chosen. It allows +-- convBranch to avoid creating nested FlaggedDeps that are +-- controlled by the same flag and avoid creating DependencyReasons with +-- conflicting values for the same flag. +-- +-- 2. The DependencyReason calculated at this point in the tree of +-- conditionals. The flag values in the DependencyReason are similar to +-- the values in the map above, except for the use of FlagBoth. +-- +-- 3. Some pre dependency-solving known information ('OS', 'Arch', +-- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, +-- +-- 4. The package name @'PN'@ which this condition tree +-- came from, so that we can correctly associate @flag()@ +-- variables with the correct package name qualifier, +-- +-- 5. The flag defaults 'FlagInfo' so that we can populate +-- 'Flagged' dependencies with 'FInfo', +-- +-- 6. The name of the component 'Component' so we can record where +-- the fine-grained information about where the component came +-- from (see 'convCondTree'), and +-- +-- 7. A selector to extract the 'BuildInfo' from the leaves of +-- the 'CondTree' (which actually contains the needed +-- dependency information.) +-- +-- 8. The set of package names which should be considered internal +-- dependencies, and thus not handled as dependencies. +convBranch :: Map FlagName Bool + -> DependencyReason PN + -> PackageDescription + -> OS + -> Arch + -> CompilerInfo + -> PN + -> FlagInfo + -> Component + -> (a -> BuildInfo) + -> SolveExecutables + -> CondBranch ConfVar [Dependency] a + -> FlaggedDeps PN +convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') = + go c' + (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes t') + (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf') + flags dr + where + go :: Condition ConfVar + -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) + -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) + -> Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN + go (Lit True) t _ = t + go (Lit False) _ f = f + go (CNot c) t f = go c f t + go (CAnd c d) t f = go c (go d t f) f + go (COr c d) t f = go c t (go d t f) + go (Var (PackageFlag fn)) t f = \flags' -> + case M.lookup fn flags' of + Just True -> t flags' + Just False -> f flags' + Nothing -> \dr' -> + -- Add each flag to the DependencyReason for all dependencies below, + -- including any extracted dependencies. Extracted dependencies are + -- introduced by both flag values (FlagBoth). Note that we don't + -- actually need to add the flag to the extracted dependencies for + -- correct backjumping; the information only improves log messages + -- by giving the user the full reason for each dependency. + let addFlagValue v = addFlagToDependencyReason fn v dr' + addFlag v = M.insert fn v flags' + in extractCommon (t (addFlag True) (addFlagValue FlagBoth)) + (f (addFlag False) (addFlagValue FlagBoth)) + ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True) (addFlagValue FlagTrue)) + (f (addFlag False) (addFlagValue FlagFalse)) ] + go (Var (OS os')) t f + | os == os' = t + | otherwise = f + go (Var (Arch arch')) t f + | arch == arch' = t + | otherwise = f + go (Var (Impl cf cvr)) t f + | matchImpl (compilerInfoId cinfo) || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t + | otherwise = f + where + matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + + addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn + addFlagToDependencyReason fn v (DependencyReason pn' fs ss) = + DependencyReason pn' (M.insert fn v fs) ss + + -- If both branches contain the same package as a simple dep, we lift it to + -- the next higher-level, but with the union of version ranges. This + -- heuristic together with deferring flag choices will then usually first + -- resolve this package, and try an already installed version before imposing + -- a default flag choice that might not be what we want. + -- + -- Note that we make assumptions here on the form of the dependencies that + -- can occur at this point. In particular, no occurrences of Fixed, as all + -- dependencies below this point have been generated using 'convLibDep'. + -- + -- WARNING: This is quadratic! + extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn + extractCommon ps ps' = + -- Union the DependencyReasons, because the extracted dependency can be + -- avoided by removing the dependency from either side of the + -- conditional. + [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp + | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps + , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps' + , dep1 == dep2 + ] + +-- | Merge DependencyReasons by unioning their variables. +unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn +unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = + DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) + +-- | Convert a Cabal dependency on a set of library components (from a single +-- package) to solver-specific dependencies. +convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN] +convLibDeps dr (Dependency pn vr libs) = + [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr) + | lib <- NonEmptySet.toList libs ] + +-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. +convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN +convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr) + +-- | Convert setup dependencies +convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN +convSetupBuildInfo pn nfo = + [ D.Simple singleDep ComponentSetup + | dep <- setupDepends nfo + , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ] diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs b/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs @@ -0,0 +1,117 @@ +-- | Wrapper around Data.Graph with support for edge labels +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.LabeledGraph ( + -- * Graphs + Graph + , Vertex + -- ** Building graphs + , graphFromEdges + , graphFromEdges' + , buildG + , transposeG + -- ** Graph properties + , vertices + , edges + -- ** Operations on the underlying unlabeled graph + , forgetLabels + , topSort + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Data.Array +import Data.Graph (Vertex, Bounds) +import qualified Data.Graph as G + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +type Graph e = Array Vertex [(e, Vertex)] +type Edge e = (Vertex, e, Vertex) + +{------------------------------------------------------------------------------- + Building graphs +-------------------------------------------------------------------------------} + +-- | Construct an edge-labeled graph +-- +-- This is a simple adaptation of the definition in Data.Graph +graphFromEdges :: forall key node edge. Ord key + => [ (node, key, [(edge, key)]) ] + -> ( Graph edge + , Vertex -> (node, key, [(edge, key)]) + , key -> Maybe Vertex + ) +graphFromEdges edges0 = + (graph, \v -> vertex_map ! v, key_vertex) + where + max_v = length edges0 - 1 + bounds0 = (0, max_v) :: (Vertex, Vertex) + sorted_edges = sortBy lt edges0 + edges1 = zip [0..] sorted_edges + + graph = array bounds0 [(v, (mapMaybe mk_edge ks)) + | (v, (_, _, ks)) <- edges1] + key_map = array bounds0 [(v, k ) + | (v, (_, k, _ )) <- edges1] + vertex_map = array bounds0 edges1 + + (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 + + mk_edge :: (edge, key) -> Maybe (edge, Vertex) + mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v) + + -- returns Nothing for non-interesting vertices + key_vertex :: key -> Maybe Vertex + key_vertex k = findVertex 0 max_v + where + findVertex a b + | a > b = Nothing + | otherwise = case compare k (key_map ! mid) of + LT -> findVertex a (mid-1) + EQ -> Just mid + GT -> findVertex (mid+1) b + where + mid = a + (b - a) `div` 2 + +graphFromEdges' :: Ord key + => [ (node, key, [(edge, key)]) ] + -> ( Graph edge + , Vertex -> (node, key, [(edge, key)]) + ) +graphFromEdges' x = (a,b) + where + (a,b,_) = graphFromEdges x + +transposeG :: Graph e -> Graph e +transposeG g = buildG (bounds g) (reverseE g) + +buildG :: Bounds -> [Edge e] -> Graph e +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) + where + reassoc (v, e, w) = (v, (e, w)) + +reverseE :: Graph e -> [Edge e] +reverseE g = [ (w, e, v) | (v, e, w) <- edges g ] + +{------------------------------------------------------------------------------- + Graph properties +-------------------------------------------------------------------------------} + +vertices :: Graph e -> [Vertex] +vertices = indices + +edges :: Graph e -> [Edge e] +edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ] + +{------------------------------------------------------------------------------- + Operations on the underlying unlabelled graph +-------------------------------------------------------------------------------} + +forgetLabels :: Graph e -> G.Graph +forgetLabels = fmap (map snd) + +topSort :: Graph e -> [Vertex] +topSort = G.topSort . forgetLabels diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- TODO: remove this +{-# OPTIONS -fno-warn-incomplete-uni-patterns #-} +module Distribution.Solver.Modular.Linking ( + validateLinking + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (get,put) + +import Control.Exception (assert) +import Control.Monad.Reader +import Control.Monad.State +import Data.Map ((!)) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Traversable as T + +import Distribution.Client.Utils.Assertion +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.ConflictSet as CS +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath +import Distribution.Types.Flag (unFlagName) + +{------------------------------------------------------------------------------- + Validation + + Validation of links is a separate pass that's performed after normal + validation. Validation of links checks that if the tree indicates that a + package is linked, then everything underneath that choice really matches the + package we have linked to. + + This is interesting because it isn't unidirectional. Consider that we've + chosen a.foo to be version 1 and later decide that b.foo should link to a.foo. + Now foo depends on bar. Because a.foo and b.foo are linked, it's required that + a.bar and b.bar are also linked. However, it's not required that we actually + choose a.bar before b.bar. Goal choice order is relatively free. It's possible + that we choose a.bar first, but also possible that we choose b.bar first. In + both cases, we have to recognize that we have freedom of choice for the first + of the two, but no freedom of choice for the second. + + This is what LinkGroups are all about. Using LinkGroup, we can record (in the + situation above) that a.bar and b.bar need to be linked even if we haven't + chosen either of them yet. +-------------------------------------------------------------------------------} + +data ValidateState = VS { + vsIndex :: Index + , vsLinks :: Map QPN LinkGroup + , vsFlags :: FAssignment + , vsStanzas :: SAssignment + , vsQualifyOptions :: QualifyOptions + + -- Saved qualified dependencies. Every time 'validateLinking' makes a + -- package choice, it qualifies the package's dependencies and saves them in + -- this map. Then the qualified dependencies are available for subsequent + -- flag and stanza choices for the same package. + , vsSaved :: Map QPN (FlaggedDeps QPN) + } + +type Validate = Reader ValidateState + +-- | Validate linked packages +-- +-- Verify that linked packages have +-- +-- * Linked dependencies, +-- * Equal flag assignments +-- * Equal stanza assignments +validateLinking :: Index -> Tree d c -> Tree d c +validateLinking index = (`runReader` initVS) . cata go + where + go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) + + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr <$> T.sequence (W.mapWithKey (goP qpn) cs) + go (FChoiceF qfn rdm gr t m d cs) = + FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs) + go (SChoiceF qsn rdm gr t cs) = + SChoice qsn rdm gr t <$> T.sequence (W.mapWithKey (goS qsn) cs) + + -- For the other nodes we just recurse + go (GoalChoiceF rdm cs) = GoalChoice rdm <$> T.sequence cs + go (DoneF revDepMap s) = return $ Done revDepMap s + go (FailF conflictSet failReason) = return $ Fail conflictSet failReason + + -- Package choices + goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) + goP qpn@(Q _pp pn) opt@(POption i _) r = do + vs <- ask + let PInfo deps _ _ _ = vsIndex vs ! pn ! i + qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + newSaved = M.insert qpn qdeps (vsSaved vs) + case execUpdateState (pickPOption qpn opt qdeps) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs' { vsSaved = newSaved }) r + + -- Flag choices + goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goF qfn b r = do + vs <- ask + case execUpdateState (pickFlag qfn b) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r + + -- Stanza choices (much the same as flag choices) + goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goS qsn b r = do + vs <- ask + case execUpdateState (pickStanza qsn b) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r + + initVS :: ValidateState + initVS = VS { + vsIndex = index + , vsLinks = M.empty + , vsFlags = M.empty + , vsStanzas = M.empty + , vsQualifyOptions = defaultQualifyOptions index + , vsSaved = M.empty + } + +{------------------------------------------------------------------------------- + Updating the validation state +-------------------------------------------------------------------------------} + +type Conflict = (ConflictSet, String) + +newtype UpdateState a = UpdateState { + unUpdateState :: StateT ValidateState (Either Conflict) a + } + deriving (Functor, Applicative, Monad) + +instance MonadState ValidateState UpdateState where + get = UpdateState $ get + put st = UpdateState $ do + expensiveAssert (lgInvariant $ vsLinks st) $ return () + put st + +lift' :: Either Conflict a -> UpdateState a +lift' = UpdateState . lift + +conflict :: Conflict -> UpdateState a +conflict = lift' . Left + +execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState +execUpdateState = execStateT . unUpdateState + +pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () +pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i +pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps + +pickConcrete :: QPN -> I -> UpdateState () +pickConcrete qpn@(Q pp _) i = do + vs <- get + case M.lookup qpn (vsLinks vs) of + -- Package is not yet in a LinkGroup. Create a new singleton link group. + Nothing -> do + let lg = lgSingleton qpn (Just $ PI pp i) + updateLinkGroup lg + + -- Package is already in a link group. Since we are picking a concrete + -- instance here, it must by definition be the canonical package. + Just lg -> + makeCanonical lg qpn i + +pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () +pickLink qpn@(Q _pp pn) i pp' deps = do + vs <- get + + -- The package might already be in a link group + -- (because one of its reverse dependencies is) + let lgSource = case M.lookup qpn (vsLinks vs) of + Nothing -> lgSingleton qpn Nothing + Just lg -> lg + + -- Find the link group for the package we are linking to + -- + -- Since the builder never links to a package without having first picked a + -- concrete instance for that package, and since we create singleton link + -- groups for concrete instances, this link group must exist (and must + -- in fact already have a canonical member). + let target = Q pp' pn + lgTarget = vsLinks vs ! target + + -- Verify here that the member we add is in fact for the same package and + -- matches the version of the canonical instance. However, violations of + -- these checks would indicate a bug in the linker, not a true conflict. + let sanityCheck :: Maybe (PI PackagePath) -> Bool + sanityCheck Nothing = False + sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI + assert (sanityCheck (lgCanon lgTarget)) $ return () + + -- Merge the two link groups (updateLinkGroup will propagate the change) + lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget + updateLinkGroup lgTarget' + + -- Make sure all dependencies are linked as well + linkDeps target deps + +makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () +makeCanonical lg qpn@(Q pp _) i = + case lgCanon lg of + -- There is already a canonical member. Fail. + Just _ -> + conflict ( CS.insert (P qpn) (lgConflictSet lg) + , "cannot make " ++ showQPN qpn + ++ " canonical member of " ++ showLinkGroup lg + ) + Nothing -> do + let lg' = lg { lgCanon = Just (PI pp i) } + updateLinkGroup lg' + +-- | Link the dependencies of linked parents. +-- +-- When we decide to link one package against another we walk through the +-- package's direct depedencies and make sure that they're all linked to each +-- other by merging their link groups (or creating new singleton link groups if +-- they don't have link groups yet). We do not need to do this recursively, +-- because having the direct dependencies in a link group means that we must +-- have already made or will make sooner or later a link choice for one of these +-- as well, and cover their dependencies at that point. +linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState () +linkDeps target = \deps -> do + -- linkDeps is called in two places: when we first link one package to + -- another, and when we discover more dependencies of an already linked + -- package after doing some flag assignment. It is therefore important that + -- flag assignments cannot influence _how_ dependencies are qualified; + -- fortunately this is a documented property of 'qualifyDeps'. + rdeps <- requalify deps + go deps rdeps + where + go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState () + go = zipWithM_ go1 + + go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () + go1 dep rdep = case (dep, rdep) of + (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do + vs <- get + let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs + lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs + lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' + updateLinkGroup lg'' + (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do + vs <- get + case M.lookup fn (vsFlags vs) of + Nothing -> return () -- flag assignment not yet known + Just True -> go t t' + Just False -> go f f' + (Stanza sn t, ~(Stanza _ t')) -> do + vs <- get + case M.lookup sn (vsStanzas vs) of + Nothing -> return () -- stanza assignment not yet known + Just True -> go t t' + Just False -> return () -- stanza not enabled; no new deps + -- For extensions and language dependencies, there is nothing to do. + -- No choice is involved, just checking, so there is nothing to link. + -- The same goes for pkg-config constraints. + (Simple (LDep _ (Ext _)) _, _) -> return () + (Simple (LDep _ (Lang _)) _, _) -> return () + (Simple (LDep _ (Pkg _ _)) _, _) -> return () + + requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) + requalify deps = do + vs <- get + return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) + +pickFlag :: QFN -> Bool -> UpdateState () +pickFlag qfn b = do + modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) } + verifyFlag qfn + linkNewDeps (F qfn) b + +pickStanza :: QSN -> Bool -> UpdateState () +pickStanza qsn b = do + modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) } + verifyStanza qsn + linkNewDeps (S qsn) b + +-- | Link dependencies that we discover after making a flag or stanza choice. +-- +-- When we make a flag choice for a package, then new dependencies for that +-- package might become available. If the package under consideration is in a +-- non-trivial link group, then these new dependencies have to be linked as +-- well. In linkNewDeps, we compute such new dependencies and make sure they are +-- linked. +linkNewDeps :: Var QPN -> Bool -> UpdateState () +linkNewDeps var b = do + vs <- get + let qpn@(Q pp pn) = varPN var + qdeps = vsSaved vs ! qpn + lg = vsLinks vs ! qpn + newDeps = findNewDeps vs qdeps + linkedTo = S.delete pp (lgMembers lg) + forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps + where + findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN + findNewDeps vs = concatMap (findNewDeps' vs) + + findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN + findNewDeps' _ (Simple _ _) = [] + findNewDeps' vs (Flagged qfn _ t f) = + case (F qfn == var, M.lookup qfn (vsFlags vs)) of + (True, _) -> if b then t else f + (_, Nothing) -> [] -- not yet known + (_, Just b') -> findNewDeps vs (if b' then t else f) + findNewDeps' vs (Stanza qsn t) = + case (S qsn == var, M.lookup qsn (vsStanzas vs)) of + (True, _) -> if b then t else [] + (_, Nothing) -> [] -- not yet known + (_, Just b') -> findNewDeps vs (if b' then t else []) + +updateLinkGroup :: LinkGroup -> UpdateState () +updateLinkGroup lg = do + verifyLinkGroup lg + modify $ \vs -> vs { + vsLinks = M.fromList (map aux (S.toList (lgMembers lg))) + `M.union` vsLinks vs + } + where + aux pp = (Q pp (lgPackage lg), lg) + +{------------------------------------------------------------------------------- + Verification +-------------------------------------------------------------------------------} + +verifyLinkGroup :: LinkGroup -> UpdateState () +verifyLinkGroup lg = + case lgInstance lg of + -- No instance picked yet. Nothing to verify + Nothing -> + return () + + -- We picked an instance. Verify flags and stanzas + -- TODO: The enumeration of OptionalStanza names is very brittle; + -- if a constructor is added to the datatype we won't notice it here + Just i -> do + vs <- get + let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i + flags = M.keys finfo + stanzas = [TestStanzas, BenchStanzas] + forM_ flags $ \fn -> do + let flag = FN (lgPackage lg) fn + verifyFlag' flag lg + forM_ stanzas $ \sn -> do + let stanza = SN (lgPackage lg) sn + verifyStanza' stanza lg + +verifyFlag :: QFN -> UpdateState () +verifyFlag (FN qpn@(Q _pp pn) fn) = do + vs <- get + -- We can only pick a flag after picking an instance; link group must exist + verifyFlag' (FN pn fn) (vsLinks vs ! qpn) + +verifyStanza :: QSN -> UpdateState () +verifyStanza (SN qpn@(Q _pp pn) sn) = do + vs <- get + -- We can only pick a stanza after picking an instance; link group must exist + verifyStanza' (SN pn sn) (vsLinks vs ! qpn) + +-- | Verify that all packages in the link group agree on flag assignments +-- +-- For the given flag and the link group, obtain all assignments for the flag +-- that have already been made for link group members, and check that they are +-- equal. +verifyFlag' :: FN PN -> LinkGroup -> UpdateState () +verifyFlag' (FN pn fn) lg = do + vs <- get + let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) + vals = map (`M.lookup` vsFlags vs) flags + if allEqual (catMaybes vals) -- We ignore not-yet assigned flags + then return () + else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg + , "flag \"" ++ unFlagName fn ++ "\" incompatible" + ) + +-- | Verify that all packages in the link group agree on stanza assignments +-- +-- For the given stanza and the link group, obtain all assignments for the +-- stanza that have already been made for link group members, and check that +-- they are equal. +-- +-- This function closely mirrors 'verifyFlag''. +verifyStanza' :: SN PN -> LinkGroup -> UpdateState () +verifyStanza' (SN pn sn) lg = do + vs <- get + let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) + vals = map (`M.lookup` vsStanzas vs) stanzas + if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas + then return () + else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg + , "stanza \"" ++ showStanza sn ++ "\" incompatible" + ) + +{------------------------------------------------------------------------------- + Link groups +-------------------------------------------------------------------------------} + +-- | Set of packages that must be linked together +-- +-- A LinkGroup is between several qualified package names. In the validation +-- state, we maintain a map vsLinks from qualified package names to link groups. +-- There is an invariant that for all members of a link group, vsLinks must map +-- to the same link group. The function updateLinkGroup can be used to +-- re-establish this invariant after creating or expanding a LinkGroup. +data LinkGroup = LinkGroup { + -- | The name of the package of this link group + lgPackage :: PN + + -- | The canonical member of this link group (the one where we picked + -- a concrete instance). Once we have picked a canonical member, all + -- other packages must link to this one. + -- + -- We may not know this yet (if we are constructing link groups + -- for dependencies) + , lgCanon :: Maybe (PI PackagePath) + + -- | The members of the link group + , lgMembers :: Set PackagePath + + -- | The set of variables that should be added to the conflict set if + -- something goes wrong with this link set (in addition to the members + -- of the link group itself) + , lgBlame :: ConflictSet + } + deriving (Show, Eq) + +-- | Invariant for the set of link groups: every element in the link group +-- must be pointing to the /same/ link group +lgInvariant :: Map QPN LinkGroup -> Bool +lgInvariant links = all invGroup (M.elems links) + where + invGroup :: LinkGroup -> Bool + invGroup lg = allEqual $ map (`M.lookup` links) members + where + members :: [QPN] + members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg) + +-- | Package version of this group +-- +-- This is only known once we have picked a canonical element. +lgInstance :: LinkGroup -> Maybe I +lgInstance = fmap (\(PI _ i) -> i) . lgCanon + +showLinkGroup :: LinkGroup -> String +showLinkGroup lg = + "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" + where + showMember :: PackagePath -> String + showMember pp = case lgCanon lg of + Just (PI pp' _i) | pp == pp' -> "*" + _otherwise -> "" + ++ case lgInstance lg of + Nothing -> showQPN (qpn pp) + Just i -> showPI (PI (qpn pp) i) + + qpn :: PackagePath -> QPN + qpn pp = Q pp (lgPackage lg) + +-- | Creates a link group that contains a single member. +lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup +lgSingleton (Q pp pn) canon = LinkGroup { + lgPackage = pn + , lgCanon = canon + , lgMembers = S.singleton pp + , lgBlame = CS.empty + } + +lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup +lgMerge blame lg lg' = do + canon <- pick (lgCanon lg) (lgCanon lg') + return LinkGroup { + lgPackage = lgPackage lg + , lgCanon = canon + , lgMembers = lgMembers lg `S.union` lgMembers lg' + , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] + } + where + pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) + pick Nothing Nothing = Right Nothing + pick (Just x) Nothing = Right $ Just x + pick Nothing (Just y) = Right $ Just y + pick (Just x) (Just y) = + if x == y then Right $ Just x + else Left ( CS.unions [ + blame + , lgConflictSet lg + , lgConflictSet lg' + ] + , "cannot merge " ++ showLinkGroup lg + ++ " and " ++ showLinkGroup lg' + ) + +lgConflictSet :: LinkGroup -> ConflictSet +lgConflictSet lg = + CS.fromList (map aux (S.toList (lgMembers lg))) + `CS.union` lgBlame lg + where + aux pp = P (Q pp (lgPackage lg)) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +allEqual :: Eq a => [a] -> Bool +allEqual [] = True +allEqual [_] = True +allEqual (x:y:ys) = x == y && allEqual (y:ys) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs @@ -0,0 +1,31 @@ +module Distribution.Solver.Modular.Log + ( displayLogMessages + , SolverFailure(..) + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import Distribution.Solver.Types.Progress + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.RetryLog + +-- | Information about a dependency solver failure. +data SolverFailure = + ExhaustiveSearch ConflictSet ConflictMap + | BackjumpLimitReached + +-- | Postprocesses a log file. This function discards all log messages and +-- avoids calling 'showMessages' if the log isn't needed (specified by +-- 'keepLog'), for efficiency. +displayLogMessages :: Bool + -> RetryLog Message SolverFailure a + -> RetryLog String SolverFailure a +displayLogMessages keepLog lg = fromProgress $ + if keepLog + then showMessages progress + else foldProgress (const id) Fail Done progress + where + progress = toProgress lg diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE BangPatterns #-} + +module Distribution.Solver.Modular.Message ( + Message(..), + showMessages + ) where + +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Maybe (catMaybes, mapMaybe) +import Prelude hiding (pi) + +import Distribution.Pretty (prettyShow) -- from Cabal + +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree + ( FailReason(..), POption(..), ConflictingDep(..) ) +import Distribution.Solver.Modular.Version +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Progress +import Distribution.Types.LibraryName +import Distribution.Types.UnqualComponentName + +data Message = + Enter -- ^ increase indentation level + | Leave -- ^ decrease indentation level + | TryP QPN POption + | TryF QFN Bool + | TryS QSN Bool + | Next (Goal QPN) + | Skip (Set CS.Conflict) + | Success + | Failure ConflictSet FailReason + +-- | Transforms the structured message type to actual messages (strings). +-- +-- The log contains level numbers, which are useful for any trace that involves +-- backtracking, because only the level numbers will allow to keep track of +-- backjumps. +showMessages :: Progress Message a b -> Progress String a b +showMessages = go 0 + where + -- 'go' increments the level for a recursive call when it encounters + -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'. + go :: Int -> Progress Message a b -> Progress String a b + go !_ (Done x) = Done x + go !_ (Fail x) = Fail x + -- complex patterns + go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + goPReject l qpn [i] c fr ms + go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) = + goPSkip l qpn [i] conflicts ms + go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms) + go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) + go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = + (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) + go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) = + (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms + -- standard display + go !l (Step Enter ms) = go (l+1) ms + go !l (Step Leave ms) = go (l-1) ms + go !l (Step (TryP qpn i) ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms) + go !l (Step (TryF qfn b) ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms) + go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms) + go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms) + go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log + go !l (Step (Skip conflicts) ms) = + -- 'Skip' should always be handled by 'goPSkip' in the case above. + (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms) + go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms) + go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms) + + showPackageGoal :: QPN -> QGoalReason -> String + showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr + + showFailure :: ConflictSet -> FailReason -> String + showFailure c fr = "fail" ++ showFR c fr + + -- special handler for many subsequent package rejections + goPReject :: Int + -> QPN + -> [POption] + -> ConflictSet + -> FailReason + -> Progress Message a b + -> Progress String a b + goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) + | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms + goPReject l qpn is c fr ms = + (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) + + -- Handle many subsequent skipped package instances. + goPSkip :: Int + -> QPN + -> [POption] + -> Set CS.Conflict + -> Progress Message a b + -> Progress String a b + goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms)))) + | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms + goPSkip l qpn is conflicts ms = + let msg = "skipping: " + ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) + ++ showConflicts conflicts + in atLevel l msg (go l ms) + + -- write a message with the current level number + atLevel :: Int -> String -> Progress String a b -> Progress String a b + atLevel l x xs = + let s = show l + in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs + +-- | Display the set of 'Conflicts' for a skipped package version. +showConflicts :: Set CS.Conflict -> String +showConflicts conflicts = + " (has the same characteristics that caused the previous version to fail: " + ++ conflictMsg ++ ")" + where + conflictMsg :: String + conflictMsg = + if S.member CS.OtherConflict conflicts + then + -- This case shouldn't happen, because an unknown conflict should not + -- cause a version to be skipped. + "unknown conflict" + else let mergedConflicts = + [ showConflict qpn conflict + | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ] + in if L.null mergedConflicts + then + -- This case shouldn't happen unless backjumping is turned off. + "none" + else L.intercalate "; " mergedConflicts + + -- Merge conflicts to simplify the log message. + mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict + mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList + where + mergeConflict :: MergedPackageConflict + -> MergedPackageConflict + -> MergedPackageConflict + mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict { + isGoalConflict = + isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 + , versionConstraintConflict = + L.nub $ versionConstraintConflict mergedConflict1 + ++ versionConstraintConflict mergedConflict2 + , versionConflict = + mergeVersionConflicts (versionConflict mergedConflict1) + (versionConflict mergedConflict2) + } + where + mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2) + mergeVersionConflicts (Just vr1) Nothing = Just vr1 + mergeVersionConflicts Nothing (Just vr2) = Just vr2 + mergeVersionConflicts Nothing Nothing = Nothing + + toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict) + toMergedConflict (CS.GoalConflict qpn) = + Just (qpn, MergedPackageConflict True [] Nothing) + toMergedConflict (CS.VersionConstraintConflict qpn v) = + Just (qpn, MergedPackageConflict False [v] Nothing) + toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) = + Just (qpn, MergedPackageConflict False [] (Just vr)) + toMergedConflict CS.OtherConflict = Nothing + + showConflict :: QPN -> MergedPackageConflict -> String + showConflict qpn mergedConflict = L.intercalate "; " conflictStrings + where + conflictStrings = catMaybes [ + case () of + () | isGoalConflict mergedConflict -> Just $ + "depends on '" ++ showQPN qpn ++ "'" ++ + (if null (versionConstraintConflict mergedConflict) + then "" + else " but excludes " + ++ showVersions (versionConstraintConflict mergedConflict)) + | not $ L.null (versionConstraintConflict mergedConflict) -> Just $ + "excludes '" ++ showQPN qpn + ++ "' " ++ showVersions (versionConstraintConflict mergedConflict) + | otherwise -> Nothing + , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") + <$> versionConflict mergedConflict + ] + + showVersions [] = "no versions" + showVersions [v] = "version " ++ showVer v + showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) + +-- | All conflicts related to one package, used for simplifying the display of +-- a 'Set CS.Conflict'. +data MergedPackageConflict = MergedPackageConflict { + isGoalConflict :: Bool + , versionConstraintConflict :: [Ver] + , versionConflict :: Maybe VR + } + +showQPNPOpt :: QPN -> POption -> String +showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = + case linkedTo of + Nothing -> showPI (PI qpn i) -- Consistent with prior to POption + Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) + +showGR :: QGoalReason -> String +showGR UserGoal = " (user goal)" +showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" + +showFR :: ConflictSet -> FailReason -> String +showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ prettyShow ext ++ ")" +showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ prettyShow lang ++ ")" +showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)" +showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" +showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" +showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" +showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")" +showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" +showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)" +showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)" +showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" +showFR _ CannotInstall = " (only already installed instances can be used)" +showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" +showFR _ NotExplicit = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)" +showFR _ Shadowed = " (shadowed by another installed package with same version)" +showFR _ (Broken u) = " (package is broken, missing dependency " ++ prettyShow u ++ ")" +showFR _ UnknownPackage = " (unknown package)" +showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" +showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" +showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" +showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" +showFR _ ManualFlag = " (manual flag can only be changed explicitly)" +showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" +showFR _ MultipleInstances = " (multiple instances)" +showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" +showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" +showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ prettyShow ver ++ ")" +-- The following are internal failures. They should not occur. In the +-- interest of not crashing unnecessarily, we still just print an error +-- message though. +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" +showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" +showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" + +showExposedComponent :: ExposedComponent -> String +showExposedComponent (ExposedLib LMainLibName) = "library" +showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'" +showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" + +constraintSource :: ConstraintSource -> String +constraintSource src = "constraint from " ++ showConstraintSource src + +showConflictingDep :: ConflictingDep -> String +showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = + let DependencyReason qpn' _ _ = dr + componentStr = case comp of + ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" + ExposedLib LMainLibName -> "" + ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")" + in case ci of + Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ + showQPN qpn ++ componentStr ++ "==" ++ showI i + Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ + componentStr ++ showVR vr diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs b/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +module Distribution.Solver.Modular.PSQ + ( PSQ(..) -- Unit test needs constructor access + , casePSQ + , cons + , length + , lookup + , filter + , filterIfAny + , filterIfAnyByKeys + , filterKeys + , firstOnly + , fromList + , isZeroOrOne + , keys + , map + , mapKeys + , mapWithKey + , maximumBy + , minimumBy + , null + , prefer + , preferByKeys + , snoc + , sortBy + , sortByKeys + , toList + , union + ) where + +-- Priority search queues. +-- +-- I am not yet sure what exactly is needed. But we need a data structure with +-- key-based lookup that can be sorted. We're using a sequence right now with +-- (inefficiently implemented) lookup, because I think that queue-based +-- operations and sorting turn out to be more efficiency-critical in practice. + +import Control.Arrow (first, second) + +import qualified Data.Foldable as F +import Data.Function +import qualified Data.List as S +import Data.Ord (comparing) +import Data.Traversable +import Prelude hiding (foldr, length, lookup, filter, null, map) + +newtype PSQ k v = PSQ [(k, v)] + deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP + +keys :: PSQ k v -> [k] +keys (PSQ xs) = fmap fst xs + +lookup :: Eq k => k -> PSQ k v -> Maybe v +lookup k (PSQ xs) = S.lookup k xs + +map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 +map f (PSQ xs) = PSQ (fmap (second f) xs) + +mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v +mapKeys f (PSQ xs) = PSQ (fmap (first f) xs) + +mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b +mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) + +fromList :: [(k, a)] -> PSQ k a +fromList = PSQ + +cons :: k -> a -> PSQ k a -> PSQ k a +cons k x (PSQ xs) = PSQ ((k, x) : xs) + +snoc :: PSQ k a -> k -> a -> PSQ k a +snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) + +casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r +casePSQ (PSQ xs) n c = + case xs of + [] -> n + (k, v) : ys -> c k v (PSQ ys) + +sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a +sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) + +sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a +sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) + +maximumBy :: (k -> Int) -> PSQ k a -> (k, a) +maximumBy sel (PSQ xs) = + S.minimumBy (flip (comparing (sel . fst))) xs + +minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a +minimumBy sel (PSQ xs) = + PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] + +-- | Sort the list so that values satisfying the predicate are first. +prefer :: (a -> Bool) -> PSQ k a -> PSQ k a +prefer p = sortBy $ flip (comparing p) + +-- | Sort the list so that keys satisfying the predicate are first. +preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +preferByKeys p = sortByKeys $ flip (comparing p) + +-- | Will partition the list according to the predicate. If +-- there is any element that satisfies the precidate, then only +-- the elements satisfying the predicate are returned. +-- Otherwise, the rest is returned. +-- +filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a +filterIfAny p (PSQ xs) = + let + (pro, con) = S.partition (p . snd) xs + in + if S.null pro then PSQ con else PSQ pro + +-- | Variant of 'filterIfAny' that takes a predicate on the keys +-- rather than on the values. +-- +filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterIfAnyByKeys p (PSQ xs) = + let + (pro, con) = S.partition (p . fst) xs + in + if S.null pro then PSQ con else PSQ pro + +filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) + +filter :: (a -> Bool) -> PSQ k a -> PSQ k a +filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) + +length :: PSQ k a -> Int +length (PSQ xs) = S.length xs + +null :: PSQ k a -> Bool +null (PSQ xs) = S.null xs + +isZeroOrOne :: PSQ k a -> Bool +isZeroOrOne (PSQ []) = True +isZeroOrOne (PSQ [_]) = True +isZeroOrOne _ = False + +firstOnly :: PSQ k a -> PSQ k a +firstOnly (PSQ []) = PSQ [] +firstOnly (PSQ (x : _)) = PSQ [x] + +toList :: PSQ k a -> [(k, a)] +toList (PSQ xs) = xs + +union :: PSQ k a -> PSQ k a -> PSQ k a +union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Package + ( I(..) + , Loc(..) + , PackageId + , PackageIdentifier(..) + , PackageName, mkPackageName, unPackageName + , PkgconfigName, mkPkgconfigName, unPkgconfigName + , PI(..) + , PN + , QPV + , instI + , makeIndependent + , primaryPP + , setupPP + , showI + , showPI + , unPN + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import Distribution.Package -- from Cabal +import Distribution.Pretty (prettyShow) + +import Distribution.Solver.Modular.Version +import Distribution.Solver.Types.PackagePath + +-- | A package name. +type PN = PackageName + +-- | Unpacking a package name. +unPN :: PN -> String +unPN = unPackageName + +-- | Package version. A package name plus a version number. +type PV = PackageId + +-- | Qualified package version. +type QPV = Qualified PV + +-- | Package id. Currently just a black-box string. +type PId = UnitId + +-- | Location. Info about whether a package is installed or not, and where +-- exactly it is located. For installed packages, uniquely identifies the +-- package instance via its 'PId'. +-- +-- TODO: More information is needed about the repo. +data Loc = Inst PId | InRepo + deriving (Eq, Ord, Show) + +-- | Instance. A version number and a location. +data I = I Ver Loc + deriving (Eq, Ord, Show) + +-- | String representation of an instance. +showI :: I -> String +showI (I v InRepo) = showVer v +showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid + where + extractPackageAbiHash xs = + case first reverse $ break (=='-') $ reverse (prettyShow xs) of + (ys, []) -> ys + (ys, _) -> '-' : ys + +-- | Package instance. A package name and an instance. +data PI qpn = PI qpn I + deriving (Eq, Ord, Show, Functor) + +-- | String representation of a package instance. +showPI :: PI QPN -> String +showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i + +instI :: I -> Bool +instI (I _ (Inst _)) = True +instI _ = False + +-- | Is the package in the primary group of packages. This is used to +-- determine (1) if we should try to establish stanza preferences +-- for this goal, and (2) whether or not a user specified @--constraint@ +-- should apply to this dependency (grep 'primaryPP' to see the +-- use sites). In particular this does not include packages pulled in +-- as setup deps. +-- +primaryPP :: PackagePath -> Bool +primaryPP (PackagePath _ns q) = go q + where + go QualToplevel = True + go (QualBase _) = True + go (QualSetup _) = False + go (QualExe _ _) = False + +-- | Is the package a dependency of a setup script. This is used to +-- establish whether or not certain constraints should apply to this +-- dependency (grep 'setupPP' to see the use sites). +-- +setupPP :: PackagePath -> Bool +setupPP (PackagePath _ns (QualSetup _)) = True +setupPP (PackagePath _ns _) = False + +-- | Qualify a target package with its own name so that its dependencies are not +-- required to be consistent with other targets. +makeIndependent :: PN -> QPN +makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | Reordering or pruning the tree in order to prefer or make certain choices. +module Distribution.Solver.Modular.Preference + ( avoidReinstalls + , deferSetupExeChoices + , deferWeakFlagChoices + , enforceManualFlags + , enforcePackageConstraints + , enforceSingleInstanceRestriction + , firstGoal + , preferBaseGoalChoice + , preferLinked + , preferPackagePreferences + , preferReallyEasyGoalChoices + , requireInstalled + , onlyConstrained + , sortGoals + , pruneAfterFirstSuccess + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import qualified Data.List as L +import qualified Data.Map as M +import Control.Monad.Trans.Reader (Reader, runReader, ask, local) + +import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal + +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.InstalledPreference +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.Variable + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.PSQ as P +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.ConflictSet as CS +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +-- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a +-- list of weight-calculating functions in order to avoid sorting the package +-- choices multiple times. Each function takes the package name, sorted list of +-- children's versions, and package option. 'addWeights' prepends the new +-- weights to the existing weights, which gives precedence to preferences that +-- are applied later. +addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c +addWeights fs = trav go + where + go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c) + go (PChoiceF qpn@(Q _ pn) rdm x cs) = + let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs) + weights k = [f pn sortedVersions k | f <- fs] + + elemsToWhnf :: [a] -> () + elemsToWhnf = foldr seq () + in PChoiceF qpn rdm x + -- Evaluate the children's versions before evaluating any of the + -- subtrees, so that 'sortedVersions' doesn't hold onto all of the + -- subtrees (referenced by cs) and cause a space leak. + (elemsToWhnf sortedVersions `seq` + W.mapWeightsWithKey (\k w -> weights k ++ w) cs) + go x = x + +addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c +addWeight f = addWeights [f] + +version :: POption -> Ver +version (POption (I v _) _) = v + +-- | Prefer to link packages whenever possible. +preferLinked :: Tree d c -> Tree d c +preferLinked = addWeight (const (const linked)) + where + linked (POption _ Nothing) = 1 + linked (POption _ (Just _)) = 0 + +-- Works by setting weights on choice nodes. Also applies stanza preferences. +preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c +preferPackagePreferences pcs = + preferPackageStanzaPreferences pcs . + addWeights [ + \pn _ opt -> preferred pn opt + + -- Note that we always rank installed before uninstalled, and later + -- versions before earlier, but we can change the priority of the + -- two orderings. + , \pn vs opt -> case preference pn of + PreferInstalled -> installed opt + PreferLatest -> latest vs opt + , \pn vs opt -> case preference pn of + PreferInstalled -> latest vs opt + PreferLatest -> installed opt + ] + where + -- Prefer packages with higher version numbers over packages with + -- lower version numbers. + latest :: [Ver] -> POption -> Weight + latest sortedVersions opt = + let l = length sortedVersions + index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions + in fromIntegral index / fromIntegral l + + preference :: PN -> InstalledPreference + preference pn = + let PackagePreferences _ ipref _ = pcs pn + in ipref + + -- | Prefer versions satisfying more preferred version ranges. + preferred :: PN -> POption -> Weight + preferred pn opt = + let PackagePreferences vrs _ _ = pcs pn + in fromIntegral . negate . L.length $ + L.filter (flip checkVR (version opt)) vrs + + -- Prefer installed packages over non-installed packages. + installed :: POption -> Weight + installed (POption (I _ (Inst _)) _) = 0 + installed _ = 1 + +-- | Traversal that tries to establish package stanza enable\/disable +-- preferences. Works by reordering the branches of stanza choices. +preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c +preferPackageStanzaPreferences pcs = trav go + where + go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts) + | primaryPP pp && enableStanzaPref pn s = + -- move True case first to try enabling the stanza + let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts + weight k = if k then 0 else 1 + -- defer the choice by setting it to weak + in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' + go x = x + + enableStanzaPref :: PN -> OptionalStanza -> Bool + enableStanzaPref pn s = + let PackagePreferences _ _ spref = pcs pn + in s `elem` spref + +-- | Helper function that tries to enforce a single package constraint on a +-- given instance for a P-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintP :: forall d c. QPN + -> ConflictSet + -> I + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go i prop + else r + where + go :: I -> PackageProperty -> Tree d c + go (I v _) (PackagePropertyVersion vr) + | checkVR vr v = r + | otherwise = Fail c (GlobalConstraintVersion vr src) + go _ PackagePropertyInstalled + | instI i = r + | otherwise = Fail c (GlobalConstraintInstalled src) + go _ PackagePropertySource + | not (instI i) = r + | otherwise = Fail c (GlobalConstraintSource src) + go _ _ = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintF :: forall d c. QPN + -> Flag + -> ConflictSet + -> Bool + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go prop + else r + where + go :: PackageProperty -> Tree d c + go (PackagePropertyFlags fa) = + case lookupFlagAssignment f fa of + Nothing -> r + Just b | b == b' -> r + | otherwise -> Fail c (GlobalConstraintFlag src) + go _ = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintS :: forall d c. QPN + -> OptionalStanza + -> ConflictSet + -> Bool + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go prop + else r + where + go :: PackageProperty -> Tree d c + go (PackagePropertyStanzas ss) = + if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) + else r + go _ = r + +-- | Traversal that tries to establish various kinds of user constraints. Works +-- by selectively disabling choices that have been ruled out by global user +-- constraints. +enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] + -> Tree d c + -> Tree d c +enforcePackageConstraints pcs = trav go + where + go (PChoiceF qpn@(Q _ pn) rdm gr ts) = + let c = varToConflictSet (P qpn) + -- compose the transformation functions for each of the relevant constraint + g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc) + id + (M.findWithDefault [] pn pcs) + in PChoiceF qpn rdm gr (W.mapWithKey g ts) + go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) = + let c = varToConflictSet (F qfn) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) + id + (M.findWithDefault [] pn pcs) + in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) + go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = + let c = varToConflictSet (S qsn) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) + id + (M.findWithDefault [] pn pcs) + in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) + go x = x + +-- | Transformation that tries to enforce the rule that manual flags can only be +-- set by the user. +-- +-- If there are no constraints on a manual flag, this function prunes all but +-- the default value. If there are constraints, then the flag is allowed to have +-- the values specified by the constraints. Note that the type used for flag +-- values doesn't need to be Bool. +-- +-- This function makes an exception for the case where there are multiple goals +-- for a single package (with different qualifiers), and flag constraints for +-- manual flag x only apply to some of those goals. In that case, we allow the +-- unconstrained goals to use the default value for x OR any of the values in +-- the constraints on x (even though the constraints don't apply), in order to +-- allow the unconstrained goals to be linked to the constrained goals. See +-- https://github.com/haskell/cabal/issues/4299. Removing the single instance +-- restriction (SIR) would also fix #4299, so we may want to remove this +-- exception and only let the user toggle manual flags if we remove the SIR. +-- +-- This function does not enforce any of the constraints, since that is done by +-- 'enforcePackageConstraints'. +enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c +enforceManualFlags pcs = trav go + where + go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) = + FChoiceF qfn rdm gr tr Manual d $ + let -- A list of all values specified by constraints on 'fn'. + -- We ignore the constraint scope in order to handle issue #4299. + flagConstraintValues :: [Bool] + flagConstraintValues = + [ flagVal + | let lpcs = M.findWithDefault [] pn pcs + , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs + , (fn', flagVal) <- unFlagAssignment fa + , fn' == fn ] + + -- Prune flag values that are not the default and do not match any + -- of the constraints. + restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c + restrictToggling flagDefault constraintVals flagVal r = + if flagVal `elem` constraintVals || flagVal == flagDefault + then r + else Fail (varToConflictSet (F qfn)) ManualFlag + + in W.mapWithKey (restrictToggling d flagConstraintValues) ts + go x = x + +-- | Require installed packages. +requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c +requireInstalled p = trav go + where + go (PChoiceF v@(Q _ pn) rdm gr cs) + | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) + | otherwise = PChoiceF v rdm gr cs + where + installed (POption (I _ (Inst _)) _) x = x + installed _ _ = Fail (varToConflictSet (P v)) CannotInstall + go x = x + +-- | Avoid reinstalls. +-- +-- This is a tricky strategy. If a package version is installed already and the +-- same version is available from a repo, the repo version will never be chosen. +-- This would result in a reinstall (either destructively, or potentially, +-- shadowing). The old instance won't be visible or even present anymore, but +-- other packages might have depended on it. +-- +-- TODO: It would be better to actually check the reverse dependencies of installed +-- packages. If they're not depended on, then reinstalling should be fine. Even if +-- they are, perhaps this should just result in trying to reinstall those other +-- packages as well. However, doing this all neatly in one pass would require to +-- change the builder, or at least to change the goal set after building. +avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c +avoidReinstalls p = trav go + where + go (PChoiceF qpn@(Q _ pn) rdm gr cs) + | p pn = PChoiceF qpn rdm gr disableReinstalls + | otherwise = PChoiceF qpn rdm gr cs + where + disableReinstalls = + let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] + in W.mapWithKey (notReinstall installed) cs + + notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = + Fail (varToConflictSet (P qpn)) CannotReinstall + notReinstall _ _ x = + x + go x = x + +-- | Require all packages to be mentioned in a constraint or as a goal. +onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason +onlyConstrained p = trav go + where + go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) + = FailF + (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) + NotExplicit + go x + = x + +-- | Sort all goals using the provided function. +sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c +sortGoals variableOrder = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) + go x = x + + goalOrder :: Goal QPN -> Goal QPN -> Ordering + goalOrder = variableOrder `on` (varToVariable . goalToVar) + + varToVariable :: Var QPN -> Variable QPN + varToVariable (P qpn) = PackageVar qpn + varToVariable (F (FN qpn fn)) = FlagVar qpn fn + varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza + +-- | Reduce the branching degree of the search tree by removing all choices +-- after the first successful choice at each level. The returned tree is the +-- minimal subtree containing the path to the first backjump. +pruneAfterFirstSuccess :: Tree d c -> Tree d c +pruneAfterFirstSuccess = trav go + where + go (PChoiceF qpn rdm gr ts) = PChoiceF qpn rdm gr (W.takeUntil active ts) + go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts) + go (SChoiceF qsn rdm gr w ts) = SChoiceF qsn rdm gr w (W.takeUntil active ts) + go x = x + +-- | Always choose the first goal in the list next, abandoning all +-- other choices. +-- +-- This is unnecessary for the default search strategy, because +-- it descends only into the first goal choice anyway, +-- but may still make sense to just reduce the tree size a bit. +firstGoal :: Tree d c -> Tree d c +firstGoal = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) + go x = x + -- Note that we keep empty choice nodes, because they mean success. + +-- | Transformation that tries to make a decision on base as early as +-- possible by pruning all other goals when base is available. In nearly +-- all cases, there's a single choice for the base package. Also, fixing +-- base early should lead to better error messages. +preferBaseGoalChoice :: Tree d c -> Tree d c +preferBaseGoalChoice = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) + go x = x + + isBase :: Goal QPN -> Bool + isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" + isBase _ = False + +-- | Deal with setup and build-tool-depends dependencies after regular dependencies, +-- so we will link setup/exe dependencies against package dependencies when possible +deferSetupExeChoices :: Tree d c -> Tree d c +deferSetupExeChoices = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetupOrExe xs) + go x = x + + noSetupOrExe :: Goal QPN -> Bool + noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False + noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False + noSetupOrExe _ = True + +-- | Transformation that tries to avoid making weak flag choices early. +-- Weak flags are trivial flags (not influencing dependencies) or such +-- flags that are explicitly declared to be weak in the index. +deferWeakFlagChoices :: Tree d c -> Tree d c +deferWeakFlagChoices = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) + go x = x + + noWeakStanza :: Tree d c -> Bool + noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False + noWeakStanza _ = True + + noWeakFlag :: Tree d c -> Bool + noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False + noWeakFlag _ = True + +-- | Transformation that prefers goals with lower branching degrees. +-- +-- When a goal choice node has at least one goal with zero or one children, this +-- function prunes all other goals. This transformation can help the solver find +-- a solution in fewer steps by allowing it to backtrack sooner when it is +-- exploring a subtree with no solutions. However, each step is more expensive. +preferReallyEasyGoalChoices :: Tree d c -> Tree d c +preferReallyEasyGoalChoices = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) + go x = x + +-- | Monad used internally in enforceSingleInstanceRestriction +-- +-- For each package instance we record the goal for which we picked a concrete +-- instance. The SIR means that for any package instance there can only be one. +type EnforceSIR = Reader (Map (PI PN) QPN) + +-- | Enforce ghc's single instance restriction +-- +-- From the solver's perspective, this means that for any package instance +-- (that is, package name + package version) there can be at most one qualified +-- goal resolving to that instance (there may be other goals _linking_ to that +-- instance however). +enforceSingleInstanceRestriction :: Tree d c -> Tree d c +enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go + where + go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c) + + -- We just verify package choices. + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) cs) + go _otherwise = + innM _otherwise + + -- The check proper + goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c) + goP qpn@(Q _ pn) (POption i linkedTo) r = do + let inst = PI pn i + env <- ask + case (linkedTo, M.lookup inst env) of + (Just _, _) -> + -- For linked nodes we don't check anything + r + (Nothing, Nothing) -> + -- Not linked, not already used + local (M.insert inst qpn) r + (Nothing, Just qpn') -> do + -- Not linked, already used. This is an error + return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs b/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE Rank2Types #-} +module Distribution.Solver.Modular.RetryLog + ( RetryLog + , toProgress + , fromProgress + , mapFailure + , retry + , failWith + , succeedWith + , continueWith + , tryWith + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Solver.Modular.Message +import Distribution.Solver.Types.Progress + +-- | 'Progress' as a difference list that allows efficient appends at failures. +newtype RetryLog step fail done = RetryLog { + unRetryLog :: forall fail2 . (fail -> Progress step fail2 done) + -> Progress step fail2 done + } + +-- | /O(1)/. Convert a 'RetryLog' to a 'Progress'. +toProgress :: RetryLog step fail done -> Progress step fail done +toProgress (RetryLog f) = f Fail + +-- | /O(N)/. Convert a 'Progress' to a 'RetryLog'. +fromProgress :: Progress step fail done -> RetryLog step fail done +fromProgress l = RetryLog $ \f -> go f l + where + go :: (fail1 -> Progress step fail2 done) + -> Progress step fail1 done + -> Progress step fail2 done + go _ (Done d) = Done d + go f (Fail failure) = f failure + go f (Step m ms) = Step m (go f ms) + +-- | /O(1)/. Apply a function to the failure value in a log. +mapFailure :: (fail1 -> fail2) + -> RetryLog step fail1 done + -> RetryLog step fail2 done +mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure) + +-- | /O(1)/. If the first log leads to failure, continue with the second. +retry :: RetryLog step fail1 done + -> (fail1 -> RetryLog step fail2 done) + -> RetryLog step fail2 done +retry (RetryLog f) g = + RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog + +-- | /O(1)/. Create a log with one message before a failure. +failWith :: step -> fail -> RetryLog step fail done +failWith m failure = RetryLog $ \f -> Step m (f failure) + +-- | /O(1)/. Create a log with one message before a success. +succeedWith :: step -> done -> RetryLog step fail done +succeedWith m d = RetryLog $ const $ Step m (Done d) + +-- | /O(1)/. Prepend a message to a log. +continueWith :: step + -> RetryLog step fail done + -> RetryLog step fail done +continueWith m (RetryLog f) = RetryLog $ Step m . f + +-- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert +-- 'Leave' before the failure if the log fails. +tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done +tryWith m f = + RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave)) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE CPP #-} +#ifdef DEBUG_TRACETREE +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif +module Distribution.Solver.Modular.Solver + ( SolverConfig(..) + , solve + , PruneAfterFirstSuccess(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import Distribution.Verbosity + +import Distribution.Compiler (CompilerInfo) + +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Variable + +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Builder +import Distribution.Solver.Modular.Cycles +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Explore +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Log +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.Preference as P +import Distribution.Solver.Modular.Validate +import Distribution.Solver.Modular.Linking +import Distribution.Solver.Modular.PSQ (PSQ) +import Distribution.Solver.Modular.RetryLog +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.PSQ as PSQ + +import Distribution.Simple.Setup (BooleanFlag(..)) + +#ifdef DEBUG_TRACETREE +import qualified Distribution.Solver.Modular.ConflictSet as CS +import qualified Distribution.Solver.Modular.WeightedPSQ as W +import qualified Distribution.Deprecated.Text as T + +import Debug.Trace.Tree (gtraceJson) +import Debug.Trace.Tree.Simple +import Debug.Trace.Tree.Generic +import Debug.Trace.Tree.Assoc (Assoc(..)) +#endif + +-- | Various options for the modular solver. +data SolverConfig = SolverConfig { + reorderGoals :: ReorderGoals, + countConflicts :: CountConflicts, + fineGrainedConflicts :: FineGrainedConflicts, + minimizeConflictSet :: MinimizeConflictSet, + independentGoals :: IndependentGoals, + avoidReinstalls :: AvoidReinstalls, + shadowPkgs :: ShadowPkgs, + strongFlags :: StrongFlags, + allowBootLibInstalls :: AllowBootLibInstalls, + onlyConstrained :: OnlyConstrained, + maxBackjumps :: Maybe Int, + enableBackjumping :: EnableBackjumping, + solveExecutables :: SolveExecutables, + goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + solverVerbosity :: Verbosity, + pruneAfterFirstSuccess :: PruneAfterFirstSuccess +} + +-- | Whether to remove all choices after the first successful choice at each +-- level in the search tree. +newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool + +-- | Run all solver phases. +-- +-- In principle, we have a valid tree after 'validationPhase', which +-- means that every 'Done' node should correspond to valid solution. +-- +-- There is one exception, though, and that is cycle detection, which +-- has been added relatively recently. Cycles are only removed directly +-- before exploration. +-- +solve :: SolverConfig -- ^ solver parameters + -> CompilerInfo + -> Index -- ^ all available packages as an index + -> PkgConfigDb -- ^ available pkg-config pkgs + -> (PN -> PackagePreferences) -- ^ preferences + -> M.Map PN [LabeledPackageConstraint] -- ^ global constraints + -> S.Set PN -- ^ global goals + -> RetryLog Message SolverFailure (Assignment, RevDepMap) +solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = + explorePhase $ + detectCycles $ + heuristicsPhase $ + preferencesPhase $ + validationPhase $ + prunePhase $ + buildPhase + where + explorePhase = backjumpAndExplore (maxBackjumps sc) + (enableBackjumping sc) + (fineGrainedConflicts sc) + (countConflicts sc) + idx + detectCycles = traceTree "cycles.json" id . detectCyclesPhase + heuristicsPhase = + let heuristicsTree = traceTree "heuristics.json" id + sortGoals = case goalOrder sc of + Nothing -> goalChoiceHeuristics . + heuristicsTree . + P.deferSetupExeChoices . + P.deferWeakFlagChoices . + P.preferBaseGoalChoice + Just order -> P.firstGoal . + heuristicsTree . + P.sortGoals order + PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc + in sortGoals . + (if prune then P.pruneAfterFirstSuccess else id) + preferencesPhase = P.preferLinked . + P.preferPackagePreferences userPrefs + validationPhase = traceTree "validated.json" id . + P.enforcePackageConstraints userConstraints . + P.enforceManualFlags userConstraints . + P.enforceSingleInstanceRestriction . + validateLinking idx . + validateTree cinfo idx pkgConfigDB + prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . + (if asBool (allowBootLibInstalls sc) + then id + else P.requireInstalled (`elem` nonInstallable)) . + (case onlyConstrained sc of + OnlyConstrainedAll -> + P.onlyConstrained pkgIsExplicit + OnlyConstrainedNone -> + id) + buildPhase = traceTree "build.json" id + $ buildTree idx (independentGoals sc) (S.toList userGoals) + + allExplicit = M.keysSet userConstraints `S.union` userGoals + + pkgIsExplicit :: PN -> Bool + pkgIsExplicit pn = S.member pn allExplicit + + -- packages that can never be installed or upgraded + -- If you change this enumeration, make sure to update the list in + -- "Distribution.Client.Dependency" as well + nonInstallable :: [PackageName] + nonInstallable = + L.map mkPackageName + [ "base" + , "ghc-prim" + , "integer-gmp" + , "integer-simple" + , "template-haskell" + ] + + -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which + -- prefers (keeps) goals only if the have 0 or 1 enabled choice. + -- + -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes + -- to just a single option. This was a way to work around a space leak that was + -- unnecessary and is now fixed, so we no longer do it. + -- + -- If --count-conflicts is active, it will then choose among the remaining goals + -- the one that has been responsible for the most conflicts so far. + -- + -- Otherwise, we simply choose the first remaining goal. + -- + goalChoiceHeuristics + | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices + | otherwise = id {- P.firstGoal -} + +-- | Dump solver tree to a file (in debugging mode) +-- +-- This only does something if the @debug-tracetree@ configure argument was +-- given; otherwise this is just the identity function. +traceTree :: +#ifdef DEBUG_TRACETREE + GSimpleTree a => +#endif + FilePath -- ^ Output file + -> (a -> a) -- ^ Function to summarize the tree before dumping + -> a -> a +#ifdef DEBUG_TRACETREE +traceTree = gtraceJson +#else +traceTree _ _ = id +#endif + +#ifdef DEBUG_TRACETREE +instance GSimpleTree (Tree d c) where + fromGeneric = go + where + go :: Tree d c -> SimpleTree + go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq + go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq + go (Done _rdm _s) = Node "D" $ Assoc [] + go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] + + psqToList :: W.WeightedPSQ w k v -> [(k, v)] + psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList + + -- Show package choice + goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) + goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) + goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) + + -- Show flag or stanza choice + goFS :: Bool -> Tree d c -> (String, SimpleTree) + goFS val subtree = (show val, go subtree) + + -- Show goal choice + goG :: Goal QPN -> Tree d c -> (String, SimpleTree) + goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) + + -- Variation on 'showGR' that produces shorter strings + -- (Actually, QGoalReason records more info than necessary: we only need + -- to know the variable that introduced the goal, not the value assigned + -- to that variable) + shortGR :: QGoalReason -> String + shortGR UserGoal = "user" + shortGR (DependencyGoal dr) = showDependencyReason dr + + -- Show conflict set + goCS :: ConflictSet -> String + goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" +#endif + +-- | Replace all goal reasons with a dummy goal reason in the tree +-- +-- This is useful for debugging (when experimenting with the impact of GRs) +_removeGR :: Tree d c -> Tree d QGoalReason +_removeGR = trav go + where + go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) + go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq + go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq + go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq + go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) + go (DoneF rdm s) = DoneF rdm s + go (FailF cs reason) = FailF cs reason + + goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) + goG = PSQ.fromList + . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree)) + . PSQ.toList + + dummy :: QGoalReason + dummy = + DependencyGoal $ + DependencyReason + (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + M.empty S.empty diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +module Distribution.Solver.Modular.Tree + ( POption(..) + , Tree(..) + , TreeF(..) + , Weight + , FailReason(..) + , ConflictingDep(..) + , ana + , cata + , inn + , innM + , para + , trav + , zeroOrOneChoices + , active + ) where + +import Control.Monad hiding (mapM, sequence) +import Data.Foldable +import Data.Traversable +import Prelude hiding (foldr, mapM, sequence) + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.PSQ (PSQ) +import Distribution.Solver.Modular.Version +import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ) +import qualified Distribution.Solver.Modular.WeightedPSQ as W +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.PackagePath +import Distribution.Types.PkgconfigVersionRange +import Distribution.Types.UnitId (UnitId) +import Language.Haskell.Extension (Extension, Language) + +type Weight = Double + +-- | Type of the search tree. Inlining the choice nodes for now. Weights on +-- package, flag, and stanza choices control the traversal order. +-- +-- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes +-- (type 'c'). For example, during the final traversal, choice nodes contain the +-- variables that introduced the choices, and 'Done' nodes contain the +-- assignments for all variables. +-- +-- TODO: The weight type should be changed from [Double] to Double to avoid +-- giving too much weight to preferences that are applied later. +data Tree d c = + -- | Choose a version for a package (or choose to link) + PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) + + -- | Choose a value for a flag + -- + -- The Bool is the default value. + | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) + + -- | Choose whether or not to enable a stanza + | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + + -- | Choose which choice to make next + -- + -- Invariants: + -- + -- * PSQ should never be empty + -- * For each choice we additionally record the 'QGoalReason' why we are + -- introducing that goal into tree. Note that most of the time we are + -- working with @Tree QGoalReason@; in that case, we must have the + -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' + -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason + -- recorded on that 'GoalChoice' node. + | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) + + -- | We're done -- we found a solution! + | Done RevDepMap d + + -- | We failed to find a solution in this path through the tree + | Fail ConflictSet FailReason + +-- | A package option is a package instance with an optional linking annotation +-- +-- The modular solver has a number of package goals to solve for, and can only +-- pick a single package version for a single goal. In order to allow to +-- install multiple versions of the same package as part of a single solution +-- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both +-- be qualified goals for @P@, allowing to pick a difference version of package +-- @P@ for @0.P@ and @1.P@. +-- +-- Linking is an essential part of this story. In addition to picking a specific +-- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or +-- vice versa). It means that @1.P@ and @0.P@ really must be the very same package +-- (and hence must have the same build time configuration, and their +-- dependencies must also be the exact same). +-- +-- See for details. +data POption = POption I (Maybe PackagePath) + deriving (Eq, Show) + +data FailReason = UnsupportedExtension Extension + | UnsupportedLanguage Language + | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange + | NewPackageDoesNotMatchExistingConstraint ConflictingDep + | ConflictingConstraints ConflictingDep ConflictingDep + | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) + | PackageRequiresMissingComponent QPN ExposedComponent + | PackageRequiresPrivateComponent QPN ExposedComponent + | PackageRequiresUnbuildableComponent QPN ExposedComponent + | CannotInstall + | CannotReinstall + | NotExplicit + | Shadowed + | Broken UnitId + | UnknownPackage + | GlobalConstraintVersion VR ConstraintSource + | GlobalConstraintInstalled ConstraintSource + | GlobalConstraintSource ConstraintSource + | GlobalConstraintFlag ConstraintSource + | ManualFlag + | MalformedFlagChoice QFN + | MalformedStanzaChoice QSN + | EmptyGoalChoice + | Backjump + | MultipleInstances + | DependenciesNotLinked String + | CyclicDependencies + | UnsupportedSpecVer Ver + deriving (Eq, Show) + +-- | Information about a dependency involved in a conflict, for error messages. +data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI + deriving (Eq, Show) + +-- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' +-- have the same meaning as in 'Tree'. +data TreeF d c a = + PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) + | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) + | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) + | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) + | DoneF RevDepMap d + | FailF ConflictSet FailReason + deriving (Functor, Foldable, Traversable) + +out :: Tree d c -> TreeF d c (Tree d c) +out (PChoice p s i ts) = PChoiceF p s i ts +out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts +out (SChoice p s i b ts) = SChoiceF p s i b ts +out (GoalChoice s ts) = GoalChoiceF s ts +out (Done x s ) = DoneF x s +out (Fail c x ) = FailF c x + +inn :: TreeF d c (Tree d c) -> Tree d c +inn (PChoiceF p s i ts) = PChoice p s i ts +inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts +inn (SChoiceF p s i b ts) = SChoice p s i b ts +inn (GoalChoiceF s ts) = GoalChoice s ts +inn (DoneF x s ) = Done x s +inn (FailF c x ) = Fail c x + +innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c) +innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts) +innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts) +innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts) +innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts) +innM (DoneF x s ) = return $ Done x s +innM (FailF c x ) = return $ Fail c x + +-- | Determines whether a tree is active, i.e., isn't a failure node. +active :: Tree d c -> Bool +active (Fail _ _) = False +active _ = True + +-- | Approximates the number of active choices that are available in a node. +-- Note that we count goal choices as having one choice, always. +zeroOrOneChoices :: Tree d c -> Bool +zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (GoalChoice _ _ ) = True +zeroOrOneChoices (Done _ _ ) = True +zeroOrOneChoices (Fail _ _ ) = True + +-- | Catamorphism on trees. +cata :: (TreeF d c a -> a) -> Tree d c -> a +cata phi x = (phi . fmap (cata phi) . out) x + +trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a +trav psi x = cata (inn . psi) x + +-- | Paramorphism on trees. +para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a +para phi = phi . fmap (\ x -> (para phi x, x)) . out + +-- | Anamorphism on trees. +ana :: (a -> TreeF d c a) -> a -> Tree d c +ana psi = inn . fmap (ana psi) . psi diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -0,0 +1,593 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +#ifdef DEBUG_CONFLICT_SETS +{-# LANGUAGE ImplicitParams #-} +#endif +module Distribution.Solver.Modular.Validate (validateTree) where + +-- Validation of the tree. +-- +-- The task here is to make sure all constraints hold. After validation, any +-- assignment returned by exploration of the tree should be a complete valid +-- assignment, i.e., actually constitute a solution. + +import Control.Applicative +import Control.Monad.Reader hiding (sequence) +import Data.Either (lefts) +import Data.Function (on) +import Data.Traversable +import Prelude hiding (sequence) + +import qualified Data.List as L +import qualified Data.Set as S + +import Language.Haskell.Extension (Extension, Language) + +import Data.Map.Strict as M +import Distribution.Compiler (CompilerInfo(..)) + +import Distribution.Solver.Modular.Assignment +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) +import Distribution.Types.LibraryName +import Distribution.Types.PkgconfigVersionRange + +#ifdef DEBUG_CONFLICT_SETS +import GHC.Stack (CallStack) +#endif + +-- In practice, most constraints are implication constraints (IF we have made +-- a number of choices, THEN we also have to ensure that). We call constraints +-- that for which the preconditions are fulfilled ACTIVE. We maintain a set +-- of currently active constraints that we pass down the node. +-- +-- We aim at detecting inconsistent states as early as possible. +-- +-- Whenever we make a choice, there are two things that need to happen: +-- +-- (1) We must check that the choice is consistent with the currently +-- active constraints. +-- +-- (2) The choice increases the set of active constraints. For the new +-- active constraints, we must check that they are consistent with +-- the current state. +-- +-- We can actually merge (1) and (2) by saying the current choice is +-- a new active constraint, fixing the choice. +-- +-- If a test fails, we have detected an inconsistent state. We can +-- disable the current subtree and do not have to traverse it any further. +-- +-- We need a good way to represent the current state, i.e., the current +-- set of active constraints. Since the main situation where we have to +-- search in it is (1), it seems best to store the state by package: for +-- every package, we store which versions are still allowed. If for any +-- package, we have inconsistent active constraints, we can also stop. +-- This is a particular way to read task (2): +-- +-- (2, weak) We only check if the new constraints are consistent with +-- the choices we've already made, and add them to the active set. +-- +-- (2, strong) We check if the new constraints are consistent with the +-- choices we've already made, and the constraints we already have. +-- +-- It currently seems as if we're implementing the weak variant. However, +-- when used together with 'preferEasyGoalChoices', we will find an +-- inconsistent state in the very next step. +-- +-- What do we do about flags? +-- +-- Like for packages, we store the flag choices we have already made. +-- Now, regarding (1), we only have to test whether we've decided the +-- current flag before. Regarding (2), the interesting bit is in discovering +-- the new active constraints. To this end, we look up the constraints for +-- the package the flag belongs to, and traverse its flagged dependencies. +-- Wherever we find the flag in question, we start recording dependencies +-- underneath as new active dependencies. If we encounter other flags, we +-- check if we've chosen them already and either proceed or stop. + +-- | The state needed during validation. +data ValidateState = VS { + supportedExt :: Extension -> Bool, + supportedLang :: Language -> Bool, + presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool, + index :: Index, + + -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, + -- it qualifies the package's dependencies and saves them in this map. Then + -- the qualified dependencies are available for subsequent flag and stanza + -- choices for the same package. + saved :: Map QPN (FlaggedDeps QPN), + + pa :: PreAssignment, + + -- Map from package name to the components that are provided by the chosen + -- instance of that package, and whether those components are visible and + -- buildable. + availableComponents :: Map QPN (Map ExposedComponent ComponentInfo), + + -- Map from package name to the components that are required from that + -- package. + requiredComponents :: Map QPN ComponentDependencyReasons, + + qualifyOptions :: QualifyOptions +} + +newtype Validate a = Validate (Reader ValidateState a) + deriving (Functor, Applicative, Monad, MonadReader ValidateState) + +runValidate :: Validate a -> ValidateState -> a +runValidate (Validate r) = runReader r + +-- | A preassignment comprises knowledge about variables, but not +-- necessarily fixed values. +data PreAssignment = PA PPreAssignment FAssignment SAssignment + +-- | A (partial) package preassignment. Qualified package names +-- are associated with MergedPkgDeps. +type PPreAssignment = Map QPN MergedPkgDep + +-- | A dependency on a component, including its DependencyReason. +data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI + +-- | Map from component name to one of the reasons that the component is +-- required. +type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN) + +-- | MergedPkgDep records constraints about the instances that can still be +-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a +-- list of version ranges paired with the goals / variables that introduced +-- them. It also records whether a package is a build-tool dependency, for each +-- reason that it was introduced. +-- +-- It is important to store the component name with the version constraint, for +-- error messages, because whether something is a build-tool dependency affects +-- its qualifier, which affects which constraint is applied. +data MergedPkgDep = + MergedDepFixed ExposedComponent (DependencyReason QPN) I + | MergedDepConstrained [VROrigin] + +-- | Version ranges paired with origins. +type VROrigin = (VR, ExposedComponent, DependencyReason QPN) + +-- | The information needed to create a 'Fail' node. +type Conflict = (ConflictSet, FailReason) + +validate :: Tree d c -> Validate (Tree d c) +validate = cata go + where + go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) + + go (PChoiceF qpn rdm gr ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts) + go (FChoiceF qfn rdm gr b m d ts) = + do + -- Flag choices may occur repeatedly (because they can introduce new constraints + -- in various places). However, subsequent choices must be consistent. We thereby + -- collapse repeated flag choice nodes. + PA _ pfa _ <- asks pa -- obtain current flag-preassignment + case M.lookup qfn pfa of + Just rb -> -- flag has already been assigned; collapse choice to the correct branch + case W.lookup rb ts of + Just t -> goF qfn rb t + Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) + Nothing -> -- flag choice is new, follow both branches + FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts) + go (SChoiceF qsn rdm gr b ts) = + do + -- Optional stanza choices are very similar to flag choices. + PA _ _ psa <- asks pa -- obtain current stanza-preassignment + case M.lookup qsn psa of + Just rb -> -- stanza choice has already been made; collapse choice to the correct branch + case W.lookup rb ts of + Just t -> goS qsn rb t + Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) + Nothing -> -- stanza choice is new, follow both branches + SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts) + + -- We don't need to do anything for goal choices or failure nodes. + go (GoalChoiceF rdm ts) = GoalChoice rdm <$> sequence ts + go (DoneF rdm s ) = pure (Done rdm s) + go (FailF c fr ) = pure (Fail c fr) + + -- What to do for package nodes ... + goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) + goP qpn@(Q _pp pn) (POption i _) r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + idx <- asks index -- obtain the index + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents + qo <- asks qualifyOptions + -- obtain dependencies and index-dictated exclusions introduced by the choice + let (PInfo deps comps _ mfr) = idx ! pn ! i + -- qualify the deps in the current scope + let qdeps = qualifyDeps qo qpn deps + -- the new active constraints are given by the instance we have chosen, + -- plus the dependency information we have for that instance + let newactives = extractAllDeps pfa psa qdeps + -- We now try to extend the partial assignment with the new active constraints. + let mnppa = extend extSupported langSupported pkgPresent newactives + =<< extendWithPackageChoice (PI qpn i) ppa + -- In case we continue, we save the scoped dependencies + let nsvd = M.insert qpn qdeps svd + case mfr of + Just fr -> -- The index marks this as an invalid choice. We can stop. + return (Fail (varToConflictSet (P qpn)) fr) + Nothing -> + let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons) + newDeps = do + nppa <- mnppa + rComps' <- extendRequiredComponents qpn aComps rComps newactives + checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps + return (nppa, rComps') + in case newDeps of + Left (c, fr) -> -- We have an inconsistency. We can stop. + return (Fail c fr) + Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation. + local (\ s -> s { pa = PA nppa pfa psa + , saved = nsvd + , availableComponents = M.insert qpn comps aComps + , requiredComponents = rComps' + }) r + + -- What to do for flag nodes ... + goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goF qfn@(FN qpn _f) b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npfa = M.insert qfn b pfa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (F qfn) b npfa psa qdeps + mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives + -- As in the package case, we try to extend the partial assignment. + let mnppa = extend extSupported langSupported pkgPresent newactives ppa + case liftM2 (,) mnppa mNewRequiredComps of + Left (c, fr) -> return (Fail c fr) -- inconsistency found + Right (nppa, rComps') -> + local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r + + -- What to do for stanza nodes (similar to flag nodes) ... + goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goS qsn@(SN qpn _f) b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + svd <- asks saved -- obtain saved dependencies + aComps <- asks availableComponents + rComps <- asks requiredComponents + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npsa = M.insert qsn b psa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (S qsn) b pfa npsa qdeps + mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives + -- As in the package case, we try to extend the partial assignment. + let mnppa = extend extSupported langSupported pkgPresent newactives ppa + case liftM2 (,) mnppa mNewRequiredComps of + Left (c, fr) -> return (Fail c fr) -- inconsistency found + Right (nppa, rComps') -> + local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r + +-- | Check that a newly chosen package instance contains all components that +-- are required from that package so far. The components must also be visible +-- and buildable. +checkComponentsInNewPackage :: ComponentDependencyReasons + -> QPN + -> Map ExposedComponent ComponentInfo + -> Either Conflict () +checkComponentsInNewPackage required qpn providedComps = + case M.toList $ deleteKeys (M.keys providedComps) required of + (missingComp, dr) : _ -> + Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent + [] -> + let failures = lefts + [ case () of + _ | compIsVisible compInfo == IsVisible False -> + Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent + | compIsBuildable compInfo == IsBuildable False -> + Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent + | otherwise -> Right () + | let merged = M.intersectionWith (,) required providedComps + , (comp, (dr, compInfo)) <- M.toList merged ] + in case failures of + failure : _ -> Left failure + [] -> Right () + where + mkConflict :: ExposedComponent + -> DependencyReason QPN + -> (ExposedComponent -> DependencyReason QPN -> FailReason) + -> Conflict + mkConflict comp dr mkFailure = + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) + + deleteKeys :: Ord k => [k] -> Map k v -> Map k v + deleteKeys ks m = L.foldr M.delete m ks + +-- | We try to extract as many concrete dependencies from the given flagged +-- dependencies as possible. We make use of all the flag knowledge we have +-- already acquired. +extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractAllDeps fa sa deps = do + d <- deps + case d of + Simple sd _ -> return sd + Flagged qfn _ td fd -> case M.lookup qfn fa of + Nothing -> mzero + Just True -> extractAllDeps fa sa td + Just False -> extractAllDeps fa sa fd + Stanza qsn td -> case M.lookup qsn sa of + Nothing -> mzero + Just True -> extractAllDeps fa sa td + Just False -> [] + +-- | We try to find new dependencies that become available due to the given +-- flag or stanza choice. We therefore look for the choice in question, and then call +-- 'extractAllDeps' for everything underneath. +extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractNewDeps v b fa sa = go + where + go :: FlaggedDeps QPN -> [LDep QPN] + go deps = do + d <- deps + case d of + Simple _ _ -> mzero + Flagged qfn' _ td fd + | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd + | otherwise -> case M.lookup qfn' fa of + Nothing -> mzero + Just True -> go td + Just False -> go fd + Stanza qsn' td + | v == S qsn' -> if b then extractAllDeps fa sa td else [] + | otherwise -> case M.lookup qsn' sa of + Nothing -> mzero + Just True -> go td + Just False -> [] + +-- | Extend a package preassignment. +-- +-- Takes the variable that causes the new constraints, a current preassignment +-- and a set of new dependency constraints. +-- +-- We're trying to extend the preassignment with each dependency one by one. +-- Each dependency is for a particular variable. We check if we already have +-- constraints for that variable in the current preassignment. If so, we're +-- trying to merge the constraints. +-- +-- Either returns a witness of the conflict that would arise during the merge, +-- or the successfully extended assignment. +extend :: (Extension -> Bool) -- ^ is a given extension supported + -> (Language -> Bool) -- ^ is a given language supported + -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable + -> [LDep QPN] + -> PPreAssignment + -> Either Conflict PPreAssignment +extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives + where + + extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment + extendSingle a (LDep dr (Ext ext )) = + if extSupported ext then Right a + else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) + extendSingle a (LDep dr (Lang lang)) = + if langSupported lang then Right a + else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) + extendSingle a (LDep dr (Pkg pn vr)) = + if pkgPresent pn vr then Right a + else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) + extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = + let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of + Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') + Right x -> Right x + +-- | Extend a package preassignment with a package choice. For example, when +-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. +-- +-- TODO: The new constraint is implemented as a dependency from foo to foo's +-- main library. That isn't correct, because foo might only be needed as a build +-- tool dependency. The implemention may need to change when we support +-- component-based dependency solving. +extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment +extendWithPackageChoice (PI qpn i) ppa = + let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa + newChoice = PkgDep (DependencyReason qpn M.empty S.empty) + (PkgComponent qpn (ExposedLib LMainLibName)) + (Fixed i) + in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of + Left (c, (d, _d')) -> -- Don't include the package choice in the + -- FailReason, because it is redundant. + Left (c, NewPackageDoesNotMatchExistingConstraint d) + Right x -> Right x + +-- | Merge constrained instances. We currently adopt a lazy strategy for +-- merging, i.e., we only perform actual checking if one of the two choices +-- is fixed. If the merge fails, we return a conflict set indicating the +-- variables responsible for the failure, as well as the two conflicting +-- fragments. +-- +-- Note that while there may be more than one conflicting pair of version +-- ranges, we only return the first we find. +-- +-- The ConflictingDeps are returned in order, i.e., the first describes the +-- conflicting part of the MergedPkgDep, and the second describes the PkgDep. +-- +-- TODO: Different pairs might have different conflict sets. We're +-- obviously interested to return a conflict that has a "better" conflict +-- set in the sense the it contains variables that allow us to backjump +-- further. We might apply some heuristics here, such as to change the +-- order in which we check the constraints. +merge :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep +merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) + | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 + | otherwise = + Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 + , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) + , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) + +merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) + | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i + | otherwise = + Left ( createConflictSetForVersionConflict p v vs1 vr vs2 + , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) + , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) + +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) = + go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... + where + go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep + go [] = Right (MergedDepFixed comp2 vs2 i) + go ((vr, comp1, vs1) : vros) + | checkVR vr v = go vros + | otherwise = + Left ( createConflictSetForVersionConflict p v vs2 vr vs1 + , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) + , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) + +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) = + Right (MergedDepConstrained $ + + -- TODO: This line appends the new version range, to preserve the order used + -- before a refactoring. Consider prepending the version range, if there is + -- no negative performance impact. + vrOrigins ++ [(vr, comp2, vs2)]) + +-- | Creates a conflict set representing a conflict between a version constraint +-- and the fixed version chosen for a package. +createConflictSetForVersionConflict :: QPN + -> Ver + -> DependencyReason QPN + -> VR + -> DependencyReason QPN + -> ConflictSet +createConflictSetForVersionConflict pkg + conflictingVersion + versionDR@(DependencyReason p1 _ _) + conflictingVersionRange + versionRangeDR@(DependencyReason p2 _ _) = + let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) + in + -- The solver currently only optimizes the case where there is a conflict + -- between the version chosen for a package and a version constraint that + -- is not under any flags or stanzas. Here is how we check for this case: + -- + -- (1) Choosing a specific version for a package foo is implemented as + -- adding a dependency from foo to that version of foo (See + -- extendWithPackageChoice), so we check that the DependencyReason + -- contains the current package and no flag or stanza choices. + -- + -- (2) We check that the DependencyReason for the version constraint also + -- contains no flag or stanza choices. + -- + -- When these criteria are not met, we fall back to calling + -- dependencyReasonToConflictSet. + if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) + then let cs1 = dependencyReasonToConflictSetWithVersionConflict + p2 + (CS.OrderedVersionRange conflictingVersionRange) + versionDR + cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict + pkg conflictingVersion versionRangeDR + in cs1 `CS.union` cs2 + else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR + +-- | Takes a list of new dependencies and uses it to try to update the map of +-- known component dependencies. It returns a failure when a new dependency +-- requires a component that is missing, private, or unbuildable in a previously +-- chosen package. +extendRequiredComponents :: QPN -- ^ package we extend + -> Map QPN (Map ExposedComponent ComponentInfo) + -> Map QPN ComponentDependencyReasons + -> [LDep QPN] + -> Either Conflict (Map QPN ComponentDependencyReasons) +extendRequiredComponents eqpn available = foldM extendSingle + where + extendSingle :: Map QPN ComponentDependencyReasons + -> LDep QPN + -> Either Conflict (Map QPN ComponentDependencyReasons) + extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) = + let compDeps = M.findWithDefault M.empty qpn required + success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required + in -- Only check for the existence of the component if its package has + -- already been chosen. + case M.lookup qpn available of + Just comps -> + case M.lookup comp comps of + Nothing -> + Left $ mkConflict qpn comp dr PackageRequiresMissingComponent + Just compInfo + | compIsVisible compInfo == IsVisible False + , eqpn /= qpn -- package components can depend on other components + -> + Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent + | compIsBuildable compInfo == IsBuildable False -> + Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent + | otherwise -> success + Nothing -> success + extendSingle required _ = Right required + + mkConflict :: QPN + -> ExposedComponent + -> DependencyReason QPN + -> (QPN -> ExposedComponent -> FailReason) + -> Conflict + mkConflict qpn comp dr mkFailure = + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) + + +-- | Interface. +validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c +validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { + supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported + (\ es -> let s = S.fromList es in \ x -> S.member x s) + (compilerInfoExtensions cinfo) + , supportedLang = maybe (const True) + (flip L.elem) -- use list lookup because language list is small and no Ord instance + (compilerInfoLanguages cinfo) + , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb + , index = idx + , saved = M.empty + , pa = PA M.empty M.empty M.empty + , availableComponents = M.empty + , requiredComponents = M.empty + , qualifyOptions = defaultQualifyOptions idx + } diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Var.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Var ( + Var(..) + , showVar + , varPN + ) where + +import Prelude hiding (pi) + +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Types.PackagePath + +{------------------------------------------------------------------------------- + Variables +-------------------------------------------------------------------------------} + +-- | The type of variables that play a role in the solver. +-- Note that the tree currently does not use this type directly, +-- and rather has separate tree nodes for the different types of +-- variables. This fits better with the fact that in most cases, +-- these have to be treated differently. +data Var qpn = P qpn | F (FN qpn) | S (SN qpn) + deriving (Eq, Ord, Show, Functor) + +showVar :: Var QPN -> String +showVar (P qpn) = showQPN qpn +showVar (F qfn) = showQFN qfn +showVar (S qsn) = showQSN qsn + +-- | Extract the package name from a Var +varPN :: Var qpn -> qpn +varPN (P qpn) = qpn +varPN (F (FN qpn _)) = qpn +varPN (S (SN qpn _)) = qpn diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Version.hs @@ -0,0 +1,56 @@ +module Distribution.Solver.Modular.Version + ( Ver + , VR + , anyVR + , checkVR + , eqVR + , showVer + , showVR + , simplifyVR + , (.&&.) + , (.||.) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import qualified Distribution.Version as CV -- from Cabal +import Distribution.Pretty (prettyShow) + +-- | Preliminary type for versions. +type Ver = CV.Version + +-- | String representation of a version. +showVer :: Ver -> String +showVer = prettyShow + +-- | Version range. Consists of a lower and upper bound. +type VR = CV.VersionRange + +-- | String representation of a version range. +showVR :: VR -> String +showVR = prettyShow + +-- | Unconstrained version range. +anyVR :: VR +anyVR = CV.anyVersion + +-- | Version range fixing a single version. +eqVR :: Ver -> VR +eqVR = CV.thisVersion + +-- | Intersect two version ranges. +(.&&.) :: VR -> VR -> VR +v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2 + +-- | Union of two version ranges. +(.||.) :: VR -> VR -> VR +v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2 + +-- | Simplify a version range. +simplifyVR :: VR -> VR +simplifyVR = CV.simplifyVersionRange + +-- | Checking a version against a version range. +checkVR :: VR -> Ver -> Bool +checkVR = flip CV.withinRange diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.WeightedPSQ ( + WeightedPSQ + , fromList + , toList + , keys + , weights + , isZeroOrOne + , filter + , lookup + , mapWithKey + , mapWeightsWithKey + , union + , takeUntil + ) where + +import qualified Data.Foldable as F +import qualified Data.List as L +import Data.Ord (comparing) +import qualified Data.Traversable as T +import Prelude hiding (filter, lookup) + +-- | An association list that is sorted by weight. +-- +-- Each element has a key ('k'), value ('v'), and weight ('w'). All operations +-- that add elements or modify weights stably sort the elements by weight. +newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)] + deriving (Eq, Show, Functor, F.Foldable, T.Traversable) + +-- | /O(N)/. +filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v +filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs) + +-- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements. +isZeroOrOne :: WeightedPSQ w k v -> Bool +isZeroOrOne (WeightedPSQ []) = True +isZeroOrOne (WeightedPSQ [_]) = True +isZeroOrOne _ = False + +-- | /O(1)/. Return the elements in order. +toList :: WeightedPSQ w k v -> [(w, k, v)] +toList (WeightedPSQ xs) = xs + +-- | /O(N log N)/. +fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v +fromList = WeightedPSQ . L.sortBy (comparing triple_1) + +-- | /O(N)/. Return the weights in order. +weights :: WeightedPSQ w k v -> [w] +weights (WeightedPSQ xs) = L.map triple_1 xs + +-- | /O(N)/. Return the keys in order. +keys :: WeightedPSQ w k v -> [k] +keys (WeightedPSQ xs) = L.map triple_2 xs + +-- | /O(N)/. Return the value associated with the first occurrence of the give +-- key, if it exists. +lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v +lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs + +-- | /O(N log N)/. Update the weights. +mapWeightsWithKey :: Ord w2 + => (k -> w1 -> w2) + -> WeightedPSQ w1 k v + -> WeightedPSQ w2 k v +mapWeightsWithKey f (WeightedPSQ xs) = fromList $ + L.map (\ (w, k, v) -> (f k w, k, v)) xs + +-- | /O(N)/. Update the values. +mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2 +mapWithKey f (WeightedPSQ xs) = WeightedPSQ $ + L.map (\ (w, k, v) -> (w, k, f k v)) xs + +-- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all +-- elements. Elements from the first @WeightedPSQ@ come before elements in the +-- second when they have the same weight. +union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v +union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys) + +-- | /O(N)/. Return the prefix of values ending with the first element that +-- satisfies p, or all elements if none satisfy p. +takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v +takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs) + where + go :: [(w, k, v)] -> [(w, k, v)] + go [] = [] + go (y : ys) = y : if p (triple_3 y) then [] else go ys + +triple_1 :: (x, y, z) -> x +triple_1 (x, _, _) = x + +triple_2 :: (x, y, z) -> y +triple_2 (_, y, _) = y + +triple_3 :: (x, y, z) -> z +triple_3 (_, _, z) = z diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | Fine-grained package dependencies +-- +-- Like many others, this module is meant to be "double-imported": +-- +-- > import Distribution.Solver.Types.ComponentDeps ( +-- > Component +-- > , ComponentDep +-- > , ComponentDeps +-- > ) +-- > import qualified Distribution.Solver.Types.ComponentDeps as CD +module Distribution.Solver.Types.ComponentDeps ( + -- * Fine-grained package dependencies + Component(..) + , componentNameToComponent + , ComponentDep + , ComponentDeps -- opaque + -- ** Constructing ComponentDeps + , empty + , fromList + , singleton + , insert + , zip + , filterDeps + , fromLibraryDeps + , fromSetupDeps + , fromInstalled + -- ** Deconstructing ComponentDeps + , toList + , flatDeps + , nonSetupDeps + , libraryDeps + , setupDeps + , select + , components + ) where + +import Prelude () +import Distribution.Types.UnqualComponentName +import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) + +import qualified Data.Map as Map +import Data.Foldable (fold) + +import Distribution.Pretty (Pretty (..)) +import qualified Distribution.Types.ComponentName as CN +import qualified Distribution.Types.LibraryName as LN +import qualified Text.PrettyPrint as PP + + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +-- | Component of a package. +data Component = + ComponentLib + | ComponentSubLib UnqualComponentName + | ComponentFLib UnqualComponentName + | ComponentExe UnqualComponentName + | ComponentTest UnqualComponentName + | ComponentBench UnqualComponentName + | ComponentSetup + deriving (Show, Eq, Ord, Generic) + +instance Binary Component +instance Structured Component + +instance Pretty Component where + pretty ComponentLib = PP.text "lib" + pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n + pretty (ComponentFLib n) = PP.text "flib:" <<>> pretty n + pretty (ComponentExe n) = PP.text "exe:" <<>> pretty n + pretty (ComponentTest n) = PP.text "test:" <<>> pretty n + pretty (ComponentBench n) = PP.text "bench:" <<>> pretty n + pretty ComponentSetup = PP.text "setup" + +-- | Dependency for a single component. +type ComponentDep a = (Component, a) + +-- | Fine-grained dependencies for a package. +-- +-- Typically used as @ComponentDeps [Dependency]@, to represent the list of +-- dependencies for each named component within a package. +-- +newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } + deriving (Show, Functor, Eq, Ord, Generic) + +instance Semigroup a => Monoid (ComponentDeps a) where + mempty = ComponentDeps Map.empty + mappend = (<>) + +instance Semigroup a => Semigroup (ComponentDeps a) where + ComponentDeps d <> ComponentDeps d' = + ComponentDeps (Map.unionWith (<>) d d') + +instance Foldable ComponentDeps where + foldMap f = foldMap f . unComponentDeps + +instance Traversable ComponentDeps where + traverse f = fmap ComponentDeps . traverse f . unComponentDeps + +instance Binary a => Binary (ComponentDeps a) +instance Structured a => Structured (ComponentDeps a) + +componentNameToComponent :: CN.ComponentName -> Component +componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib +componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s +componentNameToComponent (CN.CFLibName s) = ComponentFLib s +componentNameToComponent (CN.CExeName s) = ComponentExe s +componentNameToComponent (CN.CTestName s) = ComponentTest s +componentNameToComponent (CN.CBenchName s) = ComponentBench s + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +empty :: ComponentDeps a +empty = ComponentDeps $ Map.empty + +fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a +fromList = ComponentDeps . Map.fromListWith mappend + +singleton :: Component -> a -> ComponentDeps a +singleton comp = ComponentDeps . Map.singleton comp + +insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a +insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps + where + aux Nothing = Just a + aux (Just a') = Just $ a `mappend` a' + +-- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' +-- as the neutral element when a 'Component' is present only in one. +zip + :: (Monoid a, Monoid b) + => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) +zip (ComponentDeps d1) (ComponentDeps d2) = + ComponentDeps $ + Map.mergeWithKey + (\_ a b -> Just (a,b)) + (fmap (\a -> (a, mempty))) + (fmap (\b -> (mempty, b))) + d1 d2 + +-- | Keep only selected components (and their associated deps info). +filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a +filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps + +-- | ComponentDeps containing library dependencies only +fromLibraryDeps :: a -> ComponentDeps a +fromLibraryDeps = singleton ComponentLib + +-- | ComponentDeps containing setup dependencies only. +fromSetupDeps :: a -> ComponentDeps a +fromSetupDeps = singleton ComponentSetup + +-- | ComponentDeps for installed packages. +-- +-- We assume that installed packages only record their library dependencies. +fromInstalled :: a -> ComponentDeps a +fromInstalled = fromLibraryDeps + +{------------------------------------------------------------------------------- + Deconstruction +-------------------------------------------------------------------------------} + +toList :: ComponentDeps a -> [ComponentDep a] +toList = Map.toList . unComponentDeps + +-- | All dependencies of a package. +-- +-- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more +-- obvious than a use of 'fold', and moreover this avoids introducing lots of +-- @#ifdef@s for 7.10 just for the use of 'fold'. +flatDeps :: Monoid a => ComponentDeps a -> a +flatDeps = fold + +-- | All dependencies except the setup dependencies. +-- +-- Prior to the introduction of setup dependencies in version 1.24 this +-- would have been _all_ dependencies. +nonSetupDeps :: Monoid a => ComponentDeps a -> a +nonSetupDeps = select (/= ComponentSetup) + +-- | Library dependencies proper only. (Includes dependencies +-- of internal libraries.) +libraryDeps :: Monoid a => ComponentDeps a -> a +libraryDeps = select (\c -> case c of ComponentSubLib _ -> True + ComponentLib -> True + _ -> False) + +-- | List components +components :: ComponentDeps a -> Set Component +components = Map.keysSet . unComponentDeps + +-- | Setup dependencies. +setupDeps :: Monoid a => ComponentDeps a -> a +setupDeps = select (== ComponentSetup) + +-- | Select dependencies satisfying a given predicate. +select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a +select p = foldMap snd . filter (p . fst) . toList diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) + , showConstraintSource + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +-- | Source of a 'PackageConstraint'. +data ConstraintSource = + + -- | Main config file, which is ~/.cabal/config by default. + ConstraintSourceMainConfig FilePath + + -- | Local cabal.project file + | ConstraintSourceProjectConfig FilePath + + -- | Sandbox config file, which is ./cabal.sandbox.config by default. + | ConstraintSourceSandboxConfig FilePath + + -- | User config file, which is ./cabal.config by default. + | ConstraintSourceUserConfig FilePath + + -- | Flag specified on the command line. + | ConstraintSourceCommandlineFlag + + -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ + -- implies @package==0.1.0.0@. + | ConstraintSourceUserTarget + + -- | Internal requirement to use installed versions of packages like ghc-prim. + | ConstraintSourceNonUpgradeablePackage + + -- | Internal requirement to use the add-source version of a package when that + -- version is installed and the source is modified. + | ConstraintSourceModifiedAddSourceDep + + -- | Internal constraint used by @cabal freeze@. + | ConstraintSourceFreeze + + -- | Constraint specified by a config file, a command line flag, or a user + -- target, when a more specific source is not known. + | ConstraintSourceConfigFlagOrTarget + + -- | The source of the constraint is not specified. + | ConstraintSourceUnknown + + -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a minimum lower bound on Cabal + | ConstraintSetupCabalMinVersion + + -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a maximum upper bound on Cabal + | ConstraintSetupCabalMaxVersion + deriving (Eq, Show, Generic) + +instance Binary ConstraintSource +instance Structured ConstraintSource + +-- | Description of a 'ConstraintSource'. +showConstraintSource :: ConstraintSource -> String +showConstraintSource (ConstraintSourceMainConfig path) = + "main config " ++ path +showConstraintSource (ConstraintSourceProjectConfig path) = + "project config " ++ path +showConstraintSource (ConstraintSourceSandboxConfig path) = + "sandbox config " ++ path +showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path +showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" +showConstraintSource ConstraintSourceUserTarget = "user target" +showConstraintSource ConstraintSourceNonUpgradeablePackage = + "non-upgradeable package" +showConstraintSource ConstraintSourceModifiedAddSourceDep = + "modified add-source dependency" +showConstraintSource ConstraintSourceFreeze = "cabal freeze" +showConstraintSource ConstraintSourceConfigFlagOrTarget = + "config file, command line flag, or user target" +showConstraintSource ConstraintSourceUnknown = "unknown source" +showConstraintSource ConstraintSetupCabalMinVersion = + "minimum version of Cabal used by Setup.hs" +showConstraintSource ConstraintSetupCabalMaxVersion = + "maximum version of Cabal used by Setup.hs" diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -0,0 +1,37 @@ +module Distribution.Solver.Types.DependencyResolver + ( DependencyResolver + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PackageIndex ( PackageIndex ) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SourcePackage + +import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) +import Distribution.Package ( PackageName ) +import Distribution.Compiler ( CompilerInfo ) +import Distribution.System ( Platform ) + +-- | A dependency resolver is a function that works out an installation plan +-- given the set of installed and available packages and a set of deps to +-- solve for. +-- +-- The reason for this interface is because there are dozens of approaches to +-- solving the package dependency problem and we want to make it easy to swap +-- in alternatives. +-- +type DependencyResolver loc = Platform + -> CompilerInfo + -> InstalledPackageIndex + -> PackageIndex (SourcePackage loc) + -> PkgConfigDb + -> (PackageName -> PackagePreferences) + -> [LabeledPackageConstraint] + -> Set PackageName + -> Progress String String [ResolverPackage loc] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs b/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs @@ -0,0 +1,8 @@ +module Distribution.Solver.Types.Flag + ( FlagType(..) + ) where + +import Prelude (Eq, Show) + +data FlagType = Manual | Automatic + deriving (Eq, Show) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.InstSolverPackage + ( InstSolverPackage(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.SolverId +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.MungedPackageName +import Distribution.InstalledPackageInfo (InstalledPackageInfo) + +-- | An 'InstSolverPackage' is a pre-existing installed package +-- specified by the dependency solver. +data InstSolverPackage = InstSolverPackage { + instSolverPkgIPI :: InstalledPackageInfo, + instSolverPkgLibDeps :: ComponentDeps [SolverId], + instSolverPkgExeDeps :: ComponentDeps [SolverId] + } + deriving (Eq, Show, Generic) + +instance Binary InstSolverPackage +instance Structured InstSolverPackage + +instance Package InstSolverPackage where + packageId i = + -- HACK! See Note [Index conversion with internal libraries] + let MungedPackageId mpn v = mungedId i + in PackageIdentifier (encodeCompatPackageName mpn) v + +instance HasMungedPackageId InstSolverPackage where + mungedId = mungedId . instSolverPkgIPI + +instance HasUnitId InstSolverPackage where + installedUnitId = installedUnitId . instSolverPkgIPI diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs @@ -0,0 +1,11 @@ +module Distribution.Solver.Types.InstalledPreference + ( InstalledPreference(..), + ) where + +import Prelude (Show) + +-- | Whether we prefer an installed version of a package or simply the latest +-- version. +-- +data InstalledPreference = PreferInstalled | PreferLatest + deriving Show diff --git a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/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/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs b/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.OptionalStanza ( + -- * OptionalStanza + OptionalStanza(..), + showStanza, + showStanzas, + enableStanzas, + -- * Set of stanzas + OptionalStanzaSet, + optStanzaSetFromList, + optStanzaSetToList, + optStanzaSetMember, + optStanzaSetInsert, + optStanzaSetSingleton, + optStanzaSetIntersection, + optStanzaSetNull, + optStanzaSetIsSubset, + -- * Map indexed by stanzas + OptionalStanzaMap, + optStanzaTabulate, + optStanzaIndex, + optStanzaLookup, + optStanzaKeysFilteredByValue, +) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Data.Bits (testBit, (.|.), (.&.)) +import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec (..)) +import Distribution.Utils.Structured (Structured (..), nominalStructure) + +------------------------------------------------------------------------------- +-- OptionalStanza +------------------------------------------------------------------------------- + +data OptionalStanza + = TestStanzas + | BenchStanzas + deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) + +-- | String representation of an OptionalStanza. +showStanza :: OptionalStanza -> String +showStanza TestStanzas = "test" +showStanza BenchStanzas = "bench" + +showStanzas :: OptionalStanzaSet -> String +showStanzas = unwords . map (("*" ++) . showStanza) . optStanzaSetToList + +-- | Convert a list of 'OptionalStanza' into the corresponding +-- Cabal's 'ComponentRequestedSpec' which records what components are enabled. +-- +enableStanzas :: OptionalStanzaSet -> ComponentRequestedSpec +enableStanzas optionalStanzas = ComponentRequestedSpec + { testsRequested = optStanzaSetMember TestStanzas optionalStanzas + , benchmarksRequested = optStanzaSetMember BenchStanzas optionalStanzas + } + +instance Binary OptionalStanza +instance Structured OptionalStanza + +------------------------------------------------------------------------------- +-- OptionalStanzaSet +------------------------------------------------------------------------------- + +newtype OptionalStanzaSet = OptionalStanzaSet Word + deriving (Eq, Ord, Show) + +instance Binary OptionalStanzaSet where + put (OptionalStanzaSet w) = put w + get = fmap (OptionalStanzaSet . (.&. 0x03)) get + +instance Structured OptionalStanzaSet where + structure = nominalStructure + +optStanzaSetFromList :: [OptionalStanza] -> OptionalStanzaSet +optStanzaSetFromList = foldl' (flip optStanzaSetInsert) mempty + +optStanzaSetToList :: OptionalStanzaSet -> [OptionalStanza] +optStanzaSetToList (OptionalStanzaSet 0) = [] +optStanzaSetToList (OptionalStanzaSet 1) = [TestStanzas] +optStanzaSetToList (OptionalStanzaSet 2) = [BenchStanzas] +optStanzaSetToList (OptionalStanzaSet 3) = [TestStanzas, BenchStanzas] +optStanzaSetToList (OptionalStanzaSet _) = [] + +optStanzaSetInsert :: OptionalStanza -> OptionalStanzaSet -> OptionalStanzaSet +optStanzaSetInsert x s = optStanzaSetSingleton x <> s + +optStanzaSetMember :: OptionalStanza -> OptionalStanzaSet -> Bool +optStanzaSetMember TestStanzas (OptionalStanzaSet w) = testBit w 0 +optStanzaSetMember BenchStanzas (OptionalStanzaSet w) = testBit w 1 + +optStanzaSetSingleton :: OptionalStanza -> OptionalStanzaSet +optStanzaSetSingleton TestStanzas = OptionalStanzaSet 1 +optStanzaSetSingleton BenchStanzas = OptionalStanzaSet 2 + +optStanzaSetIntersection :: OptionalStanzaSet -> OptionalStanzaSet -> OptionalStanzaSet +optStanzaSetIntersection (OptionalStanzaSet a) (OptionalStanzaSet b) = OptionalStanzaSet (a .&. b) + +optStanzaSetNull :: OptionalStanzaSet -> Bool +optStanzaSetNull (OptionalStanzaSet w) = w == 0 + +optStanzaSetIsSubset :: OptionalStanzaSet -> OptionalStanzaSet -> Bool +optStanzaSetIsSubset (OptionalStanzaSet a) (OptionalStanzaSet b) = (a .|. b) == b + +instance Semigroup OptionalStanzaSet where + OptionalStanzaSet a <> OptionalStanzaSet b = OptionalStanzaSet (a .|. b) + +instance Monoid OptionalStanzaSet where + mempty = OptionalStanzaSet 0 + mappend = (<>) + +------------------------------------------------------------------------------- +-- OptionalStanzaMap +------------------------------------------------------------------------------- + +-- | Note: this is total map. +data OptionalStanzaMap a = OptionalStanzaMap a a + deriving (Eq, Ord, Show, Generic) + +instance Binary a => Binary (OptionalStanzaMap a) +instance Structured a => Structured (OptionalStanzaMap a) + +optStanzaTabulate :: (OptionalStanza -> a) -> OptionalStanzaMap a +optStanzaTabulate f = OptionalStanzaMap (f TestStanzas) (f BenchStanzas) + +optStanzaIndex :: OptionalStanzaMap a -> OptionalStanza -> a +optStanzaIndex (OptionalStanzaMap x _) TestStanzas = x +optStanzaIndex (OptionalStanzaMap _ x) BenchStanzas = x + +optStanzaLookup :: OptionalStanza -> OptionalStanzaMap a -> a +optStanzaLookup = flip optStanzaIndex + +optStanzaKeysFilteredByValue :: (a -> Bool) -> OptionalStanzaMap a -> OptionalStanzaSet +optStanzaKeysFilteredByValue p (OptionalStanzaMap x y) + | p x = if p y then OptionalStanzaSet 3 else OptionalStanzaSet 1 + | otherwise = if p y then OptionalStanzaSet 2 else OptionalStanzaSet 0 diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- +module Distribution.Solver.Types.PackageConstraint ( + ConstraintScope(..), + scopeToplevel, + scopeToPackageName, + constraintScopeMatches, + PackageProperty(..), + dispPackageProperty, + PackageConstraint(..), + dispPackageConstraint, + showPackageConstraint, + packageConstraintToDependency + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package (PackageName) +import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) +import Distribution.Pretty (flatStyle, pretty) +import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) +import Distribution.Version (VersionRange, simplifyVersionRange) + +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +import qualified Text.PrettyPrint as Disp + + +-- | Determines to what packages and in what contexts a +-- constraint applies. +data ConstraintScope + -- | A scope that applies when the given package is used as a build target. + -- In other words, the scope applies iff a goal has a top-level qualifier + -- and its namespace matches the given package name. A namespace is + -- considered to match a package name when it is either the default + -- namespace (for --no-independent-goals) or it is an independent namespace + -- with the given package name (for --independent-goals). + + -- TODO: Try to generalize the ConstraintScopes once component-based + -- solving is implemented, and remove this special case for targets. + = ScopeTarget PackageName + -- | The package with the specified name and qualifier. + | ScopeQualified Qualifier PackageName + -- | The package with the specified name when it has a + -- setup qualifier. + | ScopeAnySetupQualifier PackageName + -- | The package with the specified name regardless of + -- qualifier. + | ScopeAnyQualifier PackageName + deriving (Eq, Show) + +-- | Constructor for a common use case: the constraint applies to +-- the package with the specified name when that package is a +-- top-level dependency in the default namespace. +scopeToplevel :: PackageName -> ConstraintScope +scopeToplevel = ScopeQualified QualToplevel + +-- | Returns the package name associated with a constraint scope. +scopeToPackageName :: ConstraintScope -> PackageName +scopeToPackageName (ScopeTarget pn) = pn +scopeToPackageName (ScopeQualified _ pn) = pn +scopeToPackageName (ScopeAnySetupQualifier pn) = pn +scopeToPackageName (ScopeAnyQualifier pn) = pn + +constraintScopeMatches :: ConstraintScope -> QPN -> Bool +constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = + let namespaceMatches DefaultNamespace = True + namespaceMatches (Independent namespacePn) = pn == namespacePn + in namespaceMatches ns && q == QualToplevel && pn == pn' +constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = + q == q' && pn == pn' +constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = + let setup (PackagePath _ (QualSetup _)) = True + setup _ = False + in setup pp && pn == pn' +constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' + +-- | Pretty-prints a constraint scope. +dispConstraintScope :: ConstraintScope -> Disp.Doc +dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn +dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn +dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn +dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn + +-- | A package property is a logical predicate on packages. +data PackageProperty + = PackagePropertyVersion VersionRange + | PackagePropertyInstalled + | PackagePropertySource + | PackagePropertyFlags FlagAssignment + | PackagePropertyStanzas [OptionalStanza] + deriving (Eq, Show, Generic) + +instance Binary PackageProperty +instance Structured PackageProperty + +-- | Pretty-prints a package property. +dispPackageProperty :: PackageProperty -> Disp.Doc +dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange +dispPackageProperty PackagePropertyInstalled = Disp.text "installed" +dispPackageProperty PackagePropertySource = Disp.text "source" +dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags +dispPackageProperty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas + +-- | A package constraint consists of a scope plus a property +-- that must hold for all packages within that scope. +data PackageConstraint = PackageConstraint ConstraintScope PackageProperty + deriving (Eq, Show) + +-- | Pretty-prints a package constraint. +dispPackageConstraint :: PackageConstraint -> Disp.Doc +dispPackageConstraint (PackageConstraint scope prop) = + dispConstraintScope scope <+> dispPackageProperty prop + +-- | Alternative textual representation of a package constraint +-- for debugging purposes (slightly more verbose than that +-- produced by 'dispPackageConstraint'). +-- +showPackageConstraint :: PackageConstraint -> String +showPackageConstraint pc@(PackageConstraint scope prop) = + Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 + where + pc2 = case prop of + PackagePropertyVersion vr -> + PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr) + _ -> pc + postprocess = case prop of + PackagePropertyFlags _ -> (Disp.text "flags" <+>) + PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) + _ -> id + +-- | Lossily convert a 'PackageConstraint' to a 'Dependency'. +packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint +packageConstraintToDependency (PackageConstraint scope prop) = toDep prop + where + toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr + toDep (PackagePropertyInstalled) = Nothing + toDep (PackagePropertySource) = Nothing + toDep (PackagePropertyFlags _) = Nothing + toDep (PackagePropertyStanzas _) = Nothing diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/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/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Solver.Types.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Solver.Types.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + override, + insert, + deletePackageName, + deletePackageId, + deleteDependency, + + -- * Queries + + -- ** Precise lookups + elemByPackageId, + elemByPackageName, + lookupPackageName, + lookupPackageId, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + searchWithPredicate, + + -- ** Bulk queries + allPackages, + allPackagesByName, + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (lookup) + +import qualified Data.Map as Map +import Data.List (isInfixOf) +import qualified Data.List.NonEmpty as NE + +import Distribution.Client.Utils.Assertion ( expensiveAssert ) +import Distribution.Package + ( PackageName, unPackageName, PackageIdentifier(..) + , Package(..), packageName, packageVersion ) +import Distribution.Version + ( VersionRange, withinRange ) +import Distribution.Simple.Utils + ( lowercase ) + +import qualified Prelude (foldr1) + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- It can be searched efficiently by package name and version. +-- +newtype PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) + + deriving (Eq, Show, Read, Functor, Generic) +--FIXME: the Functor instance here relies on no package id changes + +instance Package pkg => Semigroup (PackageIndex pkg) where + (<>) = merge + +instance Package pkg => Monoid (PackageIndex pkg) where + mempty = PackageIndex Map.empty + mappend = (<>) + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = Prelude.foldr1 mappend xs + +instance Binary pkg => Binary (PackageIndex pkg) + +invariant :: Package pkg => PackageIndex pkg -> Bool +invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) + where + goodBucket _ [] = False + goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + where + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where pkgid' = packageId pkg' + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg +mkPackageIndex index = expensiveAssert (invariant (PackageIndex index)) + (PackageIndex index) + +internalError :: String -> a +internalError name = error ("PackageIndex." ++ name ++ ": internal error") + +-- | Lookup a name in the index to get all packages that match that name +-- case-sensitively. +-- +lookup :: PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates, later ones mask earlier ones. +-- +fromList :: Package pkg => [pkg] -> PackageIndex pkg +fromList pkgs = mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs ] + where + fixBucket = -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map NE.head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . NE.groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +merge i1@(PackageIndex m1) i2@(PackageIndex m2) = + expensiveAssert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + + +-- | Elements in the second list mask those in the first. +mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x:xs') ys@(y:ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys + +-- | Override-merge oftwo indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +override i1@(PackageIndex m1) i2@(PackageIndex m2) = + expensiveAssert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2) + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg +insert pkg (PackageIndex index) = mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index + where + pkgid = packageId pkg + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' + GT -> pkg' : insertNoDup pkgs' + +-- | Internal delete helper. +-- +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg + -> PackageIndex pkg +delete name p (PackageIndex index) = mkPackageIndex $ + Map.update filterBucket name index + where + filterBucket = deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing + deleteEmptyBucket remaining = Just remaining + +-- | Removes a single package from the index. +-- +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg + -> PackageIndex pkg +deletePackageId pkgid = + delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg + -> PackageIndex pkg +deletePackageName name = + delete name (\pkg -> packageName pkg == name) + +-- | Removes all packages satisfying this dependency from the index. +deleteDependency :: Package pkg + => PackageName -> VersionRange -> PackageIndex pkg + -> PackageIndex pkg +deleteDependency name verstionRange = + delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: PackageIndex pkg -> [pkg] +allPackages (PackageIndex m) = concat (Map.elems m) + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: PackageIndex pkg -> [[pkg]] +allPackagesByName (PackageIndex m) = Map.elems m + +-- +-- * Lookups +-- + +elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool +elemByPackageId index = isJust . lookupPackageId index + +elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool +elemByPackageName index = not . null . lookupPackageName index + + +-- | Does a lookup by package id (name & version). +-- +-- Since multiple package DBs mask each other case-sensitively by package name, +-- then we get back at most one package. +-- +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier + -> Maybe pkg +lookupPackageId index pkgid = + case [ pkg | pkg <- lookup index (packageName pkgid) + , packageId pkg == pkgid ] of + [] -> Nothing + [pkg] -> Just pkg + _ -> internalError "lookupPackageIdentifier" + +-- | Does a case-sensitive search by package name. +-- +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookupPackageName index name = + [ pkg | pkg <- lookup index name + , packageName pkg == name ] + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: Package pkg + => PackageIndex pkg + -> PackageName -> VersionRange + -> [pkg] +lookupDependency index name versionRange = + [ pkg | pkg <- lookup index name + , packageName pkg == name + , packageVersion pkg `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insensitively to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insensitively but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insensitively and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByName (PackageIndex m) name = + [ pkgs + | pkgs@(pname,_) <- Map.toList m + , lowercase (unPackageName pname) == lname ] + where + lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByNameSubstring index searchterm = + searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) + where lsearchterm = lowercase searchterm + +searchWithPredicate :: PackageIndex pkg + -> (String -> Bool) -> [(PackageName, [pkg])] +searchWithPredicate (PackageIndex m) predicate = + [ pkgs + | pkgs@(pname, _) <- Map.toList m + , predicate (unPackageName pname) + ] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -0,0 +1,102 @@ +module Distribution.Solver.Types.PackagePath + ( PackagePath(..) + , Namespace(..) + , Qualifier(..) + , dispQualifier + , Qualified(..) + , QPN + , dispQPN + , showQPN + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () +import Distribution.Package (PackageName) +import Distribution.Pretty (pretty, flatStyle) +import qualified Text.PrettyPrint as Disp + +-- | A package path consists of a namespace and a package path inside that +-- namespace. +data PackagePath = PackagePath Namespace Qualifier + deriving (Eq, Ord, Show) + +-- | Top-level namespace +-- +-- Package choices in different namespaces are considered completely independent +-- by the solver. +data Namespace = + -- | The default namespace + DefaultNamespace + + -- | A namespace for a specific build target + | Independent PackageName + deriving (Eq, Ord, Show) + +-- | Pretty-prints a namespace. The result is either empty or +-- ends in a period, so it can be prepended onto a qualifier. +dispNamespace :: Namespace -> Disp.Doc +dispNamespace DefaultNamespace = Disp.empty +dispNamespace (Independent i) = pretty i <<>> Disp.text "." + +-- | Qualifier of a package within a namespace (see 'PackagePath') +data Qualifier = + -- | Top-level dependency in this namespace + QualToplevel + + -- | Any dependency on base is considered independent + -- + -- This makes it possible to have base shims. + | QualBase PackageName + + -- | Setup dependency + -- + -- By rights setup dependencies ought to be nestable; after all, the setup + -- dependencies of a package might themselves have setup dependencies, which + -- are independent from everything else. However, this very quickly leads to + -- infinite search trees in the solver. Therefore we limit ourselves to + -- a single qualifier (within a given namespace). + | QualSetup PackageName + + -- | If we depend on an executable from a package (via + -- @build-tools@), we should solve for the dependencies of that + -- package separately (since we're not going to actually try to + -- link it.) We qualify for EACH package separately; e.g., + -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on + -- @pn2@ from package @pn1@. (If we tracked only @pn1@, that + -- would require a consistent dependency resolution for all + -- of the depended upon executables from a package; if we + -- tracked only @pn2@, that would require us to pick only one + -- version of an executable over the entire install plan.) + | QualExe PackageName PackageName + deriving (Eq, Ord, Show) + +-- | Pretty-prints a qualifier. The result is either empty or +-- ends in a period, so it can be prepended onto a package name. +-- +-- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is +-- there to make sure different dependencies on base are all independent. +-- So we want to print something like @"A.base"@, where the @"A."@ part +-- is the qualifier and @"base"@ is the actual dependency (which, for the +-- 'Base' qualifier, will always be @base@). +dispQualifier :: Qualifier -> Disp.Doc +dispQualifier QualToplevel = Disp.empty +dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." +dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> + pretty pn2 <<>> Disp.text ":exe." +dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." + +-- | A qualified entity. Pairs a package path with the entity. +data Qualified a = Q PackagePath a + deriving (Eq, Ord, Show) + +-- | Qualified package name. +type QPN = Qualified PackageName + +-- | Pretty-prints a qualified package name. +dispQPN :: QPN -> Disp.Doc +dispQPN (Q (PackagePath ns qual) pn) = + dispNamespace ns <<>> dispQualifier qual <<>> pretty pn + +-- | String representation of a qualified package name. +showQPN :: QPN -> String +showQPN = Disp.renderStyle flatStyle . dispQPN diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/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/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs b/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Solver.Types.PkgConfigDb +-- Copyright : (c) Iñaki García Etxebarria 2016 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Read the list of packages available to pkg-config. +----------------------------------------------------------------------------- +module Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb + , readPkgConfigDb + , pkgConfigDbFromList + , pkgConfigPkgIsPresent + , pkgConfigDbPkgVersion + , getPkgConfigDbDirs + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Control.Exception (handle) +import qualified Data.Map as M +import System.FilePath (splitSearchPath) + +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Package (PkgconfigName, mkPkgconfigName) +import Distribution.Parsec +import Distribution.Simple.Program + (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram) +import Distribution.Simple.Utils (info) +import Distribution.Types.PkgconfigVersion +import Distribution.Types.PkgconfigVersionRange +import Distribution.Verbosity (Verbosity) + +-- | The list of packages installed in the system visible to +-- @pkg-config@. This is an opaque datatype, to be constructed with +-- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. +data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) + -- ^ If an entry is `Nothing`, this means that the + -- package seems to be present, but we don't know the + -- exact version (because parsing of the version + -- number failed). + | NoPkgConfigDb + -- ^ For when we could not run pkg-config successfully. + deriving (Show, Generic, Typeable) + +instance Binary PkgConfigDb +instance Structured PkgConfigDb + +-- | Query pkg-config for the list of installed packages, together +-- with their versions. Return a `PkgConfigDb` encapsulating this +-- information. +readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb +readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> noPkgConfig "Cannot find pkg-config program" + Just (pkgConfig, _) -> do + pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] + -- The output of @pkg-config --list-all@ also includes a description + -- for each package, which we do not need. + let pkgNames = map (takeWhile (not . isSpace)) pkgList + pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig + ("--modversion" : pkgNames) + (return . pkgConfigDbFromList . zip pkgNames) pkgVersions + where + -- For when pkg-config invocation fails (possibly because of a + -- too long command line). + noPkgConfig extra = do + info verbosity ("Failed to query pkg-config, Cabal will continue" + ++ " without solving for pkg-config constraints: " + ++ extra) + return NoPkgConfigDb + + ioErrorHandler :: IOException -> IO PkgConfigDb + ioErrorHandler e = noPkgConfig (show e) + +-- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. +pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb +pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs + where + convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion) + convert (n,vs) = (mkPkgconfigName n, simpleParsec vs) + +-- | Check whether a given package range is satisfiable in the given +-- @pkg-config@ database. +pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool +pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = + case M.lookup pn db of + Nothing -> False -- Package not present in the DB. + Just Nothing -> True -- Package present, but version unknown. + Just (Just v) -> withinPkgconfigVersionRange v vr +-- If we could not read the pkg-config database successfully we allow +-- the check to succeed. The plan found by the solver may fail to be +-- executed later on, but we have no grounds for rejecting the plan at +-- this stage. +pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True + + +-- | Query the version of a package in the @pkg-config@ database. +-- @Nothing@ indicates the package is not in the database, while +-- @Just Nothing@ indicates that the package is in the database, +-- but its version is not known. +pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion) +pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db +-- NB: Since the solver allows solving to succeed if there is +-- NoPkgConfigDb, we should report that we *guess* that there +-- is a matching pkg-config configuration, but that we just +-- don't know about it. +pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing + + +-- | Query pkg-config for the locations of pkg-config's package files. Use this +-- to monitor for changes in the pkg-config DB. +-- +getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath] +getPkgConfigDbDirs verbosity progdb = + (++) <$> getEnvPath <*> getDefPath + where + -- According to @man pkg-config@: + -- + -- PKG_CONFIG_PATH + -- A colon-separated (on Windows, semicolon-separated) list of directories + -- to search for .pc files. The default directory will always be searched + -- after searching the path + -- + getEnvPath = maybe [] parseSearchPath + <$> lookupEnv "PKG_CONFIG_PATH" + + -- Again according to @man pkg-config@: + -- + -- pkg-config can be used to query itself for the default search path, + -- version number and other information, for instance using: + -- + -- > pkg-config --variable pc_path pkg-config + -- + getDefPath = handle ioErrorHandler $ do + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> return [] + Just (pkgConfig, _) -> parseSearchPath <$> + getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] + + parseSearchPath str = + case lines str of + [p] | not (null p) -> splitSearchPath p + _ -> [] + + ioErrorHandler :: IOException -> IO [FilePath] + ioErrorHandler _e = return [] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs @@ -0,0 +1,49 @@ +module Distribution.Solver.Types.Progress + ( Progress(..) + , foldProgress + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (fail) + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail. We may get intermediate steps before the final +-- result which may be used to indicate progress and\/or logging messages. +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + +-- This Functor instance works around a bug in GHC 7.6.3. +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637. +-- The derived functor instance caused a space leak in the solver. +instance Functor (Progress step fail) where + fmap f (Step s p) = Step s (fmap f p) + fmap _ (Fail x) = Fail x + fmap f (Done r) = Done (f r) + +-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two +-- base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step fail done = fold + where fold (Step s p) = step s (fold p) + fold (Fail f) = fail f + fold (Done r) = done r + +instance Monad (Progress step fail) where + return = pure + p >>= f = foldProgress Step Fail f p + +instance Applicative (Progress step fail) where + pure a = Done a + p <*> x = foldProgress Step Fail (flip fmap x) p + +instance Monoid fail => Alternative (Progress step fail) where + empty = Fail mempty + p <|> q = foldProgress Step (const q) Done p diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.ResolverPackage + ( ResolverPackage(..) + , resolverPackageLibDeps + , resolverPackageExeDeps + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import qualified Distribution.Solver.Types.ComponentDeps as CD + +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Package (Package(..), HasUnitId(..)) +import Distribution.Simple.Utils (ordNub) + +-- | The dependency resolver picks either pre-existing installed packages +-- or it picks source packages along with package configuration. +-- +-- This is like the 'InstallPlan.PlanPackage' but with fewer cases. +-- +data ResolverPackage loc = PreExisting InstSolverPackage + | Configured (SolverPackage loc) + deriving (Eq, Show, Generic) + +instance Binary loc => Binary (ResolverPackage loc) +instance Structured loc => Structured (ResolverPackage loc) + +instance Package (ResolverPackage loc) where + packageId (PreExisting ipkg) = packageId ipkg + packageId (Configured spkg) = packageId spkg + +resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] +resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg +resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg + +resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] +resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg +resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg + +instance IsNode (ResolverPackage loc) where + type Key (ResolverPackage loc) = SolverId + nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) + nodeKey (Configured spkg) = PlannedId (packageId spkg) + -- Use dependencies for ALL components + nodeNeighbors pkg = + ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ + CD.flatDeps (resolverPackageExeDeps pkg) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs b/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Solver.Types.Settings + ( ReorderGoals(..) + , IndependentGoals(..) + , MinimizeConflictSet(..) + , AvoidReinstalls(..) + , ShadowPkgs(..) + , StrongFlags(..) + , AllowBootLibInstalls(..) + , OnlyConstrained(..) + , EnableBackjumping(..) + , CountConflicts(..) + , FineGrainedConflicts(..) + , SolveExecutables(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Simple.Setup ( BooleanFlag(..) ) +import Distribution.Pretty ( Pretty(pretty) ) +import Distribution.Parsec ( Parsec(parsec) ) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +newtype ReorderGoals = ReorderGoals Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype CountConflicts = CountConflicts Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype FineGrainedConflicts = FineGrainedConflicts Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype MinimizeConflictSet = MinimizeConflictSet Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype IndependentGoals = IndependentGoals Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype AvoidReinstalls = AvoidReinstalls Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype ShadowPkgs = ShadowPkgs Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype StrongFlags = StrongFlags Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype AllowBootLibInstalls = AllowBootLibInstalls Bool + deriving (BooleanFlag, Eq, Generic, Show) + +-- | Should we consider all packages we know about, or only those that +-- have constraints explicitly placed on them or which are goals? +data OnlyConstrained + = OnlyConstrainedNone + | OnlyConstrainedAll + deriving (Eq, Generic, Show) + +newtype EnableBackjumping = EnableBackjumping Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype SolveExecutables = SolveExecutables Bool + deriving (BooleanFlag, Eq, Generic, Show) + +instance Binary ReorderGoals +instance Binary CountConflicts +instance Binary FineGrainedConflicts +instance Binary IndependentGoals +instance Binary MinimizeConflictSet +instance Binary AvoidReinstalls +instance Binary ShadowPkgs +instance Binary StrongFlags +instance Binary AllowBootLibInstalls +instance Binary OnlyConstrained +instance Binary SolveExecutables + +instance Structured ReorderGoals +instance Structured CountConflicts +instance Structured FineGrainedConflicts +instance Structured IndependentGoals +instance Structured MinimizeConflictSet +instance Structured AvoidReinstalls +instance Structured ShadowPkgs +instance Structured StrongFlags +instance Structured AllowBootLibInstalls +instance Structured OnlyConstrained +instance Structured SolveExecutables + +instance Pretty OnlyConstrained where + pretty OnlyConstrainedAll = PP.text "all" + pretty OnlyConstrainedNone = PP.text "none" + +instance Parsec OnlyConstrained where + parsec = P.choice + [ P.string "all" >> return OnlyConstrainedAll + , P.string "none" >> return OnlyConstrainedNone + ] + diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.SolverId + ( SolverId(..) + ) + +where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package (PackageId, Package(..), UnitId) + +-- | The solver can produce references to existing packages or +-- packages we plan to install. Unlike 'ConfiguredId' we don't +-- yet know the 'UnitId' for planned packages, because it's +-- not the solver's job to compute them. +-- +data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } + | PlannedId { solverSrcId :: PackageId } + deriving (Eq, Ord, Generic) + +instance Binary SolverId +instance Structured SolverId + +instance Show SolverId where + show = show . solverSrcId + +instance Package SolverId where + packageId = solverSrcId diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.SolverPackage + ( SolverPackage(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package ( Package(..) ) +import Distribution.PackageDescription ( FlagAssignment ) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SourcePackage + +-- | A 'SolverPackage' is a package specified by the dependency solver. +-- It will get elaborated into a 'ConfiguredPackage' or even an +-- 'ElaboratedConfiguredPackage'. +-- +-- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc', +-- but for symmetry we have the parameter. (Maybe it can be removed.) +-- +data SolverPackage loc = SolverPackage { + solverPkgSource :: SourcePackage loc, + solverPkgFlags :: FlagAssignment, + solverPkgStanzas :: OptionalStanzaSet, + solverPkgLibDeps :: ComponentDeps [SolverId], + solverPkgExeDeps :: ComponentDeps [SolverId] + } + deriving (Eq, Show, Generic) + +instance Binary loc => Binary (SolverPackage loc) +instance Structured loc => Structured (SolverPackage loc) + +instance Package (SolverPackage loc) where + packageId = packageId . solverPkgSource diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.Solver.Types.SourcePackage + ( PackageDescriptionOverride + , SourcePackage(..) + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Package + ( PackageId, Package(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..) ) + +import Data.ByteString.Lazy (ByteString) + +-- | A package description along with the location of the package sources. +-- +data SourcePackage loc = SourcePackage + { srcpkgPackageId :: PackageId + , srcpkgDescription :: GenericPackageDescription + -- ^ Note, this field is lazy, e.g. when reading in hackage index + -- we parse only what we need, not whole index. + , srcpkgSource :: loc + , srcpkgDescrOverride :: PackageDescriptionOverride + } + deriving (Eq, Show, Generic, Typeable) + +instance Binary loc => Binary (SourcePackage loc) +instance Structured loc => Structured (SourcePackage loc) + +instance Package (SourcePackage a) where packageId = srcpkgPackageId + +-- | We sometimes need to override the .cabal file in the tarball with +-- the newer one from the package index. +type PackageDescriptionOverride = Maybe ByteString diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs b/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs new file mode 100644 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Variable.hs @@ -0,0 +1,15 @@ +module Distribution.Solver.Types.Variable where + +import Prelude (Eq, Show) + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.PackageDescription (FlagName) + +-- | Variables used by the dependency solver. This type is similar to the +-- internal 'Var' type. +data Variable qpn = + PackageVar qpn + | FlagVar qpn FlagName + | StanzaVar qpn OptionalStanza + deriving (Eq, Show) diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -4,7 +4,7 @@ -- To update this file, edit 'cabal-install.cabal.pp' and run -- 'make cabal-install-prod' in the project's root folder. Name: cabal-install -Version: 3.4.1.0 +Version: 3.6.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -22,82 +22,6 @@ Extra-Source-Files: README.md bash-completion/cabal changelog - -- Generated with 'make gen-extra-source-files' - -- Do NOT edit this section manually; instead, run the script. - -- BEGIN gen-extra-source-files - tests/IntegrationTests2/build/keep-going/cabal.project - tests/IntegrationTests2/build/keep-going/p/P.hs - tests/IntegrationTests2/build/keep-going/p/p.cabal - tests/IntegrationTests2/build/keep-going/q/Q.hs - tests/IntegrationTests2/build/keep-going/q/q.cabal - tests/IntegrationTests2/build/local-tarball/cabal.project - tests/IntegrationTests2/build/local-tarball/q/Q.hs - tests/IntegrationTests2/build/local-tarball/q/q.cabal - tests/IntegrationTests2/build/setup-custom1/A.hs - tests/IntegrationTests2/build/setup-custom1/Setup.hs - tests/IntegrationTests2/build/setup-custom1/a.cabal - tests/IntegrationTests2/build/setup-custom2/A.hs - tests/IntegrationTests2/build/setup-custom2/Setup.hs - tests/IntegrationTests2/build/setup-custom2/a.cabal - tests/IntegrationTests2/build/setup-simple/A.hs - tests/IntegrationTests2/build/setup-simple/Setup.hs - tests/IntegrationTests2/build/setup-simple/a.cabal - tests/IntegrationTests2/exception/bad-config/cabal.project - tests/IntegrationTests2/exception/build/Main.hs - tests/IntegrationTests2/exception/build/a.cabal - tests/IntegrationTests2/exception/configure/a.cabal - tests/IntegrationTests2/exception/no-pkg/empty.in - tests/IntegrationTests2/exception/no-pkg2/cabal.project - tests/IntegrationTests2/regression/3324/cabal.project - tests/IntegrationTests2/regression/3324/p/P.hs - tests/IntegrationTests2/regression/3324/p/p.cabal - tests/IntegrationTests2/regression/3324/q/Q.hs - tests/IntegrationTests2/regression/3324/q/q.cabal - tests/IntegrationTests2/targets/all-disabled/cabal.project - tests/IntegrationTests2/targets/all-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project - tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal - tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal - tests/IntegrationTests2/targets/complex/cabal.project - tests/IntegrationTests2/targets/complex/q/Q.hs - tests/IntegrationTests2/targets/complex/q/q.cabal - tests/IntegrationTests2/targets/empty-pkg/cabal.project - tests/IntegrationTests2/targets/empty-pkg/p.cabal - tests/IntegrationTests2/targets/empty/cabal.project - tests/IntegrationTests2/targets/empty/foo.hs - tests/IntegrationTests2/targets/exes-disabled/cabal.project - tests/IntegrationTests2/targets/exes-disabled/p/p.cabal - tests/IntegrationTests2/targets/exes-disabled/q/q.cabal - tests/IntegrationTests2/targets/lib-only/p.cabal - tests/IntegrationTests2/targets/libs-disabled/cabal.project - tests/IntegrationTests2/targets/libs-disabled/p/p.cabal - tests/IntegrationTests2/targets/libs-disabled/q/q.cabal - tests/IntegrationTests2/targets/multiple-exes/cabal.project - tests/IntegrationTests2/targets/multiple-exes/p.cabal - tests/IntegrationTests2/targets/multiple-libs/cabal.project - tests/IntegrationTests2/targets/multiple-libs/p/p.cabal - tests/IntegrationTests2/targets/multiple-libs/q/q.cabal - tests/IntegrationTests2/targets/multiple-tests/cabal.project - tests/IntegrationTests2/targets/multiple-tests/p.cabal - tests/IntegrationTests2/targets/simple/P.hs - tests/IntegrationTests2/targets/simple/app/Main.hs - tests/IntegrationTests2/targets/simple/cabal.project - tests/IntegrationTests2/targets/simple/p.cabal - tests/IntegrationTests2/targets/simple/q/Q.hs - tests/IntegrationTests2/targets/simple/q/QQ.hs - tests/IntegrationTests2/targets/simple/q/q.cabal - tests/IntegrationTests2/targets/test-only/p.cabal - tests/IntegrationTests2/targets/tests-disabled/cabal.project - tests/IntegrationTests2/targets/tests-disabled/p.cabal - tests/IntegrationTests2/targets/tests-disabled/q/q.cabal - tests/IntegrationTests2/targets/variety/cabal.project - tests/IntegrationTests2/targets/variety/p.cabal - -- END gen-extra-source-files - - -- Additional manual extra-source-files: - tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz - - source-repository head type: git location: https://github.com/haskell/cabal/ @@ -132,7 +56,7 @@ main-is: Main.hs hs-source-dirs: main default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances @@ -148,7 +72,7 @@ -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a if os(aix) extra-libraries: bsd - hs-source-dirs: . + hs-source-dirs: src other-modules: -- this modules are moved from Cabal -- they are needed for as long until cabal-install moves to parsec parser @@ -192,7 +116,6 @@ Distribution.Client.Dependency Distribution.Client.Dependency.Types Distribution.Client.DistDirLayout - Distribution.Client.Exec Distribution.Client.Fetch Distribution.Client.FetchUtils Distribution.Client.FileMonitor @@ -274,15 +197,20 @@ Distribution.Client.Types.SourcePackageDb Distribution.Client.Types.SourceRepo Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy - Distribution.Client.Update Distribution.Client.Upload Distribution.Client.Utils - Distribution.Client.Utils.Assertion Distribution.Client.Utils.Json Distribution.Client.Utils.Parsec Distribution.Client.VCS Distribution.Client.Win32SelfUpgrade Distribution.Client.World + + hs-source-dirs: cabal-install-solver/src-assertion + other-modules: + Distribution.Client.Utils.Assertion + + hs-source-dirs: cabal-install-solver/src + other-modules: Distribution.Solver.Compat.Prelude Distribution.Solver.Modular Distribution.Solver.Modular.Assignment @@ -331,6 +259,8 @@ Distribution.Solver.Types.SolverPackage Distribution.Solver.Types.SourcePackage Distribution.Solver.Types.Variable + + other-modules: Paths_cabal_install build-depends: @@ -339,8 +269,8 @@ base >= 4.8 && < 4.15, base16-bytestring >= 0.1.1 && < 1.1.0.0, binary >= 0.7.3 && < 0.9, - bytestring >= 0.10.6.0 && < 0.11, - Cabal == 3.4.1.*, + bytestring >= 0.10.6.0 && < 0.12, + Cabal == 3.6.*, containers >= 0.5.6.2 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, deepseq >= 1.4.1.1 && < 1.5, diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,7 +1,6 @@ -*-change-log-*- - -3.4.1.0 Emily Pillmore October 2021 - * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.1.0.md +3.6.0.0 Emily Pillmore August 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.6.0.0.md 3.4.0.0 Oleg Grenrus February 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.0.0.md diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -32,7 +32,6 @@ , GetFlags(..), getCommand, unpackCommand , checkCommand , formatCommand - , UpdateFlags(..), updateCommand , ListFlags(..), listCommand, listNeedsCompiler , InfoFlags(..), infoCommand , UploadFlags(..), uploadCommand @@ -40,19 +39,16 @@ , runCommand , InitFlags(initVerbosity, initHcPath), initCommand , ActAsSetupFlags(..), actAsSetupCommand - , ExecFlags(..), execCommand , UserConfigFlags(..), userConfigCommand , reportCommand , manpageCommand , haddockCommand , cleanCommand - , doctestCommand , copyCommand , registerCommand ) import Distribution.Simple.Setup ( HaddockTarget(..) - , DoctestFlags(..) , HaddockFlags(..), defaultHaddockFlags , HscolourFlags(..), hscolourCommand , ReplFlags(..) @@ -65,7 +61,7 @@ ) import Prelude () -import Distribution.Solver.Compat.Prelude hiding (get) +import Distribution.Client.Compat.Prelude hiding (get) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) @@ -95,8 +91,6 @@ import Distribution.Client.Install (install) import Distribution.Client.Configure (configure, writeConfigFlags) -import Distribution.Client.Update (update) -import Distribution.Client.Exec (exec) import Distribution.Client.Fetch (fetch) import Distribution.Client.Freeze (freeze) import Distribution.Client.GenBounds (genBounds) @@ -112,8 +106,7 @@ ) import Distribution.Client.Sandbox (loadConfigOrSandboxConfig ,findSavedDistPref - ,updateInstallDirs - ,getPersistOrConfigCompiler) + ,updateInstallDirs) import Distribution.Client.Tar (createTarGzFile) import Distribution.Client.Types.Credentials (Password (..)) import Distribution.Client.Init (initCabal) @@ -157,7 +150,7 @@ import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity - ( Verbosity, normal ) + ( normal ) import Distribution.Version ( Version, mkVersion, orLaterVersion ) import qualified Paths_cabal_install (version) @@ -270,7 +263,6 @@ , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction , legacyCmd configureExCommand configureAction - , legacyCmd updateCommand updateAction , legacyCmd buildCommand buildAction , legacyCmd replCommand replAction , legacyCmd freezeCommand freezeAction @@ -279,9 +271,7 @@ , legacyCmd runCommand runAction , legacyCmd testCommand testAction , legacyCmd benchmarkCommand benchmarkAction - , legacyCmd execCommand execAction , legacyCmd cleanCommand cleanAction - , legacyCmd doctestCommand doctestAction , legacyWrapperCmd copyCommand copyVerbosity copyDistPref , legacyWrapperCmd registerCommand regVerbosity regDistPref , legacyCmd reconfigureCommand reconfigureAction @@ -678,13 +668,6 @@ createTarGzFile dest docDir name notice verbosity $ "Documentation tarball created: " ++ dest -doctestAction :: DoctestFlags -> [String] -> Action -doctestAction doctestFlags extraArgs _globalFlags = do - let verbosity = fromFlag (doctestVerbosity doctestFlags) - - setupWrapper verbosity defaultSetupScriptOptions Nothing - doctestCommand (const doctestFlags) (const extraArgs) - cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do load <- try (loadConfigOrSandboxConfig verbosity globalFlags) @@ -746,16 +729,6 @@ infoFlags targets -updateAction :: UpdateFlags -> [String] -> Action -updateAction updateFlags extraArgs globalFlags = do - let verbosity = fromFlag (updateVerbosity updateFlags) - unless (null extraArgs) $ - die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs - config <- loadConfigOrSandboxConfig verbosity globalFlags - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - update verbosity updateFlags repoContext - fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do let verbosity = fromFlag (fetchVerbosity fetchFlags) @@ -964,16 +937,6 @@ comp progdb initFlags' - -execAction :: ExecFlags -> [String] -> Action -execAction execFlags extraArgs globalFlags = do - let verbosity = fromFlag (execVerbosity execFlags) - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (execDistPref execFlags) - let configFlags = savedConfigureFlags config - configFlags' = configFlags { configDistPref = Flag distPref } - (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' - exec verbosity comp platform progdb extraArgs userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do diff --git a/src/Distribution/Client/BuildReports/Anonymous.hs b/src/Distribution/Client/BuildReports/Anonymous.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/BuildReports/Anonymous.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Anonymous ( + BuildReport(..), + InstallOutcome(..), + Outcome(..), + + -- * Constructing and writing reports + newBuildReport, + + -- * parsing and pretty printing + parseBuildReport, + parseBuildReportList, + showBuildReport, +-- showList, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Client.BuildReports.Types +import Distribution.Client.Utils (cabalInstallVersion) +import Distribution.Compiler (CompilerId (..)) +import Distribution.FieldGrammar +import Distribution.Fields (readFields, showFields) +import Distribution.Fields.ParseResult (ParseResult, parseFatalFailure, runParseResult) +import Distribution.Package (PackageIdentifier (..), mkPackageName) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.Parsec (PError (..), zeroPos) +import Distribution.System (Arch, OS) + +import qualified Distribution.Client.BuildReports.Lens as L +import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..)) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + + +------------------------------------------------------------------------------- +-- New +------------------------------------------------------------------------------- + +newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment + -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport +newBuildReport os' arch' comp pkgid flags deps result = + BuildReport { + package = pkgid, + os = os', + arch = arch', + compiler = comp, + client = cabalInstallID, + flagAssignment = flags, + dependencies = deps, + installOutcome = convertInstallOutcome, +-- cabalVersion = undefined + docsOutcome = convertDocsOutcome, + testsOutcome = convertTestsOutcome + } + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildResult _ _ _) -> InstallOk + convertDocsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried + Right (BR.BuildResult BR.DocsFailed _ _) -> Failed + Right (BR.BuildResult BR.DocsOk _ _) -> Ok + convertTestsOutcome = case result of + Left (BR.TestsFailed _) -> Failed + Left _ -> NotTried + Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried + Right (BR.BuildResult _ BR.TestsOk _) -> Ok + +cabalInstallID :: PackageIdentifier +cabalInstallID = + PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion + +------------------------------------------------------------------------------- +-- FieldGrammar +------------------------------------------------------------------------------- + +fieldDescrs + :: ( Applicative (g BuildReport), FieldGrammar c g + , c (Identity Arch) + , c (Identity CompilerId) + , c (Identity FlagAssignment) + , c (Identity InstallOutcome) + , c (Identity OS) + , c (Identity Outcome) + , c (Identity PackageIdentifier) + , c (List VCat (Identity PackageIdentifier) PackageIdentifier) + ) + => g BuildReport BuildReport +fieldDescrs = BuildReport + <$> uniqueField "package" L.package + <*> uniqueField "os" L.os + <*> uniqueField "arch" L.arch + <*> uniqueField "compiler" L.compiler + <*> uniqueField "client" L.client + <*> monoidalField "flags" L.flagAssignment + <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies + <*> uniqueField "install-outcome" L.installOutcome + <*> uniqueField "docs-outcome" L.docsOutcome + <*> uniqueField "tests-outcome" L.testsOutcome + +-- ----------------------------------------------------------------------------- +-- Parsing + +parseBuildReport :: BS.ByteString -> Either String BuildReport +parseBuildReport s = case snd $ runParseResult $ parseFields s of + Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ] + Right report -> Right report + +parseFields :: BS.ByteString -> ParseResult BuildReport +parseFields input = do + fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input + case partitionFields fields of + (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs + _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport" + +parseBuildReportList :: BS.ByteString -> [BuildReport] +parseBuildReportList str = + [ report | Right report <- map parseBuildReport (split str) ] + + where + split :: BS.ByteString -> [BS.ByteString] + split = filter (not . BS.null) . unfoldr chunk . BS8.lines + chunk [] = Nothing + chunk ls = case break BS.null ls of + (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs) + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +showBuildReport :: BuildReport -> String +showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs diff --git a/src/Distribution/Client/BuildReports/Lens.hs b/src/Distribution/Client/BuildReports/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/BuildReports/Lens.hs @@ -0,0 +1,46 @@ +module Distribution.Client.BuildReports.Lens ( + BuildReport, + module Distribution.Client.BuildReports.Lens, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Lens +import Prelude () + +import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome) +import Distribution.Compiler (CompilerId) +import Distribution.System (Arch, OS) +import Distribution.Types.Flag (FlagAssignment) +import Distribution.Types.PackageId (PackageIdentifier) + +import qualified Distribution.Client.BuildReports.Types as T + +package :: Lens' BuildReport PackageIdentifier +package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) + +os :: Lens' BuildReport OS +os f s = fmap (\x -> s { T.os = x }) (f (T.os s)) + +arch :: Lens' BuildReport Arch +arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s)) + +compiler :: Lens' BuildReport CompilerId +compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s)) + +client :: Lens' BuildReport PackageIdentifier +client f s = fmap (\x -> s { T.client = x }) (f (T.client s)) + +flagAssignment :: Lens' BuildReport FlagAssignment +flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s)) + +dependencies :: Lens' BuildReport [PackageIdentifier] +dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s)) + +installOutcome :: Lens' BuildReport InstallOutcome +installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s)) + +docsOutcome :: Lens' BuildReport Outcome +docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s)) + +testsOutcome :: Lens' BuildReport Outcome +testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s)) diff --git a/src/Distribution/Client/BuildReports/Storage.hs b/src/Distribution/Client/BuildReports/Storage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/BuildReports/Storage.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Storage ( + + -- * Storing and retrieving build reports + storeAnonymous, + storeLocal, +-- retrieve, + + -- * 'InstallPlan' support + fromInstallPlan, + fromPlanningFailure, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( InstallPlan ) + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.SourcePackage + +import Distribution.Package + ( PackageId, packageId ) +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate + , initialPathTemplateEnv, substPathTemplate ) +import Distribution.System + ( Platform(Platform) ) +import Distribution.Compiler + ( CompilerId(..), CompilerInfo(..) ) +import Distribution.Simple.Utils + ( equating ) + +import Data.List.NonEmpty + ( groupBy ) +import qualified Data.List as L +import System.FilePath + ( (), takeDirectory ) +import System.Directory + ( createDirectoryIfMissing ) + +storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO () +storeAnonymous reports = sequence_ + [ appendFile file (concatMap format reports') + | (repo, reports') <- separate reports + , let file = repoLocalDir repo "build-reports.log" ] + --TODO: make this concurrency safe, either lock the report file or make sure + -- the writes for each report are atomic (under 4k and flush at boundaries) + + where + format r = '\n' : showBuildReport r ++ "\n" + separate :: [(BuildReport, Maybe Repo)] + -> [(Repo, [BuildReport])] + separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) + . map (concatMap toList) + . L.groupBy (equating (repoName' . head)) + . sortBy (comparing (repoName' . head)) + . groupBy (equating repoName') + . onlyRemote + + repoName' (_,_,rrepo) = remoteRepoName rrepo + + onlyRemote :: [(BuildReport, Maybe Repo)] + -> [(BuildReport, Repo, RemoteRepo)] + onlyRemote rs = + [ (report, repo, remoteRepo) + | (report, Just repo) <- rs + , Just remoteRepo <- [maybeRepoRemote repo] + ] + +storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)] + -> Platform -> IO () +storeLocal cinfo templates reports platform = sequence_ + [ do createDirectoryIfMissing True (takeDirectory file) + appendFile file output + --TODO: make this concurrency safe, either lock the report file or make + -- sure the writes for each report are atomic + | (file, reports') <- groupByFileName + [ (reportFileName template report, report) + | template <- templates + , (report, _repo) <- reports ] + , let output = concatMap format reports' + ] + where + format r = '\n' : showBuildReport r ++ "\n" + + reportFileName template report = + fromPathTemplate (substPathTemplate env template) + where env = initialPathTemplateEnv + (BuildReport.package report) + -- TODO: In principle, we can support $pkgkey, but only + -- if the configure step succeeds. So add a Maybe field + -- to the build report, and either use that or make up + -- a fake identifier if it's not available. + (error "storeLocal: package key not available") + cinfo + platform + + groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) + . L.groupBy (equating fst) + . sortBy (comparing fst) + +-- ------------------------------------------------------------ +-- * InstallPlan support +-- ------------------------------------------------------------ + +fromInstallPlan :: Platform -> CompilerId + -> InstallPlan + -> BuildOutcomes + -> [(BuildReport, Maybe Repo)] +fromInstallPlan platform comp plan buildOutcomes = + mapMaybe (\pkg -> fromPlanPackage + platform comp pkg + (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) + . InstallPlan.toList + $ plan + +fromPlanPackage :: Platform -> CompilerId + -> InstallPlan.PlanPackage + -> Maybe BuildOutcome + -> Maybe (BuildReport, Maybe Repo) +fromPlanPackage (Platform arch os) comp + (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps)) + (Just buildResult) = + Just ( newBuildReport os arch comp + (packageId srcPkg) flags + (map packageId (CD.nonSetupDeps deps)) + buildResult + , extractRepo srcPkg) + where + extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ }) + = Just repo + extractRepo _ = Nothing + +fromPlanPackage _ _ _ _ = Nothing + + +fromPlanningFailure :: Platform -> CompilerId + -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] +fromPlanningFailure (Platform arch os) comp pkgids flags = + [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing) + | pkgid <- pkgids ] diff --git a/src/Distribution/Client/BuildReports/Types.hs b/src/Distribution/Client/BuildReports/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/BuildReports/Types.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.BuildReports.Types +-- Copyright : (c) Duncan Coutts 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Types related to build reporting +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Types ( + ReportLevel(..), + BuildReport (..), + InstallOutcome(..), + Outcome(..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +import Distribution.Compiler (CompilerId (..)) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.System (Arch, OS) +import Distribution.Types.PackageId (PackageIdentifier) + +------------------------------------------------------------------------------- +-- ReportLevel +------------------------------------------------------------------------------- + +data ReportLevel = NoReports | AnonymousReports | DetailedReports + deriving (Eq, Ord, Enum, Bounded, Show, Generic) + +instance Binary ReportLevel +instance Structured ReportLevel + +instance Pretty ReportLevel where + pretty NoReports = Disp.text "none" + pretty AnonymousReports = Disp.text "anonymous" + pretty DetailedReports = Disp.text "detailed" + +instance Parsec ReportLevel where + parsec = do + name <- P.munch1 isAlpha + case lowercase name of + "none" -> return NoReports + "anonymous" -> return AnonymousReports + "detailed" -> return DetailedReports + _ -> P.unexpected $ "ReportLevel: " ++ name + +lowercase :: String -> String +lowercase = map toLower + +------------------------------------------------------------------------------- +-- BuildReport +------------------------------------------------------------------------------- + +data BuildReport = BuildReport { + -- | The package this build report is about + package :: PackageIdentifier, + + -- | The OS and Arch the package was built on + os :: OS, + arch :: Arch, + + -- | The Haskell compiler (and hopefully version) used + compiler :: CompilerId, + + -- | The uploading client, ie cabal-install-x.y.z + client :: PackageIdentifier, + + -- | Which configurations flags we used + flagAssignment :: FlagAssignment, + + -- | Which dependent packages we were using exactly + dependencies :: [PackageIdentifier], + + -- | Did installing work ok? + installOutcome :: InstallOutcome, + + -- Which version of the Cabal library was used to compile the Setup.hs +-- cabalVersion :: Version, + + -- Which build tools we were using (with versions) +-- tools :: [PackageIdentifier], + + -- | Configure outcome, did configure work ok? + docsOutcome :: Outcome, + + -- | Configure outcome, did configure work ok? + testsOutcome :: Outcome + } + deriving (Eq, Show, Generic) + + + +------------------------------------------------------------------------------- +-- InstallOutcome +------------------------------------------------------------------------------- + +data InstallOutcome + = PlanningFailed + | DependencyFailed PackageIdentifier + | DownloadFailed + | UnpackFailed + | SetupFailed + | ConfigureFailed + | BuildFailed + | TestsFailed + | InstallFailed + | InstallOk + deriving (Eq, Show, Generic) + +instance Pretty InstallOutcome where + pretty PlanningFailed = Disp.text "PlanningFailed" + pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid + pretty DownloadFailed = Disp.text "DownloadFailed" + pretty UnpackFailed = Disp.text "UnpackFailed" + pretty SetupFailed = Disp.text "SetupFailed" + pretty ConfigureFailed = Disp.text "ConfigureFailed" + pretty BuildFailed = Disp.text "BuildFailed" + pretty TestsFailed = Disp.text "TestsFailed" + pretty InstallFailed = Disp.text "InstallFailed" + pretty InstallOk = Disp.text "InstallOk" + +instance Parsec InstallOutcome where + parsec = do + name <- P.munch1 isAlpha + case name of + "PlanningFailed" -> return PlanningFailed + "DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec + "DownloadFailed" -> return DownloadFailed + "UnpackFailed" -> return UnpackFailed + "SetupFailed" -> return SetupFailed + "ConfigureFailed" -> return ConfigureFailed + "BuildFailed" -> return BuildFailed + "TestsFailed" -> return TestsFailed + "InstallFailed" -> return InstallFailed + "InstallOk" -> return InstallOk + _ -> P.unexpected $ "InstallOutcome: " ++ name + +------------------------------------------------------------------------------- +-- Outcome +------------------------------------------------------------------------------- + +data Outcome = NotTried | Failed | Ok + deriving (Eq, Show, Enum, Bounded, Generic) + +instance Pretty Outcome where + pretty NotTried = Disp.text "NotTried" + pretty Failed = Disp.text "Failed" + pretty Ok = Disp.text "Ok" + +instance Parsec Outcome where + parsec = do + name <- P.munch1 isAlpha + case name of + "NotTried" -> return NotTried + "Failed" -> return Failed + "Ok" -> return Ok + _ -> P.unexpected $ "Outcome: " ++ name diff --git a/src/Distribution/Client/BuildReports/Upload.hs b/src/Distribution/Client/BuildReports/Upload.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/BuildReports/Upload.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP, PatternGuards #-} +-- This is a quick hack for uploading build reports to Hackage. + +module Distribution.Client.BuildReports.Upload + ( BuildLog + , BuildReportId + , uploadReports + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +{- +import Network.Browser + ( BrowserAction, request, setAllowRedirects ) +import Network.HTTP + ( Header(..), HeaderName(..) + , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) +-} +import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo) + +import System.FilePath.Posix + ( () ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport) +import Distribution.Simple.Utils (die') +import Distribution.Client.HttpUtils +import Distribution.Client.Setup + ( RepoContext(..) ) + +type BuildReportId = URI +type BuildLog = String + +uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO () +uploadReports verbosity repoCtxt auth uri reports = do + for_ reports $ \(report, mbBuildLog) -> do + buildId <- postBuildReport verbosity repoCtxt auth uri report + case mbBuildLog of + Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog + Nothing -> return () + +postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId +postBuildReport verbosity repoCtxt auth uri buildReport = do + let fullURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" } + transport <- repoContextGetTransport repoCtxt + res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth) + case res of + (303, redir) -> return $ undefined redir --TODO parse redir + _ -> die' verbosity "unrecognized response" -- give response + +{- + setAllowRedirects False + (_, response) <- request Request { + rqURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" }, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + case rspCode response of + (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location +#if defined(VERSION_network_uri) + return $ relativeTo rel uri +#elif defined(VERSION_network) +#if MIN_VERSION_network(2,4,0) + return $ relativeTo rel uri +#else + relativeTo rel uri +#endif +#endif + | Header HdrLocation location <- rspHeaders response ] + -> return $ buildId + _ -> error "Unrecognised response from server." + where body = BuildReport.show buildReport +-} + + +-- TODO force this to be a PUT? + +putBuildLog :: Verbosity -> RepoContext -> (String, String) + -> BuildReportId -> BuildLog + -> IO () +putBuildLog verbosity repoCtxt auth reportId buildLog = do + let fullURI = reportId {uriPath = uriPath reportId "log"} + transport <- repoContextGetTransport repoCtxt + res <- postHttp transport verbosity fullURI buildLog (Just auth) + case res of + (200, _) -> return () + _ -> die' verbosity "unrecognized response" -- give response diff --git a/src/Distribution/Client/Check.hs b/src/Distribution/Client/Check.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Check.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Check +-- Copyright : (c) Lennart Kolmodin 2008 +-- License : BSD-like +-- +-- Maintainer : kolmodin@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Check a package for common mistakes +-- +----------------------------------------------------------------------------- +module Distribution.Client.Check ( + check + ) where + + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Utils.Parsec (renderParseError) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Check +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Parsec + (parseGenericPackageDescription, runParseResult) +import Distribution.Parsec (PWarning (..), showPError, showPWarning) +import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) +import System.IO (hPutStr, stderr) + +import qualified Data.ByteString as BS +import qualified System.Directory as Dir + +readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription) +readGenericPackageDescriptionCheck verbosity fpath = do + exists <- Dir.doesFileExist fpath + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." + bs <- BS.readFile fpath + let (warnings, result) = runParseResult (parseGenericPackageDescription bs) + case result of + Left (_, errors) -> do + traverse_ (warn verbosity . showPError fpath) errors + hPutStr stderr $ renderParseError fpath bs errors warnings + die' verbosity "parse error" + Right x -> return (warnings, x) + +-- | Note: must be called with the CWD set to the directory containing +-- the '.cabal' file. +check :: Verbosity -> IO Bool +check verbosity = do + pdfile <- defaultPackageDesc verbosity + (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile + -- convert parse warnings into PackageChecks + -- Note: we /could/ pick different levels, based on warning type. + let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ] + -- flatten the generic package description into a regular package + -- description + -- TODO: this may give more warnings than it should give; + -- consider two branches of a condition, one saying + -- ghc-options: -Wall + -- and the other + -- ghc-options: -Werror + -- joined into + -- ghc-options: -Wall -Werror + -- checkPackages will yield a warning on the last line, but it + -- would not on each individual branch. + -- Hovever, this is the same way hackage does it, so we will yield + -- the exact same errors as it will. + let pkg_desc = flattenPackageDescription ppd + ioChecks <- checkPackageFiles verbosity pkg_desc "." + let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' + buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] + buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] + distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] + ++ [ x | x@PackageDistSuspiciousWarn {} <- packageChecks ] + distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] + + unless (null buildImpossible) $ do + warn verbosity "The package will not build sanely due to these errors:" + printCheckMessages buildImpossible + + unless (null buildWarning) $ do + warn verbosity "The following warnings are likely to affect your build negatively:" + printCheckMessages buildWarning + + unless (null distSuspicious) $ do + warn verbosity "These warnings may cause trouble when distributing the package:" + printCheckMessages distSuspicious + + unless (null distInexusable) $ do + warn verbosity "The following errors will cause portability problems on other environments:" + printCheckMessages distInexusable + + let isDistError (PackageDistSuspicious {}) = False + isDistError (PackageDistSuspiciousWarn {}) = False + isDistError _ = True + isCheckError (PackageDistSuspiciousWarn {}) = False + isCheckError _ = True + errors = filter isDistError packageChecks + + unless (null errors) $ + warn verbosity "Hackage would reject this package." + + when (null packageChecks) $ + notice verbosity "No errors or warnings could be found in the package." + + return (not . any isCheckError $ packageChecks) + + where + printCheckMessages = traverse_ (warn verbosity . explanation) diff --git a/src/Distribution/Client/CmdBench.hs b/src/Distribution/Client/CmdBench.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdBench.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | cabal-install CLI command: bench +-- +module Distribution.Client.CmdBench ( + -- * The @bench@ CLI and action + benchCommand, + benchAction, + + -- * Internals exposed for testing + componentNotBenchmarkProblem, + isSubComponentProblem, + noBenchmarksProblem, + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + ( renderTargetSelector, showTargetSelector, renderTargetProblem, + renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, + targetSelectorFilter ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +benchCommand :: CommandUI (NixStyleFlags ()) +benchCommand = CommandUI { + commandName = "v2-bench", + commandSynopsis = "Run benchmarks", + commandUsage = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Runs the specified benchmarks, first ensuring they are up to " + ++ "date.\n\n" + + ++ "Any benchmark in any package in the project can be specified. " + ++ "A package can be specified in which case all the benchmarks in the " + ++ "package are run. The default is to run all the benchmarks in the " + ++ "package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-bench\n" + ++ " Run all the benchmarks in the package in the current directory\n" + ++ " " ++ pname ++ " v2-bench pkgname\n" + ++ " Run all the benchmarks in the package named pkgname\n" + ++ " " ++ pname ++ " v2-bench cname\n" + ++ " Run the benchmark named cname\n" + ++ " " ++ pname ++ " v2-bench cname -O2\n" + ++ " Run the benchmark built with '-O2' (including local libs used)\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + + +-- | The @build@ command does a lot. It brings the install plan up to date, +-- selects that part of the plan needed by the given or implicit targets and +-- then executes the plan. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The bench command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'bench'." + + -- Interpret the targets on the command line as bench targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBench + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @bench@ command we select all buildable benchmarks, +-- or fail if there are no benchmarks or no buildable benchmarks. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either BenchTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable benchmark targets then we select those + | not (null targetsBenchBuildable) + = Right targetsBenchBuildable + + -- If there are benchmarks but none are buildable then we report those + | not (null targetsBench) + = Left (TargetProblemNoneEnabled targetSelector targetsBench) + + -- If there are no benchmarks but some other targets then we report that + | not (null targets) + = Left (noBenchmarksProblem targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targetsBenchBuildable = selectBuildableTargets + . filterTargetsKind BenchKind + $ targets + + targetsBench = forgetTargetsDetail + . filterTargetsKind BenchKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @bench@ command we just need to check it is a benchmark, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either BenchTargetProblem k +selectComponentTarget subtarget@WholeComponent t + | CBenchName _ <- availableTargetComponentName t + = selectComponentTargetBasic subtarget t + | otherwise + = Left (componentNotBenchmarkProblem + (availableTargetPackageId t) + (availableTargetComponentName t)) + +selectComponentTarget subtarget t + = Left (isSubComponentProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. +-- +data BenchProblem = + -- | The 'TargetSelector' matches targets but no benchmarks + TargetProblemNoBenchmarks TargetSelector + + -- | The 'TargetSelector' refers to a component that is not a benchmark + | TargetProblemComponentNotBenchmark PackageId ComponentName + + -- | Asking to benchmark an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + + +type BenchTargetProblem = TargetProblem BenchProblem + +noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem +noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks + +componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem +componentNotBenchmarkProblem pkgid name = CustomTargetProblem $ + TargetProblemComponentNotBenchmark pkgid name + +isSubComponentProblem + :: PackageId + -> ComponentName + -> SubComponentTarget + -> TargetProblem BenchProblem +isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent + +reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderBenchTargetProblem + +renderBenchTargetProblem :: BenchTargetProblem -> String +renderBenchTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= BenchKind + -> "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "benchmark" targetSelector +renderBenchTargetProblem problem = + renderTargetProblem "benchmark" renderBenchProblem problem + +renderBenchProblem :: BenchProblem -> String +renderBenchProblem (TargetProblemNoBenchmarks targetSelector) = + "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any benchmarks." + +renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) = + "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ prettyShow pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The bench command can only run benchmarks as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget diff --git a/src/Distribution/Client/CmdBuild.hs b/src/Distribution/Client/CmdBuild.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdBuild.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE RecordWildCards #-} +-- | cabal-install CLI command: build +-- +module Distribution.Client.CmdBuild ( + -- * The @build@ CLI and action + buildCommand, + buildAction, + + -- * Internals exposed for testing + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.TargetProblem + ( TargetProblem (..), TargetProblem' ) +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), yesNoOpt ) +import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives, option, optionName ) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +import qualified Data.Map as Map + + +buildCommand :: CommandUI (NixStyleFlags BuildFlags) +buildCommand = CommandUI { + commandName = "v2-build", + commandSynopsis = "Compile targets within the project.", + commandUsage = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Build one or more targets from within the project. The available " + ++ "targets are the packages in the project as well as individual " + ++ "components within those packages, including libraries, executables, " + ++ "test-suites or benchmarks. Targets can be specified by name or " + ++ "location. If no target is specified then the default is to build " + ++ "the package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-build\n" + ++ " Build the package in the current directory " + ++ "or all packages in the project\n" + ++ " " ++ pname ++ " v2-build pkgname\n" + ++ " Build the package named pkgname in the project\n" + ++ " " ++ pname ++ " v2-build ./pkgfoo\n" + ++ " Build the package in the ./pkgfoo directory\n" + ++ " " ++ pname ++ " v2-build cname\n" + ++ " Build the component named cname in the project\n" + ++ " " ++ pname ++ " v2-build cname --enable-profiling\n" + ++ " Build the component in profiling mode " + ++ "(including dependencies as needed)\n" + + , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags + , commandOptions = filter (\o -> optionName o /= "ignore-project") + . nixStyleOptions (\showOrParseArgs -> + [ option [] ["only-configure"] + "Instead of performing a full build just run the configure step" + buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v }) + (yesNoOpt showOrParseArgs) + ]) + } + +data BuildFlags = BuildFlags + { buildOnlyConfigure :: Flag Bool + } + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = BuildFlags + { buildOnlyConfigure = toFlag False + } + +-- | The @build@ command does a lot. It brings the install plan up to date, +-- selects that part of the plan needed by the given or implicit targets and +-- then executes the plan. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO () +buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do + -- TODO: This flags defaults business is ugly + let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags + <> buildOnlyConfigure buildFlags) + targetAction + | onlyConfigure = TargetActionConfigure + | otherwise = TargetActionBuild + + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportBuildTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + targetAction + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' + + return (elaboratedPlan'', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @build@ command select all components except non-buildable +-- and disabled tests\/benchmarks, fail if there are no such +-- components +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargetsWith + (buildable targetSelector) + targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable _ _ = True + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @build@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget = selectComponentTargetBasic + +reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a +reportBuildTargetProblems verbosity problems = + reportTargetProblems verbosity "build" problems + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + die' verbosity . renderCannotPruneDependencies diff --git a/src/Distribution/Client/CmdClean.hs b/src/Distribution/Client/CmdClean.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdClean.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.CmdClean (cleanCommand, cleanAction) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), defaultDistDirLayout ) +import Distribution.Client.ProjectConfig + ( findProjectRoot ) +import Distribution.Client.Setup + ( GlobalFlags ) +import Distribution.ReadE ( succeedReadE ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe + , optionDistPref, optionVerbosity, falseArg + ) +import Distribution.Simple.Command + ( CommandUI(..), option, reqArg ) +import Distribution.Simple.Utils + ( info, die', wrapText, handleDoesNotExist ) +import Distribution.Verbosity + ( normal ) + +import System.Directory + ( removeDirectoryRecursive, removeFile + , doesDirectoryExist, getDirectoryContents ) +import System.FilePath + ( () ) + +data CleanFlags = CleanFlags + { cleanSaveConfig :: Flag Bool + , cleanVerbosity :: Flag Verbosity + , cleanDistDir :: Flag FilePath + , cleanProjectFile :: Flag FilePath + } deriving (Eq) + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = CleanFlags + { cleanSaveConfig = toFlag False + , cleanVerbosity = toFlag normal + , cleanDistDir = NoFlag + , cleanProjectFile = mempty + } + +cleanCommand :: CommandUI CleanFlags +cleanCommand = CommandUI + { commandName = "v2-clean" + , commandSynopsis = "Clean the package store and remove temporary files." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " new-clean [FLAGS]\n" + , commandDescription = Just $ \_ -> wrapText $ + "Removes all temporary files created during the building process " + ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " + ++ "local caches (by default).\n\n" + , commandNotes = Nothing + , commandDefaultFlags = defaultCleanFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + , optionDistPref + cleanDistDir (\dd flags -> flags { cleanDistDir = dd }) + showOrParseArgs + , option [] ["project-file"] + ("Set the name of the cabal.project file" + ++ " to search for in parent directories") + cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf}) + (reqArg "FILE" (succeedReadE Flag) flagToList) + , option ['s'] ["save-config"] + "Save configuration, only remove build artifacts" + cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc }) + falseArg + ] + } + +cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () +cleanAction CleanFlags{..} extraArgs _ = do + let verbosity = fromFlagOrDefault normal cleanVerbosity + saveConfig = fromFlagOrDefault False cleanSaveConfig + mdistDirectory = flagToMaybe cleanDistDir + mprojectFile = flagToMaybe cleanProjectFile + + unless (null extraArgs) $ + die' verbosity $ "'clean' doesn't take any extra arguments: " + ++ unwords extraArgs + + projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile + + let distLayout = defaultDistDirLayout projectRoot mdistDirectory + + if saveConfig + then do + let buildRoot = distBuildRootDirectory distLayout + + buildRootExists <- doesDirectoryExist buildRoot + + when buildRootExists $ do + info verbosity ("Deleting build root (" ++ buildRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive buildRoot + else do + let distRoot = distDirectory distLayout + + info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive distRoot + + removeEnvFiles (distProjectRootDirectory distLayout) + +removeEnvFiles :: FilePath -> IO () +removeEnvFiles dir = + (traverse_ (removeFile . (dir )) . filter ((".ghc.environment" ==) . take 16)) + =<< getDirectoryContents dir diff --git a/src/Distribution/Client/CmdConfigure.hs b/src/Distribution/Client/CmdConfigure.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdConfigure.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE RecordWildCards #-} +-- | cabal-install CLI command: configure +-- +module Distribution.Client.CmdConfigure ( + configureCommand, + configureAction, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import System.Directory +import System.FilePath +import qualified Data.Map as Map + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectConfig + ( writeProjectLocalExtraConfig ) + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Verbosity + ( normal ) + +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives, optionName ) +import Distribution.Simple.Utils + ( wrapText, notice ) + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..) ) + +configureCommand :: CommandUI (NixStyleFlags ()) +configureCommand = CommandUI { + commandName = "v2-configure", + commandSynopsis = "Add extra project configuration", + commandUsage = usageAlternatives "v2-configure" [ "[FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Adjust how the project is built by setting additional package flags " + ++ "and other flags.\n\n" + + ++ "The configuration options are written to the 'cabal.project.local' " + ++ "file (or '$project_file.local', if '--project-file' is specified) " + ++ "which extends the configuration from the 'cabal.project' file " + ++ "(if any). This combination is used as the project configuration for " + ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it " + ++ "can be extended/overridden on a per-command basis.\n\n" + + ++ "The v2-configure command also checks that the project configuration " + ++ "will work. In particular it checks that there is a consistent set of " + ++ "dependencies for the project as a whole.\n\n" + + ++ "The 'cabal.project.local' file persists across 'v2-clean' but is " + ++ "overwritten on the next use of the 'v2-configure' command. The " + ++ "intention is that the 'cabal.project' file should be kept in source " + ++ "control but the 'cabal.project.local' should not.\n\n" + + ++ "It is never necessary to use the 'v2-configure' command. It is " + ++ "merely a convenience in cases where you do not want to specify flags " + ++ "to 'v2-build' (and other commands) every time and yet do not want " + ++ "to alter the 'cabal.project' persistently.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n" + ++ " Adjust the project configuration to use the given compiler\n" + ++ " program and check the resulting configuration works.\n" + ++ " " ++ pname ++ " v2-configure\n" + ++ " Reset the local configuration to empty and check the overall\n" + ++ " project configuration works.\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = filter (\o -> optionName o /= "ignore-project") + . nixStyleOptions (const []) + } + +-- | To a first approximation, the @configure@ just runs the first phase of +-- the @build@ command where we bring the install plan up to date (thus +-- checking that it's possible). +-- +-- The only difference is that @configure@ also allows the user to specify +-- some extra config flags which we save in the file @cabal.project.local@. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +configureAction flags@NixStyleFlags {..} _extraArgs globalFlags = do + --TODO: deal with _extraArgs, since flags with wrong syntax end up there + + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + -- Write out the @cabal.project.local@ so it gets picked up by the + -- planning phase. If old config exists, then print the contents + -- before overwriting + + let localFile = distProjectFile (distDirLayout baseCtx) "local" + -- | Chooses cabal.project.local~, or if it already exists + -- cabal.project.local~0, cabal.project.local~1 etc. + firstFreeBackup = firstFreeBackup' (0 :: Int) + firstFreeBackup' i = do + let backup = localFile <> "~" <> (if i <= 0 then "" else show (i - 1)) + exists <- doesFileExist backup + if exists + then firstFreeBackup' (i + 1) + else return backup + dryRun = buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + if dryRun + then notice verbosity "Config file not written due to flag(s)." + else do + -- If cabal.project.local already exists, back up to cabal.project.local~[n] + exists <- doesFileExist localFile + when exists $ do + backup <- firstFreeBackup + notice verbosity $ + quote (takeFileName localFile) <> " already exists, backing it up to " + <> quote (takeFileName backup) <> "." + copyFile localFile backup + writeProjectLocalExtraConfig (distDirLayout baseCtx) + cliConfig + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> + + -- TODO: Select the same subset of targets as 'CmdBuild' would + -- pick (ignoring, for example, executables in libraries + -- we depend on). But we don't want it to fail, so actually we + -- have to do it slightly differently from build. + return (elaboratedPlan, Map.empty) + + let baseCtx' = baseCtx { + buildSettings = (buildSettings baseCtx) { + buildSettingDryRun = True + } + } + + -- TODO: Hmm, but we don't have any targets. Currently this prints + -- what we would build if we were to build everything. Could pick + -- implicit target like "." + -- + -- TODO: should we say what's in the project (+deps) as a whole? + printPlan verbosity baseCtx' buildCtx + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + quote s = "'" <> s <> "'" + diff --git a/src/Distribution/Client/CmdErrorMessages.hs b/src/Distribution/Client/CmdErrorMessages.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdErrorMessages.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + + +-- | Utilities to help format error messages for the various CLI commands. +-- +module Distribution.Client.CmdErrorMessages ( + module Distribution.Client.CmdErrorMessages, + module Distribution.Client.TargetSelector, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectPlanning + ( AvailableTarget(..), AvailableTargetStatus(..), + CannotPruneDependencies(..), TargetRequested(..) ) +import Distribution.Client.TargetSelector + ( SubComponentTarget(..) ) +import Distribution.Client.TargetProblem + ( TargetProblem(..), TargetProblem' ) +import Distribution.Client.TargetSelector + ( ComponentKind(..), ComponentKindFilter, TargetSelector(..), + componentKind, showTargetSelector ) + +import Distribution.Package + ( PackageId, packageId, PackageName, packageName ) +import Distribution.Simple.Utils + ( die' ) +import Distribution.Types.ComponentName + ( ComponentName(..), showComponentName ) +import Distribution.Types.LibraryName + ( LibraryName(..) ) +import Distribution.Solver.Types.OptionalStanza + ( OptionalStanza(..) ) + +import qualified Data.List.NonEmpty as NE + + +----------------------- +-- Singular or plural +-- + +-- | A tag used in rendering messages to distinguish singular or plural. +-- +data Plural = Singular | Plural + +-- | Used to render a singular or plural version of something +-- +-- > plural (listPlural theThings) "it is" "they are" +-- +plural :: Plural -> a -> a -> a +plural Singular si _pl = si +plural Plural _si pl = pl + +-- | Singular for singleton lists and plural otherwise. +-- +listPlural :: [a] -> Plural +listPlural [_] = Singular +listPlural _ = Plural + + +-------------------- +-- Rendering lists +-- + +-- | Render a list of things in the style @foo, bar and baz@ +renderListCommaAnd :: [String] -> String +renderListCommaAnd [] = "" +renderListCommaAnd [x] = x +renderListCommaAnd [x,x'] = x ++ " and " ++ x' +renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs + +-- | Render a list of things in the style @blah blah; this that; and the other@ +renderListSemiAnd :: [String] -> String +renderListSemiAnd [] = "" +renderListSemiAnd [x] = x +renderListSemiAnd [x,x'] = x ++ "; and " ++ x' +renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs + +-- | When rendering lists of things it often reads better to group related +-- things, e.g. grouping components by package name +-- +-- > renderListSemiAnd +-- > [ "the package " ++ prettyShow pkgname ++ " components " +-- > ++ renderListCommaAnd showComponentName components +-- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] +-- +sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] +sortGroupOn key = map (\(x:|xs) -> (key x, x:xs)) + . NE.groupBy ((==) `on` key) + . sortBy (compare `on` key) + + +---------------------------------------------------- +-- Renderering for a few project and package types +-- + +renderTargetSelector :: TargetSelector -> String +renderTargetSelector (TargetPackage _ pkgids Nothing) = + "the " ++ plural (listPlural pkgids) "package" "packages" ++ " " + ++ renderListCommaAnd (map prettyShow pkgids) + +renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = + "the " ++ renderComponentKind Plural kfilter + ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " + ++ renderListCommaAnd (map prettyShow pkgids) + +renderTargetSelector (TargetPackageNamed pkgname Nothing) = + "the package " ++ prettyShow pkgname + +renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) = + "the " ++ renderComponentKind Plural kfilter + ++ " in the package " ++ prettyShow pkgname + +renderTargetSelector (TargetAllPackages Nothing) = + "all the packages in the project" + +renderTargetSelector (TargetAllPackages (Just kfilter)) = + "all the " ++ renderComponentKind Plural kfilter + ++ " in the project" + +renderTargetSelector (TargetComponent pkgid cname subtarget) = + renderSubComponentTarget subtarget ++ "the " + ++ renderComponentName (packageName pkgid) cname + +renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) = + renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname + ++ " in the package " ++ prettyShow pkgname + +renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) = + renderSubComponentTarget subtarget ++ "the " + ++ renderComponentName pkgname cname + +renderSubComponentTarget :: SubComponentTarget -> String +renderSubComponentTarget WholeComponent = "" +renderSubComponentTarget (FileTarget filename) = + "the file " ++ filename ++ " in " +renderSubComponentTarget (ModuleTarget modname) = + "the module " ++ prettyShow modname ++ " in " + + +renderOptionalStanza :: Plural -> OptionalStanza -> String +renderOptionalStanza Singular TestStanzas = "test suite" +renderOptionalStanza Plural TestStanzas = "test suites" +renderOptionalStanza Singular BenchStanzas = "benchmark" +renderOptionalStanza Plural BenchStanzas = "benchmarks" + +-- | The optional stanza type (test suite or benchmark), if it is one. +optionalStanza :: ComponentName -> Maybe OptionalStanza +optionalStanza (CTestName _) = Just TestStanzas +optionalStanza (CBenchName _) = Just BenchStanzas +optionalStanza _ = Nothing + +-- | Does the 'TargetSelector' potentially refer to one package or many? +-- +targetSelectorPluralPkgs :: TargetSelector -> Plural +targetSelectorPluralPkgs (TargetAllPackages _) = Plural +targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids +targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular +targetSelectorPluralPkgs TargetComponent{} = Singular +targetSelectorPluralPkgs TargetComponentUnknown{} = Singular + +-- | Does the 'TargetSelector' refer to packages or to components? +targetSelectorRefersToPkgs :: TargetSelector -> Bool +targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs TargetComponent{} = False +targetSelectorRefersToPkgs TargetComponentUnknown{} = False + +targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter +targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter +targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter +targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter +targetSelectorFilter TargetComponent{} = Nothing +targetSelectorFilter TargetComponentUnknown{} = Nothing + +renderComponentName :: PackageName -> ComponentName -> String +renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname +renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name +renderComponentName _ (CFLibName name) = "foreign library " ++ prettyShow name +renderComponentName _ (CExeName name) = "executable " ++ prettyShow name +renderComponentName _ (CTestName name) = "test suite " ++ prettyShow name +renderComponentName _ (CBenchName name) = "benchmark " ++ prettyShow name + +renderComponentKind :: Plural -> ComponentKind -> String +renderComponentKind Singular ckind = case ckind of + LibKind -> "library" -- internal/sub libs? + FLibKind -> "foreign library" + ExeKind -> "executable" + TestKind -> "test suite" + BenchKind -> "benchmark" +renderComponentKind Plural ckind = case ckind of + LibKind -> "libraries" -- internal/sub libs? + FLibKind -> "foreign libraries" + ExeKind -> "executables" + TestKind -> "test suites" + BenchKind -> "benchmarks" + + +------------------------------------------------------- +-- Renderering error messages for TargetProblem +-- + +-- | Default implementation of 'reportTargetProblems' simply renders one problem per line. +reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a +reportTargetProblems verbosity verb = + die' verbosity . unlines . map (renderTargetProblem verb absurd) + +-- | Default implementation of 'renderTargetProblem'. +renderTargetProblem + :: String -- ^ verb + -> (a -> String) -- ^ how to render custom problems + -> TargetProblem a + -> String +renderTargetProblem _verb f (CustomTargetProblem x) = f x +renderTargetProblem verb _ (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled verb targetSelector targets +renderTargetProblem verb _ (TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets verb targetSelector + +renderTargetProblem verb _ (TargetNotInProject pkgname) = + "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " + ++ "in this project (either directly or indirectly). If you want to add it " + ++ "to the project then edit the cabal.project file." + +renderTargetProblem verb _ (TargetAvailableInIndex pkgname) = + "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " + ++ "in this project (either directly or indirectly), but it is in the current " + ++ "package index. If you want to add it to the project then edit the " + ++ "cabal.project file." + +renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " + ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal " + ++ "does not currently support building test suites or benchmarks of " + ++ "non-local dependencies. To run test suites or benchmarks from " + ++ "dependencies you can unpack the package locally and adjust the " + ++ "cabal.project file to include that package directory." + +renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is " + ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid) + ++ ".cabal' file (at least for the current configuration). If you believe it " + ++ "should be buildable then check the .cabal file to see if the buildable " + ++ "property is conditional on flags. Alternatively you may simply have to " + ++ "edit the .cabal file to declare it as buildable and fix any resulting " + ++ "build problems." + +renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because " + ++ "building " ++ compkinds ++ " has been explicitly disabled in the " + ++ "configuration. You can adjust this configuration in the " + ++ "cabal.project{.local} file either for all packages in the project or on " + ++ "a per-package basis. Note that if you do not explicitly disable " + ++ compkinds ++ " then the solver will merely try to make a plan with " + ++ "them available, so you may wish to explicitly enable them which will " + ++ "require the solver to find a plan with them available or to fail with an " + ++ "explanation." + where + compkinds = renderComponentKind Plural (componentKind cname) + +renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " + ++ "solver did not find a plan that included the " ++ compkinds + ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with " + ++ compkinds ++ " explicitly enabled in the configuration in the " + ++ "cabal.project{.local} file. This will ask the solver to find a plan with " + ++ "the " ++ compkinds ++ " available. It will either fail with an " + ++ "explanation or find a different plan that uses different versions of some " + ++ "other packages. Use the '--dry-run' flag to see package versions and " + ++ "check that you are happy with the choices." + where + compkinds = renderComponentKind Plural (componentKind cname) + +renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) = + "Cannot " ++ verb ++ " the " + ++ (case ecname of + Left ucname -> "component " ++ prettyShow ucname + Right cname -> renderComponentName pkgname cname) + ++ " from the package " ++ prettyShow pkgname + ++ ", because the package does not contain a " + ++ (case ecname of + Left _ -> "component" + Right cname -> renderComponentKind Singular (componentKind cname)) + ++ " with that name." + +renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) = + "Internal error when trying to " ++ verb ++ " the package " + ++ prettyShow pkgid ++ ". The package is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." + +renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) = + "Internal error when trying to " ++ verb ++ " the " + ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid + ++ ". The package,component pair is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." + + +------------------------------------------------------------ +-- Renderering error messages for TargetProblemNoneEnabled +-- + +-- | Several commands have a @TargetProblemNoneEnabled@ problem constructor. +-- This renders an error message for those cases. +-- +renderTargetProblemNoneEnabled :: String + -> TargetSelector + -> [AvailableTarget ()] + -> String +renderTargetProblemNoneEnabled verb targetSelector targets = + "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector + ++ " because none of the components are available to build: " + ++ renderListSemiAnd + [ case (status, mstanza) of + (TargetDisabledByUser, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are " + ++ " not available because building " + ++ renderOptionalStanza Plural stanza + ++ " has been disabled in the configuration" + (TargetDisabledBySolver, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are " + ++ "not available because the solver did not find a plan that " + ++ "included the " ++ renderOptionalStanza Plural stanza + ++ ". Force the solver to enable this for all packages by adding the " + ++ "line 'tests: True' to the 'cabal.project.local' file." + (TargetNotBuildable, _) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are all " + ++ "marked as 'buildable: False'" + (TargetNotLocal, _) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ " cannot be built because cabal does not currently support " + ++ "building test suites or benchmarks of non-local dependencies" + (TargetBuildable () TargetNotRequestedByDefault, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ " will not be built because " ++ renderOptionalStanza Plural stanza + ++ " are not built by default in the current configuration (but you " + ++ "can still build them specifically)" --TODO: say how + _ -> error $ "renderBuildTargetProblem: unexpected status " + ++ show (status, mstanza) + | ((status, mstanza), targets') <- sortGroupOn groupingKey targets + ] + where + groupingKey t = + ( availableTargetStatus t + , case availableTargetStatus t of + TargetNotBuildable -> Nothing + TargetNotLocal -> Nothing + _ -> optionalStanza (availableTargetComponentName t) + ) + +------------------------------------------------------------ +-- Renderering error messages for TargetProblemNoneEnabled +-- + +-- | Several commands have a @TargetProblemNoTargets@ problem constructor. +-- This renders an error message for those cases. +-- +renderTargetProblemNoTargets :: String -> TargetSelector -> String +renderTargetProblemNoTargets verb targetSelector = + "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector + ++ " because " ++ reason targetSelector ++ ". " + ++ "Check the .cabal " + ++ plural (targetSelectorPluralPkgs targetSelector) + "file for the package and make sure that it properly declares " + "files for the packages and make sure that they properly declare " + ++ "the components that you expect." + where + reason (TargetPackage _ _ Nothing) = + "it does not contain any components at all" + reason (TargetPackage _ _ (Just kfilter)) = + "it does not contain any " ++ renderComponentKind Plural kfilter + reason (TargetPackageNamed _ Nothing) = + "it does not contain any components at all" + reason (TargetPackageNamed _ (Just kfilter)) = + "it does not contain any " ++ renderComponentKind Plural kfilter + reason (TargetAllPackages Nothing) = + "none of them contain any components at all" + reason (TargetAllPackages (Just kfilter)) = + "none of the packages contain any " + ++ renderComponentKind Plural kfilter + reason ts@TargetComponent{} = + error $ "renderTargetProblemNoTargets: " ++ show ts + reason ts@TargetComponentUnknown{} = + error $ "renderTargetProblemNoTargets: " ++ show ts + +----------------------------------------------------------- +-- Renderering error messages for CannotPruneDependencies +-- + +renderCannotPruneDependencies :: CannotPruneDependencies -> String +renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ (case pkgids of + [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " + _ -> "the packages " + ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ") + ++ "required by a dependency of one of the other targets." + where + -- throw away the details and just list the deps that are needed + pkgids :: [PackageId] + pkgids = nub . map packageId . concatMap snd $ brokenPackages + +{- + ++ "Syntax:\n" + ++ " - build [package]\n" + ++ " - build [package:]component\n" + ++ " - build [package:][component:]module\n" + ++ " - build [package:][component:]file\n" + ++ " where\n" + ++ " package is a package name, package dir or .cabal file\n\n" + ++ "Examples:\n" + ++ " - build foo -- package name\n" + ++ " - build tests -- component name\n" + ++ " (name of library, executable, test-suite or benchmark)\n" + ++ " - build Data.Foo -- module name\n" + ++ " - build Data/Foo.hsc -- file name\n\n" + ++ "An ambigious target can be qualified by package, component\n" + ++ "and/or component kind (lib|exe|test|bench|flib)\n" + ++ " - build foo:tests -- component qualified by package\n" + ++ " - build tests:Data.Foo -- module qualified by component\n" + ++ " - build lib:foo -- component qualified by kind" +-} diff --git a/src/Distribution/Client/CmdExec.hs b/src/Distribution/Client/CmdExec.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdExec.hs @@ -0,0 +1,258 @@ +------------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Exec +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'v2-exec' command for running an arbitrary executable +-- in an environment suited to the part of the store built for a project. +------------------------------------------------------------------------------- + +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.CmdExec + ( execAction + , execCommand + ) where + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..) + ) +import Distribution.Client.InstallPlan + ( GenericPlanPackage(..) + , toGraph + ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( ConfigFlags(configVerbosity) + , GlobalFlags + ) +import Distribution.Client.ProjectOrchestration + ( ProjectBuildContext(..) + , runProjectPreBuildPhase + , CurrentCommand(..) + , establishProjectBaseContext + , distDirLayout + , commandLineFlagsToProjectConfig + , ProjectBaseContext(..) + , BuildTimeSettings(..) + ) +import Distribution.Client.ProjectPlanOutput + ( updatePostBuildProjectStatus + , createPackageEnvironment + , argsEquivalentOfGhcEnvironmentFile + , PostBuildProjectStatus + ) +import qualified Distribution.Client.ProjectPlanning as Planning +import Distribution.Client.ProjectPlanning + ( ElaboratedInstallPlan + , ElaboratedSharedConfig(..) + ) +import Distribution.Simple.Command + ( CommandUI(..), optionName + ) +import Distribution.Simple.Program.Db + ( modifyProgramSearchPath + , requireProgram + , configuredPrograms + ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry(..) + ) +import Distribution.Simple.Program.Run + ( programInvocation + , runProgramInvocation + ) +import Distribution.Simple.Program.Types + ( programOverrideEnv + , programDefaultArgs + , programPath + , simpleProgram + , ConfiguredProgram + ) +import Distribution.Simple.GHC + ( getImplInfo + , GhcImplInfo(supportsPkgEnvFiles) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.Utils + ( die' + , info + , createDirectoryIfMissingVerbose + , withTempDirectory + , wrapText + , notice + ) +import Distribution.Verbosity + ( normal + ) + +import Prelude () +import Distribution.Client.Compat.Prelude + +import qualified Data.Set as S +import qualified Data.Map as M + +execCommand :: CommandUI (NixStyleFlags ()) +execCommand = CommandUI + { commandName = "v2-exec" + , commandSynopsis = "Give a command access to the store." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" + , commandDescription = Just $ \pname -> wrapText $ + "During development it is often useful to run build tasks and perform" + ++ " one-off program executions to experiment with the behavior of build" + ++ " tools. It is convenient to run these tools in the same way " ++ pname + ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to" + ++ " do so.\n" + ++ "\n" + ++ "Compiler tools will be configured to see the same subset of the store" + ++ " that builds would see. The PATH is modified to make all executables in" + ++ " the dependency tree available (provided they have been built already)." + ++ " Commands are also rewritten in the way cabal itself would. For" + ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration" + ++ " to choose an appropriate version of ghc and to include any" + ++ " ghc-specific flags requested." + , commandNotes = Nothing + , commandOptions = filter (\o -> optionName o /= "ignore-project") + . nixStyleOptions (const []) + , commandDefaultFlags = defaultNixStyleFlags () + } + +execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +execAction flags@NixStyleFlags {..} extraArgs globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + -- To set up the environment, we'd like to select the libraries in our + -- dependency tree that we've already built. So first we set up an install + -- plan, but we walk the dependency tree without first executing the plan. + buildCtx <- runProjectPreBuildPhase + verbosity + baseCtx + (\plan -> return (plan, M.empty)) + + -- We use the build status below to decide what libraries to include in the + -- compiler environment, but we don't want to actually build anything. So we + -- pass mempty to indicate that nothing happened and we just want the current + -- status. + buildStatus <- updatePostBuildProjectStatus + verbosity + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + (pkgsBuildStatus buildCtx) + mempty + + -- Some dependencies may have executables. Let's put those on the PATH. + extraPaths <- pathAdditions verbosity baseCtx buildCtx + let programDb = modifyProgramSearchPath + (map ProgramSearchPathDir extraPaths ++) + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx + + -- Now that we have the packages, set up the environment. We accomplish this + -- by creating an environment file that selects the databases and packages we + -- computed in the previous step, and setting an environment variable to + -- point at the file. + -- In case ghc is too old to support environment files, + -- we pass the same info as arguments + let compiler = pkgConfigCompiler $ elaboratedShared buildCtx + envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) + case extraArgs of + [] -> die' verbosity "Please specify an executable to run" + exe:args -> do + (program, _) <- requireProgram verbosity (simpleProgram exe) programDb + let argOverrides = + argsEquivalentOfGhcEnvironmentFile + compiler + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + buildStatus + programIsConfiguredCompiler = matchCompilerPath + (elaboratedShared buildCtx) + program + argOverrides' = + if envFilesSupported + || not programIsConfiguredCompiler + then [] + else argOverrides + + (if envFilesSupported + then withTempEnvFile verbosity baseCtx buildCtx buildStatus + else \f -> f []) $ \envOverrides -> do + let program' = withOverrides + envOverrides + argOverrides' + program + invocation = programInvocation program' args + dryRun = buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + if dryRun + then notice verbosity "Running of executable suppressed by flag(s)" + else runProgramInvocation verbosity invocation + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + withOverrides env args program = program + { programOverrideEnv = programOverrideEnv program ++ env + , programDefaultArgs = programDefaultArgs program ++ args} + +matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool +matchCompilerPath elaboratedShared program = + programPath program + `elem` + (programPath <$> configuredCompilers) + where + configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared + +-- | Execute an action with a temporary .ghc.environment file reflecting the +-- current environment. The action takes an environment containing the env +-- variable which points ghc to the file. +withTempEnvFile :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> PostBuildProjectStatus + -> ([(String, Maybe String)] -> IO a) + -> IO a +withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do + createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) + withTempDirectory + verbosity + (distTempDirectory (distDirLayout baseCtx)) + "environment." + (\tmpDir -> do + envOverrides <- createPackageEnvironment + verbosity + tmpDir + (elaboratedPlanToExecute buildCtx) + (elaboratedShared buildCtx) + buildStatus + action envOverrides) + +pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] +pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do + info verbosity . unlines $ "Including the following directories in PATH:" + : paths + return paths + where + paths = S.toList + $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute + +binDirectories + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> Set FilePath +binDirectories layout config = fromElaboratedInstallPlan where + fromElaboratedInstallPlan = fromGraph . toGraph + fromGraph = foldMap fromPlan + fromSrcPkg = S.fromList . Planning.binDirectories layout config + + fromPlan (PreExisting _) = mempty + fromPlan (Configured pkg) = fromSrcPkg pkg + fromPlan (Installed pkg) = fromSrcPkg pkg + diff --git a/src/Distribution/Client/CmdFreeze.hs b/src/Distribution/Client/CmdFreeze.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdFreeze.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} + +-- | cabal-install CLI command: freeze +-- +module Distribution.Client.CmdFreeze ( + freezeCommand, + freezeAction, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), ProjectConfigShared(..) + , writeProjectLocalFreezeConfig ) +import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos) +import Distribution.Client.Targets + ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) ) +import Distribution.Client.DistDirLayout + ( DistDirLayout(distProjectFile) ) +import qualified Distribution.Client.InstallPlan as InstallPlan + + +import Distribution.Package + ( PackageName, packageName, packageVersion ) +import Distribution.Version + ( VersionRange, thisVersion + , unionVersionRanges, simplifyVersionRange ) +import Distribution.PackageDescription + ( FlagAssignment, nullFlagAssignment ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Simple.Flag (Flag (..)) +import Distribution.Simple.Utils + ( die', notice, wrapText ) +import Distribution.Verbosity + ( normal ) + +import qualified Data.Map as Map + +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) + +freezeCommand :: CommandUI (NixStyleFlags ()) +freezeCommand = CommandUI { + commandName = "v2-freeze", + commandSynopsis = "Freeze dependencies.", + commandUsage = usageAlternatives "v2-freeze" [ "[FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "The project configuration is frozen so that it will be reproducible " + ++ "in future.\n\n" + + ++ "The precise dependency configuration for the project is written to " + ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " + ++ "'--project-file' is specified). This file extends the configuration " + ++ "from the 'cabal.project' file and thus is used as the project " + ++ "configuration for all other commands (such as 'v2-build', " + ++ "'v2-repl' etc).\n\n" + + ++ "The freeze file can be kept in source control. To make small " + ++ "adjustments it may be edited manually, or to make bigger changes " + ++ "you may wish to delete the file and re-freeze. For more control, " + ++ "one approach is to try variations using 'v2-build --dry-run' with " + ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " + ++ "a satisfactory solution to freeze it using the 'v2-freeze' command " + ++ "with the same set of flags.", + + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-freeze\n" + ++ " Freeze the configuration of the current project\n\n" + ++ " " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n" + ++ " Check what a solution with the given constraints would look like\n" + ++ " " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n" + ++ " Freeze a solution using the given constraints\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + +-- | To a first approximation, the @freeze@ command runs the first phase of +-- the @build@ command where we bring the install plan up to date, and then +-- based on the install plan we write out a @cabal.project.freeze@ config file. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do + + unless (null extraArgs) $ + die' verbosity $ "'freeze' doesn't take any extra arguments: " + ++ unwords extraArgs + + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings + } <- establishProjectBaseContext verbosity cliConfig OtherCommand + + (_, elaboratedPlan, _, totalIndexState, activeRepos) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + + let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos + dryRun = buildSettingDryRun buildSettings + || buildSettingOnlyDownload buildSettings + + if dryRun + then notice verbosity "Freeze file not written due to flag(s)" + else do + writeProjectLocalFreezeConfig distDirLayout freezeConfig + notice verbosity $ + "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" + + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags + mempty -- ClientInstallFlags, not needed here + +-- | Given the install plan, produce a config value with constraints that +-- freezes the versions of packages used in the plan. +-- +projectFreezeConfig + :: ElaboratedInstallPlan + -> TotalIndexState + -> ActiveRepos + -> ProjectConfig +projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty + { projectConfigShared = mempty + { projectConfigConstraints = + concat (Map.elems (projectFreezeConstraints elaboratedPlan)) + , projectConfigIndexState = Flag totalIndexState + , projectConfigActiveRepos = Flag activeRepos + } + } + where + activeRepos :: ActiveRepos + activeRepos = filterSkippedActiveRepos activeRepos0 + +-- | Given the install plan, produce solver constraints that will ensure the +-- solver picks the same solution again in future in different environments. +-- +projectFreezeConstraints :: ElaboratedInstallPlan + -> Map PackageName [(UserConstraint, ConstraintSource)] +projectFreezeConstraints plan = + -- + -- TODO: [required eventually] this is currently an underapproximation + -- since the constraints language is not expressive enough to specify the + -- precise solution. See https://github.com/haskell/cabal/issues/3502. + -- + -- For the moment we deal with multiple versions in the solution by using + -- constraints that allow either version. Also, we do not include any + -- /version/ constraints for packages that are local to the project (e.g. + -- if the solution has two instances of Cabal, one from the local project + -- and one pulled in as a setup deps then we exclude all constraints on + -- Cabal, not just the constraint for the local instance since any + -- constraint would apply to both instances). We do however keep flag + -- constraints of local packages. + -- + deleteLocalPackagesVersionConstraints + (Map.unionWith (++) versionConstraints flagConstraints) + where + versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] + versionConstraints = + Map.mapWithKey + (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v), + ConstraintSourceFreeze)]) + versionRanges + + versionRanges :: Map PackageName VersionRange + versionRanges = + Map.map simplifyVersionRange $ + Map.fromListWith unionVersionRanges $ + [ (packageName pkg, thisVersion (packageVersion pkg)) + | InstallPlan.PreExisting pkg <- InstallPlan.toList plan + ] + ++ [ (packageName pkg, thisVersion (packageVersion pkg)) + | InstallPlan.Configured pkg <- InstallPlan.toList plan + ] + + flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] + flagConstraints = + Map.mapWithKey + (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f), + ConstraintSourceFreeze)]) + flagAssignments + + flagAssignments :: Map PackageName FlagAssignment + flagAssignments = + Map.fromList + [ (pkgname, flags) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , let flags = elabFlagAssignment elab + pkgname = packageName elab + , not (nullFlagAssignment flags) ] + + -- As described above, remove the version constraints on local packages, + -- but leave any flag constraints. + deleteLocalPackagesVersionConstraints + :: Map PackageName [(UserConstraint, ConstraintSource)] + -> Map PackageName [(UserConstraint, ConstraintSource)] + deleteLocalPackagesVersionConstraints = + Map.mergeWithKey + (\_pkgname () constraints -> + case filter (not . isVersionConstraint . fst) constraints of + [] -> Nothing + constraints' -> Just constraints') + (const Map.empty) id + localPackages + + isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True + isVersionConstraint _ = False + + localPackages :: Map PackageName () + localPackages = + Map.fromList + [ (packageName elab, ()) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , elabLocalToProject elab + ] + diff --git a/src/Distribution/Client/CmdHaddock.hs b/src/Distribution/Client/CmdHaddock.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdHaddock.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | cabal-install CLI command: haddock +-- +module Distribution.Client.CmdHaddock ( + -- * The @haddock@ CLI and action + haddockCommand, + haddockAction, + + -- * Internals exposed for testing + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages +import Distribution.Client.TargetProblem + ( TargetProblem (..), TargetProblem' ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import Distribution.Simple.Setup + ( HaddockFlags(..), fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +haddockCommand :: CommandUI (NixStyleFlags ()) +haddockCommand = CommandUI { + commandName = "v2-haddock", + commandSynopsis = "Build Haddock documentation", + commandUsage = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ], + commandDescription = Just $ \_ -> wrapText $ + "Build Haddock documentation for the specified packages within the " + ++ "project.\n\n" + + ++ "Any package in the project can be specified. If no package is " + ++ "specified, the default is to build the documentation for the package " + ++ "in the current directory. The default behaviour is to build " + ++ "documentation for the exposed modules of the library component (if " + ++ "any). This can be changed with the '--internal', '--executables', " + ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" + + ++ "Currently, documentation for dependencies is NOT built. This " + ++ "behavior may change in future.\n\n" + + ++ "Additional configuration flags can be specified on the command line " + ++ "and these extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-haddock pkgname" + ++ " Build documentation for the package named pkgname\n" + , commandOptions = nixStyleOptions (const []) + , commandDefaultFlags = defaultNixStyleFlags () + } + --TODO: [nice to have] support haddock on specific components, not just + -- whole packages and the silly --executables etc modifiers. + +-- | The @haddock@ command is TODO. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +haddockAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do + baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity + "The haddock command does not support '--only-dependencies'." + + -- When we interpret the targets on the command line, interpret them as + -- haddock targets + targets <- either (reportBuildDocumentationTargetProblems verbosity) return + $ resolveTargets + (selectPackageTargets haddockFlags) + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionHaddock + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here + +-- | This defines what a 'TargetSelector' means for the @haddock@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @haddock@ command we select all buildable libraries. Additionally, +-- depending on the @--executables@ flag we also select all the buildable exes. +-- We do similarly for test-suites, benchmarks and foreign libs. +-- +selectPackageTargets :: HaddockFlags -> TargetSelector + -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets haddockFlags targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail (map disableNotRequested targets) + targetsBuildable = selectBuildableTargets (map disableNotRequested targets) + + -- When there's a target filter like "pkg:exes" then we do select exes, + -- but if it's just a target like "pkg" then we don't build docs for exes + -- unless they are requested by default (i.e. by using --executables) + disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _) + | not (isRequested targetSelector (componentKind cname)) + = t { availableTargetStatus = TargetDisabledByUser } + disableNotRequested t = t + + isRequested (TargetPackage _ _ (Just _)) _ = True + isRequested (TargetAllPackages (Just _)) _ = True + isRequested _ LibKind = True +-- isRequested _ SubLibKind = True --TODO: what about sublibs? + + -- TODO/HACK, we encode some defaults here as v2-haddock's logic; + -- make sure this matches the defaults applied in + -- "Distribution.Client.ProjectPlanning"; this may need more work + -- to be done properly + -- + -- See also https://github.com/haskell/cabal/pull/4886 + isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags) + isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags) + isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags) + isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags) + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @haddock@ command we just need the basic checks on being buildable +-- etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget = selectComponentTargetBasic + +reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a +reportBuildDocumentationTargetProblems verbosity problems = + reportTargetProblems verbosity "build documentation for" problems diff --git a/src/Distribution/Client/CmdInstall.hs b/src/Distribution/Client/CmdInstall.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdInstall.hs @@ -0,0 +1,965 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | cabal-install CLI command: build +-- +module Distribution.Client.CmdInstall ( + -- * The @build@ CLI and action + installCommand, + installAction, + + -- * Internals exposed for testing + selectPackageTargets, + selectComponentTarget, + -- * Internals exposed for CmdRepl + CmdRun + establishDummyDistDirLayout, + establishDummyProjectBaseContext + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Directory + ( doesPathExist ) + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages +import Distribution.Client.CmdSdist +import Distribution.Client.TargetProblem + ( TargetProblem', TargetProblem (..) ) + +import Distribution.Client.CmdInstall.ClientInstallFlags +import Distribution.Client.CmdInstall.ClientInstallTargetSelector + +import Distribution.Client.Setup + ( GlobalFlags(..), ConfigFlags(..) ) +import Distribution.Client.Types + ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage + , SourcePackageDb(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Package + ( Package(..), PackageName, mkPackageName, unPackageName ) +import Distribution.Types.PackageId + ( PackageIdentifier(..) ) +import Distribution.Client.ProjectConfig + ( ProjectPackageLocation(..) + , fetchAndReadSourcePackages + , projectConfigWithBuilderRepoContext + , resolveBuildTimeSettings, withProjectOrGlobalConfig ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.ProjectFlags (ProjectFlags (..)) +import Distribution.Client.ProjectConfig.Types + ( ProjectConfig(..), ProjectConfigShared(..) + , ProjectConfigBuildOnly(..), PackageConfig(..) + , getMapLast, getMapMappend, projectConfigLogsDir + , projectConfigStoreDir, projectConfigBuildOnly + , projectConfigConfigFile ) +import Distribution.Simple.Program.Db + ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb + , modifyProgramSearchPath, ProgramDb ) +import Distribution.Simple.BuildPaths + ( exeExtension ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry(..) ) +import Distribution.Client.Config + ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) ) +import qualified Distribution.Simple.PackageIndex as PI +import Distribution.Solver.Types.PackageIndex + ( lookupPackageName, searchByName ) +import Distribution.Types.InstalledPackageInfo + ( InstalledPackageInfo(..) ) +import Distribution.Types.Version + ( Version, nullVersion ) +import Distribution.Types.VersionRange + ( thisVersion ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) +import Distribution.Client.IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.ProjectPlanning + ( storePackageInstallDirs' ) +import Distribution.Client.ProjectPlanning.Types + ( ElaboratedInstallPlan ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), mkCabalDirLayout + , cabalStoreDirLayout + , CabalDirLayout(..), StoreDirLayout(..) ) +import Distribution.Client.RebuildMonad + ( runRebuild ) +import Distribution.Client.InstallSymlink + ( symlinkBinary, trySymlink ) +import Distribution.Client.Types.OverwritePolicy + ( OverwritePolicy (..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault, flagToMaybe, flagElim ) +import Distribution.Simple.Setup + ( Flag(..) ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Configure + ( configCompilerEx ) +import Distribution.Simple.Compiler + ( Compiler(..), CompilerId(..), CompilerFlavor(..) + , PackageDBStack ) +import Distribution.Simple.GHC + ( ghcPlatformAndVersionString, getGhcAppDir + , GhcImplInfo(..), getImplInfo + , GhcEnvironmentFileEntry(..) + , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) +import Distribution.System + ( Platform , buildOS, OS (Windows) ) +import Distribution.Types.UnitId + ( UnitId ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Verbosity + ( normal, lessVerbose ) +import Distribution.Simple.Utils + ( wrapText, die', notice, warn + , withTempDirectory, createDirectoryIfMissingVerbose + , ordNub ) +import Distribution.Utils.Generic + ( safeHead, writeFileAtomic ) + +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Ord + ( Down(..) ) +import qualified Data.Map as Map +import Distribution.Utils.NubList + ( fromNubList ) +import Network.URI (URI) +import System.Directory + ( doesFileExist, createDirectoryIfMissing + , getTemporaryDirectory, makeAbsolute, doesDirectoryExist + , removeFile, removeDirectory, copyFile ) +import System.FilePath + ( (), (<.>), takeDirectory, takeBaseName ) + +installCommand :: CommandUI (NixStyleFlags ClientInstallFlags) +installCommand = CommandUI + { commandName = "v2-install" + , commandSynopsis = "Install packages." + , commandUsage = usageAlternatives + "v2-install" [ "[TARGETS] [FLAGS]" ] + , commandDescription = Just $ \_ -> wrapText $ + "Installs one or more packages. This is done by installing them " + ++ "in the store and symlinking/copying the executables in the directory " + ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). " + ++ "If you want the installed executables to be available globally, " + ++ "make sure that the PATH environment variable contains that directory. " + ++ "\n\n" + ++ "If TARGET is a library and --lib (provisional) is used, " + ++ "it will be added to the global environment. " + ++ "When doing this, cabal will try to build a plan that includes all " + ++ "the previously installed libraries. This is currently not implemented." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-install\n" + ++ " Install the package in the current directory\n" + ++ " " ++ pname ++ " v2-install pkgname\n" + ++ " Install the package named pkgname" + ++ " (fetching it from hackage if necessary)\n" + ++ " " ++ pname ++ " v2-install ./pkgfoo\n" + ++ " Install the package in the ./pkgfoo directory\n" + + , commandOptions = nixStyleOptions clientInstallOptions + , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags + } + +-- | The @install@ command actually serves four different needs. It installs: +-- * exes: +-- For example a program from hackage. The behavior is similar to the old +-- install command, except that now conflicts between separate runs of the +-- command are impossible thanks to the store. +-- Exes are installed in the store like a normal dependency, then they are +-- symlinked/copied in the directory specified by --installdir. +-- To do this we need a dummy projectBaseContext containing the targets as +-- estra packages and using a temporary dist directory. +-- * libraries +-- Libraries install through a similar process, but using GHC environment +-- files instead of symlinks. This means that 'v2-install'ing libraries +-- only works on GHC >= 8.0. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO () +installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do + -- Ensure there were no invalid configuration options specified. + verifyPreconditionsOrDie verbosity configFlags' + + -- We cannot use establishDummyProjectBaseContext to get these flags, since + -- it requires one of them as an argument. Normal establishProjectBaseContext + -- does not, and this is why this is done only for the install command + clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags' + + let + installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) + targetFilter = if installLibs then Just LibKind else Just ExeKind + targetStrings' = if null targetStrings then ["."] else targetStrings + + withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig) + withProject = do + let reducedVerbosity = lessVerbose verbosity + + -- First, we need to learn about what's available to be installed. + localBaseCtx <- + establishProjectBaseContext reducedVerbosity cliConfig InstallCommand + let localDistDirLayout = distDirLayout localBaseCtx + pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity + (buildSettings localBaseCtx) (getSourcePackages verbosity) + + let + (targetStrings'', packageIds) = + partitionEithers . + flip fmap targetStrings' $ + \str -> case simpleParsec str of + Just (pkgId :: PackageId) + | pkgVersion pkgId /= nullVersion -> Right pkgId + _ -> Left str + packageSpecifiers = + flip fmap packageIds $ \case + PackageIdentifier{..} + | pkgVersion == nullVersion -> NamedPackage pkgName [] + | otherwise -> NamedPackage pkgName + [PackagePropertyVersion + (thisVersion pkgVersion)] + packageTargets = + flip TargetPackageNamed targetFilter . pkgName <$> packageIds + + if null targetStrings' + then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx) + else do + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages localBaseCtx) + Nothing targetStrings'' + + (specs, selectors) <- + getSpecsAndTargetSelectors + verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter + + return ( specs ++ packageSpecifiers + , [] + , selectors ++ packageTargets + , projectConfig localBaseCtx ) + + withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig) + withoutProject globalConfig = do + tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings' + + cabalDir <- getCabalDir + let + projectConfig = globalConfig <> cliConfig + + ProjectConfigBuildOnly { + projectConfigLogsDir + } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext + verbosity buildSettings + (getSourcePackages verbosity) + + for_ (concatMap woPackageNames tss) $ \name -> do + when (null (lookupPackageName packageIndex name)) $ do + let xs = searchByName packageIndex (unPackageName name) + let emptyIf True _ = [] + emptyIf False zs = zs + die' verbosity $ concat $ + [ "Unknown package \"", unPackageName name, "\". " + ] ++ emptyIf (null xs) + [ "Did you mean any of the following?\n" + , unlines (("- " ++) . unPackageName . fst <$> xs) + ] + + let + (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss + packageTargets = map woPackageTargets tss + + return (packageSpecifiers, uris, packageTargets, projectConfig) + + (specs, uris, targetSelectors, config) <- + withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject + + let + ProjectConfig { + projectConfigBuildOnly = ProjectConfigBuildOnly { + projectConfigLogsDir + }, + projectConfigShared = ProjectConfigShared { + projectConfigHcFlavor, + projectConfigHcPath, + projectConfigHcPkg, + projectConfigStoreDir + }, + projectConfigLocalPackages = PackageConfig { + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra + } + } = config + + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + + -- ProgramDb with directly user specified paths + preProgDb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) + . modifyProgramSearchPath + (++ [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra ]) + $ defaultProgramDb + + -- progDb is a program database with compiler tools configured properly + (compiler@Compiler { compilerId = + compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <- + configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity + + let + GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler + + envFile <- getEnvFile clientInstallFlags platform compilerVersion + existingEnvEntries <- + getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile + packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir + installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb + + let + (envSpecs, nonGlobalEnvEntries) = + getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs + + -- Second, we need to use a fake project to let Cabal build the + -- installables correctly. For that, we need a place to put a + -- temporary dist directory. + globalTmp <- getTemporaryDirectory + + withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do + distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir + + uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages + verbosity + distDirLayout + (projectConfigShared config) + (projectConfigBuildOnly config) + [ ProjectPackageRemoteTarball uri | uri <- uris ] + + baseCtx <- establishDummyProjectBaseContext + verbosity + config + distDirLayout + (envSpecs ++ specs ++ uriSpecs) + InstallCommand + + buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + -- Now that we built everything we can do the installation part. + -- First, figure out if / what parts we want to install: + let + dryRun = buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + -- Then, install! + unless dryRun $ + if installLibs + then installLibraries verbosity + buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries + else installExes verbosity + baseCtx buildCtx platform compiler configFlags clientInstallFlags + where + configFlags' = disableTestsBenchsByDefault configFlags + verbosity = fromFlagOrDefault normal (configVerbosity configFlags') + ignoreProject = flagIgnoreProject projectFlags + cliConfig = commandLineFlagsToProjectConfig + globalFlags + flags { configFlags = configFlags' } + clientInstallFlags' + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + +-- | Verify that invalid config options were not passed to the install command. +-- +-- If an invalid configuration is found the command will @die'@. +verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO () +verifyPreconditionsOrDie verbosity configFlags = do + -- We never try to build tests/benchmarks for remote packages. + -- So we set them as disabled by default and error if they are explicitly + -- enabled. + when (configTests configFlags == Flag True) $ + die' verbosity $ "--enable-tests was specified, but tests can't " + ++ "be enabled in a remote package" + when (configBenchmarks configFlags == Flag True) $ + die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " + ++ "be enabled in a remote package" + +getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags +getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do + let configFileFlag = globalConfigFile globalFlags + savedConfig <- loadConfig verbosity configFileFlag + pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags + + +getSpecsAndTargetSelectors + :: Verbosity + -> Verbosity + -> SourcePackageDb + -> [TargetSelector] + -> DistDirLayout + -> ProjectBaseContext + -> Maybe ComponentKindFilter + -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) +getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter = + withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do + -- Split into known targets and hackage packages. + (targets, hackageNames) <- + partitionToKnownTargetsAndHackagePackages + verbosity pkgDb elaboratedPlan targetSelectors + + let + planMap = InstallPlan.toMap elaboratedPlan + targetIds = Map.keys targets + + sdistize (SpecificSourcePackage spkg) = + SpecificSourcePackage spkg' + where + sdistPath = distSdistFile localDistDirLayout (packageId spkg) + spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath } + sdistize named = named + + local = sdistize <$> localPackages localBaseCtx + + gatherTargets :: UnitId -> TargetSelector + gatherTargets targetId = TargetPackageNamed pkgName targetFilter + where + targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap + PackageIdentifier{..} = packageId targetUnit + + targets' = fmap gatherTargets targetIds + + hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] + hackagePkgs = flip NamedPackage [] <$> hackageNames + + hackageTargets :: [TargetSelector] + hackageTargets = + flip TargetPackageNamed targetFilter <$> hackageNames + + createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) + + unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of + SpecificSourcePackage pkg -> packageToSdist verbosity + (distProjectRootDirectory localDistDirLayout) TarGzArchive + (distSdistFile localDistDirLayout (packageId pkg)) pkg + NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName + + if null targets + then return (hackagePkgs, hackageTargets) + else return (local ++ hackagePkgs, targets' ++ hackageTargets) + +-- | Partitions the target selectors into known local targets and hackage packages. +partitionToKnownTargetsAndHackagePackages + :: Verbosity + -> SourcePackageDb + -> ElaboratedInstallPlan + -> [TargetSelector] + -> IO (Map UnitId [(ComponentTarget,[TargetSelector])], [PackageName]) +partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do + let mTargets = resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + (Just pkgDb) + targetSelectors + case mTargets of + Right targets -> + -- Everything is a local dependency. + return (targets, []) + Left errs -> do + -- Not everything is local. + let + (errs', hackageNames) = partitionEithers . flip fmap errs $ \case + TargetAvailableInIndex name -> Right name + err -> Left err + + -- report incorrect case for known package. + for_ errs' $ \case + TargetNotInProject hn -> + case searchByName (packageIndex pkgDb) (unPackageName hn) of + [] -> return () + xs -> die' verbosity . concat $ + [ "Unknown package \"", unPackageName hn, "\". " + , "Did you mean any of the following?\n" + , unlines (("- " ++) . unPackageName . fst <$> xs) + ] + _ -> return () + + when (not . null $ errs') $ reportBuildTargetProblems verbosity errs' + + let + targetSelectors' = flip filter targetSelectors $ \case + TargetComponentUnknown name _ _ + | name `elem` hackageNames -> False + TargetPackageNamed name _ + | name `elem` hackageNames -> False + _ -> True + + -- This can't fail, because all of the errors are + -- removed (or we've given up). + targets <- + either (reportBuildTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors' + + return (targets, hackageNames) + + + +constructProjectBuildContext + :: Verbosity + -> ProjectBaseContext + -- ^ The synthetic base context to use to produce the full build context. + -> [TargetSelector] + -> IO ProjectBuildContext +constructProjectBuildContext verbosity baseCtx targetSelectors = do + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + targets <- either (reportBuildTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let prunedToTargetsElaboratedPlan = + pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + prunedElaboratedPlan <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies (Map.keysSet targets) + prunedToTargetsElaboratedPlan + else return prunedToTargetsElaboratedPlan + + return (prunedElaboratedPlan, targets) + + +-- | Install any built exe by symlinking/copying it +-- we don't use BuildOutcomes because we also need the component names +installExes + :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> Platform + -> Compiler + -> ConfigFlags + -> ClientInstallFlags + -> IO () +installExes verbosity baseCtx buildCtx platform compiler + configFlags clientInstallFlags = do + installPath <- defaultInstallPath + let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx + + prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags)) + suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags)) + + mkUnitBinDir :: UnitId -> FilePath + mkUnitBinDir = + InstallDirs.bindir . + storePackageInstallDirs' storeDirLayout (compilerId compiler) + + mkExeName :: UnqualComponentName -> FilePath + mkExeName exe = unUnqualComponentName exe <.> exeExtension platform + + mkFinalExeName :: UnqualComponentName -> FilePath + mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform + installdirUnknown = + "installdir is not defined. Set it in your cabal config file " + ++ "or use --installdir=. Using default installdir: " ++ show installPath + + installdir <- fromFlagOrDefault + (warn verbosity installdirUnknown >> pure installPath) $ + pure <$> cinstInstalldir clientInstallFlags + createDirectoryIfMissingVerbose verbosity False installdir + warnIfNoExes verbosity buildCtx + + installMethod <- flagElim defaultMethod return $ + cinstInstallMethod clientInstallFlags + + let + doInstall = installUnitExes + verbosity + overwritePolicy + mkUnitBinDir mkExeName mkFinalExeName + installdir installMethod + in traverse_ doInstall $ Map.toList $ targetsMap buildCtx + where + overwritePolicy = fromFlagOrDefault NeverOverwrite $ + cinstOverwritePolicy clientInstallFlags + isWindows = buildOS == Windows + + -- This is in IO as we will make environment checks, + -- to decide which method is best + defaultMethod :: IO InstallMethod + defaultMethod + -- Try symlinking in temporary directory, if it works default to + -- symlinking even on windows + | isWindows = do + symlinks <- trySymlink verbosity + return $ if symlinks then InstallMethodSymlink else InstallMethodCopy + | otherwise = return InstallMethodSymlink + +-- | Install any built library by adding it to the default ghc environment +installLibraries + :: Verbosity + -> ProjectBuildContext + -> Compiler + -> PackageDBStack + -> ProgramDb + -> FilePath -- ^ Environment file + -> [GhcEnvironmentFileEntry] + -> IO () +installLibraries verbosity buildCtx compiler + packageDbs programDb envFile envEntries = do + -- Why do we get it again? If we updated a globalPackage then we need + -- the new version. + installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb + if supportsPkgEnvFiles $ getImplInfo compiler + then do + let + getLatest :: PackageName -> [InstalledPackageInfo] + getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) + . PI.lookupPackageName installedIndex + globalLatest = concat (getLatest <$> globalPackages) + + baseEntries = + GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs + globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest + pkgEntries = ordNub $ + globalEntries + ++ envEntries + ++ entriesForLibraryComponents (targetsMap buildCtx) + contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) + createDirectoryIfMissing True (takeDirectory envFile) + writeFileAtomic envFile (BS.pack contents') + else + warn verbosity $ + "The current compiler doesn't support safely installing libraries, " + ++ "so only executables will be available. (Library installation is " + ++ "supported on GHC 8.0+ only)" + +warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () +warnIfNoExes verbosity buildCtx = + when noExes $ + warn verbosity $ + "\n" <> + "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> + "@ WARNING: Installation might not be completed as desired! @\n" <> + "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> + "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" <> + "* You might have wanted to add them as dependencies to your package." <> + " In this case add \"" <> + intercalate ", " (showTargetSelector <$> selectors) <> + "\" to the build-depends field(s) of your package's .cabal file.\n" <> + "* You might have wanted to add them to a GHC environment. In this case" <> + " use \"cabal install --lib " <> + unwords (showTargetSelector <$> selectors) <> "\". " <> + " The \"--lib\" flag is provisional: see" <> + " https://github.com/haskell/cabal/issues/6481 for more information." + where + targets = concat $ Map.elems $ targetsMap buildCtx + components = fst <$> targets + selectors = concatMap snd targets + noExes = null $ catMaybes $ exeMaybe <$> components + + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe + exeMaybe _ = Nothing + +globalPackages :: [PackageName] +globalPackages = mkPackageName <$> + [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath" + , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary" + , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq" + , "ghc-boot-th", "pretty", "template-haskell", "directory", "text" + , "bin-package-db" + ] + +-- | Return the package specifiers and non-global environment file entries. +getEnvSpecsAndNonGlobalEntries + :: PI.InstalledPackageIndex + -> [GhcEnvironmentFileEntry] + -> Bool + -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) +getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs = + if installLibs + then (envSpecs, envEntries') + else ([], envEntries') + where + (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries + +environmentFileToSpecifiers + :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] + -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) +environmentFileToSpecifiers ipi = foldMap $ \case + (GhcEnvFilePackageId unitId) + | Just InstalledPackageInfo + { sourcePackageId = PackageIdentifier{..}, installedUnitId } + <- PI.lookupUnitId ipi unitId + , let pkgSpec = NamedPackage pkgName + [PackagePropertyVersion (thisVersion pkgVersion)] + -> if pkgName `elem` globalPackages + then ([pkgSpec], []) + else ([pkgSpec], [GhcEnvFilePackageId installedUnitId]) + _ -> ([], []) + + +-- | Disables tests and benchmarks if they weren't explicitly enabled. +disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags +disableTestsBenchsByDefault configFlags = + configFlags { configTests = Flag False <> configTests configFlags + , configBenchmarks = Flag False <> configBenchmarks configFlags } + +-- | Symlink/copy every exe from a package from the store to a given location +installUnitExes + :: Verbosity + -> OverwritePolicy -- ^ Whether to overwrite existing files + -> (UnitId -> FilePath) -- ^ A function to get an UnitId's + -- ^ store directory + -> (UnqualComponentName -> FilePath) -- ^ A function to get an + -- ^ exe's filename + -> (UnqualComponentName -> FilePath) -- ^ A function to get an + -- ^ exe's final possibly + -- ^ different to the name in the store. + -> FilePath + -> InstallMethod + -> ( UnitId + , [(ComponentTarget, [TargetSelector])] ) + -> IO () +installUnitExes verbosity overwritePolicy + mkSourceBinDir mkExeName mkFinalExeName + installdir installMethod + (unit, components) = + traverse_ installAndWarn exes + where + exes = catMaybes $ (exeMaybe . fst) <$> components + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe + exeMaybe _ = Nothing + installAndWarn exe = do + success <- installBuiltExe + verbosity overwritePolicy + (mkSourceBinDir unit) (mkExeName exe) + (mkFinalExeName exe) + installdir installMethod + let errorMessage = case overwritePolicy of + NeverOverwrite -> + "Path '" <> (installdir prettyShow exe) <> "' already exists. " + <> "Use --overwrite-policy=always to overwrite." + -- This shouldn't even be possible, but we keep it in case + -- symlinking/copying logic changes + AlwaysOverwrite -> + case installMethod of + InstallMethodSymlink -> "Symlinking" + InstallMethodCopy -> + "Copying" <> " '" <> prettyShow exe <> "' failed." + unless success $ die' verbosity errorMessage + +-- | Install a specific exe. +installBuiltExe + :: Verbosity -> OverwritePolicy + -> FilePath -- ^ The directory where the built exe is located + -> FilePath -- ^ The exe's filename + -> FilePath -- ^ The exe's filename in the public install directory + -> FilePath -- ^ the directory where it should be installed + -> InstallMethod + -> IO Bool -- ^ Whether the installation was successful +installBuiltExe verbosity overwritePolicy + sourceDir exeName finalExeName + installdir InstallMethodSymlink = do + notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'" + symlinkBinary + overwritePolicy + installdir + sourceDir + finalExeName + exeName + where + destination = installdir finalExeName +installBuiltExe verbosity overwritePolicy + sourceDir exeName finalExeName + installdir InstallMethodCopy = do + notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'" + exists <- doesPathExist destination + case (exists, overwritePolicy) of + (True , NeverOverwrite ) -> pure False + (True , AlwaysOverwrite) -> remove >> copy + (False, _ ) -> copy + where + source = sourceDir exeName + destination = installdir finalExeName + remove = do + isDir <- doesDirectoryExist destination + if isDir + then removeDirectory destination + else removeFile destination + copy = copyFile source destination >> pure True + +-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. +entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] +entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] + where + hasLib :: (ComponentTarget, [TargetSelector]) -> Bool + hasLib (ComponentTarget (CLibName _) _, _) = True + hasLib _ = False + + go :: UnitId + -> [(ComponentTarget, [TargetSelector])] + -> [GhcEnvironmentFileEntry] + go unitId targets + | any hasLib targets = [GhcEnvFilePackageId unitId] + | otherwise = [] + + +-- | Gets the file path to the request environment file. +getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath +getEnvFile clientInstallFlags platform compilerVersion = do + appDir <- getGhcAppDir + case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of + Just spec + -- Is spec a bare word without any "pathy" content, then it refers to + -- a named global environment. + | takeBaseName spec == spec -> + return (getGlobalEnv appDir platform compilerVersion spec) + | otherwise -> do + spec' <- makeAbsolute spec + isDir <- doesDirectoryExist spec' + if isDir + -- If spec is a directory, then make an ambient environment inside + -- that directory. + then return (getLocalEnv spec' platform compilerVersion) + -- Otherwise, treat it like a literal file path. + else return spec' + Nothing -> + return (getGlobalEnv appDir platform compilerVersion "default") + +-- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the +-- environment being operated on. +getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry] +getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do + envFileExists <- doesFileExist envFile + filterEnvEntries <$> if + (compilerFlavor == GHC || compilerFlavor == GHCJS) + && supportsPkgEnvFiles && envFileExists + then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) -> + warn verbosity ("The environment file " ++ envFile ++ + " is unparsable. Libraries cannot be installed.") >> return [] + else return [] + where + -- Why? We know what the first part will be, we only care about the packages. + filterEnvEntries = filter $ \case + GhcEnvFilePackageId _ -> True + _ -> False + +-- | Constructs the path to the global GHC environment file. +-- +-- TODO(m-renaud): Create PkgEnvName newtype wrapper. +getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath +getGlobalEnv appDir platform compilerVersion name = + appDir ghcPlatformAndVersionString platform compilerVersion + "environments" name + +-- | Constructs the path to a local GHC environment file. +getLocalEnv :: FilePath -> Platform -> Version -> FilePath +getLocalEnv dir platform compilerVersion = + dir + ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion + +getPackageDbStack + :: CompilerId + -> Flag FilePath + -> Flag FilePath + -> IO PackageDBStack +getPackageDbStack compilerId storeDirFlag logsDirFlag = do + cabalDir <- getCabalDir + mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag + let + mlogsDir = flagToMaybe logsDirFlag + cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @build@ command select all components except non-buildable +-- and disabled tests\/benchmarks, fail if there are no such +-- components +-- +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargetsWith + (buildable targetSelector) + targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable _ _ = True + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @build@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget = selectComponentTargetBasic + +reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a +reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + die' verbosity . renderCannotPruneDependencies diff --git a/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.CmdInstall.ClientInstallFlags +( InstallMethod(..) +, ClientInstallFlags(..) +, defaultClientInstallFlags +, clientInstallOptions +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.ReadE + ( succeedReadE, parsecToReadE ) +import Distribution.Simple.Command + ( ShowOrParseArgs(..), OptionField(..), option, reqArg ) +import Distribution.Simple.Setup + ( Flag(..), trueArg, flagToList, toFlag ) + +import Distribution.Client.Types.InstallMethod + ( InstallMethod (..) ) +import Distribution.Client.Types.OverwritePolicy + ( OverwritePolicy(..) ) + +import qualified Distribution.Compat.CharParsing as P + +data ClientInstallFlags = ClientInstallFlags + { cinstInstallLibs :: Flag Bool + , cinstEnvironmentPath :: Flag FilePath + , cinstOverwritePolicy :: Flag OverwritePolicy + , cinstInstallMethod :: Flag InstallMethod + , cinstInstalldir :: Flag FilePath + } deriving (Eq, Show, Generic) + +instance Monoid ClientInstallFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ClientInstallFlags where + (<>) = gmappend + +instance Binary ClientInstallFlags +instance Structured ClientInstallFlags + +defaultClientInstallFlags :: ClientInstallFlags +defaultClientInstallFlags = ClientInstallFlags + { cinstInstallLibs = toFlag False + , cinstEnvironmentPath = mempty + , cinstOverwritePolicy = mempty + , cinstInstallMethod = mempty + , cinstInstalldir = mempty + } + +clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags] +clientInstallOptions _ = + [ option [] ["lib"] + ( "Install libraries rather than executables from the target package " <> + "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)." ) + cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v }) + trueArg + , option [] ["package-env", "env"] + "Set the environment file that may be modified." + cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf }) + (reqArg "ENV" (succeedReadE Flag) flagToList) + , option [] ["overwrite-policy"] + "How to handle already existing symlinks." + cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) + $ reqArg "always|never" + (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) + (map prettyShow . flagToList) + , option [] ["install-method"] + "How to install the executables." + cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v }) + $ reqArg + "default|copy|symlink" + (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod)) + (map prettyShow . flagToList) + , option [] ["installdir"] + "Where to install (by symlinking or copying) the executables in." + cinstInstalldir (\v flags -> flags { cinstInstalldir = v }) + $ reqArg "DIR" (succeedReadE Flag) flagToList + ] + +parsecInstallMethod :: CabalParsing m => m InstallMethod +parsecInstallMethod = do + name <- P.munch1 isAlpha + case name of + "copy" -> pure InstallMethodCopy + "symlink" -> pure InstallMethodSymlink + _ -> P.unexpected $ "InstallMethod: " ++ name diff --git a/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs @@ -0,0 +1,68 @@ +module Distribution.Client.CmdInstall.ClientInstallTargetSelector ( + WithoutProjectTargetSelector (..), + parseWithoutProjectTargetSelector, + woPackageNames, + woPackageTargets, + woPackageSpecifiers, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Network.URI (URI, parseURI) + +import Distribution.Client.TargetSelector +import Distribution.Client.Types +import Distribution.Compat.CharParsing (char, optional) +import Distribution.Package +import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName)) +import Distribution.Simple.Utils (die') +import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) +import Distribution.Version + +data WithoutProjectTargetSelector + = WoPackageId PackageId + | WoPackageComponent PackageId ComponentName + | WoURI URI + deriving (Show) + +parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector +parseWithoutProjectTargetSelector verbosity input = + case explicitEitherParsec parser input of + Right ts -> return ts + Left err -> case parseURI input of + Just uri -> return (WoURI uri) + Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err + where + parser :: CabalParsing m => m WithoutProjectTargetSelector + parser = do + pid <- parsec + cn <- optional (char ':' *> parsec) + return $ case cn of + Nothing -> WoPackageId pid + Just cn' -> WoPackageComponent pid (CExeName cn') + +woPackageNames :: WithoutProjectTargetSelector -> [PackageName] +woPackageNames (WoPackageId pid) = [pkgName pid] +woPackageNames (WoPackageComponent pid _) = [pkgName pid] +woPackageNames (WoURI _) = [] + +woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector +woPackageTargets (WoPackageId pid) = + TargetPackageNamed (pkgName pid) Nothing +woPackageTargets (WoPackageComponent pid cn) = + TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent +woPackageTargets (WoURI _) = + TargetAllPackages (Just ExeKind) + +woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg) +woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid) +woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid) +woPackageSpecifiers (WoURI uri) = Left uri + +pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg +pidPackageSpecifiers pid + | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) [] + | otherwise = NamedPackage (pkgName pid) + [ PackagePropertyVersion (thisVersion (pkgVersion pid)) + ] diff --git a/src/Distribution/Client/CmdLegacy.hs b/src/Distribution/Client/CmdLegacy.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdLegacy.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Sandbox + ( loadConfigOrSandboxConfig, findSavedDistPref ) +import qualified Distribution.Client.Setup as Client +import Distribution.Client.SetupWrapper + ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions ) +import qualified Distribution.Simple.Setup as Setup +import Distribution.Simple.Command +import Distribution.Simple.Utils + ( wrapText ) +import Distribution.Verbosity + ( normal ) + +import Control.Exception + ( try ) +import qualified Data.Text as T + +-- Tweaked versions of code from Main. +regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action) +regularCmd ui action = + CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand + +wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ()) +wrapperCmd ui verbosity' distPref = + CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand + +wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ()) +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do + let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) + + load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) + let config = either (\(SomeException _) -> mempty) id load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } + + let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command } + + setupWrapper verbosity' setupScriptOptions Nothing + command' (const flags) (const extraArgs) + +-- + +class HasVerbosity a where + verbosity :: a -> Verbosity + +instance HasVerbosity (Setup.Flag Verbosity) where + verbosity = Setup.fromFlagOrDefault normal + +instance (HasVerbosity a) => HasVerbosity (a, b) where + verbosity (a, _) = verbosity a + +instance (HasVerbosity a) => HasVerbosity (a, b, c) where + verbosity (a , _, _) = verbosity a + +instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where + verbosity (a, _, _, _) = verbosity a + +instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where + verbosity (a, _, _, _, _) = verbosity a + +instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where + verbosity (a, _, _, _, _, _) = verbosity a + +instance HasVerbosity Setup.BuildFlags where + verbosity = verbosity . Setup.buildVerbosity + +instance HasVerbosity Setup.ConfigFlags where + verbosity = verbosity . Setup.configVerbosity + +instance HasVerbosity Setup.ReplFlags where + verbosity = verbosity . Setup.replVerbosity + +instance HasVerbosity Client.FreezeFlags where + verbosity = verbosity . Client.freezeVerbosity + +instance HasVerbosity Setup.HaddockFlags where + verbosity = verbosity . Setup.haddockVerbosity + +instance HasVerbosity Client.UpdateFlags where + verbosity = verbosity . Client.updateVerbosity + +instance HasVerbosity Setup.CleanFlags where + verbosity = verbosity . Setup.cleanVerbosity + +-- + +legacyNote :: String -> String +legacyNote cmd = wrapText $ + "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ + + "It is a legacy feature and will be removed in a future release of cabal-install." ++ + " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++ + " commands.\n\n" ++ + + "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" + +toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] +toLegacyCmd mkSpec = [toLegacy mkSpec] + where + toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' + where + legUi = origUi + { commandName = "v1-" ++ commandName + , commandNotes = Just $ \pname -> case commandNotes of + Just notes -> notes pname ++ "\n" ++ legacyNote commandName + Nothing -> legacyNote commandName + } + +legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] +legacyCmd ui action = toLegacyCmd (regularCmd ui action) + +legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())] +legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref) + +newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] +newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi] + where + cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand + + newMsg = T.unpack . T.replace "v2-" "new-" . T.pack + newUi = origUi + { commandName = newMsg commandName + , commandUsage = newMsg . commandUsage + , commandDescription = (newMsg .) <$> commandDescription + , commandNotes = (newMsg .) <$> commandNotes + } + + defaultMsg = T.unpack . T.replace "v2-" "" . T.pack + defaultUi = origUi + { commandName = defaultMsg commandName + , commandUsage = defaultMsg . commandUsage + , commandDescription = (defaultMsg .) <$> commandDescription + , commandNotes = (defaultMsg .) <$> commandNotes + } diff --git a/src/Distribution/Client/CmdListBin.hs b/src/Distribution/Client/CmdListBin.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdListBin.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Distribution.Client.CmdListBin ( + listbinCommand, + listbinAction, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.CmdErrorMessages + (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets, + renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs) +import Distribution.Client.DistDirLayout (DistDirLayout (..), ProjectRoot (..)) +import Distribution.Client.NixStyleOptions + (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions) +import Distribution.Client.ProjectConfig + (ProjectConfig, projectConfigConfigFile, projectConfigShared, withProjectOrGlobalConfig) +import Distribution.Client.ProjectFlags (ProjectFlags (..)) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.Setup (GlobalFlags (..)) +import Distribution.Client.TargetProblem (TargetProblem (..)) +import Distribution.Simple.BuildPaths (dllExtension, exeExtension) +import Distribution.Simple.Command (CommandUI (..)) +import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault) +import Distribution.Simple.Utils (die', ordNub, wrapText) +import Distribution.System (Platform) +import Distribution.Types.ComponentName (showComponentName) +import Distribution.Types.UnitId (UnitId) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Verbosity (silent, verboseStderr) +import System.Directory (getCurrentDirectory) +import System.FilePath ((<.>), ()) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Distribution.Client.InstallPlan as IP +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Solver.Types.ComponentDeps as CD + +------------------------------------------------------------------------------- +-- Command +------------------------------------------------------------------------------- + +listbinCommand :: CommandUI (NixStyleFlags ()) +listbinCommand = CommandUI + { commandName = "list-bin" + , commandSynopsis = "list path to a single executable." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n" + , commandDescription = Just $ \_ -> wrapText + "List path to a build product." + , commandNotes = Nothing + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + +------------------------------------------------------------------------------- +-- Action +------------------------------------------------------------------------------- + +listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +listbinAction flags@NixStyleFlags{..} args globalFlags = do + -- fail early if multiple target selectors specified + target <- case args of + [] -> die' verbosity "One target is required, none provided" + [x] -> return x + _ -> die' verbosity "One target is required, given multiple" + + -- configure + (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject + let localPkgs = localPackages baseCtx + + -- elaborate target selectors + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors localPkgs (Just ExeKind) [target] + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- singleComponentOrElse + (reportTargetProblems + verbosity + [multipleTargetsProblem targets]) + targets + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) + + (selectedUnitId, _selectedComponent) <- + -- Slight duplication with 'runProjectPreBuildPhase'. + singleComponentOrElse + (die' verbosity $ "No or multiple targets given, but the run " + ++ "phase has been reached. This is a bug.") + $ targetsMap buildCtx + + printPlan verbosity baseCtx buildCtx + + binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of + Nothing -> die' verbosity "No or multiple targets given..." + Just gpp -> return $ IP.foldPlanPackage + (const []) -- IPI don't have executables + (elaboratedPackage distDirLayout (elaboratedShared buildCtx)) + gpp + + case binfiles of + [exe] -> putStrLn exe + _ -> die' verbosity "No or multiple targets given" + where + defaultVerbosity = verboseStderr silent + verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) + ignoreProject = flagIgnoreProject projectFlags + prjConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here + globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) + + withProject :: IO (ProjectBaseContext, DistDirLayout) + withProject = do + baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand + return (baseCtx, distDirLayout baseCtx) + + withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) + withoutProject config = do + cwd <- getCurrentDirectory + baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand + return (baseCtx, distDirLayout baseCtx) + + -- this is copied from + elaboratedPackage + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> [FilePath] + elaboratedPackage distDirLayout elaboratedSharedConfig elab = case elabPkgOrComp elab of + ElabPackage pkg -> + [ bin + | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg) + (pkgExeDependencies pkg) + , bin <- bin_file c + ] + ElabComponent comp -> bin_file (compSolverName comp) + where + dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab) + + bin_file c = case c of + CD.ComponentExe s -> [bin_file' s] + CD.ComponentTest s -> [bin_file' s] + CD.ComponentBench s -> [bin_file' s] + CD.ComponentFLib s -> [flib_file' s] + _ -> [] + + plat :: Platform + plat = pkgConfigPlatform elaboratedSharedConfig + + -- here and in PlanOutput, + -- use binDirectoryFor? + bin_file' s = + if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat + else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + + flib_file' s = + if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat + else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + +------------------------------------------------------------------------------- +-- Target Problem: the very similar to CmdRun +------------------------------------------------------------------------------- + +singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleComponentOrElse action targetsMap = + case Set.toList . distinctTargetComponents $ targetsMap + of [(unitId, CExeName component)] -> return (unitId, component) + [(unitId, CTestName component)] -> return (unitId, component) + [(unitId, CBenchName component)] -> return (unitId, component) + [(unitId, CFLibName component)] -> return (unitId, component) + _ -> action + +-- | This defines what a 'TargetSelector' means for the @list-bin@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @list-bin@ command we select the exe or flib if there is only one +-- and it's buildable. Fail if there are no or multiple buildable exe components. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either ListBinTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) + = Left (matchesMultipleProblem targetSelector targetsExesBuildable') + + -- If there are executables but none are buildable then we report those + | not (null targetsExes) + = Left (TargetProblemNoneEnabled targetSelector targetsExes) + + -- If there are no executables but some other targets then we report that + | not (null targets) + = Left (noComponentsProblem targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + -- Targets that can be executed + targetsExecutableLike = + concatMap (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] + (targetsExesBuildable, + targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike + + targetsExes = forgetTargetsDetail targetsExecutableLike + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @run@ command we just need to check it is a executable-like +-- (an executable, a test, or a benchmark), in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either ListBinTargetProblem k +selectComponentTarget subtarget@WholeComponent t + = case availableTargetComponentName t + of CExeName _ -> component + CTestName _ -> component + CBenchName _ -> component + CFLibName _ -> component + _ -> Left (componentNotRightKindProblem pkgid cname) + where pkgid = availableTargetPackageId t + cname = availableTargetComponentName t + component = selectComponentTargetBasic subtarget t + +selectComponentTarget subtarget t + = Left (isSubComponentProblem (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @run@ command. +-- +data ListBinProblem = + -- | The 'TargetSelector' matches targets but no executables + TargetProblemNoRightComps TargetSelector + + -- | A single 'TargetSelector' matches multiple targets + | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + + -- | The 'TargetSelector' refers to a component that is not an executable + | TargetProblemComponentNotRightKind PackageId ComponentName + + -- | Asking to run an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +type ListBinTargetProblem = TargetProblem ListBinProblem + +noComponentsProblem :: TargetSelector -> ListBinTargetProblem +noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps + +matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem +matchesMultipleProblem selector targets = CustomTargetProblem $ + TargetProblemMatchesMultiple selector targets + +multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem +multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets + +componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem +componentNotRightKindProblem pkgid name = CustomTargetProblem $ + TargetProblemComponentNotRightKind pkgid name + +isSubComponentProblem + :: PackageId + -> ComponentName + -> SubComponentTarget + -> TargetProblem ListBinProblem +isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent + +reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderListBinTargetProblem + +renderListBinTargetProblem :: ListBinTargetProblem -> String +renderListBinTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= ExeKind + -> "The list-bin command is for finding binaries, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "list-bin" targetSelector +renderListBinTargetProblem problem = + renderTargetProblem "list-bin" renderListBinProblem problem + +renderListBinProblem :: ListBinProblem -> String +renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) = + "The list-bin command is for finding a single binary at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which includes " + ++ renderListCommaAnd ( ("the "++) <$> + showComponentName <$> + availableTargetComponentName <$> + foldMap + (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] ) + ++ "." + +renderListBinProblem (TargetProblemMultipleTargets selectorMap) = + "The list-bin command is for finding a single binary at once. The targets " + ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" + | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] + ++ " refer to different executables." + +renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) = + "The list-bin command is for finding binaries, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ prettyShow pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The list-bin command can only find a binary as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget + +renderListBinProblem (TargetProblemNoRightComps targetSelector) = + "Cannot list-bin the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any executables or foreign libraries." diff --git a/src/Distribution/Client/CmdRepl.hs b/src/Distribution/Client/CmdRepl.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdRepl.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +-- | cabal-install CLI command: repl +-- +module Distribution.Client.CmdRepl ( + -- * The @repl@ CLI and action + replCommand, + replAction, + + -- * Internals exposed for testing + matchesMultipleProblem, + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Compat.Lens +import qualified Distribution.Types.Lens as L + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.CmdErrorMessages + ( renderTargetSelector, showTargetSelector, + renderTargetProblem, + targetSelectorRefersToPkgs, + renderComponentKind, renderListCommaAnd, renderListSemiAnd, + componentKind, sortGroupOn, Plural(..) ) +import Distribution.Client.TargetProblem + ( TargetProblem(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectBuilding + ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), withProjectOrGlobalConfig + , projectConfigConfigFile ) +import Distribution.Client.ProjectFlags + ( flagIgnoreProject ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning + ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) +import Distribution.Client.ProjectPlanning.Types + ( elabOrderExeDependencies ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) ) +import qualified Distribution.Client.Setup as Client +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) +import Distribution.Simple.Setup + ( fromFlagOrDefault, replOptions + , Flag(..), toFlag, falseArg ) +import Distribution.Simple.Command + ( CommandUI(..), liftOptionL, usageAlternatives, option + , ShowOrParseArgs, OptionField, reqArg ) +import Distribution.Compiler + ( CompilerFlavor(GHC) ) +import Distribution.Simple.Compiler + ( compilerCompatVersion ) +import Distribution.Package + ( Package(..), packageName, UnitId, installedUnitId ) +import Distribution.PackageDescription.PrettyPrint +import Distribution.Parsec + ( parsecCommaList ) +import Distribution.ReadE + ( ReadE, parsecToReadE ) +import qualified Distribution.SPDX.License as SPDX +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.Types.BuildInfo + ( BuildInfo(..), emptyBuildInfo ) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Types.CondTree + ( CondTree(..), traverseCondTreeC ) +import Distribution.Types.Dependency + ( Dependency(..), mainLibSet ) +import Distribution.Types.GenericPackageDescription + ( emptyGenericPackageDescription ) +import Distribution.Types.PackageDescription + ( PackageDescription(..), emptyPackageDescription ) +import Distribution.Types.PackageName.Magic + ( fakePackageId ) +import Distribution.Types.Library + ( Library(..), emptyLibrary ) +import Distribution.Types.Version + ( mkVersion ) +import Distribution.Types.VersionRange + ( anyVersion ) +import Distribution.Utils.Generic + ( safeHead ) +import Distribution.Verbosity + ( normal, lessVerbose ) +import Distribution.Simple.Utils + ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist ) +import Language.Haskell.Extension + ( Language(..) ) +import Distribution.CabalSpecVersion + ( CabalSpecVersion (..) ) + +import Data.List + ( (\\) ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.Directory + ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive ) +import System.FilePath + ( () ) + +type ReplFlags = [String] + +data EnvFlags = EnvFlags + { envPackages :: [Dependency] + , envIncludeTransitive :: Flag Bool + } + +defaultEnvFlags :: EnvFlags +defaultEnvFlags = EnvFlags + { envPackages = [] + , envIncludeTransitive = toFlag True + } + +envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] +envOptions _ = + [ option ['b'] ["build-depends"] + "Include additional packages in the environment presented to GHCi." + envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) + (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) + , option [] ["no-transitive-deps"] + "Don't automatically include transitive dependencies of requested packages." + envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) + falseArg + ] + where + dependenciesReadE :: ReadE [Dependency] + dependenciesReadE = + parsecToReadE + ("couldn't parse dependencies: " ++) + (parsecCommaList parsec) + +replCommand :: CommandUI (NixStyleFlags (ReplFlags, EnvFlags)) +replCommand = Client.installCommand { + commandName = "v2-repl", + commandSynopsis = "Open an interactive session for the given component.", + commandUsage = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Open an interactive session for a component within the project. The " + ++ "available targets are the same as for the 'v2-build' command: " + ++ "individual components within packages in the project, including " + ++ "libraries, executables, test-suites or benchmarks. Packages can " + ++ "also be specified in which case the library component in the " + ++ "package will be used, or the (first listed) executable in the " + ++ "package if there is no library.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples, open an interactive session:\n" + ++ " " ++ pname ++ " v2-repl\n" + ++ " for the default component in the package in the current directory\n" + ++ " " ++ pname ++ " v2-repl pkgname\n" + ++ " for the default component in the package named 'pkgname'\n" + ++ " " ++ pname ++ " v2-repl ./pkgfoo\n" + ++ " for the default component in the package in the ./pkgfoo directory\n" + ++ " " ++ pname ++ " v2-repl cname\n" + ++ " for the component named 'cname'\n" + ++ " " ++ pname ++ " v2-repl pkgname:cname\n" + ++ " for the component 'cname' in the package 'pkgname'\n\n" + ++ " " ++ pname ++ " v2-repl --build-depends lens\n" + ++ " add the latest version of the library 'lens' to the default component " + ++ "(or no componentif there is no project present)\n" + ++ " " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" + ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " + ++ "to the default component (or no component if there is no project present)\n", + + commandDefaultFlags = defaultNixStyleFlags ([], defaultEnvFlags), + commandOptions = nixStyleOptions $ \showOrParseArgs -> + map (liftOptionL _1) (replOptions showOrParseArgs) ++ + map (liftOptionL _2) (envOptions showOrParseArgs) + } + +-- | The @repl@ command is very much like @build@. It brings the install plan +-- up to date, selects that part of the plan needed by the given or implicit +-- repl target and then executes the plan. +-- +-- Compared to @build@ the difference is that only one target is allowed +-- (given or implicit) and the target type is repl rather than build. The +-- general plan execution infrastructure handles both build and repl targets. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO () +replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do + let + with = withProject cliConfig verbosity targetStrings + without config = withoutProject (config <> cliConfig) verbosity targetStrings + + (baseCtx, targetSelectors, finalizer, replType) <- + withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ "The repl command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'repl'." + + (originalComponent, baseCtx') <- if null (envPackages envFlags) + then return (Nothing, baseCtx) + else + -- Unfortunately, the best way to do this is to let the normal solver + -- help us resolve the targets, but that isn't ideal for performance, + -- especially in the no-project case. + withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do + -- targets should be non-empty map, but there's no NonEmptyMap yet. + targets <- validatedTargets elaboratedPlan targetSelectors + + let + (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets + originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId + oci = OriginalComponentInfo unitId originalDeps + pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId + baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx + + return (Just oci, baseCtx') + + -- Now, we run the solver again with the added packages. While the graph + -- won't actually reflect the addition of transitive dependencies, + -- they're going to be available already and will be offered to the REPL + -- and that's good enough. + -- + -- In addition, to avoid a *third* trip through the solver, we are + -- replicating the second half of 'runProjectPreBuildPhase' by hand + -- here. + (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $ + \elaboratedPlan elaboratedShared' -> do + let ProjectBaseContext{..} = baseCtx' + + -- Recalculate with updated project. + targets <- validatedTargets elaboratedPlan targetSelectors + + let + elaboratedPlan' = pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags) + + pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared' + elaboratedPlan' + + let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages + pkgsBuildStatus elaboratedPlan' + debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') + + let + buildCtx = ProjectBuildContext + { elaboratedPlanOriginal = elaboratedPlan + , elaboratedPlanToExecute = elaboratedPlan'' + , elaboratedShared = elaboratedShared' + , pkgsBuildStatus + , targetsMap = targets + } + + ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared' + + -- First version of GHC where GHCi supported the flag we need. + -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html + minGhciScriptVersion = mkVersion [7, 6] + + replFlags' = case originalComponent of + Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci + Nothing -> [] + replFlags'' = case replType of + GlobalRepl scriptPath + | Just version <- compilerCompatVersion GHC compiler + , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags' + _ -> replFlags' + + return (buildCtx, replFlags'') + + let buildCtx' = buildCtx + { elaboratedShared = (elaboratedShared buildCtx) + { pkgConfigReplOptions = replFlags ++ replFlags'' } + } + printPlan verbosity baseCtx' buildCtx' + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx' + runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes + finalizer + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + ignoreProject = flagIgnoreProject projectFlags + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + + validatedTargets elaboratedPlan targetSelectors = do + -- Interpret the targets on the command line as repl targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + when (Set.size (distinctTargetComponents targets) > 1) $ + reportTargetProblems verbosity + [multipleTargetsProblem targets] + + return targets + +data OriginalComponentInfo = OriginalComponentInfo + { ociUnitId :: UnitId + , ociOriginalDeps :: [UnitId] + } + deriving (Show) + +-- | Tracks what type of GHCi instance we're creating. +data ReplType = ProjectRepl + | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi + -- script responsible for changing to the + -- correct directory. Only works on GHC geq + -- 7.6, though. 🙁 + deriving (Show, Eq) + +withProject :: ProjectConfig -> Verbosity -> [String] + -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) +withProject cliConfig verbosity targetStrings = do + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings + + return (baseCtx, targetSelectors, return (), ProjectRepl) + +withoutProject :: ProjectConfig -> Verbosity -> [String] + -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) +withoutProject config verbosity extraArgs = do + unless (null extraArgs) $ + die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs + + globalTmp <- getTemporaryDirectory + tempDir <- createTempDirectory globalTmp "cabal-repl." + + -- We need to create a dummy package that lives in our dummy project. + let + sourcePackage = SourcePackage + { srcpkgPackageId = pkgId + , srcpkgDescription = genericPackageDescription + , srcpkgSource = LocalUnpackedPackage tempDir + , srcpkgDescrOverride = Nothing + } + genericPackageDescription = emptyGenericPackageDescription + & L.packageDescription .~ packageDescription + & L.condLibrary .~ Just (CondNode library [baseDep] []) + packageDescription = emptyPackageDescription + { package = pkgId + , specVersion = CabalSpecV2_2 + , licenseRaw = Left SPDX.NONE + } + library = emptyLibrary { libBuildInfo = buildInfo } + buildInfo = emptyBuildInfo + { targetBuildDepends = [baseDep] + , defaultLanguage = Just Haskell2010 + } + baseDep = Dependency "base" anyVersion mainLibSet + pkgId = fakePackageId + + writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription + + let ghciScriptPath = tempDir "setcwd.ghci" + cwd <- getCurrentDirectory + writeFile ghciScriptPath (":cd " ++ cwd) + + distDirLayout <- establishDummyDistDirLayout verbosity config tempDir + baseCtx <- + establishDummyProjectBaseContext + verbosity + config + distDirLayout + [SpecificSourcePackage sourcePackage] + OtherCommand + + let + targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] + finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir) + + return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath) + +addDepsToProjectTarget :: [Dependency] + -> PackageId + -> ProjectBaseContext + -> ProjectBaseContext +addDepsToProjectTarget deps pkgId ctx = + (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx + where + addDeps :: PackageSpecifier UnresolvedSourcePackage + -> PackageSpecifier UnresolvedSourcePackage + addDeps (SpecificSourcePackage pkg) + | packageId pkg /= pkgId = SpecificSourcePackage pkg + | SourcePackage{..} <- pkg = + SpecificSourcePackage $ pkg { srcpkgDescription = + srcpkgDescription & (\f -> L.allCondTrees $ traverseCondTreeC f) + %~ (deps ++) + } + addDeps spec = spec + +generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags +generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags + where + exeDeps :: [UnitId] + exeDeps = + foldMap + (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies) + (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId]) + + deps, deps', trans, trans' :: [UnitId] + flags :: ReplFlags + deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId + deps' = deps \\ ociOriginalDeps + trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' + trans' = trans \\ ociOriginalDeps + flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) + $ if includeTransitive then trans' else deps' + +-- | This defines what a 'TargetSelector' means for the @repl@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For repl we select: +-- +-- * the library if there is only one and it's buildable; or +-- +-- * the exe if there is only one and it's buildable; or +-- +-- * any other buildable component. +-- +-- Fail if there are no buildable lib\/exe components, or if there are +-- multiple libs or exes. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either ReplTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is exactly one buildable library then we select that + | [target] <- targetsLibsBuildable + = Right [target] + + -- but fail if there are multiple buildable libraries. + | not (null targetsLibsBuildable) + = Left (matchesMultipleProblem targetSelector targetsLibsBuildable') + + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) + = Left (matchesMultipleProblem targetSelector targetsExesBuildable') + + -- If there is exactly one other target then we select that + | [target] <- targetsBuildable + = Right [target] + + -- but fail if there are multiple such targets + | not (null targetsBuildable) + = Left (matchesMultipleProblem targetSelector targetsBuildable') + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + (targetsLibsBuildable, + targetsLibsBuildable') = selectBuildableTargets' + . filterTargetsKind LibKind + $ targets + (targetsExesBuildable, + targetsExesBuildable') = selectBuildableTargets' + . filterTargetsKind ExeKind + $ targets + (targetsBuildable, + targetsBuildable') = selectBuildableTargetsWith' + (isRequested targetSelector) targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + isRequested _ _ = True + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @repl@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either ReplTargetProblem k +selectComponentTarget = selectComponentTargetBasic + + +data ReplProblem + = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + deriving (Eq, Show) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. +-- +type ReplTargetProblem = TargetProblem ReplProblem + +matchesMultipleProblem + :: TargetSelector + -> [AvailableTarget ()] + -> ReplTargetProblem +matchesMultipleProblem targetSelector targetsExesBuildable = + CustomTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable + +multipleTargetsProblem + :: TargetsMap + -> ReplTargetProblem +multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets + +reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderReplTargetProblem + +renderReplTargetProblem :: TargetProblem ReplProblem -> String +renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem + +renderReplProblem :: ReplProblem -> String +renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) = + "Cannot open a repl for multiple components at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which " + ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") + ++ renderListSemiAnd + [ "the " ++ renderComponentKind Plural ckind ++ " " ++ + renderListCommaAnd + [ maybe (prettyShow pkgname) prettyShow (componentNameString cname) + | t <- ts + , let cname = availableTargetComponentName t + pkgname = packageName (availableTargetPackageId t) + ] + | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets + ] + ++ ".\n\n" ++ explanationSingleComponentLimitation + where + availableTargetComponentKind = componentKind + . availableTargetComponentName + +renderReplProblem (TargetProblemMultipleTargets selectorMap) = + "Cannot open a repl for multiple components at once. The targets " + ++ renderListCommaAnd + [ "'" ++ showTargetSelector ts ++ "'" + | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] + ++ " refer to different components." + ++ ".\n\n" ++ explanationSingleComponentLimitation + +explanationSingleComponentLimitation :: String +explanationSingleComponentLimitation = + "The reason for this limitation is that current versions of ghci do not " + ++ "support loading multiple components as source. Load just one component " + ++ "and when you make changes to a dependent component then quit and reload." diff --git a/src/Distribution/Client/CmdRun.hs b/src/Distribution/Client/CmdRun.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdRun.hs @@ -0,0 +1,638 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | cabal-install CLI command: run +-- +module Distribution.Client.CmdRun ( + -- * The @run@ CLI and action + runCommand, + runAction, + handleShebang, validScript, + + -- * Internals exposed for testing + matchesMultipleProblem, + noExesProblem, + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (toList) + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + ( renderTargetSelector, showTargetSelector, + renderTargetProblem, + renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, + targetSelectorFilter, renderListCommaAnd ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags(..), ConfigFlags(..) ) +import Distribution.Client.GlobalFlags + ( defaultGlobalFlags ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Types.ComponentName + ( showComponentName ) +import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( wrapText, warn, die', ordNub, info, notice + , createTempDirectory, handleDoesNotExist ) +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), ProjectConfigShared(..) + , withProjectOrGlobalConfig ) +import Distribution.Client.ProjectFlags + ( flagIgnoreProject ) +import Distribution.Client.ProjectPlanning + ( ElaboratedConfiguredPackage(..) + , ElaboratedInstallPlan, binDirectoryFor ) +import Distribution.Client.ProjectPlanning.Types + ( dataDirsEnvironmentForPlan ) +import Distribution.Client.TargetSelector + ( TargetSelectorProblem(..), TargetString(..) ) +import Distribution.Client.InstallPlan + ( toList, foldPlanPackage ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Simple.Program.Run + ( runProgramInvocation, ProgramInvocation(..), + emptyProgramInvocation ) +import Distribution.Types.UnitId + ( UnitId ) + +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..) ) +import Distribution.FieldGrammar + ( takeFields, parseFieldGrammar ) +import Distribution.PackageDescription.FieldGrammar + ( executableFieldGrammar ) +import Distribution.PackageDescription.PrettyPrint + ( writeGenericPackageDescription ) +import Distribution.Parsec + ( Position(..) ) +import Distribution.Fields + ( ParseResult, parseString, parseFatalFailure, readFields ) +import qualified Distribution.SPDX.License as SPDX +import Distribution.Solver.Types.SourcePackage as SP + ( SourcePackage(..) ) +import Distribution.Types.BuildInfo + ( BuildInfo(..) ) +import Distribution.Types.CondTree + ( CondTree(..) ) +import Distribution.Types.Executable + ( Executable(..) ) +import Distribution.Types.GenericPackageDescription as GPD + ( GenericPackageDescription(..), emptyGenericPackageDescription ) +import Distribution.Types.PackageDescription + ( PackageDescription(..), emptyPackageDescription ) +import Distribution.Types.PackageName.Magic + ( fakePackageId ) +import Language.Haskell.Extension + ( Language(..) ) + +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Text.Parsec as P +import System.Directory + ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist ) +import System.FilePath + ( (), isValid, isPathSeparator, takeExtension ) + + +runCommand :: CommandUI (NixStyleFlags ()) +runCommand = CommandUI + { commandName = "v2-run" + , commandSynopsis = "Run an executable." + , commandUsage = usageAlternatives "v2-run" + [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ] + , commandDescription = Just $ \pname -> wrapText $ + "Runs the specified executable-like component (an executable, a test, " + ++ "or a benchmark), first ensuring it is up to date.\n\n" + + ++ "Any executable-like component in any package in the project can be " + ++ "specified. A package can be specified if contains just one " + ++ "executable-like. The default is to use the package in the current " + ++ "directory if it contains just one executable-like.\n\n" + + ++ "Extra arguments can be passed to the program, but use '--' to " + ++ "separate arguments for the program from arguments for " ++ pname + ++ ". The executable is run in an environment where it can find its " + ++ "data files inplace in the build tree.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-run\n" + ++ " Run the executable-like in the package in the current directory\n" + ++ " " ++ pname ++ " v2-run foo-tool\n" + ++ " Run the named executable-like (in any package in the project)\n" + ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" + ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" + ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" + ++ " Build with '-O2' and run the program, passing it extra arguments.\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + +-- | The @run@ command runs a specified executable-like component, building it +-- first if necessary. The component can be either an executable, a test, +-- or a benchmark. This is particularly useful for passing arguments to +-- exes/tests/benchs by simply appending them after a @--@. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +runAction flags@NixStyleFlags {..} targetStrings globalFlags = do + globalTmp <- getTemporaryDirectory + tmpDir <- createTempDirectory globalTmp "cabal-repl." + + let + with = + establishProjectBaseContext verbosity cliConfig OtherCommand + without config = do + distDirLayout <- establishDummyDistDirLayout verbosity (config <> cliConfig) tmpDir + establishDummyProjectBaseContext verbosity (config <> cliConfig) distDirLayout [] OtherCommand + + baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without + + let + scriptOrError script err = do + exists <- doesFileExist script + let pol | takeExtension script == ".lhs" = LiterateHaskell + | otherwise = PlainHaskell + if exists + then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tmpDir + else reportTargetSelectorProblems verbosity err + + (baseCtx', targetSelectors) <- + readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) + >>= \case + Left err@(TargetSelectorNoTargetsInProject:_) + | (script:_) <- targetStrings -> scriptOrError script err + Left err@(TargetSelectorNoSuch t _:_) + | TargetString1 script <- t -> scriptOrError script err + Left err@(TargetSelectorExpected t _ _:_) + | TargetString1 script <- t -> scriptOrError script err + Left err -> reportTargetSelectorProblems verbosity err + Right sels -> return (baseCtx, sels) + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx')) $ + die' verbosity $ + "The run command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'run'." + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- singleExeOrElse + (reportTargetProblems + verbosity + [multipleTargetsProblem targets]) + targets + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) + + (selectedUnitId, selectedComponent) <- + -- Slight duplication with 'runProjectPreBuildPhase'. + singleExeOrElse + (die' verbosity $ "No or multiple targets given, but the run " + ++ "phase has been reached. This is a bug.") + $ targetsMap buildCtx + + printPlan verbosity baseCtx' buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx + runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes + + + let elaboratedPlan = elaboratedPlanToExecute buildCtx + matchingElaboratedConfiguredPackages = + matchingPackagesByUnitId + selectedUnitId + elaboratedPlan + + let exeName = unUnqualComponentName selectedComponent + + -- In the common case, we expect @matchingElaboratedConfiguredPackages@ + -- to consist of a single element that provides a single way of building + -- an appropriately-named executable. In that case we take that + -- package and continue. + -- + -- However, multiple packages/components could provide that + -- executable, or it's possible we don't find the executable anywhere + -- in the build plan. I suppose in principle it's also possible that + -- a single package provides an executable in two different ways, + -- though that's probably a bug if. Anyway it's a good lint to report + -- an error in all of these cases, even if some seem like they + -- shouldn't happen. + pkg <- case matchingElaboratedConfiguredPackages of + [] -> die' verbosity $ "Unknown executable " + ++ exeName + ++ " in package " + ++ prettyShow selectedUnitId + [elabPkg] -> do + info verbosity $ "Selecting " + ++ prettyShow selectedUnitId + ++ " to supply " ++ exeName + return elabPkg + elabPkgs -> die' verbosity + $ "Multiple matching executables found matching " + ++ exeName + ++ ":\n" + ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) + let exePath = binDirectoryFor (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName + let args = drop 1 targetStrings + dryRun = buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + if dryRun + then notice verbosity "Running of executable suppressed by flag(s)" + else + runProgramInvocation + verbosity + emptyProgramInvocation { + progInvokePath = exePath, + progInvokeArgs = args, + progInvokeEnv = dataDirsEnvironmentForPlan + (distDirLayout baseCtx) + elaboratedPlan + } + + handleDoesNotExist () (removeDirectoryRecursive tmpDir) + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + ignoreProject = flagIgnoreProject projectFlags + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + +-- | Used by the main CLI parser as heuristic to decide whether @cabal@ was +-- invoked as a script interpreter, i.e. via +-- +-- > #! /usr/bin/env cabal +-- +-- or +-- +-- > #! /usr/bin/cabal +-- +-- As the first argument passed to `cabal` will be a filepath to the +-- script to be interpreted. +-- +-- See also 'handleShebang' +validScript :: String -> IO Bool +validScript script + | isValid script && any isPathSeparator script = doesFileExist script + | otherwise = return False + +-- | Handle @cabal@ invoked as script interpreter, see also 'validScript' +-- +-- First argument is the 'FilePath' to the script to be executed; second +-- argument is a list of arguments to be passed to the script. +handleShebang :: FilePath -> [String] -> IO () +handleShebang script args = + runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags + +parseScriptBlock :: BS.ByteString -> ParseResult Executable +parseScriptBlock str = + case readFields str of + Right fs -> do + let (fields, _) = takeFields fs + parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") + Left perr -> parseFatalFailure pos (show perr) where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + +readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable +readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" + +readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString) +readScriptBlockFromScript verbosity pol str = do + str' <- case extractScriptBlock pol str of + Left e -> die' verbosity $ "Failed extracting script block: " ++ e + Right x -> return x + when (BS.all isSpace str') $ warn verbosity "Empty script block" + (\x -> (x, noShebang)) <$> readScriptBlock verbosity str' + where + noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str + +-- | Extract the first encountered script metadata block started end +-- terminated by the tokens +-- +-- * @{- cabal:@ +-- +-- * @-}@ +-- +-- appearing alone on lines (while tolerating trailing whitespace). +-- These tokens are not part of the 'Right' result. +-- +-- In case of missing or unterminated blocks a 'Left'-error is +-- returned. +extractScriptBlock :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString +extractScriptBlock _pol str = goPre (BS.lines str) + where + isStartMarker = (== startMarker) . stripTrailSpace + isEndMarker = (== endMarker) . stripTrailSpace + + stripTrailSpace = fst . BS.spanEnd isSpace + + -- before start marker + goPre ls = case dropWhile (not . isStartMarker) ls of + [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" + (_:ls') -> goBody [] ls' + + goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" + goBody acc (l:ls) + | isEndMarker l = Right $! BS.unlines $ reverse acc + | otherwise = goBody (l:acc) ls + + startMarker, endMarker :: BS.ByteString + startMarker = fromString "{- cabal:" + endMarker = fromString "-}" + +data PlainOrLiterate + = PlainHaskell + | LiterateHaskell + +handleScriptCase + :: Verbosity + -> PlainOrLiterate + -> ProjectBaseContext + -> FilePath + -> BS.ByteString + -> IO (ProjectBaseContext, [TargetSelector]) +handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do + (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents + + -- We need to create a dummy package that lives in our dummy project. + let + mainName = case pol of + PlainHaskell -> "Main.hs" + LiterateHaskell -> "Main.lhs" + + sourcePackage = SourcePackage + { srcpkgPackageId = pkgId + , srcpkgDescription = genericPackageDescription + , srcpkgSource = LocalUnpackedPackage tmpDir + , srcpkgDescrOverride = Nothing + } + genericPackageDescription = emptyGenericPackageDescription + { GPD.packageDescription = packageDescription + , condExecutables = [("script", CondNode executable' targetBuildDepends [])] + } + executable' = executable + { modulePath = mainName + , buildInfo = binfo + { defaultLanguage = + case defaultLanguage of + just@(Just _) -> just + Nothing -> Just Haskell2010 + } + } + binfo@BuildInfo{..} = buildInfo executable + packageDescription = emptyPackageDescription + { package = pkgId + , specVersion = CabalSpecV2_2 + , licenseRaw = Left SPDX.NONE + } + pkgId = fakePackageId + + writeGenericPackageDescription (tmpDir "fake-package.cabal") genericPackageDescription + BS.writeFile (tmpDir mainName) contents' + + let + baseCtx' = baseCtx + { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] } + targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] + + return (baseCtx', targetSelectors) + +singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleExeOrElse action targetsMap = + case Set.toList . distinctTargetComponents $ targetsMap + of [(unitId, CExeName component)] -> return (unitId, component) + [(unitId, CTestName component)] -> return (unitId, component) + [(unitId, CBenchName component)] -> return (unitId, component) + _ -> action + +-- | Filter the 'ElaboratedInstallPlan' keeping only the +-- 'ElaboratedConfiguredPackage's that match the specified +-- 'UnitId'. +matchingPackagesByUnitId :: UnitId + -> ElaboratedInstallPlan + -> [ElaboratedConfiguredPackage] +matchingPackagesByUnitId uid = + catMaybes + . fmap (foldPlanPackage + (const Nothing) + (\x -> if elabUnitId x == uid + then Just x + else Nothing)) + . toList + +-- | This defines what a 'TargetSelector' means for the @run@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @run@ command we select the exe if there is only one and it's +-- buildable. Fail if there are no or multiple buildable exe components. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either RunTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) + = Left (matchesMultipleProblem targetSelector targetsExesBuildable') + + -- If there are executables but none are buildable then we report those + | not (null targetsExes) + = Left (TargetProblemNoneEnabled targetSelector targetsExes) + + -- If there are no executables but some other targets then we report that + | not (null targets) + = Left (noExesProblem targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + -- Targets that can be executed + targetsExecutableLike = + concatMap (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] + (targetsExesBuildable, + targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike + + targetsExes = forgetTargetsDetail targetsExecutableLike + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @run@ command we just need to check it is a executable-like +-- (an executable, a test, or a benchmark), in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either RunTargetProblem k +selectComponentTarget subtarget@WholeComponent t + = case availableTargetComponentName t + of CExeName _ -> component + CTestName _ -> component + CBenchName _ -> component + _ -> Left (componentNotExeProblem pkgid cname) + where pkgid = availableTargetPackageId t + cname = availableTargetComponentName t + component = selectComponentTargetBasic subtarget t + +selectComponentTarget subtarget t + = Left (isSubComponentProblem (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @run@ command. +-- +data RunProblem = + -- | The 'TargetSelector' matches targets but no executables + TargetProblemNoExes TargetSelector + + -- | A single 'TargetSelector' matches multiple targets + | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + + -- | The 'TargetSelector' refers to a component that is not an executable + | TargetProblemComponentNotExe PackageId ComponentName + + -- | Asking to run an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +type RunTargetProblem = TargetProblem RunProblem + +noExesProblem :: TargetSelector -> RunTargetProblem +noExesProblem = CustomTargetProblem . TargetProblemNoExes + +matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem +matchesMultipleProblem selector targets = CustomTargetProblem $ + TargetProblemMatchesMultiple selector targets + +multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem +multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets + +componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem +componentNotExeProblem pkgid name = CustomTargetProblem $ + TargetProblemComponentNotExe pkgid name + +isSubComponentProblem + :: PackageId + -> ComponentName + -> SubComponentTarget + -> TargetProblem RunProblem +isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent + +reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderRunTargetProblem + +renderRunTargetProblem :: RunTargetProblem -> String +renderRunTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= ExeKind + -> "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "run" targetSelector +renderRunTargetProblem problem = + renderTargetProblem "run" renderRunProblem problem + +renderRunProblem :: RunProblem -> String +renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) = + "The run command is for running a single executable at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which includes " + ++ renderListCommaAnd ( ("the "++) <$> + showComponentName <$> + availableTargetComponentName <$> + foldMap + (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] ) + ++ "." + +renderRunProblem (TargetProblemMultipleTargets selectorMap) = + "The run command is for running a single executable at once. The targets " + ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" + | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] + ++ " refer to different executables." + +renderRunProblem (TargetProblemComponentNotExe pkgid cname) = + "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ prettyShow pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The run command can only run an executable as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget + +renderRunProblem (TargetProblemNoExes targetSelector) = + "Cannot run the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any executables." diff --git a/src/Distribution/Client/CmdSdist.hs b/src/Distribution/Client/CmdSdist.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdSdist.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +module Distribution.Client.CmdSdist + ( sdistCommand, sdistAction, packageToSdist + , OutputFormat(..)) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.CmdErrorMessages + ( Plural(..), renderComponentKind ) +import Distribution.Client.ProjectOrchestration + ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), defaultNixStyleFlags ) +import Distribution.Client.TargetSelector + ( TargetSelector(..), ComponentKind + , readTargetSelectors, reportTargetSelectorProblems ) +import Distribution.Client.Setup + ( GlobalFlags(..) ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.Client.Types + ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), ProjectRoot (..) ) +import Distribution.Client.ProjectConfig + ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared ) +import Distribution.Client.ProjectFlags + ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions ) + +import Distribution.Compat.Lens + ( _1, _2 ) +import Distribution.Package + ( Package(packageId) ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.ReadE + ( succeedReadE ) +import Distribution.Simple.Command + ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs ) +import Distribution.Simple.PreProcess + ( knownSuffixHandlers ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe + , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref + ) +import Distribution.Simple.SrcDist + ( listPackageSourcesWithDie ) +import Distribution.Client.SrcDist + ( packageDirToSdist ) +import Distribution.Simple.Utils + ( die', notice, withOutputMarker, wrapText ) +import Distribution.Types.ComponentName + ( ComponentName, showComponentName ) +import Distribution.Types.PackageName + ( PackageName, unPackageName ) +import Distribution.Verbosity + ( normal ) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) + +import qualified Data.ByteString.Lazy.Char8 as BSL +import System.Directory + ( getCurrentDirectory + , createDirectoryIfMissing, makeAbsolute + ) +import System.FilePath + ( (), (<.>), makeRelative, normalise ) + +------------------------------------------------------------------------------- +-- Command +------------------------------------------------------------------------------- + +sdistCommand :: CommandUI (ProjectFlags, SdistFlags) +sdistCommand = CommandUI + { commandName = "v2-sdist" + , commandSynopsis = "Generate a source distribution file (.tar.gz)." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n" + , commandDescription = Just $ \_ -> wrapText + "Generates tarballs of project packages suitable for upload to Hackage." + , commandNotes = Nothing + , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags) + , commandOptions = \showOrParseArgs -> + map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) ++ + map (liftOptionL _2) (sdistOptions showOrParseArgs) + } + +------------------------------------------------------------------------------- +-- Flags +------------------------------------------------------------------------------- + +data SdistFlags = SdistFlags + { sdistVerbosity :: Flag Verbosity + , sdistDistDir :: Flag FilePath + , sdistListSources :: Flag Bool + , sdistNulSeparated :: Flag Bool + , sdistOutputPath :: Flag FilePath + } + +defaultSdistFlags :: SdistFlags +defaultSdistFlags = SdistFlags + { sdistVerbosity = toFlag normal + , sdistDistDir = mempty + , sdistListSources = toFlag False + , sdistNulSeparated = toFlag False + , sdistOutputPath = mempty + } + +sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags] +sdistOptions showOrParseArgs = + [ optionVerbosity + sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) + , optionDistPref + sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) + showOrParseArgs + , option ['l'] ["list-only"] + "Just list the sources, do not make a tarball" + sdistListSources (\v flags -> flags { sdistListSources = v }) + trueArg + , option [] ["null-sep"] + "Separate the source files with NUL bytes rather than newlines." + sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) + trueArg + , option ['o'] ["output-directory", "outputdir"] + "Choose the output directory of this command. '-' sends all output to stdout" + sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) + (reqArg "PATH" (succeedReadE Flag) flagToList) + ] + +------------------------------------------------------------------------------- +-- Action +------------------------------------------------------------------------------- + +sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO () +sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do + (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject + + let localPkgs = localPackages baseCtx + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors localPkgs Nothing targetStrings + + -- elaborate path, create target directory + mOutputPath' <- case mOutputPath of + Just "-" -> return (Just "-") + Just path -> do + abspath <- makeAbsolute path + createDirectoryIfMissing True abspath + return (Just abspath) + Nothing -> do + createDirectoryIfMissing True (distSdistDirectory distDirLayout) + return Nothing + + let format :: OutputFormat + format = + if | listSources, nulSeparated -> SourceList '\0' + | listSources -> SourceList '\n' + | otherwise -> TarGzArchive + + ext = case format of + SourceList _ -> "list" + TarGzArchive -> "tar.gz" + + outputPath pkg = case mOutputPath' of + Just path + | path == "-" -> "-" + | otherwise -> path prettyShow (packageId pkg) <.> ext + Nothing + | listSources -> "-" + | otherwise -> distSdistFile distDirLayout (packageId pkg) + + + case reifyTargetSelectors localPkgs targetSelectors of + Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs + Right pkgs + | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> + die' verbosity "Can't write multiple tarballs to standard output!" + | otherwise -> + traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs + where + verbosity = fromFlagOrDefault normal sdistVerbosity + listSources = fromFlagOrDefault False sdistListSources + nulSeparated = fromFlagOrDefault False sdistNulSeparated + mOutputPath = flagToMaybe sdistOutputPath + ignoreProject = flagIgnoreProject + + prjConfig :: ProjectConfig + prjConfig = commandLineFlagsToProjectConfig + globalFlags + (defaultNixStyleFlags ()) + { configFlags = (configFlags $ defaultNixStyleFlags ()) + { configVerbosity = sdistVerbosity + , configDistPref = sdistDistDir + } + } + mempty + + globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) + + withProject :: IO (ProjectBaseContext, DistDirLayout) + withProject = do + baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand + return (baseCtx, distDirLayout baseCtx) + + withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) + withoutProject config = do + cwd <- getCurrentDirectory + baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand + return (baseCtx, distDirLayout baseCtx) + +data OutputFormat = SourceList Char + | TarGzArchive + deriving (Show, Eq) + +packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () +packageToSdist verbosity projectRootDir format outputFile pkg = do + let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg)) + dir0 <- case srcpkgSource pkg of + LocalUnpackedPackage path -> pure (Right path) + RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz) + RemoteSourceRepoPackage {} -> death + LocalTarballPackage tgz -> pure (Left tgz) + RemoteTarballPackage _ (Just tgz) -> pure (Left tgz) + RemoteTarballPackage {} -> death + RepoTarballPackage {} -> death + + let -- Write String to stdout or file, using the default TextEncoding. + write str + | outputFile == "-" = putStr (withOutputMarker verbosity str) + | otherwise = do + writeFile outputFile str + notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" + -- Write raw ByteString to stdout or file as it is, without encoding. + writeLBS lbs + | outputFile == "-" = BSL.putStr lbs + | otherwise = do + BSL.writeFile outputFile lbs + notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" + + case dir0 of + Left tgz -> do + case format of + TarGzArchive -> do + writeLBS =<< BSL.readFile tgz + _ -> die' verbosity ("cannot convert tarball package to " ++ show format) + + Right dir -> case format of + SourceList nulSep -> do + let gpd :: GenericPackageDescription + gpd = srcpkgDescription pkg + + let thisDie :: Verbosity -> String -> IO a + thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s + + files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers + let files = nub $ sort $ map normalise files' + let prefix = makeRelative projectRootDir dir + write $ concat [prefix i ++ [nulSep] | i <- files] + + TarGzArchive -> do + packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS + +-- + +reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] +reifyTargetSelectors pkgs sels = + case partitionEithers (foldMap go sels) of + ([], sels') -> Right sels' + (errs, _) -> Left errs + where + flatten (SpecificSourcePackage pkg@SourcePackage{}) = pkg + flatten _ = error "The impossible happened: how do we not know about a local package?" + pkgs' = fmap flatten pkgs + + getPkg pid = case find ((== pid) . packageId) pkgs' of + Just pkg -> Right pkg + Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." + + go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] + go (TargetPackage _ pids Nothing) = fmap getPkg pids + go (TargetAllPackages Nothing) = Right <$> pkgs' + + go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] + go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] + + go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] + go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] + + go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] + +data TargetProblem = AllComponentsOnly ComponentKind + | NonlocalPackageNotAllowed PackageName + | ComponentsNotAllowed ComponentName + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (AllComponentsOnly kind) = + "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package " + ++ "for distribution. Only entire packages may be packaged for distribution." +renderTargetProblem (ComponentsNotAllowed cname) = + "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. " + ++ "Only entire packages may be packaged for distribution." +renderTargetProblem (NonlocalPackageNotAllowed pname) = + "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not " + ++ "local to this project." diff --git a/src/Distribution/Client/CmdTest.hs b/src/Distribution/Client/CmdTest.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdTest.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | cabal-install CLI command: test +-- +module Distribution.Client.CmdTest ( + -- * The @test@ CLI and action + testCommand, + testAction, + + -- * Internals exposed for testing + isSubComponentProblem, + notTestProblem, + noTestsProblem, + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural, + renderTargetProblem, + renderTargetProblemNoTargets, targetSelectorPluralPkgs ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Setup + ( GlobalFlags(..), ConfigFlags(..) ) +import Distribution.Simple.Setup + ( TestFlags(..), fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Flag + ( Flag(..) ) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( notice, wrapText, die' ) + +import qualified System.Exit (exitSuccess) + + +testCommand :: CommandUI (NixStyleFlags ()) +testCommand = CommandUI + { commandName = "v2-test" + , commandSynopsis = "Run test-suites" + , commandUsage = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ] + , commandDescription = Just $ \_ -> wrapText $ + "Runs the specified test-suites, first ensuring they are up to " + ++ "date.\n\n" + + ++ "Any test-suite in any package in the project can be specified. " + ++ "A package can be specified in which case all the test-suites in the " + ++ "package are run. The default is to run all the test-suites in the " + ++ "package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.\n\n" + + ++ "To pass command-line arguments to a test suite, see the " + ++ "v2-run command." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-test\n" + ++ " Run all the test-suites in the package in the current directory\n" + ++ " " ++ pname ++ " v2-test pkgname\n" + ++ " Run all the test-suites in the package named pkgname\n" + ++ " " ++ pname ++ " v2-test cname\n" + ++ " Run the test-suite named cname\n" + ++ " " ++ pname ++ " v2-test cname --enable-coverage\n" + ++ " Run the test-suite built with code coverage (including local libs used)\n" + + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } + + + +-- | The @test@ command is very much like @build@. It brings the install plan +-- up to date, selects that part of the plan needed by the given or implicit +-- test target(s) and then executes the plan. +-- +-- Compared to @build@ the difference is that there's also test targets +-- which are ephemeral. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +testAction flags@NixStyleFlags {..} targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The test command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'test'." + + -- Interpret the targets on the command line as test targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionTest + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + failWhenNoTestSuites = testFailWhenNoTestSuites testFlags + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags + +-- | This defines what a 'TargetSelector' means for the @test@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @test@ command we select all buildable test-suites, +-- or fail if there are no test-suites or no buildable test-suites. +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either TestTargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable test-suite targets then we select those + | not (null targetsTestsBuildable) + = Right targetsTestsBuildable + + -- If there are test-suites but none are buildable then we report those + | not (null targetsTests) + = Left (TargetProblemNoneEnabled targetSelector targetsTests) + + -- If there are no test-suite but some other targets then we report that + | not (null targets) + = Left (noTestsProblem targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targetsTestsBuildable = selectBuildableTargets + . filterTargetsKind TestKind + $ targets + + targetsTests = forgetTargetsDetail + . filterTargetsKind TestKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @test@ command we just need to check it is a test-suite, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either TestTargetProblem k +selectComponentTarget subtarget@WholeComponent t + | CTestName _ <- availableTargetComponentName t + = either Left return $ + selectComponentTargetBasic subtarget t + | otherwise + = Left (notTestProblem + (availableTargetPackageId t) + (availableTargetComponentName t)) + +selectComponentTarget subtarget t + = Left (isSubComponentProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @test@ command. +-- +data TestProblem = + -- | The 'TargetSelector' matches targets but no test-suites + TargetProblemNoTests TargetSelector + + -- | The 'TargetSelector' refers to a component that is not a test-suite + | TargetProblemComponentNotTest PackageId ComponentName + + -- | Asking to test an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + + +type TestTargetProblem = TargetProblem TestProblem + + +noTestsProblem :: TargetSelector -> TargetProblem TestProblem +noTestsProblem = CustomTargetProblem . TargetProblemNoTests + +notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem +notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name + +isSubComponentProblem + :: PackageId + -> ComponentName + -> SubComponentTarget + -> TargetProblem TestProblem +isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent + +reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a +reportTargetProblems verbosity failWhenNoTestSuites problems = + case (failWhenNoTestSuites, problems) of + (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) -> + die' verbosity problemsMessage + (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do + notice verbosity (renderAllowedNoTestsProblem selector) + System.Exit.exitSuccess + (_, _) -> die' verbosity problemsMessage + where + problemsMessage = unlines . map renderTestTargetProblem $ problems + +-- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't +-- @die@ when the target problem is 'TargetProblemNoTests'. +-- Instead, we display a notice saying that no tests have run and +-- indicate how this behaviour was enabled. +renderAllowedNoTestsProblem :: TargetSelector -> String +renderAllowedNoTestsProblem selector = + "No tests to run for " ++ renderTargetSelector selector + +renderTestTargetProblem :: TestTargetProblem -> String +renderTestTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= TestKind + -> "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + ++ "\n" ++ show targetSelector + + _ -> renderTargetProblemNoTargets "test" targetSelector +renderTestTargetProblem problem = + renderTargetProblem "test" renderTestProblem problem + + +renderTestProblem :: TestProblem -> String +renderTestProblem (TargetProblemNoTests targetSelector) = + "Cannot run tests for the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any test suites." + +renderTestProblem (TargetProblemComponentNotTest pkgid cname) = + "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ prettyShow pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The test command can only run test suites as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget diff --git a/src/Distribution/Client/CmdUpdate.hs b/src/Distribution/Client/CmdUpdate.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdUpdate.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: update +-- +module Distribution.Client.CmdUpdate ( + updateCommand, + updateAction, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.Compat.Directory + ( setModificationTime ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectConfig + ( ProjectConfig(..) + , ProjectConfigShared(projectConfigConfigFile) + , projectConfigWithSolverRepoContext + , withProjectOrGlobalConfig ) +import Distribution.Client.ProjectFlags + ( ProjectFlags (..) ) +import Distribution.Client.Types + ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName ) +import Distribution.Client.HttpUtils + ( DownloadResult(..) ) +import Distribution.Client.FetchUtils + ( downloadIndex ) +import Distribution.Client.JobControl + ( newParallelJobControl, spawnJob, collectJob ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..) + , UpdateFlags, defaultUpdateFlags + , RepoContext(..) ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.Simple.Utils + ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) +import Distribution.Verbosity + ( normal, lessVerbose ) +import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.IndexUtils.IndexState +import Distribution.Client.IndexUtils + ( updateRepoIndexCache, Index(..), writeIndexTimestamp + , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile ) + +import qualified Data.Maybe as Unsafe (fromJust) +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +import qualified Data.ByteString.Lazy as BS +import Distribution.Client.GZipUtils (maybeDecompress) +import System.FilePath ((<.>), dropExtension) +import Data.Time (getCurrentTime) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) + +import qualified Hackage.Security.Client as Sec + +updateCommand :: CommandUI (NixStyleFlags ()) +updateCommand = CommandUI + { commandName = "v2-update" + , commandSynopsis = "Updates list of known packages." + , commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ] + , commandDescription = Just $ \_ -> wrapText $ + "For all known remote repositories, download the package list." + + , commandNotes = Just $ \pname -> + "REPO has the format [,] where index-state follows\n" + ++ "the same format and syntax that is supported by the --index-state flag.\n\n" + ++ "Examples:\n" + ++ " " ++ pname ++ " v2-update\n" + ++ " Download the package list for all known remote repositories.\n\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org\n" + ++ " Download hackage.haskell.org at a specific index state.\n\n" + ++ " " ++ pname ++ " new update hackage.haskell.org head.hackage\n" + ++ " Download hackage.haskell.org and head.hackage\n" + ++ " head.hackage must be a known repo-id. E.g. from\n" + ++ " your cabal.project(.local) file.\n" + + , commandOptions = nixStyleOptions $ const [] + , commandDefaultFlags = defaultNixStyleFlags () + } + +data UpdateRequest = UpdateRequest + { _updateRequestRepoName :: RepoName + , _updateRequestRepoState :: RepoIndexState + } deriving (Show) + +instance Pretty UpdateRequest where + pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s + +instance Parsec UpdateRequest where + parsec = do + name <- parsec + state <- P.char ',' *> parsec <|> pure IndexStateHead + return (UpdateRequest name state) + +updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do + let ignoreProject = flagIgnoreProject projectFlags + + projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag + (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) + (\globalConfig -> return $ globalConfig <> cliConfig) + + projectConfigWithSolverRepoContext verbosity + (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) + $ \repoCtxt -> do + + let repos :: [Repo] + repos = repoContextRepos repoCtxt + + parseArg :: String -> IO UpdateRequest + parseArg s = case simpleParsec s of + Just r -> return r + Nothing -> die' verbosity $ + "'v2-update' unable to parse repo: \"" ++ s ++ "\"" + + updateRepoRequests <- traverse parseArg extraArgs + + unless (null updateRepoRequests) $ do + let remoteRepoNames = map repoName repos + unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests + , not (r `elem` remoteRepoNames)] + unless (null unknownRepos) $ + die' verbosity $ "'v2-update' repo(s): \"" + ++ intercalate "\", \"" (map unRepoName unknownRepos) + ++ "\" can not be found in known remote repo(s): " + ++ intercalate ", " (map unRepoName remoteRepoNames) + + let reposToUpdate :: [(Repo, RepoIndexState)] + reposToUpdate = case updateRepoRequests of + -- If we are not given any specific repository, update all + -- repositories to HEAD. + [] -> map (,IndexStateHead) repos + updateRequests -> let repoMap = [(repoName r, r) | r <- repos] + lookup' k = Unsafe.fromJust (lookup k repoMap) + in [ (lookup' name, state) + | (UpdateRequest name state) <- updateRequests ] + + case reposToUpdate of + [] -> + notice verbosity "No remote repositories configured" + [(remoteRepo, _)] -> + notice verbosity $ "Downloading the latest package list from " + ++ unRepoName (repoName remoteRepo) + _ -> notice verbosity . unlines + $ "Downloading the latest package lists from: " + : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate + + unless (null reposToUpdate) $ do + jobCtrl <- newParallelJobControl (length reposToUpdate) + traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) + reposToUpdate + traverse_ (\_ -> collectJob jobCtrl) reposToUpdate + + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + +updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState) + -> IO () +updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do + transport <- repoContextGetTransport repoCtxt + case repo of + RepoLocalNoIndex{} -> do + let index = RepoIndex repoCtxt repo + updatePackageIndexCacheFile verbosity index + + RepoRemote{..} -> do + downloadResult <- downloadIndex transport verbosity + repoRemote repoLocalDir + case downloadResult of + FileAlreadyInCache -> + setModificationTime (indexBaseName repo <.> "tar") + =<< getCurrentTime + FileDownloaded indexPath -> do + writeFileAtomic (dropExtension indexPath) . maybeDecompress + =<< BS.readFile indexPath + updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) + RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do + let index = RepoIndex repoCtxt repo + -- NB: This may be a nullTimestamp if we've never updated before + current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + -- NB: always update the timestamp, even if we didn't actually + -- download anything + writeIndexTimestamp index indexState + ce <- if repoContextIgnoreExpiry repoCtxt + then Just `fmap` getCurrentTime + else return Nothing + updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce + + let rname = remoteRepoName (repoRemote repo) + + -- Update cabal's internal index as well so that it's not out of sync + -- (If all access to the cache goes through hackage-security this can go) + case updated of + Sec.NoUpdates -> do + now <- getCurrentTime + setModificationTime (indexBaseName repo <.> "tar") now + noticeNoWrap verbosity $ + "Package list of " ++ prettyShow rname ++ + " is up to date at index-state " ++ prettyShow (IndexStateTime current_ts) + + Sec.HasUpdates -> do + updateRepoIndexCache verbosity index + new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + noticeNoWrap verbosity $ + "Updated package list of " ++ prettyShow rname ++ + " to the index-state " ++ prettyShow (IndexStateTime new_ts) + + -- TODO: This will print multiple times if there are multiple + -- repositories: main problem is we don't have a way of updating + -- a specific repo. Once we implement that, update this. + when (current_ts /= nullTimestamp) $ + noticeNoWrap verbosity $ + "To revert to previous state run:\n" ++ + " cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n" diff --git a/src/Distribution/Client/Compat/Directory.hs b/src/Distribution/Client/Compat/Directory.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Compat/Directory.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +module Distribution.Client.Compat.Directory ( + setModificationTime, + createFileLink, + pathIsSymbolicLink, + getSymbolicLinkTarget, + ) where + +#if MIN_VERSION_directory(1,2,3) +import System.Directory (setModificationTime) +#else +import Data.Time.Clock (UTCTime) +#endif + +#if MIN_VERSION_directory(1,3,1) +import System.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink) +#elif defined(MIN_VERSION_unix) +import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink) +#endif + +------------------------------------------------------------------------------- +-- setModificationTime +------------------------------------------------------------------------------- + +#if !MIN_VERSION_directory(1,2,3) + +setModificationTime :: FilePath -> UTCTime -> IO () +setModificationTime _fp _t = return () + +#endif + +------------------------------------------------------------------------------- +-- Symlink +------------------------------------------------------------------------------- + +#if MIN_VERSION_directory(1,3,1) +#elif defined(MIN_VERSION_unix) +createFileLink :: FilePath -> FilePath -> IO () +createFileLink = createSymbolicLink + +pathIsSymbolicLink :: FilePath -> IO Bool +pathIsSymbolicLink fp = do + status <- getSymbolicLinkStatus fp + return (isSymbolicLink status) + +getSymbolicLinkTarget :: FilePath -> IO FilePath +getSymbolicLinkTarget = readSymbolicLink + +#else +createFileLink :: FilePath -> FilePath -> IO () +createFileLink _ _ = fail "Symlinking feature not available" + +pathIsSymbolicLink :: FilePath -> IO Bool +pathIsSymbolicLink _ = fail "Symlinking feature not available" + +getSymbolicLinkTarget :: FilePath -> IO FilePath +getSymbolicLinkTarget _ = fail "Symlinking feature not available" +#endif diff --git a/src/Distribution/Client/Compat/ExecutablePath.hs b/src/Distribution/Client/Compat/ExecutablePath.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Compat/ExecutablePath.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} + +-- Copied verbatim from base-4.6.0.0. We can't simply import +-- System.Environment.getExecutablePath because we need compatibility with older +-- GHCs. + +module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where + +import Prelude + +-- The imports are purposely kept completely disjoint to prevent edits +-- to one OS implementation from breaking another. + +#if defined(darwin_HOST_OS) +import Data.Word +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Internals +#elif defined(linux_HOST_OS) +import Foreign.C +import Foreign.Marshal.Array +import System.Posix.Internals +#elif defined(mingw32_HOST_OS) +import Data.Word +import Foreign.C +import Foreign.Marshal.Array +import Foreign.Ptr +import System.Posix.Internals +#else +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Internals +#endif + +-- The exported function is defined outside any if-guard to make sure +-- every OS implements it with the same type. + +-- | Returns the absolute pathname of the current executable. +-- +-- Note that for scripts and interactive sessions, this is the path to +-- the interpreter (e.g. ghci.) +-- +-- /Since: 4.6.0.0/ +getExecutablePath :: IO FilePath + +-------------------------------------------------------------------------------- +-- Mac OS X + +#if defined(darwin_HOST_OS) + +type UInt32 = Word32 + +foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath" + c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt + +-- | Returns the path of the main executable. The path may be a +-- symbolic link and not the real file. +-- +-- See dyld(3) +_NSGetExecutablePath :: IO FilePath +_NSGetExecutablePath = + allocaBytes 1024 $ \ buf -> -- PATH_MAX is 1024 on OS X + alloca $ \ bufsize -> do + poke bufsize 1024 + status <- c__NSGetExecutablePath buf bufsize + if status == 0 + then peekFilePath buf + else do reqBufsize <- fromIntegral `fmap` peek bufsize + allocaBytes reqBufsize $ \ newBuf -> do + status2 <- c__NSGetExecutablePath newBuf bufsize + if status2 == 0 + then peekFilePath newBuf + else error "_NSGetExecutablePath: buffer too small" + +foreign import ccall unsafe "stdlib.h realpath" + c_realpath :: CString -> CString -> IO CString + +-- | Resolves all symbolic links, extra \/ characters, and references +-- to \/.\/ and \/..\/. Returns an absolute pathname. +-- +-- See realpath(3) +realpath :: FilePath -> IO FilePath +realpath path = + withFilePath path $ \ fileName -> + allocaBytes 1024 $ \ resolvedName -> do + _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName + peekFilePath resolvedName + +getExecutablePath = _NSGetExecutablePath >>= realpath + +-------------------------------------------------------------------------------- +-- Linux + +#elif defined(linux_HOST_OS) + +foreign import ccall unsafe "readlink" + c_readlink :: CString -> CString -> CSize -> IO CInt + +-- | Reads the @FilePath@ pointed to by the symbolic link and returns +-- it. +-- +-- See readlink(2) +readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink file = + allocaArray0 4096 $ \buf -> do + withFilePath file $ \s -> do + len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ + c_readlink s buf 4096 + peekFilePathLen (buf,fromIntegral len) + +getExecutablePath = readSymbolicLink $ "/proc/self/exe" + +-------------------------------------------------------------------------------- +-- Windows + +#elif defined(mingw32_HOST_OS) + +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 + +getExecutablePath = go 2048 -- plenty, PATH_MAX is 512 under Win32 + where + go size = allocaArray (fromIntegral size) $ \ buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> error "getExecutablePath: GetModuleFileNameW returned an error" + _ | ret < size -> peekFilePath buf + | otherwise -> go (size * 2) + +-------------------------------------------------------------------------------- +-- Fallback to argv[0] + +#else + +foreign import ccall unsafe "getFullProgArgv" + c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () + +getExecutablePath = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + c_getFullProgArgv p_argc p_argv + argc <- peek p_argc + if argc > 0 + -- If argc > 0 then argv[0] is guaranteed by the standard + -- to be a pointer to a null-terminated string. + then peek p_argv >>= peek >>= peekFilePath + else error $ "getExecutablePath: " ++ msg + where msg = "no OS specific implementation and program name couldn't be " ++ + "found in argv" + +-------------------------------------------------------------------------------- + +#endif diff --git a/src/Distribution/Client/Compat/FilePerms.hs b/src/Distribution/Client/Compat/FilePerms.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Compat/FilePerms.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +module Distribution.Client.Compat.FilePerms ( + setFileOrdinary, + setFileExecutable, + setFileHidden, + ) where + +import Prelude (FilePath, IO, return, ($)) + +#ifndef mingw32_HOST_OS +import System.Posix.Types + ( FileMode ) +import System.Posix.Internals + ( c_chmod ) +import Foreign.C + ( withCString + , throwErrnoPathIfMinus1_ ) +#else +import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN) +#endif /* mingw32_HOST_OS */ + +setFileHidden, setFileOrdinary, setFileExecutable :: FilePath -> IO () +#ifndef mingw32_HOST_OS +setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x +setFileHidden _ = return () + +setFileMode :: FilePath -> FileMode -> IO () +setFileMode name m = + withCString name $ \s -> + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +setFileHidden path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN +#endif diff --git a/src/Distribution/Client/Compat/Orphans.hs b/src/Distribution/Client/Compat/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Compat/Orphans.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Distribution.Client.Compat.Orphans () where + +import Control.Exception (SomeException) +import Distribution.Compat.Binary (Binary (..)) +import Distribution.Compat.Typeable (typeRep) +import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) +import Network.URI (URI (..), URIAuth (..)) +import Prelude (error, return) + +------------------------------------------------------------------------------- +-- network-uri +------------------------------------------------------------------------------- + +-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier +-- versions do not, so we use manual Binary instances here +instance Binary URI where + put (URI a b c d e) = do put a; put b; put c; put d; put e + get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get + return (URI a b c d e) + +instance Structured URI where + structure p = Nominal (typeRep p) 0 "URI" [] + +instance Binary URIAuth where + put (URIAuth a b c) = do put a; put b; put c + get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) + +------------------------------------------------------------------------------- +-- base +------------------------------------------------------------------------------- + +--FIXME: Duncan Coutts: this is a total cheat +--Added in 46aa019ec85e313e257d122a3549cce01996c566 +instance Binary SomeException where + put _ = return () + get = error "cannot serialise exceptions" + +instance Structured SomeException where + structure p = Nominal (typeRep p) 0 "SomeException" [] diff --git a/src/Distribution/Client/Compat/Prelude.hs b/src/Distribution/Client/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Compat/Prelude.hs @@ -0,0 +1,24 @@ +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | This module does two things: +-- +-- * Acts as a compatibility layer, like @base-compat@. +-- +-- * Provides commonly used imports. +-- +-- This module is a superset of "Distribution.Compat.Prelude" (which +-- this module re-exports) +-- +module Distribution.Client.Compat.Prelude + ( module Distribution.Compat.Prelude.Internal + , module X + ) where + +import Distribution.Client.Compat.Orphans () +import Distribution.Compat.Prelude.Internal +import Prelude () + +import Distribution.Parsec as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec) +import Distribution.Pretty as X (Pretty (..), prettyShow) +import Distribution.Verbosity as X (Verbosity) diff --git a/src/Distribution/Client/Compat/Process.hs b/src/Distribution/Client/Compat/Process.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Compat/Process.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Compat.Process +-- Copyright : (c) 2013 Liu Hao, Brent Yorgey +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Cross-platform utilities for invoking processes. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Compat.Process ( + readProcessWithExitCode +) where + +import Prelude (FilePath, IO, String, return, (||)) + +import Control.Exception (catch, throw) +import System.Exit (ExitCode (ExitFailure)) +import System.IO.Error (isDoesNotExistError, isPermissionError) +import qualified System.Process as P + +-- | @readProcessWithExitCode@ creates an external process, reads its +-- standard output and standard error strictly, waits until the +-- process terminates, and then returns the @ExitCode@ of the +-- process, the standard output, and the standard error. +-- +-- See the documentation of the version from @System.Process@ for +-- more information. +-- +-- The version from @System.Process@ behaves inconsistently across +-- platforms when an executable with the given name is not found: in +-- some cases it returns an @ExitFailure@, in others it throws an +-- exception. This variant catches \"does not exist\" and +-- \"permission denied\" exceptions and turns them into +-- @ExitFailure@s. +-- +-- TODO: this doesn't use 'Distrubution.Compat.Process'. +-- +readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) +readProcessWithExitCode cmd args input = + P.readProcessWithExitCode cmd args input + `catch` \e -> if isDoesNotExistError e || isPermissionError e + then return (ExitFailure 127, "", "") + else throw e diff --git a/src/Distribution/Client/Compat/Semaphore.hs b/src/Distribution/Client/Compat/Semaphore.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Compat/Semaphore.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +module Distribution.Client.Compat.Semaphore + ( QSem + , newQSem + , waitQSem + , signalQSem + ) where + +import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip) + +import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, + writeTVar) +import Control.Exception (mask_, onException) +import Control.Monad (join, unless) +import Data.Typeable (Typeable) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE + +-- | 'QSem' is a quantity semaphore in which the resource is aqcuired +-- and released in units of one. It provides guaranteed FIFO ordering +-- for satisfying blocked `waitQSem` calls. +-- +data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool]) + deriving (Eq, Typeable) + +newQSem :: Int -> IO QSem +newQSem i = atomically $ do + q <- newTVar i + b1 <- newTVar [] + b2 <- newTVar [] + return (QSem q b1 b2) + +waitQSem :: QSem -> IO () +waitQSem s@(QSem q _b1 b2) = + mask_ $ join $ atomically $ do + -- join, because if we need to block, we have to add a TVar to + -- the block queue. + -- mask_, because we need a chance to set up an exception handler + -- after the join returns. + v <- readTVar q + if v == 0 + then do b <- newTVar False + ys <- readTVar b2 + writeTVar b2 (b:ys) + return (wait b) + else do writeTVar q $! v - 1 + return (return ()) + where + -- + -- very careful here: if we receive an exception, then we need to + -- (a) write True into the TVar, so that another signalQSem doesn't + -- try to wake up this thread, and + -- (b) if the TVar is *already* True, then we need to do another + -- signalQSem to avoid losing a unit of the resource. + -- + -- The 'wake' function does both (a) and (b), so we can just call + -- it here. + -- + wait t = + flip onException (wake s t) $ + atomically $ do + b <- readTVar t + unless b retry + + +wake :: QSem -> TVar Bool -> IO () +wake s x = join $ atomically $ do + b <- readTVar x + if b then return (signalQSem s) + else do writeTVar x True + return (return ()) + +{- + property we want: + + bracket waitQSem (\_ -> signalQSem) (\_ -> ...) + + never loses a unit of the resource. +-} + +signalQSem :: QSem -> IO () +signalQSem s@(QSem q b1 b2) = + mask_ $ join $ atomically $ do + -- join, so we don't force the reverse inside the txn + -- mask_ is needed so we don't lose a wakeup + v <- readTVar q + if v /= 0 + then do writeTVar q $! v + 1 + return (return ()) + else do xs <- readTVar b1 + checkwake1 xs + where + checkwake1 [] = do + ys <- readTVar b2 + checkwake2 ys + checkwake1 (x:xs) = do + writeTVar b1 xs + return (wake s x) + + checkwake2 [] = do + writeTVar q 1 + return (return ()) + checkwake2 (y:ys) = do + let (z:|zs) = NE.reverse (y:|ys) + writeTVar b1 zs + writeTVar b2 [] + return (wake s z) diff --git a/src/Distribution/Client/Config.hs b/src/Distribution/Client/Config.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Config.hs @@ -0,0 +1,1479 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Config +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Utilities for handling saved state such as known packages, known servers and +-- downloaded packages. +----------------------------------------------------------------------------- +module Distribution.Client.Config ( + SavedConfig(..), + loadConfig, + getConfigFilePath, + + showConfig, + showConfigWithComments, + parseConfig, + + getCabalDir, + defaultConfigFile, + defaultCacheDir, + defaultCompiler, + defaultInstallPath, + defaultLogsDir, + defaultUserInstall, + + baseSavedConfig, + commentSavedConfig, + initialSavedConfig, + configFieldDescriptions, + haddockFlagsFields, + installDirsFields, + withProgramsFields, + withProgramOptionsFields, + userConfigDiff, + userConfigUpdate, + createDefaultConfigFile, + + remoteRepoFields, + postProcessRepo, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Language.Haskell.Extension ( Language(Haskell2010) ) + +import Distribution.Deprecated.ViewAsFieldDescr + ( viewAsFieldDescr ) + +import Distribution.Client.Types + ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo + , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps + , RepoName (..), unRepoName + ) +import Distribution.Client.Types.Credentials (Username (..), Password (..)) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import qualified Distribution.Client.Init.Types as IT + ( InitFlags(..) ) +import qualified Distribution.Client.Init.Defaults as IT +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, defaultGlobalFlags + , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , initOptions + , InstallFlags(..), installOptions, defaultInstallFlags + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..), defaultClientInstallFlags + , clientInstallOptions ) +import Distribution.Utils.NubList + ( NubList, fromNubList, toNubList, overNubList ) + +import Distribution.Simple.Compiler + ( DebugInfoLevel(..), OptimisationLevel(..) ) +import Distribution.Simple.Setup + ( ConfigFlags(..), configureOptions, defaultConfigFlags + , HaddockFlags(..), haddockOptions, defaultHaddockFlags + , TestFlags(..), defaultTestFlags + , BenchmarkFlags(..), defaultBenchmarkFlags + , installDirsOptions, optionDistPref + , programDbPaths', programDbOptions + , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs + , PathTemplate, toPathTemplate ) +import Distribution.Deprecated.ParseUtils + ( FieldDescr(..), liftField, runP + , ParseResult(..), PError(..), PWarning(..) + , locatedErrorMsg, showPWarning + , readFields, warning, lineNo + , simpleField, listField, spaceListField + , parseOptCommaList, parseTokenQ, syntaxError + , simpleFieldParsec, listFieldParsec + ) +import Distribution.Client.ParseUtils + ( parseFields, ppFields, ppSection ) +import Distribution.Client.HttpUtils + ( isOldHackageURI ) +import qualified Distribution.Deprecated.ParseUtils as ParseUtils + ( Field(..) ) +import Distribution.Simple.Command + ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) ) +import Distribution.Simple.Program + ( defaultProgramDb ) +import Distribution.Simple.Utils + ( die', notice, warn, lowercase, cabalVersion, toUTF8BS ) +import Distribution.Client.Utils + ( cabalInstallVersion ) +import Distribution.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor ) +import Distribution.Verbosity + ( normal ) +import qualified Distribution.Compat.CharParsing as P +import Distribution.Client.ProjectFlags (ProjectFlags (..)) +import Distribution.Solver.Types.ConstraintSource + +import qualified Text.PrettyPrint as Disp + ( render, text, empty ) +import Distribution.Parsec (parsecOptCommaList, ParsecParser, parsecToken, parsecFilePath) +import Text.PrettyPrint + ( ($+$) ) +import Text.PrettyPrint.HughesPJ + ( text, Doc ) +import System.Directory + ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) +import Network.URI + ( URI(..), URIAuth(..), parseURI ) +import System.FilePath + ( (<.>), (), takeDirectory ) +import System.IO.Error + ( isDoesNotExistError ) +import Distribution.Compat.Environment + ( getEnvironment, lookupEnv ) +import qualified Data.Map as M +import qualified Data.ByteString as BS + +-- +-- * Configuration saved in the config file +-- + +data SavedConfig = SavedConfig + { savedGlobalFlags :: GlobalFlags + , savedInitFlags :: IT.InitFlags + , savedInstallFlags :: InstallFlags + , savedClientInstallFlags :: ClientInstallFlags + , savedConfigureFlags :: ConfigFlags + , savedConfigureExFlags :: ConfigExFlags + , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) + , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) + , savedUploadFlags :: UploadFlags + , savedReportFlags :: ReportFlags + , savedHaddockFlags :: HaddockFlags + , savedTestFlags :: TestFlags + , savedBenchmarkFlags :: BenchmarkFlags + , savedProjectFlags :: ProjectFlags + } deriving Generic + +instance Monoid SavedConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup SavedConfig where + a <> b = SavedConfig { + savedGlobalFlags = combinedSavedGlobalFlags, + savedInitFlags = combinedSavedInitFlags, + savedInstallFlags = combinedSavedInstallFlags, + savedClientInstallFlags = combinedSavedClientInstallFlags, + savedConfigureFlags = combinedSavedConfigureFlags, + savedConfigureExFlags = combinedSavedConfigureExFlags, + savedUserInstallDirs = combinedSavedUserInstallDirs, + savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, + savedUploadFlags = combinedSavedUploadFlags, + savedReportFlags = combinedSavedReportFlags, + savedHaddockFlags = combinedSavedHaddockFlags, + savedTestFlags = combinedSavedTestFlags, + savedBenchmarkFlags = combinedSavedBenchmarkFlags, + savedProjectFlags = combinedSavedProjectFlags + } + where + -- This is ugly, but necessary. If we're mappending two config files, we + -- want the values of the *non-empty* list fields from the second one to + -- *override* the corresponding values from the first one. Default + -- behaviour (concatenation) is confusing and makes some use cases (see + -- #1884) impossible. + -- + -- However, we also want to allow specifying multiple values for a list + -- field in a *single* config file. For example, we want the following to + -- continue to work: + -- + -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/ + -- remote-repo: private-collection:http://hackage.local/ + -- + -- So we can't just wrap the list fields inside Flags; we have to do some + -- special-casing just for SavedConfig. + + -- NB: the signature prevents us from using 'combine' on lists. + combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a + combine' field subfield = + (subfield . field $ a) `mappend` (subfield . field $ b) + + combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon) + -> mon + combineMonoid field subfield = + (subfield . field $ a) `mappend` (subfield . field $ b) + + lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a] + lastNonEmpty' field subfield = + let a' = subfield . field $ a + b' = subfield . field $ b + in case b' of [] -> a' + _ -> b' + + lastNonMempty' + :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a + lastNonMempty' field subfield = + let a' = subfield . field $ a + b' = subfield . field $ b + in if b' == mempty then a' else b' + + lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) + -> NubList a + lastNonEmptyNL' field subfield = + let a' = subfield . field $ a + b' = subfield . field $ b + in case fromNubList b' of [] -> a' + _ -> b' + + combinedSavedGlobalFlags = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion, + globalConfigFile = combine globalConfigFile, + globalConstraintsFile = combine globalConstraintsFile, + globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, + globalCacheDir = combine globalCacheDir, + globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, + globalActiveRepos = combine globalActiveRepos, + globalLogsDir = combine globalLogsDir, + globalWorldFile = combine globalWorldFile, + globalIgnoreExpiry = combine globalIgnoreExpiry, + globalHttpTransport = combine globalHttpTransport, + globalNix = combine globalNix, + globalStoreDir = combine globalStoreDir, + globalProgPathExtra = lastNonEmptyNL globalProgPathExtra + } + where + combine = combine' savedGlobalFlags + lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags + + combinedSavedInitFlags = IT.InitFlags { + IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs, + IT.author = combine IT.author, + IT.buildTools = combineMonoid savedInitFlags IT.buildTools, + IT.cabalVersion = combine IT.cabalVersion, + IT.category = combine IT.category, + IT.dependencies = combineMonoid savedInitFlags IT.dependencies, + IT.email = combine IT.email, + IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules, + IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc, + IT.homepage = combine IT.homepage, + IT.initHcPath = combine IT.initHcPath, + IT.initVerbosity = combine IT.initVerbosity, + IT.initializeTestSuite = combine IT.initializeTestSuite, + IT.interactive = combine IT.interactive, + IT.language = combine IT.language, + IT.license = combine IT.license, + IT.mainIs = combine IT.mainIs, + IT.minimal = combine IT.minimal, + IT.noComments = combine IT.noComments, + IT.otherExts = combineMonoid savedInitFlags IT.otherExts, + IT.otherModules = combineMonoid savedInitFlags IT.otherModules, + IT.overwrite = combine IT.overwrite, + IT.packageDir = combine IT.packageDir, + IT.packageName = combine IT.packageName, + IT.packageType = combine IT.packageType, + IT.quiet = combine IT.quiet, + IT.simpleProject = combine IT.simpleProject, + IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs, + IT.synopsis = combine IT.synopsis, + IT.testDirs = combineMonoid savedInitFlags IT.testDirs, + IT.version = combine IT.version + } + where + combine = combine' savedInitFlags + + combinedSavedInstallFlags = InstallFlags { + installDocumentation = combine installDocumentation, + installHaddockIndex = combine installHaddockIndex, + installDryRun = combine installDryRun, + installOnlyDownload = combine installOnlyDownload, + installDest = combine installDest, + installMaxBackjumps = combine installMaxBackjumps, + installReorderGoals = combine installReorderGoals, + installCountConflicts = combine installCountConflicts, + installFineGrainedConflicts = combine installFineGrainedConflicts, + installMinimizeConflictSet = combine installMinimizeConflictSet, + installIndependentGoals = combine installIndependentGoals, + installShadowPkgs = combine installShadowPkgs, + installStrongFlags = combine installStrongFlags, + installAllowBootLibInstalls = combine installAllowBootLibInstalls, + installOnlyConstrained = combine installOnlyConstrained, + installReinstall = combine installReinstall, + installAvoidReinstalls = combine installAvoidReinstalls, + installOverrideReinstall = combine installOverrideReinstall, + installUpgradeDeps = combine installUpgradeDeps, + installOnly = combine installOnly, + installOnlyDeps = combine installOnlyDeps, + installIndexState = combine installIndexState, + installRootCmd = combine installRootCmd, + installSummaryFile = lastNonEmptyNL installSummaryFile, + installLogFile = combine installLogFile, + installBuildReports = combine installBuildReports, + installReportPlanningFailure = combine installReportPlanningFailure, + installSymlinkBinDir = combine installSymlinkBinDir, + installPerComponent = combine installPerComponent, + installOneShot = combine installOneShot, + installNumJobs = combine installNumJobs, + installKeepGoing = combine installKeepGoing, + installRunTests = combine installRunTests, + installOfflineMode = combine installOfflineMode + } + where + combine = combine' savedInstallFlags + lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags + + combinedSavedClientInstallFlags = ClientInstallFlags + { cinstInstallLibs = combine cinstInstallLibs + , cinstEnvironmentPath = combine cinstEnvironmentPath + , cinstOverwritePolicy = combine cinstOverwritePolicy + , cinstInstallMethod = combine cinstInstallMethod + , cinstInstalldir = combine cinstInstalldir + } + where + combine = combine' savedClientInstallFlags + + combinedSavedConfigureFlags = ConfigFlags { + configArgs = lastNonEmpty configArgs, + configPrograms_ = configPrograms_ . savedConfigureFlags $ b, + -- TODO: NubListify + configProgramPaths = lastNonEmpty configProgramPaths, + -- TODO: NubListify + configProgramArgs = lastNonEmpty configProgramArgs, + configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, + configInstantiateWith = lastNonEmpty configInstantiateWith, + configHcFlavor = combine configHcFlavor, + configHcPath = combine configHcPath, + configHcPkg = combine configHcPkg, + configVanillaLib = combine configVanillaLib, + configProfLib = combine configProfLib, + configProf = combine configProf, + configSharedLib = combine configSharedLib, + configStaticLib = combine configStaticLib, + configDynExe = combine configDynExe, + configFullyStaticExe = combine configFullyStaticExe, + configProfExe = combine configProfExe, + configProfDetail = combine configProfDetail, + configProfLibDetail = combine configProfLibDetail, + -- TODO: NubListify + configConfigureArgs = lastNonEmpty configConfigureArgs, + configOptimization = combine configOptimization, + configDebugInfo = combine configDebugInfo, + configProgPrefix = combine configProgPrefix, + configProgSuffix = combine configProgSuffix, + -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. + configInstallDirs = + (configInstallDirs . savedConfigureFlags $ a) + `mappend` (configInstallDirs . savedConfigureFlags $ b), + configScratchDir = combine configScratchDir, + -- TODO: NubListify + configExtraLibDirs = lastNonEmpty configExtraLibDirs, + -- TODO: NubListify + configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, + -- TODO: NubListify + configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, + configDeterministic = combine configDeterministic, + configIPID = combine configIPID, + configCID = combine configCID, + configDistPref = combine configDistPref, + configCabalFilePath = combine configCabalFilePath, + configVerbosity = combine configVerbosity, + configUserInstall = combine configUserInstall, + -- TODO: NubListify + configPackageDBs = lastNonEmpty configPackageDBs, + configGHCiLib = combine configGHCiLib, + configSplitSections = combine configSplitSections, + configSplitObjs = combine configSplitObjs, + configStripExes = combine configStripExes, + configStripLibs = combine configStripLibs, + -- TODO: NubListify + configConstraints = lastNonEmpty configConstraints, + -- TODO: NubListify + configDependencies = lastNonEmpty configDependencies, + -- TODO: NubListify + configConfigurationsFlags = lastNonMempty configConfigurationsFlags, + configTests = combine configTests, + configBenchmarks = combine configBenchmarks, + configCoverage = combine configCoverage, + configLibCoverage = combine configLibCoverage, + configExactConfiguration = combine configExactConfiguration, + configFlagError = combine configFlagError, + configRelocatable = combine configRelocatable, + configUseResponseFiles = combine configUseResponseFiles, + configAllowDependingOnPrivateLibs = + combine configAllowDependingOnPrivateLibs + } + where + combine = combine' savedConfigureFlags + lastNonEmpty = lastNonEmpty' savedConfigureFlags + lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags + lastNonMempty = lastNonMempty' savedConfigureFlags + + combinedSavedConfigureExFlags = ConfigExFlags { + configCabalVersion = combine configCabalVersion, + -- TODO: NubListify + configExConstraints = lastNonEmpty configExConstraints, + -- TODO: NubListify + configPreferences = lastNonEmpty configPreferences, + configSolver = combine configSolver, + configAllowNewer = + combineMonoid savedConfigureExFlags configAllowNewer, + configAllowOlder = + combineMonoid savedConfigureExFlags configAllowOlder, + configWriteGhcEnvironmentFilesPolicy + = combine configWriteGhcEnvironmentFilesPolicy + } + where + combine = combine' savedConfigureExFlags + lastNonEmpty = lastNonEmpty' savedConfigureExFlags + + -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. + combinedSavedUserInstallDirs = savedUserInstallDirs a + `mappend` savedUserInstallDirs b + + -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. + combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a + `mappend` savedGlobalInstallDirs b + + combinedSavedUploadFlags = UploadFlags { + uploadCandidate = combine uploadCandidate, + uploadDoc = combine uploadDoc, + uploadUsername = combine uploadUsername, + uploadPassword = combine uploadPassword, + uploadPasswordCmd = combine uploadPasswordCmd, + uploadVerbosity = combine uploadVerbosity + } + where + combine = combine' savedUploadFlags + + combinedSavedReportFlags = ReportFlags { + reportUsername = combine reportUsername, + reportPassword = combine reportPassword, + reportVerbosity = combine reportVerbosity + } + where + combine = combine' savedReportFlags + + combinedSavedHaddockFlags = HaddockFlags { + -- TODO: NubListify + haddockProgramPaths = lastNonEmpty haddockProgramPaths, + -- TODO: NubListify + haddockProgramArgs = lastNonEmpty haddockProgramArgs, + haddockHoogle = combine haddockHoogle, + haddockHtml = combine haddockHtml, + haddockHtmlLocation = combine haddockHtmlLocation, + haddockForHackage = combine haddockForHackage, + haddockExecutables = combine haddockExecutables, + haddockTestSuites = combine haddockTestSuites, + haddockBenchmarks = combine haddockBenchmarks, + haddockForeignLibs = combine haddockForeignLibs, + haddockInternal = combine haddockInternal, + haddockCss = combine haddockCss, + haddockLinkedSource = combine haddockLinkedSource, + haddockQuickJump = combine haddockQuickJump, + haddockHscolourCss = combine haddockHscolourCss, + haddockContents = combine haddockContents, + haddockDistPref = combine haddockDistPref, + haddockKeepTempFiles = combine haddockKeepTempFiles, + haddockVerbosity = combine haddockVerbosity, + haddockCabalFilePath = combine haddockCabalFilePath, + haddockArgs = lastNonEmpty haddockArgs + } + where + combine = combine' savedHaddockFlags + lastNonEmpty = lastNonEmpty' savedHaddockFlags + + combinedSavedTestFlags = TestFlags { + testDistPref = combine testDistPref, + testVerbosity = combine testVerbosity, + testHumanLog = combine testHumanLog, + testMachineLog = combine testMachineLog, + testShowDetails = combine testShowDetails, + testKeepTix = combine testKeepTix, + testWrapper = combine testWrapper, + testFailWhenNoTestSuites = combine testFailWhenNoTestSuites, + testOptions = lastNonEmpty testOptions + } + where + combine = combine' savedTestFlags + lastNonEmpty = lastNonEmpty' savedTestFlags + + combinedSavedBenchmarkFlags = BenchmarkFlags { + benchmarkDistPref = combine benchmarkDistPref, + benchmarkVerbosity = combine benchmarkVerbosity, + benchmarkOptions = lastNonEmpty benchmarkOptions + } + where + combine = combine' savedBenchmarkFlags + lastNonEmpty = lastNonEmpty' savedBenchmarkFlags + + combinedSavedProjectFlags = ProjectFlags + { flagProjectFileName = combine flagProjectFileName + , flagIgnoreProject = combine flagIgnoreProject + } + where + combine = combine' savedProjectFlags + +-- +-- * Default config +-- + +-- | These are the absolute basic defaults. The fields that must be +-- initialised. When we load the config from the file we layer the loaded +-- values over these ones, so any missing fields in the file take their values +-- from here. +-- +baseSavedConfig :: IO SavedConfig +baseSavedConfig = do + userPrefix <- getCabalDir + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + return mempty { + savedConfigureFlags = mempty { + configHcFlavor = toFlag defaultCompiler, + configUserInstall = toFlag defaultUserInstall, + configVerbosity = toFlag normal + }, + savedUserInstallDirs = mempty { + prefix = toFlag (toPathTemplate userPrefix) + }, + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalLogsDir = toFlag logsDir, + globalWorldFile = toFlag worldFile + } + } + +-- | This is the initial configuration that we write out to the config file +-- if the file does not exist (or the config we use if the file cannot be read +-- for some other reason). When the config gets loaded it gets layered on top +-- of 'baseSavedConfig' so we do not need to include it into the initial +-- values we save into the config file. +-- +initialSavedConfig :: IO SavedConfig +initialSavedConfig = do + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + extraPath <- defaultExtraPath + installPath <- defaultInstallPath + return mempty { + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalRemoteRepos = toNubList [defaultRemoteRepo], + globalWorldFile = toFlag worldFile + }, + savedConfigureFlags = mempty { + configProgramPathExtra = toNubList extraPath + }, + savedInstallFlags = mempty { + installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], + installBuildReports= toFlag NoReports, + installNumJobs = toFlag Nothing + }, + savedClientInstallFlags = mempty { + cinstInstalldir = toFlag installPath + } + } + +defaultCabalDir :: IO FilePath +defaultCabalDir = getAppUserDataDirectory "cabal" + +getCabalDir :: IO FilePath +getCabalDir = do + mDir <- lookupEnv "CABAL_DIR" + case mDir of + Nothing -> defaultCabalDir + Just dir -> return dir + +defaultConfigFile :: IO FilePath +defaultConfigFile = do + dir <- getCabalDir + return $ dir "config" + +defaultCacheDir :: IO FilePath +defaultCacheDir = do + dir <- getCabalDir + return $ dir "packages" + +defaultLogsDir :: IO FilePath +defaultLogsDir = do + dir <- getCabalDir + return $ dir "logs" + +-- | Default position of the world file +defaultWorldFile :: IO FilePath +defaultWorldFile = do + dir <- getCabalDir + return $ dir "world" + +defaultExtraPath :: IO [FilePath] +defaultExtraPath = do + dir <- getCabalDir + return [dir "bin"] + +defaultInstallPath :: IO FilePath +defaultInstallPath = do + dir <- getCabalDir + return (dir "bin") + +defaultCompiler :: CompilerFlavor +defaultCompiler = fromMaybe GHC defaultCompilerFlavor + +defaultUserInstall :: Bool +defaultUserInstall = True +-- We do per-user installs by default on all platforms. We used to default to +-- global installs on Windows but that no longer works on Windows Vista or 7. + +defaultRemoteRepo :: RemoteRepo +defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False + where + str = "hackage.haskell.org" + name = RepoName str + uri = URI "http:" (Just (URIAuth "" str "")) "/" "" "" + -- Note that lots of old ~/.cabal/config files will have the old url + -- http://hackage.haskell.org/packages/archive + -- but new config files can use the new url (without the /packages/archive) + -- and avoid having to do a http redirect + +-- For the default repo we know extra information, fill this in. +-- +-- We need this because the 'defaultRemoteRepo' above is only used for the +-- first time when a config file is made. So for users with older config files +-- we might have only have older info. This lets us fill that in even for old +-- config files. +-- +addInfoForKnownRepos :: RemoteRepo -> RemoteRepo +addInfoForKnownRepos repo + | remoteRepoName repo == remoteRepoName defaultRemoteRepo + = useSecure . tryHttps . fixOldURI $ repo + where + fixOldURI r + | isOldHackageURI (remoteRepoURI r) + = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo } + | otherwise = r + + tryHttps r = r { remoteRepoShouldTryHttps = True } + + useSecure r@RemoteRepo{ + remoteRepoSecure = secure, + remoteRepoRootKeys = [], + remoteRepoKeyThreshold = 0 + } | secure /= Just False + = r { + -- Use hackage-security by default unless you opt-out with + -- secure: False + remoteRepoSecure = Just True, + remoteRepoRootKeys = defaultHackageRemoteRepoKeys, + remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold + } + useSecure r = r +addInfoForKnownRepos other = other + +-- | The current hackage.haskell.org repo root keys that we ship with cabal. +--- +-- This lets us bootstrap trust in this repo without user intervention. +-- These keys need to be periodically updated when new root keys are added. +-- See the root key procedures for details. +-- +defaultHackageRemoteRepoKeys :: [String] +defaultHackageRemoteRepoKeys = + [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0", + "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42", + "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3", + "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d", + "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + ] + +-- | The required threshold of root key signatures for hackage.haskell.org +-- +defaultHackageRemoteRepoKeyThreshold :: Int +defaultHackageRemoteRepoKeyThreshold = 3 + +-- +-- * Config file reading +-- + +-- | Loads the main configuration, and applies additional defaults to give the +-- effective configuration. To loads just what is actually in the config file, +-- use 'loadRawConfig'. +-- +loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig +loadConfig verbosity configFileFlag = do + config <- loadRawConfig verbosity configFileFlag + extendToEffectiveConfig config + +extendToEffectiveConfig :: SavedConfig -> IO SavedConfig +extendToEffectiveConfig config = do + base <- baseSavedConfig + let effective0 = base `mappend` config + globalFlags0 = savedGlobalFlags effective0 + effective = effective0 { + savedGlobalFlags = globalFlags0 { + globalRemoteRepos = + overNubList (map addInfoForKnownRepos) + (globalRemoteRepos globalFlags0) + } + } + return effective + +-- | Like 'loadConfig' but does not apply any additional defaults, it just +-- loads what is actually in the config file. This is thus suitable for +-- comparing or editing a config file, but not suitable for using as the +-- effective configuration. +-- +loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig +loadRawConfig verbosity configFileFlag = do + (source, configFile) <- getConfigFilePathAndSource configFileFlag + minp <- readConfigFile mempty configFile + case minp of + Nothing -> do + notice verbosity $ + "Config file path source is " ++ sourceMsg source ++ "." + notice verbosity $ "Config file " ++ configFile ++ " not found." + createDefaultConfigFile verbosity [] configFile + Just (ParseOk ws conf) -> do + unless (null ws) $ warn verbosity $ + unlines (map (showPWarning configFile) ws) + return conf + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + die' verbosity $ + "Error parsing config file " ++ configFile + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + + where + sourceMsg CommandlineOption = "commandline option" + sourceMsg EnvironmentVariable = "env var CABAL_CONFIG" + sourceMsg Default = "default config file" + +data ConfigFileSource = CommandlineOption + | EnvironmentVariable + | Default + +-- | Returns the config file path, without checking that the file exists. +-- The order of precedence is: input flag, CABAL_CONFIG, default location. +getConfigFilePath :: Flag FilePath -> IO FilePath +getConfigFilePath = fmap snd . getConfigFilePathAndSource + +getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath) +getConfigFilePathAndSource configFileFlag = + getSource sources + where + sources = + [ (CommandlineOption, return . flagToMaybe $ configFileFlag) + , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment) + , (Default, Just `liftM` defaultConfigFile) ] + + getSource [] = error "no config file path candidate found." + getSource ((source,action): xs) = + action >>= maybe (getSource xs) (return . (,) source) + +readConfigFile + :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) +readConfigFile initial file = handleNotExists $ + fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) + (BS.readFile file) + + where + handleNotExists action = catchIO action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig +createDefaultConfigFile verbosity extraLines filePath = do + commentConf <- commentSavedConfig + initialConf <- initialSavedConfig + extraConf <- parseExtraLines verbosity extraLines + notice verbosity $ "Writing default configuration to " ++ filePath + writeConfigFile filePath commentConf (initialConf `mappend` extraConf) + return initialConf + +writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () +writeConfigFile file comments vals = do + let tmpFile = file <.> "tmp" + createDirectoryIfMissing True (takeDirectory file) + writeFile tmpFile $ + explanation ++ showConfigWithComments comments vals ++ "\n" + renameFile tmpFile file + where + explanation = unlines + ["-- This is the configuration file for the 'cabal' command line tool." + ,"--" + ,"-- The available configuration options are listed below." + ,"-- Some of them have default values listed." + ,"--" + ,"-- Lines (like this one) beginning with '--' are comments." + ,"-- Be careful with spaces and indentation because they are" + ,"-- used to indicate layout for nested sections." + ,"--" + ,"-- This config file was generated using the following versions" + ,"-- of Cabal and cabal-install:" + ,"-- Cabal library version: " ++ prettyShow cabalVersion + ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion + ,"","" + ] + +-- | These are the default values that get used in Cabal if a no value is +-- given. We use these here to include in comments when we write out the +-- initial config file so that the user can see what default value they are +-- overriding. +-- +commentSavedConfig :: IO SavedConfig +commentSavedConfig = do + userInstallDirs <- defaultInstallDirs defaultCompiler True True + globalInstallDirs <- defaultInstallDirs defaultCompiler False True + let conf0 = mempty { + savedGlobalFlags = defaultGlobalFlags { + globalRemoteRepos = toNubList [defaultRemoteRepo] + }, + savedInitFlags = mempty { + IT.interactive = toFlag False, + IT.cabalVersion = toFlag IT.defaultCabalVersion, + IT.language = toFlag Haskell2010, + IT.license = NoFlag, + IT.sourceDirs = Just [IT.defaultSourceDir], + IT.applicationDirs = Just [IT.defaultApplicationDir] + }, + savedInstallFlags = defaultInstallFlags, + savedClientInstallFlags= defaultClientInstallFlags, + savedConfigureExFlags = defaultConfigExFlags { + configAllowNewer = Just (AllowNewer mempty), + configAllowOlder = Just (AllowOlder mempty) + }, + savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { + configUserInstall = toFlag defaultUserInstall + }, + savedUserInstallDirs = fmap toFlag userInstallDirs, + savedGlobalInstallDirs = fmap toFlag globalInstallDirs, + savedUploadFlags = commandDefaultFlags uploadCommand, + savedReportFlags = commandDefaultFlags reportCommand, + savedHaddockFlags = defaultHaddockFlags, + savedTestFlags = defaultTestFlags, + savedBenchmarkFlags = defaultBenchmarkFlags + } + conf1 <- extendToEffectiveConfig conf0 + let globalFlagsConf1 = savedGlobalFlags conf1 + conf2 = conf1 { + savedGlobalFlags = globalFlagsConf1 { + globalRemoteRepos = overNubList (map removeRootKeys) + (globalRemoteRepos globalFlagsConf1) + } + } + return conf2 + where + -- Most people don't want to see default root keys, so don't print them. + removeRootKeys :: RemoteRepo -> RemoteRepo + removeRootKeys r = r { remoteRepoRootKeys = [] } + +-- | All config file fields. +-- +configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig] +configFieldDescriptions src = + + toSavedConfig liftGlobalFlag + (commandOptions (globalCommand []) ParseArgs) + ["version", "numeric-version", "config-file"] [] + + ++ toSavedConfig liftConfigFlag + (configureOptions ParseArgs) + (["builddir", "constraint", "dependency", "ipid"] + ++ map fieldName installDirsFields) + + -- This is only here because viewAsFieldDescr gives us a parser + -- that only recognises 'ghc' etc, the case-sensitive flag names, not + -- what the normal case-insensitive parser gives us. + [simpleFieldParsec "compiler" + (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag) + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + + -- TODO: The following is a temporary fix. The "optimization" + -- and "debug-info" fields are OptArg, and viewAsFieldDescr + -- fails on that. Instead of a hand-written hackaged parser + -- and printer, we should handle this case properly in the + -- library. + ,liftField configOptimization (\v flags -> + flags { configOptimization = v }) $ + let name = "optimization" in + FieldDescr name + (\f -> case f of + Flag NoOptimisation -> Disp.text "False" + Flag NormalOptimisation -> Disp.text "True" + Flag MaximumOptimisation -> Disp.text "2" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoOptimisation) + | str == "True" -> ParseOk [] (Flag NormalOptimisation) + | str == "0" -> ParseOk [] (Flag NoOptimisation) + | str == "1" -> ParseOk [] (Flag NormalOptimisation) + | str == "2" -> ParseOk [] (Flag MaximumOptimisation) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) + | lstr == "true" -> ParseOk [caseWarning] + (Flag NormalOptimisation) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name + ++ "' field is case sensitive, use 'True' or 'False'.") + ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ + let name = "debug-info" in + FieldDescr name + (\f -> case f of + Flag NoDebugInfo -> Disp.text "False" + Flag MinimalDebugInfo -> Disp.text "1" + Flag NormalDebugInfo -> Disp.text "True" + Flag MaximalDebugInfo -> Disp.text "3" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) + | str == "True" -> ParseOk [] (Flag NormalDebugInfo) + | str == "0" -> ParseOk [] (Flag NoDebugInfo) + | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) + | str == "2" -> ParseOk [] (Flag NormalDebugInfo) + | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) + | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name + ++ "' field is case sensitive, use 'True' or 'False'.") + ] + + ++ toSavedConfig liftConfigExFlag + (configureExOptions ParseArgs src) + [] + [let pkgs = (Just . AllowOlder . RelaxDepsSome) + `fmap` parsecOptCommaList parsec + parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) + `fmap` parsec) <|> pkgs + in simpleFieldParsec "allow-older" + (showRelaxDeps . fmap unAllowOlder) parseAllowOlder + configAllowOlder (\v flags -> flags { configAllowOlder = v }) + ,let pkgs = (Just . AllowNewer . RelaxDepsSome) + `fmap` parsecOptCommaList parsec + parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) + `fmap` parsec) <|> pkgs + in simpleFieldParsec "allow-newer" + (showRelaxDeps . fmap unAllowNewer) parseAllowNewer + configAllowNewer (\v flags -> flags { configAllowNewer = v }) + ] + + ++ toSavedConfig liftInstallFlag + (installOptions ParseArgs) + ["dry-run", "only", "only-dependencies", "dependencies-only"] [] + + ++ toSavedConfig liftClientInstallFlag + (clientInstallOptions ParseArgs) + [] [] + + ++ toSavedConfig liftUploadFlag + (commandOptions uploadCommand ParseArgs) + ["verbose", "check", "documentation", "publish"] [] + + ++ toSavedConfig liftReportFlag + (commandOptions reportCommand ParseArgs) + ["verbose", "username", "password"] [] + --FIXME: this is a hack, hiding the user name and password. + -- But otherwise it masks the upload ones. Either need to + -- share the options or make then distinct. In any case + -- they should probably be per-server. + + ++ [ viewAsFieldDescr + $ optionDistPref + (configDistPref . savedConfigureFlags) + (\distPref config -> + config + { savedConfigureFlags = (savedConfigureFlags config) { + configDistPref = distPref } + , savedHaddockFlags = (savedHaddockFlags config) { + haddockDistPref = distPref } + } + ) + ParseArgs + ] + + where + toSavedConfig lift options exclusions replacements = + [ lift (fromMaybe field replacement) + | opt <- options + , let field = viewAsFieldDescr opt + name = fieldName field + replacement = find ((== name) . fieldName) replacements + , name `notElem` exclusions ] + + showRelaxDeps Nothing = mempty + showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True" + | otherwise = Disp.text "False" + + toRelaxDeps True = RelaxDepsAll + toRelaxDeps False = mempty + + +-- TODO: next step, make the deprecated fields elicit a warning. +-- +deprecatedFieldDescriptions :: [FieldDescr SavedConfig] +deprecatedFieldDescriptions = + [ liftGlobalFlag $ + listFieldParsec "repos" + pretty parsec + (fromNubList . globalRemoteRepos) + (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) + , liftGlobalFlag $ + simpleFieldParsec "cachedir" + (Disp.text . fromFlagOrDefault "") (optionalFlag parsecFilePath) + globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) + , liftUploadFlag $ + simpleFieldParsec "hackage-username" + (Disp.text . fromFlagOrDefault "" . fmap unUsername) + (optionalFlag (fmap Username parsecToken)) + uploadUsername (\d cfg -> cfg { uploadUsername = d }) + , liftUploadFlag $ + simpleFieldParsec "hackage-password" + (Disp.text . fromFlagOrDefault "" . fmap unPassword) + (optionalFlag (fmap Password parsecToken)) + uploadPassword (\d cfg -> cfg { uploadPassword = d }) + , liftUploadFlag $ + spaceListField "hackage-password-command" + Disp.text parseTokenQ + (fromFlagOrDefault [] . uploadPasswordCmd) + (\d cfg -> cfg { uploadPasswordCmd = Flag d }) + ] + ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) + installDirsFields + ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) + installDirsFields + where + optionalFlag :: ParsecParser a -> ParsecParser (Flag a) + optionalFlag p = toFlag <$> p <|> pure mempty + + modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a + modifyFieldName f d = d { fieldName = f (fieldName d) } + +liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftUserInstallDirs = liftField + savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) + +liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftGlobalInstallDirs = + liftField savedGlobalInstallDirs + (\flags conf -> conf { savedGlobalInstallDirs = flags }) + +liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig +liftGlobalFlag = liftField + savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) + +liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig +liftConfigFlag = liftField + savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) + +liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig +liftConfigExFlag = liftField + savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) + +liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig +liftInstallFlag = liftField + savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) + +liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig +liftClientInstallFlag = + liftField savedClientInstallFlags + (\flags conf -> conf { savedClientInstallFlags = flags }) + +liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig +liftUploadFlag = liftField + savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) + +liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig +liftReportFlag = liftField + savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) + +parseConfig :: ConstraintSource + -> SavedConfig + -> BS.ByteString + -> ParseResult SavedConfig +parseConfig src initial = \str -> do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + config <- parse others + let init0 = savedInitFlags config + user0 = savedUserInstallDirs config + global0 = savedGlobalInstallDirs config + (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- + foldM parseSections + ([], [], savedHaddockFlags config, init0, user0, global0, [], []) + knownSections + + let remoteRepoSections = + reverse + . nubBy ((==) `on` remoteRepoName) + $ remoteRepoSections0 + + let localRepoSections = + reverse + . nubBy ((==) `on` localRepoName) + $ localRepoSections0 + + return . fixConfigMultilines $ config { + savedGlobalFlags = (savedGlobalFlags config) { + globalRemoteRepos = toNubList remoteRepoSections, + globalLocalNoIndexRepos = toNubList localRepoSections, + -- the global extra prog path comes from the configure flag prog path + globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) + }, + savedConfigureFlags = (savedConfigureFlags config) { + configProgramPaths = paths, + configProgramArgs = args + }, + savedHaddockFlags = haddockFlags, + savedInitFlags = initFlags, + savedUserInstallDirs = user, + savedGlobalInstallDirs = global + } + + where + isKnownSection (ParseUtils.Section _ "repository" _ _) = True + isKnownSection (ParseUtils.F _ "remote-repo" _) = True + isKnownSection (ParseUtils.Section _ "haddock" _ _) = True + isKnownSection (ParseUtils.Section _ "init" _ _) = True + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True + isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True + isKnownSection _ = False + + -- Attempt to split fields that can represent lists of paths into + -- actual lists on failure, leave the field untouched. + splitMultiPath :: [String] -> [String] + splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of + ParseOk _ res -> res + _ -> [s] + splitMultiPath xs = xs + + -- This is a fixup, pending a full config parser rewrite, to + -- ensure that config fields which can be comma-separated lists + -- actually parse as comma-separated lists. + fixConfigMultilines conf = conf { + savedConfigureFlags = + let scf = savedConfigureFlags conf + in scf { + configProgramPathExtra = + toNubList $ splitMultiPath + (fromNubList $ configProgramPathExtra scf) + , configExtraLibDirs = splitMultiPath + (configExtraLibDirs scf) + , configExtraFrameworkDirs = splitMultiPath + (configExtraFrameworkDirs scf) + , configExtraIncludeDirs = splitMultiPath + (configExtraIncludeDirs scf) + , configConfigureArgs = splitMultiPath + (configConfigureArgs scf) + } + } + + parse = parseFields (configFieldDescriptions src + ++ deprecatedFieldDescriptions) initial + + parseSections (rs, ls, h, i, u, g, p, a) + (ParseUtils.Section lineno "repository" name fs) = do + name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $ + simpleParsec name + r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs + r'' <- postProcessRepo lineno name r' + case r'' of + Left local -> return (rs, local:ls, h, i, u, g, p, a) + Right remote -> return (remote:rs, ls, h, i, u, g, p, a) + + parseSections (rs, ls, h, i, u, g, p, a) + (ParseUtils.F lno "remote-repo" raw) = do + let mr' = simpleParsec raw + r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' + return (r':rs, ls, h, i, u, g, p, a) + + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "haddock" name fs) + | name == "" = do h' <- parseFields haddockFlagsFields h fs + return (rs, ls, h', i, u, g, p, a) + | otherwise = do + warning "The 'haddock' section should be unnamed" + return accum + + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "init" name fs) + | name == "" = do i' <- parseFields initFlagsFields i fs + return (rs, ls, h, i', u, g, p, a) + | otherwise = do + warning "The 'init' section should be unnamed" + return accum + + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "install-dirs" name fs) + | name' == "user" = do u' <- parseFields installDirsFields u fs + return (rs, ls, h, i, u', g, p, a) + | name' == "global" = do g' <- parseFields installDirsFields g fs + return (rs, ls, h, i, u, g', p, a) + | otherwise = do + warning "The 'install-paths' section should be for 'user' or 'global'" + return accum + where name' = lowercase name + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "program-locations" name fs) + | name == "" = do p' <- parseFields withProgramsFields p fs + return (rs, ls, h, i, u, g, p', a) + | otherwise = do + warning "The 'program-locations' section should be unnamed" + return accum + parseSections accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "program-default-options" name fs) + | name == "" = do a' <- parseFields withProgramOptionsFields a fs + return (rs, ls, h, i, u, g, p, a') + | otherwise = do + warning "The 'program-default-options' section should be unnamed" + return accum + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) +postProcessRepo lineno reponameStr repo0 = do + when (null reponameStr) $ + syntaxError lineno $ "a 'repository' section requires the " + ++ "repository name as an argument" + + reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $ + simpleParsec reponameStr + + case uriScheme (remoteRepoURI repo0) of + -- TODO: check that there are no authority, query or fragment + -- Note: the trailing colon is important + "file+noindex:" -> do + let uri = remoteRepoURI repo0 + return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") + + _ -> do + let repo = repo0 { remoteRepoName = reponame } + + when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ + warning $ "'key-threshold' for repository " + ++ show (remoteRepoName repo) + ++ " higher than number of keys" + + when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ + warning $ "'root-keys' for repository " + ++ show (remoteRepoName repo) + ++ " non-empty, but 'secure' not set to True." + + return $ Right repo + +showConfig :: SavedConfig -> String +showConfig = showConfigWithComments mempty + +showConfigWithComments :: SavedConfig -> SavedConfig -> String +showConfigWithComments comment vals = Disp.render $ + case fmap (uncurry ppRemoteRepoSection) + (zip (getRemoteRepos comment) (getRemoteRepos vals)) of + [] -> Disp.text "" + (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs + $+$ Disp.text "" + $+$ ppFields + (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) + mcomment vals + $+$ Disp.text "" + $+$ ppSection "haddock" "" haddockFlagsFields + (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) + $+$ Disp.text "" + $+$ ppSection "init" "" initFlagsFields + (fmap savedInitFlags mcomment) (savedInitFlags vals) + $+$ Disp.text "" + $+$ installDirsSection "user" savedUserInstallDirs + $+$ Disp.text "" + $+$ installDirsSection "global" savedGlobalInstallDirs + $+$ Disp.text "" + $+$ configFlagsSection "program-locations" withProgramsFields + configProgramPaths + $+$ Disp.text "" + $+$ configFlagsSection "program-default-options" withProgramOptionsFields + configProgramArgs + where + getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags + mcomment = Just comment + installDirsSection name field = + ppSection "install-dirs" name installDirsFields + (fmap field mcomment) (field vals) + configFlagsSection name fields field = + ppSection name "" fields + (fmap (field . savedConfigureFlags) mcomment) + ((field . savedConfigureFlags) vals) + + -- skip fields based on field name. currently only skips "remote-repo", + -- because that is rendered as a section. (see 'ppRemoteRepoSection'.) + skipSomeFields = filter ((/= "remote-repo") . fieldName) + +-- | Fields for the 'install-dirs' sections. +installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] +installDirsFields = map viewAsFieldDescr installDirsOptions + +ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc +ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals)) + remoteRepoFields (Just def) vals + +remoteRepoFields :: [FieldDescr RemoteRepo] +remoteRepoFields = + [ simpleField "url" + (text . show) (parseTokenQ >>= parseURI') + remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) + , simpleFieldParsec "secure" + showSecure (Just `fmap` parsec) + remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) + , listField "root-keys" + text parseTokenQ + remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) + , simpleFieldParsec "key-threshold" + showThreshold P.integral + remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) + ] + where + parseURI' uriString = + case parseURI uriString of + Nothing -> fail $ "remote-repo: no parse on " ++ show uriString + Just uri -> return uri + + showSecure Nothing = mempty -- default 'secure' setting + showSecure (Just True) = text "True" -- user explicitly enabled it + showSecure (Just False) = text "False" -- user explicitly disabled it + + -- If the key-threshold is set to 0, we omit it as this is the default + -- and it looks odd to have a value for key-threshold but not for 'secure' + -- (note that an empty list of keys is already omitted by default, since + -- that is what we do for all list fields) + showThreshold 0 = mempty + showThreshold t = text (show t) + +-- | Fields for the 'haddock' section. +haddockFlagsFields :: [FieldDescr HaddockFlags] +haddockFlagsFields = [ field + | opt <- haddockOptions ParseArgs + , let field = viewAsFieldDescr opt + name = fieldName field + , name `notElem` exclusions ] + where + exclusions = ["verbose", "builddir", "for-hackage"] + +-- | Fields for the 'init' section. +initFlagsFields :: [FieldDescr IT.InitFlags] +initFlagsFields = [ field + | opt <- initOptions ParseArgs + , let field = viewAsFieldDescr opt + name = fieldName field + , name `notElem` exclusions ] + where + exclusions = + [ "author", "email", "quiet", "no-comments", "minimal", "overwrite" + , "package-dir", "packagedir", "package-name", "version", "homepage" + , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe" + , "simple", "main-is", "expose-module", "exposed-modules", "extension" + , "dependency", "build-tool", "with-compiler" + , "verbose" + ] + +-- | Fields for the 'program-locations' section. +withProgramsFields :: [FieldDescr [(String, FilePath)]] +withProgramsFields = + map viewAsFieldDescr $ + programDbPaths' (++ "-location") defaultProgramDb + ParseArgs id (++) + +-- | Fields for the 'program-default-options' section. +withProgramOptionsFields :: [FieldDescr [(String, [String])]] +withProgramOptionsFields = + map viewAsFieldDescr $ + programDbOptions defaultProgramDb ParseArgs id (++) + +parseExtraLines :: Verbosity -> [String] -> IO SavedConfig +parseExtraLines verbosity extraLines = + case parseConfig (ConstraintSourceMainConfig "additional lines") + mempty (toUTF8BS (unlines extraLines)) of + ParseFailed err -> + let (line, msg) = locatedErrorMsg err + in die' verbosity $ + "Error parsing additional config lines\n" + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + ParseOk [] r -> return r + ParseOk ws _ -> + die' verbosity $ + unlines (map (showPWarning "Error parsing additional config lines") ws) + +-- | Get the differences (as a pseudo code diff) between the user's +-- '~/.cabal/config' and the one that cabal would generate if it didn't exist. +userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] +userConfigDiff verbosity globalFlags extraLines = do + userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + extraConfig <- parseExtraLines verbosity extraLines + testConfig <- initialSavedConfig + return $ + reverse . foldl' createDiff [] . M.toList + $ M.unionWith combine + (M.fromList . map justFst $ filterShow testConfig) + (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) + where + justFst (a, b) = (a, (Just b, Nothing)) + justSnd (a, b) = (a, (Nothing, Just b)) + + combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b) + combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b) + combine x y = error $ "Can't happen : userConfigDiff " + ++ show x ++ " " ++ show y + + createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String] + createDiff acc (key, (Just a, Just b)) + | a == b = acc + | otherwise = ("+ " ++ key ++ ": " ++ b) + : ("- " ++ key ++ ": " ++ a) : acc + createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc + createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc + createDiff acc (_, (Nothing, Nothing)) = acc + + filterShow :: SavedConfig -> [(String, String)] + filterShow cfg = map keyValueSplit + . filter (\s -> not (null s) && ':' `elem` s) + . map nonComment + . lines + $ showConfig cfg + + nonComment [] = [] + nonComment ('-':'-':_) = [] + nonComment (x:xs) = x : nonComment xs + + topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace + + keyValueSplit s = + let (left, right) = break (== ':') s + in (topAndTail left, topAndTail (drop 1 right)) + + +-- | Update the user's ~/.cabal/config' keeping the user's customizations. +userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () +userConfigUpdate verbosity globalFlags extraLines = do + userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + extraConfig <- parseExtraLines verbosity extraLines + newConfig <- initialSavedConfig + commentConf <- commentSavedConfig + cabalFile <- getConfigFilePath $ globalConfigFile globalFlags + let backup = cabalFile ++ ".backup" + notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." + renameFile cabalFile backup + notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." + writeConfigFile cabalFile commentConf + (newConfig `mappend` userConfig `mappend` extraConfig) diff --git a/src/Distribution/Client/Configure.hs b/src/Distribution/Client/Configure.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Configure.hs @@ -0,0 +1,464 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Configure +-- Copyright : (c) David Himmelstrup 2005, +-- Duncan Coutts 2005 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- High level interface to configuring a package. +----------------------------------------------------------------------------- +module Distribution.Client.Configure ( + configure, + configureSetupScript, + chooseCabalVersion, + checkConfigExFlags, + -- * Saved configure flags + readConfigFlagsFrom, readConfigFlags, + cabalConfigFlagsFile, + writeConfigFlagsTo, writeConfigFlags, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeHead) + +import Distribution.Client.Dependency +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.Setup + ( ConfigExFlags(..), RepoContext(..) + , configureCommand, configureExCommand, filterConfigureFlags ) +import Distribution.Client.Types as Source +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Targets + ( userToPackageConstraint, userConstraintPackageName ) +import Distribution.Client.JobControl (Lock) + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageIndex + ( PackageIndex, elemByPackageName ) +import Distribution.Solver.Types.PkgConfigDb + (PkgConfigDb, readPkgConfigDb) +import Distribution.Solver.Types.SourcePackage + +import Distribution.Simple.Compiler + ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramDb) +import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) +import Distribution.Simple.Setup + ( ConfigFlags(..) + , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Simple.PackageIndex + ( InstalledPackageIndex, lookupPackageName ) +import Distribution.Package + ( Package(..), packageName, PackageId ) +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..), thisPackageVersionConstraint ) +import qualified Distribution.PackageDescription as PkgDesc +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Version + ( Version, mkVersion, anyVersion, thisVersion + , VersionRange, orLaterVersion ) +import Distribution.Simple.Utils as Utils + ( warn, notice, debug, die' + , defaultPackageDesc ) +import Distribution.System + ( Platform ) + +import System.FilePath ( () ) + +-- | Choose the Cabal version such that the setup scripts compiled against this +-- version will support the given command-line flags. +chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange +chooseCabalVersion configExFlags maybeVersion = + maybe defaultVersionRange thisVersion maybeVersion + where + -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed + -- for '--allow-newer' to work. + allowNewer = isRelaxDeps + (maybe mempty unAllowNewer $ configAllowNewer configExFlags) + allowOlder = isRelaxDeps + (maybe mempty unAllowOlder $ configAllowOlder configExFlags) + + defaultVersionRange = if allowOlder || allowNewer + then orLaterVersion (mkVersion [1,19,2]) + else anyVersion + +-- | Configure the package found in the local directory +configure :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> ConfigFlags + -> ConfigExFlags + -> [String] + -> IO () +configure verbosity packageDBs repoCtxt comp platform progdb + configFlags configExFlags extraArgs = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb + + checkConfigExFlags verbosity installedPkgIndex + (packageIndex sourcePkgDb) configExFlags + + progress <- planLocalPackage verbosity comp platform configFlags configExFlags + installedPkgIndex sourcePkgDb pkgConfigDb + + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress logMsg (return . Left) (return . Right) + progress + case maybePlan of + Left message -> do + warn verbosity $ + "solver failed to find a solution:\n" + ++ message + ++ "\nTrying configure anyway." + setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) + Nothing configureCommand (const configFlags) (const extraArgs) + + Right installPlan0 -> + let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 + in case fst (InstallPlan.ready installPlan) of + [pkg@(ReadyPackage + (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _) + _ _ _))] -> do + configurePackage verbosity + platform (compilerInfo comp) + (setupScriptOptions installedPkgIndex (Just pkg)) + configFlags pkg extraArgs + + _ -> die' verbosity $ "internal error: configure install plan should have exactly " + ++ "one local ready package." + + where + setupScriptOptions :: InstalledPackageIndex + -> Maybe ReadyPackage + -> SetupScriptOptions + setupScriptOptions = + configureSetupScript + packageDBs + comp + platform + progdb + (fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags)) + (chooseCabalVersion + configExFlags + (flagToMaybe (configCabalVersion configExFlags))) + Nothing + False + + logMsg message rest = debug verbosity message >> rest + +configureSetupScript :: PackageDBStack + -> Compiler + -> Platform + -> ProgramDb + -> FilePath + -> VersionRange + -> Maybe Lock + -> Bool + -> InstalledPackageIndex + -> Maybe ReadyPackage + -> SetupScriptOptions +configureSetupScript packageDBs + comp + platform + progdb + distPref + cabalVersion + lock + forceExternal + index + mpkg + = SetupScriptOptions { + useCabalVersion = cabalVersion + , useCabalSpecVersion = Nothing + , useCompiler = Just comp + , usePlatform = Just platform + , usePackageDB = packageDBs' + , usePackageIndex = index' + , useProgramDb = progdb + , useDistPref = distPref + , useLoggingHandle = Nothing + , useWorkingDir = Nothing + , useExtraPathEnv = [] + , useExtraEnvOverrides = [] + , setupCacheLock = lock + , useWin32CleanHack = False + , forceExternalSetupMethod = forceExternal + -- If we have explicit setup dependencies, list them; otherwise, we give + -- the empty list of dependencies; ideally, we would fix the version of + -- Cabal here, so that we no longer need the special case for that in + -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet + -- know the version of Cabal at this point, but only find this there. + -- Therefore, for now, we just leave this blank. + , useDependencies = fromMaybe [] explicitSetupDeps + , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps + , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps + , isInteractive = False + } + where + -- When we are compiling a legacy setup script without an explicit + -- setup stanza, we typically want to allow the UserPackageDB for + -- finding the Cabal lib when compiling any Setup.hs even if we're doing + -- a global install. However we also allow looking in a specific package + -- db. + packageDBs' :: PackageDBStack + index' :: Maybe InstalledPackageIndex + (packageDBs', index') = + case packageDBs of + (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs + , Nothing <- explicitSetupDeps + -> (GlobalPackageDB:UserPackageDB:dbs, Nothing) + -- but if the user is using an odd db stack, don't touch it + _otherwise -> (packageDBs, Just index) + + maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo + maybeSetupBuildInfo = do + ReadyPackage cpkg <- mpkg + let gpkg = srcpkgDescription (confPkgSource cpkg) + PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg) + + -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If + -- so, 'setup-depends' must not be exclusive. See #3199. + defaultSetupDeps :: Bool + defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends + maybeSetupBuildInfo + + explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)] + explicitSetupDeps = do + -- Check if there is an explicit setup stanza. + _buildInfo <- maybeSetupBuildInfo + -- Return the setup dependencies computed by the solver + ReadyPackage cpkg <- mpkg + return [ ( cid, srcid ) + | ConfiguredId srcid + (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid + <- CD.setupDeps (confPkgDeps cpkg) + ] + +-- | Warn if any constraints or preferences name packages that are not in the +-- source package index or installed package index. +checkConfigExFlags :: Package pkg + => Verbosity + -> InstalledPackageIndex + -> PackageIndex pkg + -> ConfigExFlags + -> IO () +checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do + for_ (safeHead unknownConstraints) $ \h -> + warn verbosity $ "Constraint refers to an unknown package: " + ++ showConstraint h + for_ (safeHead unknownPreferences) $ \h -> + warn verbosity $ "Preference refers to an unknown package: " + ++ prettyShow h + where + unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ + configExConstraints flags + unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $ + configPreferences flags + unknown pkg = null (lookupPackageName installedPkgIndex pkg) + && not (elemByPackageName sourcePkgIndex pkg) + showConstraint (uc, src) = + prettyShow uc ++ " (" ++ showConstraintSource src ++ ")" + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity -> Compiler + -> Platform + -> ConfigFlags -> ConfigExFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> IO (Progress String String SolverInstallPlan) +planLocalPackage verbosity comp platform configFlags configExFlags + installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do + pkg <- readGenericPackageDescription verbosity =<< + case flagToMaybe (configCabalFilePath configFlags) of + Nothing -> defaultPackageDesc verbosity + Just fp -> return fp + solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) + (compilerInfo comp) + + let -- We create a local package and ask to resolve a dependency on it + localPkg = SourcePackage { + srcpkgPackageId = packageId pkg, + srcpkgDescription = pkg, + srcpkgSource = LocalUnpackedPackage ".", + srcpkgDescrOverride = Nothing + } + + testsEnabled = fromFlagOrDefault False $ configTests configFlags + benchmarksEnabled = + fromFlagOrDefault False $ configBenchmarks configFlags + + resolverParams = + removeLowerBounds + (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags) + . removeUpperBounds + (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags) + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- configPreferences configExFlags ] + + . addConstraints + -- version constraints from the config file or command line + -- TODO: should warn or error on constraints that are not on direct + -- deps or flag constraints not on the package in question. + [ LabeledPackageConstraint (userToPackageConstraint uc) src + | (uc, src) <- configExConstraints configExFlags ] + + . addConstraints + -- package flags from the config file or command line + [ let pc = PackageConstraint + (scopeToplevel $ packageName pkg) + (PackagePropertyFlags $ configConfigurationsFlags configFlags) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + ] + + . addConstraints + -- '--enable-tests' and '--enable-benchmarks' constraints from + -- the config file or command line + [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) . + PackagePropertyStanzas $ + [ TestStanzas | testsEnabled ] ++ + [ BenchStanzas | benchmarksEnabled ] + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + ] + + -- Don't solve for executables, since we use an empty source + -- package database and executables never show up in the + -- installed package index + . setSolveExecutables (SolveExecutables False) + + . setSolverVerbosity verbosity + + $ standardInstallPolicy + installedPkgIndex + -- NB: We pass in an *empty* source package database, + -- because cabal configure assumes that all dependencies + -- have already been installed + (SourcePackageDb mempty packagePrefs) + [SpecificSourcePackage localPkg] + + return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams) + + +-- | Call an installer for an 'SourcePackage' but override the configure +-- flags with the ones given by the 'ReadyPackage'. In particular the +-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +-- NB: when updating this function, don't forget to also update +-- 'installReadyPackage' in D.C.Install. +configurePackage :: Verbosity + -> Platform -> CompilerInfo + -> SetupScriptOptions + -> ConfigFlags + -> ReadyPackage + -> [String] + -> IO () +configurePackage verbosity platform comp scriptOptions configFlags + (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps)) + extraArgs = + + setupWrapper verbosity + scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs) + + where + gpkg = srcpkgDescription spkg + configureFlags = filterConfigureFlags configFlags { + configIPID = if isJust (flagToMaybe (configIPID configFlags)) + -- Make sure cabal configure --ipid works. + then configIPID configFlags + else toFlag (prettyShow ipid), + configConfigurationsFlags = flags, + -- We generate the legacy constraints as well as the new style precise + -- deps. In the end only one set gets passed to Setup.hs configure, + -- depending on the Cabal version we are talking to. + configConstraints = [ thisPackageVersionConstraint srcid + | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid + <- CD.nonSetupDeps deps ], + configDependencies = [ GivenComponent (packageName srcid) cname uid + | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid + <- CD.nonSetupDeps deps ], + -- Use '--exact-configuration' if supported. + configExactConfiguration = toFlag True, + configVerbosity = toFlag verbosity, + -- NB: if the user explicitly specified + -- --enable-tests/--enable-benchmarks, always respect it. + -- (But if they didn't, let solver decide.) + configBenchmarks = toFlag (BenchStanzas `optStanzaSetMember` stanzas) + `mappend` configBenchmarks configFlags, + configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas) + `mappend` configTests configFlags + } + + pkg = case finalizePD flags (enableStanzas stanzas) + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc + +-- ----------------------------------------------------------------------------- +-- * Saved configure environments and flags +-- ----------------------------------------------------------------------------- + +-- | Read saved configure flags and restore the saved environment from the +-- specified files. +readConfigFlagsFrom :: FilePath -- ^ path to saved flags file + -> IO (ConfigFlags, ConfigExFlags) +readConfigFlagsFrom flags = do + readCommandFlags flags configureExCommand + +-- | The path (relative to @--build-dir@) where the arguments to @configure@ +-- should be saved. +cabalConfigFlagsFile :: FilePath -> FilePath +cabalConfigFlagsFile dist = dist "cabal-config-flags" + +-- | Read saved configure flags and restore the saved environment from the +-- usual location. +readConfigFlags :: FilePath -- ^ @--build-dir@ + -> IO (ConfigFlags, ConfigExFlags) +readConfigFlags dist = + readConfigFlagsFrom (cabalConfigFlagsFile dist) + +-- | Save the configure flags and environment to the specified files. +writeConfigFlagsTo :: FilePath -- ^ path to saved flags file + -> Verbosity -> (ConfigFlags, ConfigExFlags) + -> IO () +writeConfigFlagsTo file verb flags = do + writeCommandFlags verb file configureExCommand flags + +-- | Save the build flags to the usual location. +writeConfigFlags :: Verbosity + -> FilePath -- ^ @--build-dir@ + -> (ConfigFlags, ConfigExFlags) -> IO () +writeConfigFlags verb dist = + writeConfigFlagsTo (cabalConfigFlagsFile dist) verb diff --git a/src/Distribution/Client/Dependency.hs b/src/Distribution/Client/Dependency.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Dependency.hs @@ -0,0 +1,1045 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Top level interface to dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency ( + -- * The main package dependency resolver + chooseSolver, + resolveDependencies, + Progress(..), + foldProgress, + + -- * Alternate, simple resolver that does not do dependencies recursively + resolveWithoutDependencies, + + -- * Constructing resolver policies + PackageProperty(..), + PackageConstraint(..), + scopeToplevel, + PackagesPreferenceDefault(..), + PackagePreference(..), + + -- ** Standard policy + basicInstallPolicy, + standardInstallPolicy, + PackageSpecifier(..), + + -- ** Extra policy options + upgradeDependencies, + reinstallTargets, + + -- ** Policy utils + addConstraints, + addPreferences, + setPreferenceDefault, + setReorderGoals, + setCountConflicts, + setFineGrainedConflicts, + setMinimizeConflictSet, + setIndependentGoals, + setAvoidReinstalls, + setShadowPkgs, + setStrongFlags, + setAllowBootLibInstalls, + setOnlyConstrained, + setMaxBackjumps, + setEnableBackjumping, + setSolveExecutables, + setGoalOrder, + setSolverVerbosity, + removeLowerBounds, + removeUpperBounds, + addDefaultSetupDependencies, + addSetupCabalMinVersionConstraint, + addSetupCabalMaxVersionConstraint, + ) where + +import Distribution.Client.Compat.Prelude +import qualified Prelude as Unsafe (head) + +import Distribution.Solver.Modular + ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Types + ( SourcePackageDb(SourcePackageDb) + , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints + , UnresolvedPkgLoc, UnresolvedSourcePackage + , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..) + , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps + ) +import Distribution.Client.Dependency.Types + ( PreSolver(..), Solver(..) + , PackagesPreferenceDefault(..) ) +import Distribution.Package + ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId + , Package(..), packageName, packageVersion ) +import Distribution.Types.Dependency +import qualified Distribution.PackageDescription as PD +import qualified Distribution.PackageDescription.Configuration as PD +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Compiler + ( CompilerInfo(..) ) +import Distribution.System + ( Platform ) +import Distribution.Client.Utils + ( duplicatesBy, mergeBy, MergeResult(..) ) +import Distribution.Simple.Setup + ( asBool ) +import Distribution.Verbosity + ( normal ) +import Distribution.Version +import qualified Distribution.Compat.Graph as Graph + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver +import Distribution.Solver.Types.InstalledPreference +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Variable + +import Data.List + ( maximumBy ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Exception + ( assert ) + + +-- ------------------------------------------------------------ +-- * High level planner policy +-- ------------------------------------------------------------ + +-- | The set of parameters to the dependency resolver. These parameters are +-- relatively low level but many kinds of high level policies can be +-- implemented in terms of adjustments to the parameters. +-- +data DepResolverParams = DepResolverParams { + depResolverTargets :: Set PackageName, + depResolverConstraints :: [LabeledPackageConstraint], + depResolverPreferences :: [PackagePreference], + depResolverPreferenceDefault :: PackagesPreferenceDefault, + depResolverInstalledPkgIndex :: InstalledPackageIndex, + depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, + depResolverReorderGoals :: ReorderGoals, + depResolverCountConflicts :: CountConflicts, + depResolverFineGrainedConflicts :: FineGrainedConflicts, + depResolverMinimizeConflictSet :: MinimizeConflictSet, + depResolverIndependentGoals :: IndependentGoals, + depResolverAvoidReinstalls :: AvoidReinstalls, + depResolverShadowPkgs :: ShadowPkgs, + depResolverStrongFlags :: StrongFlags, + + -- | Whether to allow base and its dependencies to be installed. + depResolverAllowBootLibInstalls :: AllowBootLibInstalls, + + -- | Whether to only allow explicitly constrained packages plus + -- goals or to allow any package. + depResolverOnlyConstrained :: OnlyConstrained, + + depResolverMaxBackjumps :: Maybe Int, + depResolverEnableBackjumping :: EnableBackjumping, + -- | Whether or not to solve for dependencies on executables. + -- This should be true, except in the legacy code path where + -- we can't tell if an executable has been installed or not, + -- so we shouldn't solve for them. See #3875. + depResolverSolveExecutables :: SolveExecutables, + + -- | Function to override the solver's goal-ordering heuristics. + depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + depResolverVerbosity :: Verbosity + } + +showDepResolverParams :: DepResolverParams -> String +showDepResolverParams p = + "targets: " ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p)) + ++ "\nconstraints: " + ++ concatMap (("\n " ++) . showLabeledConstraint) + (depResolverConstraints p) + ++ "\npreferences: " + ++ concatMap (("\n " ++) . showPackagePreference) + (depResolverPreferences p) + ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) + ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p)) + ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p)) + ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p)) + ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p)) + ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) + ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) + ++ "\nshadow packages: " ++ show (asBool (depResolverShadowPkgs p)) + ++ "\nstrong flags: " ++ show (asBool (depResolverStrongFlags p)) + ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p)) + ++ "\nonly constrained packages: " ++ show (depResolverOnlyConstrained p) + ++ "\nmax backjumps: " ++ maybe "infinite" show + (depResolverMaxBackjumps p) + where + showLabeledConstraint :: LabeledPackageConstraint -> String + showLabeledConstraint (LabeledPackageConstraint pc src) = + showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" + +-- | A package selection preference for a particular package. +-- +-- Preferences are soft constraints that the dependency resolver should try to +-- respect where possible. It is not specified if preferences on some packages +-- are more important than others. +-- +data PackagePreference = + + -- | A suggested constraint on the version number. + PackageVersionPreference PackageName VersionRange + + -- | If we prefer versions of packages that are already installed. + | PackageInstalledPreference PackageName InstalledPreference + + -- | If we would prefer to enable these optional stanzas + -- (i.e. test suites and/or benchmarks) + | PackageStanzasPreference PackageName [OptionalStanza] + + +-- | Provide a textual representation of a package preference +-- for debugging purposes. +-- +showPackagePreference :: PackagePreference -> String +showPackagePreference (PackageVersionPreference pn vr) = + prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr) +showPackagePreference (PackageInstalledPreference pn ip) = + prettyShow pn ++ " " ++ show ip +showPackagePreference (PackageStanzasPreference pn st) = + prettyShow pn ++ " " ++ show st + +basicDepResolverParams :: InstalledPackageIndex + -> PackageIndex.PackageIndex UnresolvedSourcePackage + -> DepResolverParams +basicDepResolverParams installedPkgIndex sourcePkgIndex = + DepResolverParams { + depResolverTargets = Set.empty, + depResolverConstraints = [], + depResolverPreferences = [], + depResolverPreferenceDefault = PreferLatestForSelected, + depResolverInstalledPkgIndex = installedPkgIndex, + depResolverSourcePkgIndex = sourcePkgIndex, + depResolverReorderGoals = ReorderGoals False, + depResolverCountConflicts = CountConflicts True, + depResolverFineGrainedConflicts = FineGrainedConflicts True, + depResolverMinimizeConflictSet = MinimizeConflictSet False, + depResolverIndependentGoals = IndependentGoals False, + depResolverAvoidReinstalls = AvoidReinstalls False, + depResolverShadowPkgs = ShadowPkgs False, + depResolverStrongFlags = StrongFlags False, + depResolverAllowBootLibInstalls = AllowBootLibInstalls False, + depResolverOnlyConstrained = OnlyConstrainedNone, + depResolverMaxBackjumps = Nothing, + depResolverEnableBackjumping = EnableBackjumping True, + depResolverSolveExecutables = SolveExecutables True, + depResolverGoalOrder = Nothing, + depResolverVerbosity = normal + } + +addTargets :: [PackageName] + -> DepResolverParams -> DepResolverParams +addTargets extraTargets params = + params { + depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params + } + +addConstraints :: [LabeledPackageConstraint] + -> DepResolverParams -> DepResolverParams +addConstraints extraConstraints params = + params { + depResolverConstraints = extraConstraints + ++ depResolverConstraints params + } + +addPreferences :: [PackagePreference] + -> DepResolverParams -> DepResolverParams +addPreferences extraPreferences params = + params { + depResolverPreferences = extraPreferences + ++ depResolverPreferences params + } + +setPreferenceDefault :: PackagesPreferenceDefault + -> DepResolverParams -> DepResolverParams +setPreferenceDefault preferenceDefault params = + params { + depResolverPreferenceDefault = preferenceDefault + } + +setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams +setReorderGoals reorder params = + params { + depResolverReorderGoals = reorder + } + +setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams +setCountConflicts count params = + params { + depResolverCountConflicts = count + } + +setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams +setFineGrainedConflicts fineGrained params = + params { + depResolverFineGrainedConflicts = fineGrained + } + +setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams +setMinimizeConflictSet minimize params = + params { + depResolverMinimizeConflictSet = minimize + } + +setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams +setIndependentGoals indep params = + params { + depResolverIndependentGoals = indep + } + +setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams +setAvoidReinstalls avoid params = + params { + depResolverAvoidReinstalls = avoid + } + +setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams +setShadowPkgs shadow params = + params { + depResolverShadowPkgs = shadow + } + +setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams +setStrongFlags sf params = + params { + depResolverStrongFlags = sf + } + +setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams +setAllowBootLibInstalls i params = + params { + depResolverAllowBootLibInstalls = i + } + +setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams +setOnlyConstrained i params = + params { + depResolverOnlyConstrained = i + } + +setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams +setMaxBackjumps n params = + params { + depResolverMaxBackjumps = n + } + +setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams +setEnableBackjumping b params = + params { + depResolverEnableBackjumping = b + } + +setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams +setSolveExecutables b params = + params { + depResolverSolveExecutables = b + } + +setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) + -> DepResolverParams + -> DepResolverParams +setGoalOrder order params = + params { + depResolverGoalOrder = order + } + +setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams +setSolverVerbosity verbosity params = + params { + depResolverVerbosity = verbosity + } + +-- | Some packages are specific to a given compiler version and should never be +-- upgraded. +dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams +dontUpgradeNonUpgradeablePackages params = + addConstraints extraConstraints params + where + extraConstraints = + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) + ConstraintSourceNonUpgradeablePackage + | Set.notMember (mkPackageName "base") (depResolverTargets params) + -- If you change this enumeration, make sure to update the list in + -- "Distribution.Solver.Modular.Solver" as well + , pkgname <- [ mkPackageName "base" + , mkPackageName "ghc-bignum" + , mkPackageName "ghc-prim" + , mkPackageName "integer-gmp" + , mkPackageName "integer-simple" + , mkPackageName "template-haskell" + ] + , isInstalled pkgname ] + + isInstalled = not . null + . InstalledPackageIndex.lookupPackageName + (depResolverInstalledPkgIndex params) + +addSourcePackages :: [UnresolvedSourcePackage] + -> DepResolverParams -> DepResolverParams +addSourcePackages pkgs params = + params { + depResolverSourcePkgIndex = + foldl (flip PackageIndex.insert) + (depResolverSourcePkgIndex params) pkgs + } + +hideInstalledPackagesSpecificBySourcePackageId :: [PackageId] + -> DepResolverParams + -> DepResolverParams +hideInstalledPackagesSpecificBySourcePackageId pkgids params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalledPkgIndex = + foldl' (flip InstalledPackageIndex.deleteSourcePackageId) + (depResolverInstalledPkgIndex params) pkgids + } + +hideInstalledPackagesAllVersions :: [PackageName] + -> DepResolverParams -> DepResolverParams +hideInstalledPackagesAllVersions pkgnames params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalledPkgIndex = + foldl' (flip InstalledPackageIndex.deletePackageName) + (depResolverInstalledPkgIndex params) pkgnames + } + + +-- | Remove upper bounds in dependencies using the policy specified by the +-- 'AllowNewer' argument (all/some/none). +-- +-- Note: It's important to apply 'removeUpperBounds' after +-- 'addSourcePackages'. Otherwise, the packages inserted by +-- 'addSourcePackages' won't have upper bounds in dependencies relaxed. +-- +removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams +removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps + +-- | Dual of 'removeUpperBounds' +removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams +removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps + +data RelaxKind = RelaxLower | RelaxUpper + +-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds' +removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams +removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation +removeBounds relKind relDeps params = + params { + depResolverSourcePkgIndex = sourcePkgIndex' + } + where + sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params + + relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage + relaxDeps srcPkg = srcPkg + { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg) + } + +-- | Relax the dependencies of this package if needed. +-- +-- Helper function used by 'removeBounds' +relaxPackageDeps :: RelaxKind + -> RelaxDeps + -> PD.GenericPackageDescription -> PD.GenericPackageDescription +relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds' +relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd + where + relaxAll :: Dependency -> Dependency + relaxAll (Dependency pkgName verRange cs) = + Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs + +relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd = + PD.transformAllBuildDepends relaxSome gpd + where + thisPkgName = packageName gpd + thisPkgId = packageId gpd + depsToRelax = Map.fromList $ mapMaybe f depsToRelax0 + + f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod) + f (RelaxedDep scope rdm p) = case scope of + RelaxDepScopeAll -> Just (p,rdm) + RelaxDepScopePackage p0 + | p0 == thisPkgName -> Just (p,rdm) + | otherwise -> Nothing + RelaxDepScopePackageId p0 + | p0 == thisPkgId -> Just (p,rdm) + | otherwise -> Nothing + + relaxSome :: Dependency -> Dependency + relaxSome d@(Dependency depName verRange cs) + | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = + -- a '*'-subject acts absorbing, for consistency with + -- the 'Semigroup RelaxDeps' instance + Dependency depName (removeBound relKind relMod verRange) cs + | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = + Dependency depName (removeBound relKind relMod verRange) cs + | otherwise = d -- no-op + +-- | Internal helper for 'relaxPackageDeps' +removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange +removeBound RelaxLower RelaxDepModNone = removeLowerBound +removeBound RelaxUpper RelaxDepModNone = removeUpperBound +removeBound RelaxLower RelaxDepModCaret = transformCaretLower +removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper + +-- | Supply defaults for packages without explicit Setup dependencies +-- +-- Note: It's important to apply 'addDefaultSetupDepends' after +-- 'addSourcePackages'. Otherwise, the packages inserted by +-- 'addSourcePackages' won't have upper bounds in dependencies relaxed. +-- +addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency]) + -> DepResolverParams -> DepResolverParams +addDefaultSetupDependencies defaultSetupDeps params = + params { + depResolverSourcePkgIndex = + fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params) + } + where + applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage + applyDefaultSetupDeps srcpkg = + srcpkg { + srcpkgDescription = gpkgdesc { + PD.packageDescription = pkgdesc { + PD.setupBuildInfo = + case PD.setupBuildInfo pkgdesc of + Just sbi -> Just sbi + Nothing -> case defaultSetupDeps srcpkg of + Nothing -> Nothing + Just deps | isCustom -> Just PD.SetupBuildInfo { + PD.defaultSetupDepends = True, + PD.setupDepends = deps + } + | otherwise -> Nothing + } + } + } + where + isCustom = PD.buildType pkgdesc == PD.Custom + gpkgdesc = srcpkgDescription srcpkg + pkgdesc = PD.packageDescription gpkgdesc + +-- | If a package has a custom setup then we need to add a setup-depends +-- on Cabal. +-- +addSetupCabalMinVersionConstraint :: Version + -> DepResolverParams -> DepResolverParams +addSetupCabalMinVersionConstraint minVersion = + addConstraints + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion minVersion)) + ConstraintSetupCabalMinVersion + ] + where + cabalPkgname = mkPackageName "Cabal" + +-- | Variant of 'addSetupCabalMinVersionConstraint' which sets an +-- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'. +-- +addSetupCabalMaxVersionConstraint :: Version + -> DepResolverParams -> DepResolverParams +addSetupCabalMaxVersionConstraint maxVersion = + addConstraints + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ earlierVersion maxVersion)) + ConstraintSetupCabalMaxVersion + ] + where + cabalPkgname = mkPackageName "Cabal" + + +upgradeDependencies :: DepResolverParams -> DepResolverParams +upgradeDependencies = setPreferenceDefault PreferAllLatest + + +reinstallTargets :: DepResolverParams -> DepResolverParams +reinstallTargets params = + hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params + + +-- | A basic solver policy on which all others are built. +-- +basicInstallPolicy :: InstalledPackageIndex + -> SourcePackageDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> DepResolverParams +basicInstallPolicy + installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) + pkgSpecifiers + + = addPreferences + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList sourcePkgPrefs ] + + . addConstraints + (concatMap pkgSpecifierConstraints pkgSpecifiers) + + . addTargets + (map pkgSpecifierTarget pkgSpecifiers) + + . hideInstalledPackagesSpecificBySourcePackageId + [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] + + . addSourcePackages + [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] + + $ basicDepResolverParams + installedPkgIndex sourcePkgIndex + + +-- | The policy used by all the standard commands, install, fetch, freeze etc +-- (but not the v2-build and related commands). +-- +-- It extends the 'basicInstallPolicy' with a policy on setup deps. +-- +standardInstallPolicy :: InstalledPackageIndex + -> SourcePackageDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> DepResolverParams +standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + = addDefaultSetupDependencies mkDefaultSetupDeps + + $ basicInstallPolicy + installedPkgIndex sourcePkgDb pkgSpecifiers + + where + -- Force Cabal >= 1.24 dep when the package is affected by #3199. + mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] + mkDefaultSetupDeps srcpkg | affected = + Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet] + | otherwise = Nothing + where + gpkgdesc = srcpkgDescription srcpkg + pkgdesc = PD.packageDescription gpkgdesc + bt = PD.buildType pkgdesc + affected = bt == PD.Custom && hasBuildableFalse gpkgdesc + + -- Does this package contain any components with non-empty 'build-depends' + -- and a 'buildable' field that could potentially be set to 'False'? False + -- positives are possible. + hasBuildableFalse :: PD.GenericPackageDescription -> Bool + hasBuildableFalse gpkg = + not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions)) + where + buildableConditions = PD.extractConditions PD.buildable gpkg + noDepConditions = PD.extractConditions + (null . PD.targetBuildDepends) gpkg + alwaysTrue (PD.Lit True) = True + alwaysTrue _ = False + +-- ------------------------------------------------------------ +-- * Interface to the standard resolver +-- ------------------------------------------------------------ + +chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver +chooseSolver _verbosity preSolver _cinfo = + case preSolver of + AlwaysModular -> do + return Modular + +runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc +runSolver Modular = modularResolver + +-- | Run the dependency solver. +-- +-- Since this is potentially an expensive operation, the result is wrapped in a +-- a 'Progress' structure that can be unfolded to provide progress information, +-- logging messages and the final result or an error. +-- +resolveDependencies :: Platform + -> CompilerInfo + -> PkgConfigDb + -> Solver + -> DepResolverParams + -> Progress String String SolverInstallPlan + + --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages +resolveDependencies platform comp _pkgConfigDB _solver params + | Set.null (depResolverTargets params) + = return (validateSolverResult platform comp indGoals []) + where + indGoals = depResolverIndependentGoals params + +resolveDependencies platform comp pkgConfigDB solver params = + + Step (showDepResolverParams finalparams) + $ fmap (validateSolverResult platform comp indGoals) + $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize + indGoals noReinstalls + shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj + solveExes order verbosity (PruneAfterFirstSuccess False)) + platform comp installedPkgIndex sourcePkgIndex + pkgConfigDB preferences constraints targets + where + + finalparams@(DepResolverParams + targets constraints + prefs defpref + installedPkgIndex + sourcePkgIndex + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + allowBootLibs + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity) = + if asBool (depResolverAllowBootLibInstalls params) + then params + else dontUpgradeNonUpgradeablePackages params + + preferences = interpretPackagesPreference targets defpref prefs + + +-- | Give an interpretation to the global 'PackagesPreference' as +-- specific per-package 'PackageVersionPreference'. +-- +interpretPackagesPreference :: Set PackageName + -> PackagesPreferenceDefault + -> [PackagePreference] + -> (PackageName -> PackagePreferences) +interpretPackagesPreference selected defaultPref prefs = + \pkgname -> PackagePreferences (versionPref pkgname) + (installPref pkgname) + (stanzasPref pkgname) + where + versionPref pkgname = + fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs) + versionPrefs = Map.fromListWith (++) + [(pkgname, [pref]) + | PackageVersionPreference pkgname pref <- prefs] + + installPref pkgname = + fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) + installPrefs = Map.fromList + [ (pkgname, pref) + | PackageInstalledPreference pkgname pref <- prefs ] + installPrefDefault = case defaultPref of + PreferAllLatest -> const PreferLatest + PreferAllInstalled -> const PreferInstalled + PreferLatestForSelected -> \pkgname -> + -- When you say cabal install foo, what you really mean is, prefer the + -- latest version of foo, but the installed version of everything else + if pkgname `Set.member` selected then PreferLatest + else PreferInstalled + + stanzasPref pkgname = + fromMaybe [] (Map.lookup pkgname stanzasPrefs) + stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b)) + [ (pkgname, pref) + | PackageStanzasPreference pkgname pref <- prefs ] + + +-- ------------------------------------------------------------ +-- * Checking the result of the solver +-- ------------------------------------------------------------ + +-- | Make an install plan from the output of the dep resolver. +-- It checks that the plan is valid, or it's an error in the dep resolver. +-- +validateSolverResult :: Platform + -> CompilerInfo + -> IndependentGoals + -> [ResolverPackage UnresolvedPkgLoc] + -> SolverInstallPlan +validateSolverResult platform comp indepGoals pkgs = + case planPackagesProblems platform comp pkgs of + [] -> case SolverInstallPlan.new indepGoals graph of + Right plan -> plan + Left problems -> error (formatPlanProblems problems) + problems -> error (formatPkgProblems problems) + + where + graph = Graph.fromDistinctList pkgs + + formatPkgProblems = formatProblemMessage . map showPlanPackageProblem + formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem + + formatProblemMessage problems = + unlines $ + "internal error: could not construct a valid install plan." + : "The proposed (invalid) plan contained the following problems:" + : problems + ++ "Proposed plan:" + : [SolverInstallPlan.showPlanIndex pkgs] + + +data PlanPackageProblem = + InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) + [PackageProblem] + | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc] + +showPlanPackageProblem :: PlanPackageProblem -> String +showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) = + "Package " ++ prettyShow (packageId pkg) + ++ " has an invalid configuration, in particular:\n" + ++ unlines [ " " ++ showPackageProblem problem + | problem <- packageProblems ] +showPlanPackageProblem (DuplicatePackageSolverId pid dups) = + "Package " ++ prettyShow (packageId pid) ++ " has " + ++ show (length dups) ++ " duplicate instances." + +planPackagesProblems :: Platform -> CompilerInfo + -> [ResolverPackage UnresolvedPkgLoc] + -> [PlanPackageProblem] +planPackagesProblems platform cinfo pkgs = + [ InvalidConfiguredPackage pkg packageProblems + | Configured pkg <- pkgs + , let packageProblems = configuredPackageProblems platform cinfo pkg + , not (null packageProblems) ] + ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups + | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ] + +data PackageProblem = DuplicateFlag PD.FlagName + | MissingFlag PD.FlagName + | ExtraFlag PD.FlagName + | DuplicateDeps [PackageId] + | MissingDep Dependency + | ExtraDep PackageId + | InvalidDep Dependency PackageId + +showPackageProblem :: PackageProblem -> String +showPackageProblem (DuplicateFlag flag) = + "duplicate flag in the flag assignment: " ++ PD.unFlagName flag + +showPackageProblem (MissingFlag flag) = + "missing an assignment for the flag: " ++ PD.unFlagName flag + +showPackageProblem (ExtraFlag flag) = + "extra flag given that is not used by the package: " ++ PD.unFlagName flag + +showPackageProblem (DuplicateDeps pkgids) = + "duplicate packages specified as selected dependencies: " + ++ intercalate ", " (map prettyShow pkgids) + +showPackageProblem (MissingDep dep) = + "the package has a dependency " ++ prettyShow dep + ++ " but no package has been selected to satisfy it." + +showPackageProblem (ExtraDep pkgid) = + "the package configuration specifies " ++ prettyShow pkgid + ++ " but (with the given flag assignment) the package does not actually" + ++ " depend on any version of that package." + +showPackageProblem (InvalidDep dep pkgid) = + "the package depends on " ++ prettyShow dep + ++ " but the configuration specifies " ++ prettyShow pkgid + ++ " which does not satisfy the dependency." + +-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if +-- in the configuration given by the flag assignment, all the package +-- dependencies are satisfied by the specified packages. +-- +configuredPackageProblems :: Platform -> CompilerInfo + -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] +configuredPackageProblems platform cinfo + (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = + [ DuplicateFlag flag + | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] + ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] + ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] + ++ [ DuplicateDeps pkgs + | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName)) + specifiedDeps1) ] + ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] + ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] + ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps + , not (packageSatisfiesDependency pkgid dep) ] + -- TODO: sanity tests on executable deps + where + thisPkgName = packageName (srcpkgDescription pkg) + + specifiedDeps1 :: ComponentDeps [PackageId] + specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0 + + specifiedDeps :: [PackageId] + specifiedDeps = CD.flatDeps specifiedDeps1 + + mergedFlags = mergeBy compare + (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg))) + (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO + + packageSatisfiesDependency + (PackageIdentifier name version) + (Dependency name' versionRange _) = assert (name == name') $ + version `withinRange` versionRange + + dependencyName (Dependency name _ _) = name + + mergedDeps :: [MergeResult Dependency PackageId] + mergedDeps = mergeDeps requiredDeps specifiedDeps + + mergeDeps :: [Dependency] -> [PackageId] + -> [MergeResult Dependency PackageId] + mergeDeps required specified = + let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in + mergeBy + (\dep pkgid -> dependencyName dep `compare` packageName pkgid) + (sortNubOn dependencyName required) + (sortNubOn packageName specified) + + compSpec = enableStanzas stanzas + -- TODO: It would be nicer to use ComponentDeps here so we can be more + -- precise in our checks. In fact, this no longer relies on buildDepends and + -- thus should be easier to fix. As long as we _do_ use a flat list here, we + -- have to allow for duplicates when we fold specifiedDeps; once we have + -- proper ComponentDeps here we should get rid of the `nubOn` in + -- `mergeDeps`. + requiredDeps :: [Dependency] + requiredDeps = + --TODO: use something lower level than finalizePD + case finalizePD specifiedFlags + compSpec + (const True) + platform cinfo + [] + (srcpkgDescription pkg) of + Right (resolvedPkg, _) -> + -- we filter self/internal dependencies. They are still there. + -- This is INCORRECT. + -- + -- If we had per-component solver, it would make this unnecessary, + -- but no finalizePDs picks components we are not building, eg. exes. + -- See #3775 + -- + filter ((/= thisPkgName) . dependencyName) + (PD.enabledBuildDepends resolvedPkg compSpec) + ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg) + Left _ -> + error "configuredPackageInvalidDeps internal error" + + +-- ------------------------------------------------------------ +-- * Simple resolver that ignores dependencies +-- ------------------------------------------------------------ + +-- | A simplistic method of resolving a list of target package names to +-- available packages. +-- +-- Specifically, it does not consider package dependencies at all. Unlike +-- 'resolveDependencies', no attempt is made to ensure that the selected +-- packages have dependencies that are satisfiable or consistent with +-- each other. +-- +-- It is suitable for tasks such as selecting packages to download for user +-- inspection. It is not suitable for selecting packages to install. +-- +-- Note: if no installed package index is available, it is OK to pass 'mempty'. +-- It simply means preferences for installed packages will be ignored. +-- +resolveWithoutDependencies :: DepResolverParams + -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] +resolveWithoutDependencies (DepResolverParams targets constraints + prefs defpref installedPkgIndex sourcePkgIndex + _reorderGoals _countConflicts _fineGrained + _minimizeConflictSet _indGoals _avoidReinstalls + _shadowing _strFlags _maxBjumps _enableBj _solveExes + _allowBootLibInstalls _onlyConstrained _order _verbosity) = + collectEithers $ map selectPackage (Set.toList targets) + where + selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage + selectPackage pkgname + | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions + | otherwise = Right $! maximumBy bestByPrefs choices + + where + -- Constraints + requiredVersions = packageConstraints pkgname + choices = PackageIndex.lookupDependency sourcePkgIndex + pkgname + requiredVersions + + -- Preferences + PackagePreferences preferredVersions preferInstalled _ + = packagePreferences pkgname + + bestByPrefs = comparing $ \pkg -> + (installPref pkg, versionPref pkg, packageVersion pkg) + installPref = case preferInstalled of + PreferLatest -> const False + PreferInstalled -> not . null + . InstalledPackageIndex.lookupSourcePackageId + installedPkgIndex + . packageId + versionPref pkg = length . filter (packageVersion pkg `withinRange`) $ + preferredVersions + + packageConstraints :: PackageName -> VersionRange + packageConstraints pkgname = + Map.findWithDefault anyVersion pkgname packageVersionConstraintMap + packageVersionConstraintMap = + let pcs = map unlabelPackageConstraint constraints + in Map.fromList [ (scopeToPackageName scope, range) + | PackageConstraint + scope (PackagePropertyVersion range) <- pcs ] + + packagePreferences :: PackageName -> PackagePreferences + packagePreferences = interpretPackagesPreference targets defpref prefs + + +collectEithers :: [Either a b] -> Either [a] [b] +collectEithers = collect . partitionEithers + where + collect ([], xs) = Right xs + collect (errs,_) = Left errs + +-- | Errors for 'resolveWithoutDependencies'. +-- +data ResolveNoDepsError = + + -- | A package name which cannot be resolved to a specific package. + -- Also gives the constraint on the version and whether there was + -- a constraint on the package being installed. + ResolveUnsatisfiable PackageName VersionRange + +instance Show ResolveNoDepsError where + show (ResolveUnsatisfiable name ver) = + "There is no available version of " ++ prettyShow name + ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver) diff --git a/src/Distribution/Client/Dependency/Types.hs b/src/Distribution/Client/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Dependency/Types.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Dependency.Types ( + PreSolver(..), + Solver(..), + PackagesPreferenceDefault(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Text.PrettyPrint (text) + +import qualified Distribution.Compat.CharParsing as P + + +-- | All the solvers that can be selected. +data PreSolver = AlwaysModular + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + +-- | All the solvers that can be used. +data Solver = Modular + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + +instance Binary PreSolver +instance Binary Solver + +instance Structured PreSolver +instance Structured Solver + +instance Pretty PreSolver where + pretty AlwaysModular = text "modular" + +instance Parsec PreSolver where + parsec = do + name <- P.munch1 isAlpha + case map toLower name of + "modular" -> return AlwaysModular + _ -> P.unexpected $ "PreSolver: " ++ name + +-- | Global policy for all packages to say if we prefer package versions that +-- are already installed locally or if we just prefer the latest available. +-- +data PackagesPreferenceDefault = + + -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + -- + PreferAllLatest + + -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest source version). + | PreferAllInstalled + + -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + -- + | PreferLatestForSelected + deriving Show diff --git a/src/Distribution/Client/DistDirLayout.hs b/src/Distribution/Client/DistDirLayout.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/DistDirLayout.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- +-- The layout of the .\/dist\/ directory where cabal keeps all of its state +-- and build artifacts. +-- +module Distribution.Client.DistDirLayout ( + -- * 'DistDirLayout' + DistDirLayout(..), + DistDirParams(..), + defaultDistDirLayout, + ProjectRoot(..), + + -- * 'StoreDirLayout' + StoreDirLayout(..), + defaultStoreDirLayout, + + -- * 'CabalDirLayout' + CabalDirLayout(..), + mkCabalDirLayout, + defaultCabalDirLayout +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import System.FilePath + +import Distribution.Package + ( PackageId, ComponentId, UnitId ) +import Distribution.Compiler +import Distribution.Simple.Compiler + ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Distribution.System + + +-- | Information which can be used to construct the path to +-- the build directory of a build. This is LESS fine-grained +-- than what goes into the hashed 'InstalledPackageId', +-- and for good reason: we don't want this path to change if +-- the user, say, adds a dependency to their project. +data DistDirParams = DistDirParams { + distParamUnitId :: UnitId, + distParamPackageId :: PackageId, + distParamComponentId :: ComponentId, + distParamComponentName :: Maybe ComponentName, + distParamCompilerId :: CompilerId, + distParamPlatform :: Platform, + distParamOptimization :: OptimisationLevel + -- TODO (see #3343): + -- Flag assignments + -- Optimization + } + + +-- | The layout of the project state directory. Traditionally this has been +-- called the @dist@ directory. +-- +data DistDirLayout = DistDirLayout { + + -- | The root directory of the project. Many other files are relative to + -- this location. In particular, the @cabal.project@ lives here. + -- + distProjectRootDirectory :: FilePath, + + -- | The @cabal.project@ file and related like @cabal.project.freeze@. + -- The parameter is for the extension, like \"freeze\", or \"\" for the + -- main file. + -- + distProjectFile :: String -> FilePath, + + -- | The \"dist\" directory, which is the root of where cabal keeps all + -- its state including the build artifacts from each package we build. + -- + distDirectory :: FilePath, + + -- | The directory under dist where we keep the build artifacts for a + -- package we're building from a local directory. + -- + -- This uses a 'UnitId' not just a 'PackageName' because technically + -- we can have multiple instances of the same package in a solution + -- (e.g. setup deps). + -- + distBuildDirectory :: DistDirParams -> FilePath, + distBuildRootDirectory :: FilePath, + + -- | The directory under dist where we download tarballs and source + -- control repos to. + -- + distDownloadSrcDirectory :: FilePath, + + -- | The directory under dist where we put the unpacked sources of + -- packages, in those cases where it makes sense to keep the build + -- artifacts to reduce rebuild times. + -- + distUnpackedSrcDirectory :: PackageId -> FilePath, + distUnpackedSrcRootDirectory :: FilePath, + + -- | The location for project-wide cache files (e.g. state used in + -- incremental rebuilds). + -- + distProjectCacheFile :: String -> FilePath, + distProjectCacheDirectory :: FilePath, + + -- | The location for package-specific cache files (e.g. state used in + -- incremental rebuilds). + -- + distPackageCacheFile :: DistDirParams -> String -> FilePath, + distPackageCacheDirectory :: DistDirParams -> FilePath, + + -- | The location that sdists are placed by default. + distSdistFile :: PackageId -> FilePath, + distSdistDirectory :: FilePath, + + distTempDirectory :: FilePath, + distBinDirectory :: FilePath, + + distPackageDB :: CompilerId -> PackageDB + } + + +-- | The layout of a cabal nix-style store. +-- +data StoreDirLayout = StoreDirLayout { + storeDirectory :: CompilerId -> FilePath, + storePackageDirectory :: CompilerId -> UnitId -> FilePath, + storePackageDBPath :: CompilerId -> FilePath, + storePackageDB :: CompilerId -> PackageDB, + storePackageDBStack :: CompilerId -> PackageDBStack, + storeIncomingDirectory :: CompilerId -> FilePath, + storeIncomingLock :: CompilerId -> UnitId -> FilePath + } + + +--TODO: move to another module, e.g. CabalDirLayout? +-- or perhaps rename this module to DirLayouts. + +-- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir +-- on unix, and equivalents on other systems. +-- +-- At the moment this is just a partial specification, but the idea is +-- eventually to cover it all. +-- +data CabalDirLayout = CabalDirLayout { + cabalStoreDirLayout :: StoreDirLayout, + + cabalLogsDirectory :: FilePath, + cabalWorldFile :: FilePath + } + + +-- | Information about the root directory of the project. +-- +-- It can either be an implicit project root in the current dir if no +-- @cabal.project@ file is found, or an explicit root if the file is found. +-- +data ProjectRoot = + -- | -- ^ An implicit project root. It contains the absolute project + -- root dir. + ProjectRootImplicit FilePath + + -- | -- ^ An explicit project root. It contains the absolute project + -- root dir and the relative @cabal.project@ file (or explicit override) + | ProjectRootExplicit FilePath FilePath + deriving (Eq, Show) + +-- | Make the default 'DistDirLayout' based on the project root dir and +-- optional overrides for the location of the @dist@ directory and the +-- @cabal.project@ file. +-- +defaultDistDirLayout :: ProjectRoot -- ^ the project root + -> Maybe FilePath -- ^ the @dist@ directory or default + -- (absolute or relative to the root) + -> DistDirLayout +defaultDistDirLayout projectRoot mdistDirectory = + DistDirLayout {..} + where + (projectRootDir, projectFile) = case projectRoot of + ProjectRootImplicit dir -> (dir, dir "cabal.project") + ProjectRootExplicit dir file -> (dir, dir file) + + distProjectRootDirectory = projectRootDir + distProjectFile ext = projectFile <.> ext + + distDirectory = distProjectRootDirectory + fromMaybe "dist-newstyle" mdistDirectory + --TODO: switch to just dist at some point, or some other new name + + distBuildRootDirectory = distDirectory "build" + distBuildDirectory params = + distBuildRootDirectory + prettyShow (distParamPlatform params) + prettyShow (distParamCompilerId params) + prettyShow (distParamPackageId params) + (case distParamComponentName params of + Nothing -> "" + Just (CLibName LMainLibName) -> "" + Just (CLibName (LSubLibName name)) -> "l" prettyShow name + Just (CFLibName name) -> "f" prettyShow name + Just (CExeName name) -> "x" prettyShow name + Just (CTestName name) -> "t" prettyShow name + Just (CBenchName name) -> "b" prettyShow name) + (case distParamOptimization params of + NoOptimisation -> "noopt" + NormalOptimisation -> "" + MaximumOptimisation -> "opt") + (let uid_str = prettyShow (distParamUnitId params) + in if uid_str == prettyShow (distParamComponentId params) + then "" + else uid_str) + + distUnpackedSrcRootDirectory = distDirectory "src" + distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory + prettyShow pkgid + -- we shouldn't get name clashes so this should be fine: + distDownloadSrcDirectory = distUnpackedSrcRootDirectory + + distProjectCacheDirectory = distDirectory "cache" + distProjectCacheFile name = distProjectCacheDirectory name + + distPackageCacheDirectory params = distBuildDirectory params "cache" + distPackageCacheFile params name = distPackageCacheDirectory params name + + distSdistFile pid = distSdistDirectory prettyShow pid <.> "tar.gz" + + distSdistDirectory = distDirectory "sdist" + + distTempDirectory = distDirectory "tmp" + + distBinDirectory = distDirectory "bin" + + distPackageDBPath compid = distDirectory "packagedb" prettyShow compid + distPackageDB = SpecificPackageDB . distPackageDBPath + + +defaultStoreDirLayout :: FilePath -> StoreDirLayout +defaultStoreDirLayout storeRoot = + StoreDirLayout {..} + where + storeDirectory compid = + storeRoot prettyShow compid + + storePackageDirectory compid ipkgid = + storeDirectory compid prettyShow ipkgid + + storePackageDBPath compid = + storeDirectory compid "package.db" + + storePackageDB compid = + SpecificPackageDB (storePackageDBPath compid) + + storePackageDBStack compid = + [GlobalPackageDB, storePackageDB compid] + + storeIncomingDirectory compid = + storeDirectory compid "incoming" + + storeIncomingLock compid unitid = + storeIncomingDirectory compid prettyShow unitid <.> "lock" + + +defaultCabalDirLayout :: FilePath -> CabalDirLayout +defaultCabalDirLayout cabalDir = + mkCabalDirLayout cabalDir Nothing Nothing + +mkCabalDirLayout :: FilePath -- ^ Cabal directory + -> Maybe FilePath -- ^ Store directory. Must be absolute + -> Maybe FilePath -- ^ Log directory + -> CabalDirLayout +mkCabalDirLayout cabalDir mstoreDir mlogDir = + CabalDirLayout {..} + where + cabalStoreDirLayout = + defaultStoreDirLayout (fromMaybe (cabalDir "store") mstoreDir) + cabalLogsDirectory = fromMaybe (cabalDir "logs") mlogDir + cabalWorldFile = cabalDir "world" diff --git a/src/Distribution/Client/Fetch.hs b/src/Distribution/Client/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Fetch.hs @@ -0,0 +1,232 @@ +------------------------------------------------------------------------------- | +-- Module : Distribution.Client.Fetch +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The cabal fetch command +----------------------------------------------------------------------------- +module Distribution.Client.Fetch ( + fetch, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.FetchUtils hiding (fetchPackage) +import Distribution.Client.Dependency +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Setup + ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage + +import Distribution.Package + ( packageId ) +import Distribution.Simple.Compiler + ( Compiler, compilerInfo, PackageDBStack ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Program + ( ProgramDb ) +import Distribution.Simple.Setup + ( fromFlag, fromFlagOrDefault ) +import Distribution.Simple.Utils + ( die', notice, debug ) +import Distribution.System + ( Platform ) + +-- ------------------------------------------------------------ +-- * The fetch command +-- ------------------------------------------------------------ + +--TODO: +-- * add fetch -o support +-- * support tarball URLs via ad-hoc download cache (or in -o mode?) +-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied +-- * Port various flags from install: +-- * --updage-dependencies +-- * --constraint and --preference +-- * --only-dependencies, but note it conflicts with --no-deps + + +-- | Fetch a list of packages and their dependencies. +-- +fetch :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FetchFlags + -> [UserTarget] + -> IO () +fetch verbosity _ _ _ _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +fetch verbosity packageDBs repoCtxt comp platform progdb + globalFlags fetchFlags userTargets = do + + traverse_ (checkTarget verbosity) userTargets + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb + + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + userTargets + + pkgs <- planPackages + verbosity comp platform fetchFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + + pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs + if null pkgs' + --TODO: when we add support for remote tarballs then this message + -- will need to be changed because for remote tarballs we fetch them + -- at the earlier phase. + then notice verbosity $ "No packages need to be fetched. " + ++ "All the requested packages are already local " + ++ "or cached locally." + else if dryRun + then notice verbosity $ unlines $ + "The following packages would be fetched:" + : map (prettyShow . packageId) pkgs' + + else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs' + + where + dryRun = fromFlag (fetchDryRun fetchFlags) + +planPackages :: Verbosity + -> Compiler + -> Platform + -> FetchFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO [UnresolvedSourcePackage] +planPackages verbosity comp platform fetchFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + + | includeDependencies = do + solver <- chooseSolver verbosity + (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) + notice verbosity "Resolving dependencies..." + installPlan <- foldProgress logMsg (die' verbosity) return $ + resolveDependencies + platform (compilerInfo comp) pkgConfigDb + solver + resolverParams + + -- The packages we want to fetch are those packages the 'InstallPlan' + -- that are in the 'InstallPlan.Configured' state. + return + [ solverPkgSource cpkg + | (SolverInstallPlan.Configured cpkg) + <- SolverInstallPlan.toList installPlan ] + + | otherwise = + either (die' verbosity . unlines . map show) return $ + resolveWithoutDependencies resolverParams + + where + resolverParams = + + setMaxBackjumps (if maxBackjumps < 0 then Nothing + else Just maxBackjumps) + + . setIndependentGoals independentGoals + + . setReorderGoals reorderGoals + + . setCountConflicts countConflicts + + . setFineGrainedConflicts fineGrainedConflicts + + . setMinimizeConflictSet minimizeConflictSet + + . setShadowPkgs shadowPkgs + + . setStrongFlags strongFlags + + . setAllowBootLibInstalls allowBootLibInstalls + + . setOnlyConstrained onlyConstrained + + . setSolverVerbosity verbosity + + . addConstraints + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | pkgSpecifier <- pkgSpecifiers ] + + -- Reinstall the targets given on the command line so that the dep + -- resolver will decide that they need fetching, even if they're + -- already installed. Since we want to get the source packages of + -- things we might have installed (but not have the sources for). + . reinstallTargets + + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + includeDependencies = fromFlag (fetchDeps fetchFlags) + logMsg message rest = debug verbosity message >> rest + + stanzas = [ TestStanzas | testsEnabled ] + ++ [ BenchStanzas | benchmarksEnabled ] + testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags + benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags + + reorderGoals = fromFlag (fetchReorderGoals fetchFlags) + countConflicts = fromFlag (fetchCountConflicts fetchFlags) + fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) + minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) + independentGoals = fromFlag (fetchIndependentGoals fetchFlags) + shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) + strongFlags = fromFlag (fetchStrongFlags fetchFlags) + maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) + allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) + onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags) + + +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of + UserTargetRemoteTarball _uri + -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + _ -> return () + +fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO () +fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of + LocalUnpackedPackage _dir -> return () + LocalTarballPackage _file -> return () + + RemoteTarballPackage _uri _ -> + die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + + RemoteSourceRepoPackage _repo _ -> + die' verbosity $ "The 'fetch' command does not yet support remote " + ++ "source repositores." + + RepoTarballPackage repo pkgid _ -> do + _ <- fetchRepoTarball verbosity repoCtxt repo pkgid + return () diff --git a/src/Distribution/Client/FetchUtils.hs b/src/Distribution/Client/FetchUtils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/FetchUtils.hs @@ -0,0 +1,317 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.FetchUtils +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Functions for fetching packages +----------------------------------------------------------------------------- +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.FetchUtils ( + + -- * fetching packages + fetchPackage, + isFetched, + checkFetched, + + -- ** specifically for repo packages + checkRepoTarballFetched, + fetchRepoTarball, + + -- ** fetching packages asynchronously + asyncFetchPackages, + waitAsyncFetchPackage, + AsyncFetchMap, + + -- * fetching other things + downloadIndex, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types +import Distribution.Client.HttpUtils + ( downloadURI, isOldHackageURI, DownloadResult(..) + , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps ) + +import Distribution.Package + ( PackageId, packageName, packageVersion ) +import Distribution.Simple.Utils + ( notice, info, debug, die' ) +import Distribution.Verbosity + ( verboseUnmarkOutput ) +import Distribution.Client.GlobalFlags + ( RepoContext(..) ) +import Distribution.Client.Utils + ( ProgressPhase(..), progressMessage ) + +import qualified Data.Map as Map +import Control.Exception +import Control.Concurrent.Async +import Control.Concurrent.MVar +import System.Directory + ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) +import System.IO + ( openTempFile, hClose ) +import System.FilePath + ( (), (<.>) ) +import qualified System.FilePath.Posix as FilePath.Posix + ( combine, joinPath ) +import Network.URI + ( URI(uriPath) ) + +import qualified Hackage.Security.Client as Sec + +-- ------------------------------------------------------------ +-- * Actually fetch things +-- ------------------------------------------------------------ + +-- | Returns @True@ if the package has already been fetched +-- or does not need fetching. +-- +isFetched :: UnresolvedPkgLoc -> IO Bool +isFetched loc = case loc of + LocalUnpackedPackage _dir -> return True + LocalTarballPackage _file -> return True + RemoteTarballPackage _uri local -> return (isJust local) + RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) + RemoteSourceRepoPackage _ local -> return (isJust local) + + +-- | Checks if the package has already been fetched (or does not need +-- fetching) and if so returns evidence in the form of a 'PackageLocation' +-- with a resolved local file location. +-- +checkFetched :: UnresolvedPkgLoc + -> IO (Maybe ResolvedPkgLoc) +checkFetched loc = case loc of + LocalUnpackedPackage dir -> + return (Just $ LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (Just $ LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (Just $ RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (Just $ RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just file) -> + return (Just $ RemoteSourceRepoPackage repo file) + + RemoteTarballPackage _uri Nothing -> return Nothing + RemoteSourceRepoPackage _repo Nothing -> return Nothing + RepoTarballPackage repo pkgid Nothing -> + fmap (fmap (RepoTarballPackage repo pkgid)) + (checkRepoTarballFetched repo pkgid) + +-- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'. +-- +checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath) +checkRepoTarballFetched repo pkgid = do + let file = packageFile repo pkgid + exists <- doesFileExist file + if exists + then return (Just file) + else return Nothing + + +-- | Fetch a package if we don't have it already. +-- +fetchPackage :: Verbosity + -> RepoContext + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc +fetchPackage verbosity repoCtxt loc = case loc of + LocalUnpackedPackage dir -> + return (LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just dir) -> + return (RemoteSourceRepoPackage repo dir) + + RemoteTarballPackage uri Nothing -> do + path <- downloadTarballPackage uri + return (RemoteTarballPackage uri path) + RepoTarballPackage repo pkgid Nothing -> do + local <- fetchRepoTarball verbosity repoCtxt repo pkgid + return (RepoTarballPackage repo pkgid local) + RemoteSourceRepoPackage _repo Nothing -> + die' verbosity "fetchPackage: source repos not supported" + where + downloadTarballPackage uri = do + transport <- repoContextGetTransport repoCtxt + transportCheckHttps verbosity transport uri + notice verbosity ("Downloading " ++ show uri) + tmpdir <- getTemporaryDirectory + (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" + hClose hnd + _ <- downloadURI transport verbosity uri path + return path + + +-- | Fetch a repo package if we don't have it already. +-- +fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath +fetchRepoTarball verbosity' repoCtxt repo pkgid = do + fetched <- doesFileExist (packageFile repo pkgid) + if fetched + then do info verbosity $ prettyShow pkgid ++ " has already been downloaded." + return (packageFile repo pkgid) + else do progressMessage verbosity ProgressDownloading (prettyShow pkgid) + res <- downloadRepoPackage + progressMessage verbosity ProgressDownloaded (prettyShow pkgid) + return res + where + -- whether we download or not is non-deterministic + verbosity = verboseUnmarkOutput verbosity' + + downloadRepoPackage = case repo of + RepoLocalNoIndex{} -> return (packageFile repo pkgid) + + RepoRemote{..} -> do + transport <- repoContextGetTransport repoCtxt + remoteRepoCheckHttps verbosity transport repoRemote + let uri = packageURI repoRemote pkgid + dir = packageDir repo pkgid + path = packageFile repo pkgid + createDirectoryIfMissing True dir + _ <- downloadURI transport verbosity uri path + return path + + RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do + let dir = packageDir repo pkgid + path = packageFile repo pkgid + createDirectoryIfMissing True dir + Sec.uncheckClientErrors $ do + info verbosity ("Writing " ++ path) + Sec.downloadPackage' rep pkgid path + return path + +-- | Downloads an index file to [config-dir/packages/serv-id] without +-- hackage-security. You probably don't want to call this directly; +-- use 'updateRepo' instead. +-- +downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult +downloadIndex transport verbosity remoteRepo cacheDir = do + remoteRepoCheckHttps verbosity transport remoteRepo + let uri = (remoteRepoURI remoteRepo) { + uriPath = uriPath (remoteRepoURI remoteRepo) + `FilePath.Posix.combine` "00-index.tar.gz" + } + path = cacheDir "00-index" <.> "tar.gz" + createDirectoryIfMissing True cacheDir + downloadURI transport verbosity uri path + + +-- ------------------------------------------------------------ +-- * Async fetch wrapper utilities +-- ------------------------------------------------------------ + +type AsyncFetchMap = Map UnresolvedPkgLoc + (MVar (Either SomeException ResolvedPkgLoc)) + +-- | Fork off an async action to download the given packages (by location). +-- +-- The downloads are initiated in order, so you can arrange for packages that +-- will likely be needed sooner to be earlier in the list. +-- +-- The body action is passed a map from those packages (identified by their +-- location) to a completion var for that package. So the body action should +-- lookup the location and use 'asyncFetchPackage' to get the result. +-- +asyncFetchPackages :: Verbosity + -> RepoContext + -> [UnresolvedPkgLoc] + -> (AsyncFetchMap -> IO a) + -> IO a +asyncFetchPackages verbosity repoCtxt pkglocs body = do + --TODO: [nice to have] use parallel downloads? + + asyncDownloadVars <- sequenceA + [ do v <- newEmptyMVar + return (pkgloc, v) + | pkgloc <- pkglocs + ] + + let fetchPackages :: IO () + fetchPackages = + for_ asyncDownloadVars $ \(pkgloc, var) -> do + -- Suppress marking here, because 'withAsync' means + -- that we get nondeterministic interleaving + result <- try $ fetchPackage (verboseUnmarkOutput verbosity) + repoCtxt pkgloc + putMVar var result + + withAsync fetchPackages $ \_ -> + body (Map.fromList asyncDownloadVars) + + +-- | Expect to find a download in progress in the given 'AsyncFetchMap' +-- and wait on it to finish. +-- +-- If the download failed with an exception then this will be thrown. +-- +-- Note: This function is supposed to be idempotent, as our install plans +-- can now use the same tarball for many builds, e.g. different +-- components and/or qualified goals, and these all go through the +-- download phase so we end up using 'waitAsyncFetchPackage' twice on +-- the same package. C.f. #4461. +waitAsyncFetchPackage :: Verbosity + -> AsyncFetchMap + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc +waitAsyncFetchPackage verbosity downloadMap srcloc = + case Map.lookup srcloc downloadMap of + Just hnd -> do + debug verbosity $ "Waiting for download of " ++ show srcloc + either throwIO return =<< readMVar hnd + Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" + + +-- ------------------------------------------------------------ +-- * Path utilities +-- ------------------------------------------------------------ + +-- | Generate the full path to the locally cached copy of +-- the tarball for a given @PackageIdentifer@. +-- +packageFile :: Repo -> PackageId -> FilePath +packageFile repo pkgid = packageDir repo pkgid + prettyShow pkgid + <.> "tar.gz" + +-- | Generate the full path to the directory where the local cached copy of +-- the tarball for a given @PackageIdentifer@ is stored. +-- +packageDir :: Repo -> PackageId -> FilePath +packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir +packageDir repo pkgid = repoLocalDir repo + prettyShow (packageName pkgid) + prettyShow (packageVersion pkgid) + +-- | Generate the URI of the tarball for a given package. +-- +packageURI :: RemoteRepo -> PackageId -> URI +packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,prettyShow (packageName pkgid) + ,prettyShow (packageVersion pkgid) + ,prettyShow pkgid <.> "tar.gz"] + } +packageURI repo pkgid = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,"package" + ,prettyShow pkgid <.> "tar.gz"] + } diff --git a/src/Distribution/Client/FileMonitor.hs b/src/Distribution/Client/FileMonitor.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/FileMonitor.hs @@ -0,0 +1,1162 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, + NamedFieldPuns, BangPatterns, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | An abstraction to help with re-running actions when files or other +-- input values they depend on have changed. +-- +module Distribution.Client.FileMonitor ( + + -- * Declaring files to monitor + MonitorFilePath(..), + MonitorKindFile(..), + MonitorKindDir(..), + FilePathGlob(..), + monitorFile, + monitorFileHashed, + monitorNonExistentFile, + monitorFileExistence, + monitorDirectory, + monitorNonExistentDirectory, + monitorDirectoryExistence, + monitorFileOrDirectory, + monitorFileGlob, + monitorFileGlobExistence, + monitorFileSearchPath, + monitorFileHashedSearchPath, + + -- * Creating and checking sets of monitored files + FileMonitor(..), + newFileMonitor, + MonitorChanged(..), + MonitorChangedReason(..), + checkFileMonitorChanged, + updateFileMonitor, + MonitorTimestamp, + beginUpdateFileMonitor, + + -- * Internal + MonitorStateFileSet, + MonitorStateFile, + MonitorStateGlob, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import qualified Distribution.Compat.Binary as Binary + +import qualified Data.Map.Strict as Map +import Data.Binary.Get (runGetOrFail) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Hashable as Hashable + +import Control.Monad +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad.State (StateT, mapStateT) +import qualified Control.Monad.State as State +import Control.Monad.Except (ExceptT, runExceptT, withExceptT, + throwError) +import Control.Exception + +import Distribution.Compat.Time +import Distribution.Client.Glob +import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) +import Distribution.Client.Utils (mergeBy, MergeResult(..)) +import Distribution.Utils.Structured (structuredEncode, Tag (..)) +import System.FilePath +import System.Directory +import System.IO + +------------------------------------------------------------------------------ +-- Types for specifying files to monitor +-- + + +-- | A description of a file (or set of files) to monitor for changes. +-- +-- Where file paths are relative they are relative to a common directory +-- (e.g. project root), not necessarily the process current directory. +-- +data MonitorFilePath = + MonitorFile { + monitorKindFile :: !MonitorKindFile, + monitorKindDir :: !MonitorKindDir, + monitorPath :: !FilePath + } + | MonitorFileGlob { + monitorKindFile :: !MonitorKindFile, + monitorKindDir :: !MonitorKindDir, + monitorPathGlob :: !FilePathGlob + } + deriving (Eq, Show, Generic) + +data MonitorKindFile = FileExists + | FileModTime + | FileHashed + | FileNotExists + deriving (Eq, Show, Generic) + +data MonitorKindDir = DirExists + | DirModTime + | DirNotExists + deriving (Eq, Show, Generic) + +instance Binary MonitorFilePath +instance Binary MonitorKindFile +instance Binary MonitorKindDir + +instance Structured MonitorFilePath +instance Structured MonitorKindFile +instance Structured MonitorKindDir + +-- | Monitor a single file for changes, based on its modification time. +-- The monitored file is considered to have changed if it no longer +-- exists or if its modification time has changed. +-- +monitorFile :: FilePath -> MonitorFilePath +monitorFile = MonitorFile FileModTime DirNotExists + +-- | Monitor a single file for changes, based on its modification time +-- and content hash. The monitored file is considered to have changed if +-- it no longer exists or if its modification time and content hash have +-- changed. +-- +monitorFileHashed :: FilePath -> MonitorFilePath +monitorFileHashed = MonitorFile FileHashed DirNotExists + +-- | Monitor a single non-existent file for changes. The monitored file +-- is considered to have changed if it exists. +-- +monitorNonExistentFile :: FilePath -> MonitorFilePath +monitorNonExistentFile = MonitorFile FileNotExists DirNotExists + +-- | Monitor a single file for existence only. The monitored file is +-- considered to have changed if it no longer exists. +-- +monitorFileExistence :: FilePath -> MonitorFilePath +monitorFileExistence = MonitorFile FileExists DirNotExists + +-- | Monitor a single directory for changes, based on its modification +-- time. The monitored directory is considered to have changed if it no +-- longer exists or if its modification time has changed. +-- +monitorDirectory :: FilePath -> MonitorFilePath +monitorDirectory = MonitorFile FileNotExists DirModTime + +-- | Monitor a single non-existent directory for changes. The monitored +-- directory is considered to have changed if it exists. +-- +monitorNonExistentDirectory :: FilePath -> MonitorFilePath +-- Just an alias for monitorNonExistentFile, since you can't +-- tell the difference between a non-existent directory and +-- a non-existent file :) +monitorNonExistentDirectory = monitorNonExistentFile + +-- | Monitor a single directory for existence. The monitored directory is +-- considered to have changed only if it no longer exists. +-- +monitorDirectoryExistence :: FilePath -> MonitorFilePath +monitorDirectoryExistence = MonitorFile FileNotExists DirExists + +-- | Monitor a single file or directory for changes, based on its modification +-- time. The monitored file is considered to have changed if it no longer +-- exists or if its modification time has changed. +-- +monitorFileOrDirectory :: FilePath -> MonitorFilePath +monitorFileOrDirectory = MonitorFile FileModTime DirModTime + +-- | Monitor a set of files (or directories) identified by a file glob. +-- The monitored glob is considered to have changed if the set of files +-- matching the glob changes (i.e. creations or deletions), or for files if the +-- modification time and content hash of any matching file has changed. +-- +monitorFileGlob :: FilePathGlob -> MonitorFilePath +monitorFileGlob = MonitorFileGlob FileHashed DirExists + +-- | Monitor a set of files (or directories) identified by a file glob for +-- existence only. The monitored glob is considered to have changed if the set +-- of files matching the glob changes (i.e. creations or deletions). +-- +monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath +monitorFileGlobExistence = MonitorFileGlob FileExists DirExists + +-- | Creates a list of files to monitor when you search for a file which +-- unsuccessfully looked in @notFoundAtPaths@ before finding it at +-- @foundAtPath@. +monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] +monitorFileSearchPath notFoundAtPaths foundAtPath = + monitorFile foundAtPath + : map monitorNonExistentFile notFoundAtPaths + +-- | Similar to 'monitorFileSearchPath', but also instructs us to +-- monitor the hash of the found file. +monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] +monitorFileHashedSearchPath notFoundAtPaths foundAtPath = + monitorFileHashed foundAtPath + : map monitorNonExistentFile notFoundAtPaths + + +------------------------------------------------------------------------------ +-- Implementation types, files status +-- + +-- | The state necessary to determine whether a set of monitored +-- files has changed. It consists of two parts: a set of specific +-- files to be monitored (index by their path), and a list of +-- globs, which monitor may files at once. +data MonitorStateFileSet + = MonitorStateFileSet ![MonitorStateFile] + ![MonitorStateGlob] + -- Morally this is not actually a set but a bag (represented by lists). + -- There is no principled reason to use a bag here rather than a set, but + -- there is also no particular gain either. That said, we do preserve the + -- order of the lists just to reduce confusion (and have predictable I/O + -- patterns). + deriving (Show, Generic) + +instance Binary MonitorStateFileSet +instance Structured MonitorStateFileSet + +type Hash = Int + +-- | The state necessary to determine whether a monitored file has changed. +-- +-- This covers all the cases of 'MonitorFilePath' except for globs which is +-- covered separately by 'MonitorStateGlob'. +-- +-- The @Maybe ModTime@ is to cover the case where we already consider the +-- file to have changed, either because it had already changed by the time we +-- did the snapshot (i.e. too new, changed since start of update process) or it +-- no longer exists at all. +-- +data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir + !FilePath !MonitorStateFileStatus + deriving (Show, Generic) + +data MonitorStateFileStatus + = MonitorStateFileExists + | MonitorStateFileModTime !ModTime -- ^ cached file mtime + | MonitorStateFileHashed !ModTime !Hash -- ^ cached mtime and content hash + | MonitorStateDirExists + | MonitorStateDirModTime !ModTime -- ^ cached dir mtime + | MonitorStateNonExistent + | MonitorStateAlreadyChanged + deriving (Show, Generic) + +instance Binary MonitorStateFile +instance Binary MonitorStateFileStatus +instance Structured MonitorStateFile +instance Structured MonitorStateFileStatus + +-- | The state necessary to determine whether the files matched by a globbing +-- match have changed. +-- +data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir + !FilePathRoot !MonitorStateGlobRel + deriving (Show, Generic) + +data MonitorStateGlobRel + = MonitorStateGlobDirs + !Glob !FilePathGlobRel + !ModTime + ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted + + | MonitorStateGlobFiles + !Glob + !ModTime + ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted + + | MonitorStateGlobDirTrailing + deriving (Show, Generic) + +instance Binary MonitorStateGlob +instance Binary MonitorStateGlobRel + +instance Structured MonitorStateGlob +instance Structured MonitorStateGlobRel + +-- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by +-- inspecting the state of the file system, and we can go in the reverse +-- direction by just forgetting the extra info. +-- +reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] +reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = + map getSinglePath singlePaths + ++ map getGlobPath globPaths + where + getSinglePath (MonitorStateFile kindfile kinddir filepath _) = + MonitorFile kindfile kinddir filepath + + getGlobPath (MonitorStateGlob kindfile kinddir root gstate) = + MonitorFileGlob kindfile kinddir $ FilePathGlob root $ + case gstate of + MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs + MonitorStateGlobFiles glob _ _ -> GlobFile glob + MonitorStateGlobDirTrailing -> GlobDirTrailing + +------------------------------------------------------------------------------ +-- Checking the status of monitored files +-- + +-- | A monitor for detecting changes to a set of files. It can be used to +-- efficiently test if any of a set of files (specified individually or by +-- glob patterns) has changed since some snapshot. In addition, it also checks +-- for changes in a value (of type @a@), and when there are no changes in +-- either it returns a saved value (of type @b@). +-- +-- The main use case looks like this: suppose we have some expensive action +-- that depends on certain pure inputs and reads some set of files, and +-- produces some pure result. We want to avoid re-running this action when it +-- would produce the same result. So we need to monitor the files the action +-- looked at, the other pure input values, and we need to cache the result. +-- Then at some later point, if the input value didn't change, and none of the +-- files changed, then we can re-use the cached result rather than re-running +-- the action. +-- +-- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance +-- saves state in a disk file, so the file for that has to be specified, +-- making sure it is unique. The pattern is to use 'checkFileMonitorChanged' +-- to see if there's been any change. If there is, re-run the action, keeping +-- track of the files, then use 'updateFileMonitor' to record the current +-- set of files to monitor, the current input value for the action, and the +-- result of the action. +-- +-- The typical occurrence of this pattern is captured by 'rerunIfChanged' +-- and the 'Rebuild' monad. More complicated cases may need to use +-- 'checkFileMonitorChanged' and 'updateFileMonitor' directly. +-- +data FileMonitor a b + = FileMonitor { + + -- | The file where this 'FileMonitor' should store its state. + -- + fileMonitorCacheFile :: FilePath, + + -- | Compares a new cache key with old one to determine if a + -- corresponding cached value is still valid. + -- + -- Typically this is just an equality test, but in some + -- circumstances it can make sense to do things like subset + -- comparisons. + -- + -- The first arg is the new value, the second is the old cached value. + -- + fileMonitorKeyValid :: a -> a -> Bool, + + -- | When this mode is enabled, if 'checkFileMonitorChanged' returns + -- 'MonitoredValueChanged' then we have the guarantee that no files + -- changed, that the value change was the only change. In the default + -- mode no such guarantee is provided which is slightly faster. + -- + fileMonitorCheckIfOnlyValueChanged :: Bool + } + +-- | Define a new file monitor. +-- +-- It's best practice to define file monitor values once, and then use the +-- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this +-- ensures you get the same types @a@ and @b@ for reading and writing. +-- +-- The path of the file monitor itself must be unique because it keeps state +-- on disk and these would clash. +-- +newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the + -- file monitor. Must be unique. + -> FileMonitor a b +newFileMonitor path = FileMonitor path (==) False + +-- | The result of 'checkFileMonitorChanged': either the monitored files or +-- value changed (and it tells us which it was) or nothing changed and we get +-- the cached result. +-- +data MonitorChanged a b = + -- | The monitored files and value did not change. The cached result is + -- @b@. + -- + -- The set of monitored files is also returned. This is useful + -- for composing or nesting 'FileMonitor's. + MonitorUnchanged b [MonitorFilePath] + + -- | The monitor found that something changed. The reason is given. + -- + | MonitorChanged (MonitorChangedReason a) + deriving Show + +-- | What kind of change 'checkFileMonitorChanged' detected. +-- +data MonitorChangedReason a = + + -- | One of the files changed (existence, file type, mtime or file + -- content, depending on the 'MonitorFilePath' in question) + MonitoredFileChanged FilePath + + -- | The pure input value changed. + -- + -- The previous cached key value is also returned. This is sometimes + -- useful when using a 'fileMonitorKeyValid' function that is not simply + -- '(==)', when invalidation can be partial. In such cases it can make + -- sense to 'updateFileMonitor' with a key value that's a combination of + -- the new and old (e.g. set union). + | MonitoredValueChanged a + + -- | There was no saved monitor state, cached value etc. Ie the file + -- for the 'FileMonitor' does not exist. + | MonitorFirstRun + + -- | There was existing state, but we could not read it. This typically + -- happens when the code has changed compared to an existing 'FileMonitor' + -- cache file and type of the input value or cached value has changed such + -- that we cannot decode the values. This is completely benign as we can + -- treat is just as if there were no cache file and re-run. + | MonitorCorruptCache + deriving (Eq, Show, Functor) + +-- | Test if the input value or files monitored by the 'FileMonitor' have +-- changed. If not, return the cached value. +-- +-- See 'FileMonitor' for a full explanation. +-- +checkFileMonitorChanged + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b -- ^ cache file path + -> FilePath -- ^ root directory + -> a -- ^ guard or key value + -> IO (MonitorChanged a b) -- ^ did the key or any paths change? +checkFileMonitorChanged + monitor@FileMonitor { fileMonitorKeyValid, + fileMonitorCheckIfOnlyValueChanged } + root currentKey = + + -- Consider it a change if the cache file does not exist, + -- or we cannot decode it. Sadly ErrorCall can still happen, despite + -- using decodeFileOrFail, e.g. Data.Char.chr errors + + handleDoesNotExist (MonitorChanged MonitorFirstRun) $ + handleErrorCall (MonitorChanged MonitorCorruptCache) $ + withCacheFile monitor $ + either (\_ -> return (MonitorChanged MonitorCorruptCache)) + checkStatusCache + + where + checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do + change <- checkForChanges + case change of + Just reason -> return (MonitorChanged reason) + Nothing -> case cachedResult of + Left _ -> pure (MonitorChanged MonitorCorruptCache) + Right cr -> return (MonitorUnchanged cr monitorFiles) + where monitorFiles = reconstructMonitorFilePaths cachedFileStatus + where + -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that + -- if we return MonitoredValueChanged that only the value changed. + -- We do that by checkin for file changes first. Otherwise it makes + -- more sense to do the cheaper test first. + checkForChanges + | fileMonitorCheckIfOnlyValueChanged + = checkFileChange cachedFileStatus cachedKey cachedResult + `mplusMaybeT` + checkValueChange cachedKey + + | otherwise + = checkValueChange cachedKey + `mplusMaybeT` + checkFileChange cachedFileStatus cachedKey cachedResult + + mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) + mplusMaybeT ma mb = do + mx <- ma + case mx of + Nothing -> mb + Just x -> return (Just x) + + -- Check if the guard value has changed + checkValueChange cachedKey + | not (fileMonitorKeyValid currentKey cachedKey) + = return (Just (MonitoredValueChanged cachedKey)) + | otherwise + = return Nothing + + -- Check if any file has changed + checkFileChange cachedFileStatus cachedKey cachedResult = do + res <- probeFileSystem root cachedFileStatus + case res of + -- Some monitored file has changed + Left changedPath -> + return (Just (MonitoredFileChanged (normalise changedPath))) + + -- No monitored file has changed + Right (cachedFileStatus', cacheStatus) -> do + + -- But we might still want to update the cache + whenCacheChanged cacheStatus $ + case cachedResult of + Left _ -> pure () + Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr + + return Nothing + +-- | Lazily decode a triple, parsing the first two fields strictly and +-- returning a lazy value containing either the last one or an error. +-- This is helpful for cabal cache files where the first two components +-- contain header data that lets one test if the cache is still valid, +-- and the last (potentially large) component is the cached value itself. +-- This way we can test for cache validity without needing to pay the +-- cost of the decode of stale cache data. This lives here rather than +-- Distribution.Utils.Structured because it depends on a newer version of +-- binary than supported in the Cabal library proper. +structuredDecodeTriple + :: forall a b c. (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c) + => BS.ByteString -> Either String (a, b, Either String c) +structuredDecodeTriple lbs = + let partialDecode = + (`runGetOrFail` lbs) $ do + (_ :: Tag (a,b,c)) <- Binary.get + (a :: a) <- Binary.get + (b :: b) <- Binary.get + pure (a, b) + cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + cleanEither (Right (_,_,v)) = Right v + + in case partialDecode of + Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + Right (lbs', _, (x,y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs') + +-- | Helper for reading the cache file. +-- +-- This determines the type and format of the binary cache file. +-- +withCacheFile :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r) + -> IO r +withCacheFile (FileMonitor {fileMonitorCacheFile}) k = + withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do + contents <- structuredDecodeTriple <$> BS.hGetContents hnd + k contents + +-- | Helper for writing the cache file. +-- +-- This determines the type and format of the binary cache file. +-- +rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> MonitorStateFileSet -> a -> b -> IO () +rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = + writeFileAtomic fileMonitorCacheFile $ + structuredEncode (fileset, key, result) + +-- | Probe the file system to see if any of the monitored files have changed. +-- +-- It returns Nothing if any file changed, or returns a possibly updated +-- file 'MonitorStateFileSet' plus an indicator of whether it actually changed. +-- +-- We may need to update the cache since there may be changes in the filesystem +-- state which don't change any of our affected files. +-- +-- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a +-- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run +-- and find @proj2@ was created, yet contains no files matching @*.cabal@ then +-- we want to update the cache despite no changes in our relevant file set. +-- Specifically, we should add an mtime for this directory so we can avoid +-- re-traversing the directory in future runs. +-- +probeFileSystem :: FilePath -> MonitorStateFileSet + -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) +probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = + runChangedM $ do + sequence_ + [ probeMonitorStateFileStatus root file status + | MonitorStateFile _ _ file status <- singlePaths ] + -- The glob monitors can require state changes + globPaths' <- + sequence + [ probeMonitorStateGlob root globPath + | globPath <- globPaths ] + return (MonitorStateFileSet singlePaths globPaths') + + +----------------------------------------------- +-- Monad for checking for file system changes +-- +-- We need to be able to bail out if we detect a change (using ExceptT), +-- but if there's no change we need to be able to rebuild the monitor +-- state. And we want to optimise that rebuilding by keeping track if +-- anything actually changed (using StateT), so that in the typical case +-- we can avoid rewriting the state file. + +newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged)) +runChangedM (ChangedM action) = + runExceptT $ State.runStateT action CacheUnchanged + +somethingChanged :: FilePath -> ChangedM a +somethingChanged path = ChangedM $ throwError path + +cacheChanged :: ChangedM () +cacheChanged = ChangedM $ State.put CacheChanged + +mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a +mapChangedFile adjust (ChangedM a) = + ChangedM (mapStateT (withExceptT adjust) a) + +data CacheChanged = CacheChanged | CacheUnchanged + +whenCacheChanged :: Monad m => CacheChanged -> m () -> m () +whenCacheChanged CacheChanged action = action +whenCacheChanged CacheUnchanged _ = return () + +---------------------- + +-- | Probe the file system to see if a single monitored file has changed. +-- +probeMonitorStateFileStatus :: FilePath -> FilePath + -> MonitorStateFileStatus + -> ChangedM () +probeMonitorStateFileStatus root file status = + case status of + MonitorStateFileExists -> + probeFileExistence root file + + MonitorStateFileModTime mtime -> + probeFileModificationTime root file mtime + + MonitorStateFileHashed mtime hash -> + probeFileModificationTimeAndHash root file mtime hash + + MonitorStateDirExists -> + probeDirExistence root file + + MonitorStateDirModTime mtime -> + probeFileModificationTime root file mtime + + MonitorStateNonExistent -> + probeFileNonExistence root file + + MonitorStateAlreadyChanged -> + somethingChanged file + + +-- | Probe the file system to see if a monitored file glob has changed. +-- +probeMonitorStateGlob :: FilePath -- ^ root path + -> MonitorStateGlob + -> ChangedM MonitorStateGlob +probeMonitorStateGlob relroot + (MonitorStateGlob kindfile kinddir globroot glob) = do + root <- liftIO $ getFilePathRootDirectory globroot relroot + case globroot of + FilePathRelative -> + MonitorStateGlob kindfile kinddir globroot <$> + probeMonitorStateGlobRel kindfile kinddir root "." glob + + -- for absolute cases, make the changed file we report absolute too + _ -> + mapChangedFile (root ) $ + MonitorStateGlob kindfile kinddir globroot <$> + probeMonitorStateGlobRel kindfile kinddir root "" glob + +probeMonitorStateGlobRel :: MonitorKindFile -> MonitorKindDir + -> FilePath -- ^ root path + -> FilePath -- ^ path of the directory we are + -- looking in relative to @root@ + -> MonitorStateGlobRel + -> ChangedM MonitorStateGlobRel +probeMonitorStateGlobRel kindfile kinddir root dirName + (MonitorStateGlobDirs glob globPath mtime children) = do + change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime + case change of + Nothing -> do + children' <- sequence + [ do fstate' <- probeMonitorStateGlobRel + kindfile kinddir root + (dirName fname) fstate + return (fname, fstate') + | (fname, fstate) <- children ] + return $! MonitorStateGlobDirs glob globPath mtime children' + + Just mtime' -> do + -- directory modification time changed: + -- a matching subdir may have been added or deleted + matches <- filterM (\entry -> let subdir = root dirName entry + in liftIO $ doesDirectoryExist subdir) + . filter (matchGlob glob) + =<< liftIO (getDirectoryContents (root dirName)) + + children' <- traverse probeMergeResult $ + mergeBy (\(path1,_) path2 -> compare path1 path2) + children + (sort matches) + return $! MonitorStateGlobDirs glob globPath mtime' children' + -- Note that just because the directory has changed, we don't force + -- a cache rewrite with 'cacheChanged' since that has some cost, and + -- all we're saving is scanning the directory. But we do rebuild the + -- cache with the new mtime', so that if the cache is rewritten for + -- some other reason, we'll take advantage of that. + + where + probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath + -> ChangedM (FilePath, MonitorStateGlobRel) + + -- Only in cached (directory deleted) + probeMergeResult (OnlyInLeft (path, fstate)) = do + case allMatchingFiles (dirName path) fstate of + [] -> return (path, fstate) + -- Strictly speaking we should be returning 'CacheChanged' above + -- as we should prune the now-missing 'MonitorStateGlobRel'. However + -- we currently just leave these now-redundant entries in the + -- cache as they cost no IO and keeping them allows us to avoid + -- rewriting the cache. + (file:_) -> somethingChanged file + + -- Only in current filesystem state (directory added) + probeMergeResult (OnlyInRight path) = do + fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty + kindfile kinddir root (dirName path) globPath + case allMatchingFiles (dirName path) fstate of + (file:_) -> somethingChanged file + -- This is the only case where we use 'cacheChanged' because we can + -- have a whole new dir subtree (of unbounded size and cost), so we + -- need to save the state of that new subtree in the cache. + [] -> cacheChanged >> return (path, fstate) + + -- Found in path + probeMergeResult (InBoth (path, fstate) _) = do + fstate' <- probeMonitorStateGlobRel kindfile kinddir + root (dirName path) fstate + return (path, fstate') + + -- | Does a 'MonitorStateGlob' have any relevant files within it? + allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] + allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = + [ dir fname | (fname, _) <- entries ] + allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = + [ res + | (subdir, fstate) <- entries + , res <- allMatchingFiles (dir subdir) fstate ] + allMatchingFiles dir MonitorStateGlobDirTrailing = + [dir] + +probeMonitorStateGlobRel _ _ root dirName + (MonitorStateGlobFiles glob mtime children) = do + change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime + mtime' <- case change of + Nothing -> return mtime + Just mtime' -> do + -- directory modification time changed: + -- a matching file may have been added or deleted + matches <- return . filter (matchGlob glob) + =<< liftIO (getDirectoryContents (root dirName)) + + traverse_ probeMergeResult $ + mergeBy (\(path1,_) path2 -> compare path1 path2) + children + (sort matches) + return mtime' + + -- Check that none of the children have changed + for_ children $ \(file, status) -> + probeMonitorStateFileStatus root (dirName file) status + + + return (MonitorStateGlobFiles glob mtime' children) + -- Again, we don't force a cache rewite with 'cacheChanged', but we do use + -- the new mtime' if any. + where + probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath + -> ChangedM () + probeMergeResult mr = case mr of + InBoth _ _ -> return () + -- this is just to be able to accurately report which file changed: + OnlyInLeft (path, _) -> somethingChanged (dirName path) + OnlyInRight path -> somethingChanged (dirName path) + +probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = + return MonitorStateGlobDirTrailing + +------------------------------------------------------------------------------ + +-- | Update the input value and the set of files monitored by the +-- 'FileMonitor', plus the cached value that may be returned in future. +-- +-- This takes a snapshot of the state of the monitored files right now, so +-- 'checkFileMonitorChanged' will look for file system changes relative to +-- this snapshot. +-- +-- This is typically done once the action has been completed successfully and +-- we have the action's result and we know what files it looked at. See +-- 'FileMonitor' for a full explanation. +-- +-- If we do take the snapshot after the action has completed then we have a +-- problem. The problem is that files might have changed /while/ the action was +-- running but /after/ the action read them. If we take the snapshot after the +-- action completes then we will miss these changes. The solution is to record +-- a timestamp before beginning execution of the action and then we make the +-- conservative assumption that any file that has changed since then has +-- already changed, ie the file monitor state for these files will be such that +-- 'checkFileMonitorChanged' will report that they have changed. +-- +-- So if you do use 'updateFileMonitor' after the action (so you can discover +-- the files used rather than predicting them in advance) then use +-- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively, +-- if you take the snapshot in advance of the action, or you're not monitoring +-- any files then you can use @Nothing@ for the timestamp parameter. +-- +updateFileMonitor + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b -- ^ cache file path + -> FilePath -- ^ root directory + -> Maybe MonitorTimestamp -- ^ timestamp when the update action started + -> [MonitorFilePath] -- ^ files of interest relative to root + -> a -- ^ the current key value + -> b -- ^ the current result value + -> IO () +updateFileMonitor monitor root startTime monitorFiles + cachedKey cachedResult = do + hashcache <- readCacheFileHashes monitor + msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles + rewriteCacheFile monitor msfs cachedKey cachedResult + +-- | A timestamp to help with the problem of file changes during actions. +-- See 'updateFileMonitor' for details. +-- +newtype MonitorTimestamp = MonitorTimestamp ModTime + +-- | Record a timestamp at the beginning of an action, and when the action +-- completes call 'updateFileMonitor' passing it the timestamp. +-- See 'updateFileMonitor' for details. +-- +beginUpdateFileMonitor :: IO MonitorTimestamp +beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime + +-- | Take the snapshot of the monitored files. That is, given the +-- specification of the set of files we need to monitor, inspect the state +-- of the file system now and collect the information we'll need later to +-- determine if anything has changed. +-- +buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp + -- of the start of the action + -> FileHashCache -- ^ existing file hashes + -> FilePath -- ^ root directory + -> [MonitorFilePath] -- ^ patterns of interest + -- relative to root + -> IO MonitorStateFileSet +buildMonitorStateFileSet mstartTime hashcache root = + go [] [] + where + go :: [MonitorStateFile] -> [MonitorStateGlob] + -> [MonitorFilePath] -> IO MonitorStateFileSet + go !singlePaths !globPaths [] = + return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) + + go !singlePaths !globPaths + (MonitorFile kindfile kinddir path : monitors) = do + monitorState <- MonitorStateFile kindfile kinddir path + <$> buildMonitorStateFile mstartTime hashcache + kindfile kinddir root path + go (monitorState : singlePaths) globPaths monitors + + go !singlePaths !globPaths + (MonitorFileGlob kindfile kinddir globPath : monitors) = do + monitorState <- buildMonitorStateGlob mstartTime hashcache + kindfile kinddir root globPath + go singlePaths (monitorState : globPaths) monitors + + +buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update + -> FileHashCache -- ^ existing file hashes + -> MonitorKindFile -> MonitorKindDir + -> FilePath -- ^ the root directory + -> FilePath + -> IO MonitorStateFileStatus +buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do + let abspath = root path + isFile <- doesFileExist abspath + isDir <- doesDirectoryExist abspath + case (isFile, kindfile, isDir, kinddir) of + (_, FileNotExists, _, DirNotExists) -> + -- we don't need to care if it exists now, since we check at probe time + return MonitorStateNonExistent + + (False, _, False, _) -> + return MonitorStateAlreadyChanged + + (True, FileExists, _, _) -> + return MonitorStateFileExists + + (True, FileModTime, _, _) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else return (MonitorStateFileModTime mtime) + + (True, FileHashed, _, _) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else do hash <- getFileHash hashcache abspath abspath mtime + return (MonitorStateFileHashed mtime hash) + + (_, _, True, DirExists) -> + return MonitorStateDirExists + + (_, _, True, DirModTime) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else return (MonitorStateDirModTime mtime) + + (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged + (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged + +-- | If we have a timestamp for the beginning of the update, then any file +-- mtime later than this means that it changed during the update and we ought +-- to consider the file as already changed. +-- +changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool +changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime + = mtime > startTime +changedDuringUpdate _ _ = False + +-- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case +-- of a file glob. +-- +-- This gets used both by 'buildMonitorStateFileSet' when we're taking the +-- file system snapshot, but also by 'probeGlobStatus' as part of checking +-- the monitored (globed) files for changes when we find a whole new subtree. +-- +buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update + -> FileHashCache -- ^ existing file hashes + -> MonitorKindFile -> MonitorKindDir + -> FilePath -- ^ the root directory + -> FilePathGlob -- ^ the matching glob + -> IO MonitorStateGlob +buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot + (FilePathGlob globroot globPath) = do + root <- liftIO $ getFilePathRootDirectory globroot relroot + MonitorStateGlob kindfile kinddir globroot <$> + buildMonitorStateGlobRel + mstartTime hashcache kindfile kinddir root "." globPath + +buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update + -> FileHashCache -- ^ existing file hashes + -> MonitorKindFile -> MonitorKindDir + -> FilePath -- ^ the root directory + -> FilePath -- ^ directory we are examining + -- relative to the root + -> FilePathGlobRel -- ^ the matching glob + -> IO MonitorStateGlobRel +buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root + dir globPath = do + let absdir = root dir + dirEntries <- getDirectoryContents absdir + dirMTime <- getModTime absdir + case globPath of + GlobDir glob globPath' -> do + subdirs <- filterM (\subdir -> doesDirectoryExist (absdir subdir)) + $ filter (matchGlob glob) dirEntries + subdirStates <- + for (sort subdirs) $ \subdir -> do + fstate <- buildMonitorStateGlobRel + mstartTime hashcache kindfile kinddir root + (dir subdir) globPath' + return (subdir, fstate) + return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates + + GlobFile glob -> do + let files = filter (matchGlob glob) dirEntries + filesStates <- + for (sort files) $ \file -> do + fstate <- buildMonitorStateFile + mstartTime hashcache kindfile kinddir root + (dir file) + return (file, fstate) + return $! MonitorStateGlobFiles glob dirMTime filesStates + + GlobDirTrailing -> + return MonitorStateGlobDirTrailing + + +-- | We really want to avoid re-hashing files all the time. We already make +-- the assumption that if a file mtime has not changed then we don't need to +-- bother checking if the content hash has changed. We can apply the same +-- assumption when updating the file monitor state. In the typical case of +-- updating a file monitor the set of files is the same or largely the same so +-- we can grab the previously known content hashes with their corresponding +-- mtimes. +-- +type FileHashCache = Map FilePath (ModTime, Hash) + +-- | We declare it a cache hit if the mtime of a file is the same as before. +-- +lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash +lookupFileHashCache hashcache file mtime = do + (mtime', hash) <- Map.lookup file hashcache + guard (mtime' == mtime) + return hash + +-- | Either get it from the cache or go read the file +getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash +getFileHash hashcache relfile absfile mtime = + case lookupFileHashCache hashcache relfile mtime of + Just hash -> return hash + Nothing -> readFileHash absfile + +-- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While +-- in principle we could preserve the structure of the previous state, given +-- that the set of files to monitor can change then it's simpler just to throw +-- away the structure and use a finite map. +-- +readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b -> IO FileHashCache +readCacheFileHashes monitor = + handleDoesNotExist Map.empty $ + handleErrorCall Map.empty $ + withCacheFile monitor $ \res -> + case res of + Left _ -> return Map.empty + Right (msfs, _, _) -> return (mkFileHashCache msfs) + where + mkFileHashCache :: MonitorStateFileSet -> FileHashCache + mkFileHashCache (MonitorStateFileSet singlePaths globPaths) = + collectAllFileHashes singlePaths + `Map.union` collectAllGlobHashes globPaths + + collectAllFileHashes singlePaths = + Map.fromList [ (fpath, (mtime, hash)) + | MonitorStateFile _ _ fpath + (MonitorStateFileHashed mtime hash) <- singlePaths ] + + collectAllGlobHashes globPaths = + Map.fromList [ (fpath, (mtime, hash)) + | MonitorStateGlob _ _ _ gstate <- globPaths + , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] + + collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = + [ res + | (subdir, fstate) <- entries + , res <- collectGlobHashes (dir subdir) fstate ] + + collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) = + [ (dir fname, (mtime, hash)) + | (fname, MonitorStateFileHashed mtime hash) <- entries ] + + collectGlobHashes _dir MonitorStateGlobDirTrailing = + [] + + +------------------------------------------------------------------------------ +-- Utils +-- + +-- | Within the @root@ directory, check if @file@ has its 'ModTime' is +-- the same as @mtime@, short-circuiting if it is different. +probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM () +probeFileModificationTime root file mtime = do + unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime + unless unchanged (somethingChanged file) + +-- | Within the @root@ directory, check if @file@ has its 'ModTime' and +-- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is +-- different. +probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash + -> ChangedM () +probeFileModificationTimeAndHash root file mtime hash = do + unchanged <- liftIO $ + checkFileModificationTimeAndHashUnchanged root file mtime hash + unless unchanged (somethingChanged file) + +-- | Within the @root@ directory, check if @file@ still exists as a file. +-- If it *does not* exist, short-circuit. +probeFileExistence :: FilePath -> FilePath -> ChangedM () +probeFileExistence root file = do + existsFile <- liftIO $ doesFileExist (root file) + unless existsFile (somethingChanged file) + +-- | Within the @root@ directory, check if @dir@ still exists. +-- If it *does not* exist, short-circuit. +probeDirExistence :: FilePath -> FilePath -> ChangedM () +probeDirExistence root dir = do + existsDir <- liftIO $ doesDirectoryExist (root dir) + unless existsDir (somethingChanged dir) + +-- | Within the @root@ directory, check if @file@ still does not exist. +-- If it *does* exist, short-circuit. +probeFileNonExistence :: FilePath -> FilePath -> ChangedM () +probeFileNonExistence root file = do + existsFile <- liftIO $ doesFileExist (root file) + existsDir <- liftIO $ doesDirectoryExist (root file) + when (existsFile || existsDir) (somethingChanged file) + +-- | Returns @True@ if, inside the @root@ directory, @file@ has the same +-- 'ModTime' as @mtime@. +checkModificationTimeUnchanged :: FilePath -> FilePath + -> ModTime -> IO Bool +checkModificationTimeUnchanged root file mtime = + handleIOException False $ do + mtime' <- getModTime (root file) + return (mtime == mtime') + +-- | Returns @True@ if, inside the @root@ directory, @file@ has the +-- same 'ModTime' and 'Hash' as @mtime and @chash@. +checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath + -> ModTime -> Hash -> IO Bool +checkFileModificationTimeAndHashUnchanged root file mtime chash = + handleIOException False $ do + mtime' <- getModTime (root file) + if mtime == mtime' + then return True + else do + chash' <- readFileHash (root file) + return (chash == chash') + +-- | Read a non-cryptographic hash of a @file@. +readFileHash :: FilePath -> IO Hash +readFileHash file = + withBinaryFile file ReadMode $ \hnd -> + evaluate . Hashable.hash =<< BS.hGetContents hnd + +-- | Given a directory @dir@, return @Nothing@ if its 'ModTime' +-- is the same as @mtime@, and the new 'ModTime' if it is not. +checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime) +checkDirectoryModificationTime dir mtime = + handleIOException Nothing $ do + mtime' <- getModTime dir + if mtime == mtime' + then return Nothing + else return (Just mtime') + +-- | Run an IO computation, returning the first argument @e@ if there is an 'error' +-- call. ('ErrorCall') +handleErrorCall :: a -> IO a -> IO a +handleErrorCall e = handle handler where +#if MIN_VERSION_base(4,9,0) + handler (ErrorCallWithLocation _ _) = return e +#else + handler (ErrorCall _) = return e +#endif + + +-- | Run an IO computation, returning @e@ if there is any 'IOException'. +-- +-- This policy is OK in the file monitor code because it just causes the +-- monitor to report that something changed, and then code reacting to that +-- will normally encounter the same IO exception when it re-runs the action +-- that uses the file. +-- +handleIOException :: a -> IO a -> IO a +handleIOException e = + handle (anyIOException e) + where + anyIOException :: a -> IOException -> IO a + anyIOException x _ = return x + + +------------------------------------------------------------------------------ +-- Instances +-- diff --git a/src/Distribution/Client/Freeze.hs b/src/Distribution/Client/Freeze.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Freeze.hs @@ -0,0 +1,266 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Freeze +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The cabal freeze command +----------------------------------------------------------------------------- +module Distribution.Client.Freeze ( + freeze, getFreezePkgs + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Config ( SavedConfig(..) ) +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.Dependency +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.SolverInstallPlan + ( SolverInstallPlan, SolverPlanPackage ) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Setup + ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) + , RepoContext(..) ) +import Distribution.Client.Sandbox.PackageEnvironment + ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment, + userPackageEnvironmentFile ) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.SolverId + +import Distribution.Package + ( Package, packageId, packageName, packageVersion ) +import Distribution.Simple.Compiler + ( Compiler, compilerInfo, PackageDBStack ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Program + ( ProgramDb ) +import Distribution.Simple.Setup + ( fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.Utils + ( die', notice, debug, writeFileAtomic, toUTF8LBS) +import Distribution.System + ( Platform ) + +import Distribution.Version + ( thisVersion ) + +-- ------------------------------------------------------------ +-- * The freeze command +-- ------------------------------------------------------------ + +-- | Freeze all of the dependencies by writing a constraints section +-- constraining each dependency to an exact version. +-- +freeze :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO () +freeze verbosity packageDBs repoCtxt comp platform progdb + globalFlags freezeFlags = do + + pkgs <- getFreezePkgs + verbosity packageDBs repoCtxt comp platform progdb + globalFlags freezeFlags + + if null pkgs + then notice verbosity $ "No packages to be frozen. " + ++ "As this package has no dependencies." + else if dryRun + then notice verbosity $ unlines $ + "The following packages would be frozen:" + : formatPkgs pkgs + + else freezePackages verbosity globalFlags pkgs + + where + dryRun = fromFlag (freezeDryRun freezeFlags) + +-- | Get the list of packages whose versions would be frozen by the @freeze@ +-- command. +getFreezePkgs :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO [SolverPlanPackage] +getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb + globalFlags freezeFlags = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb + + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + [UserTargetLocalDir "."] + + sanityCheck pkgSpecifiers + planPackages + verbosity comp platform freezeFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + where + sanityCheck pkgSpecifiers = do + when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ + die' verbosity $ "internal error: 'resolveUserTargets' returned " + ++ "unexpected named package specifiers!" + when (length pkgSpecifiers /= 1) $ + die' verbosity $ "internal error: 'resolveUserTargets' returned " + ++ "unexpected source package specifiers!" + +planPackages :: Verbosity + -> Compiler + -> Platform + -> FreezeFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO [SolverPlanPackage] +planPackages verbosity comp platform freezeFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do + + solver <- chooseSolver verbosity + (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) + notice verbosity "Resolving dependencies..." + + installPlan <- foldProgress logMsg (die' verbosity) return $ + resolveDependencies + platform (compilerInfo comp) pkgConfigDb + solver + resolverParams + + return $ pruneInstallPlan installPlan pkgSpecifiers + + where + resolverParams = + + setMaxBackjumps (if maxBackjumps < 0 then Nothing + else Just maxBackjumps) + + . setIndependentGoals independentGoals + + . setReorderGoals reorderGoals + + . setCountConflicts countConflicts + + . setFineGrainedConflicts fineGrainedConflicts + + . setMinimizeConflictSet minimizeConflictSet + + . setShadowPkgs shadowPkgs + + . setStrongFlags strongFlags + + . setAllowBootLibInstalls allowBootLibInstalls + + . setOnlyConstrained onlyConstrained + + . setSolverVerbosity verbosity + + . addConstraints + [ let pkg = pkgSpecifierTarget pkgSpecifier + pc = PackageConstraint (scopeToplevel pkg) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceFreeze + | pkgSpecifier <- pkgSpecifiers ] + + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + logMsg message rest = debug verbosity message >> rest + + stanzas = [ TestStanzas | testsEnabled ] + ++ [ BenchStanzas | benchmarksEnabled ] + testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags + benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags + + reorderGoals = fromFlag (freezeReorderGoals freezeFlags) + countConflicts = fromFlag (freezeCountConflicts freezeFlags) + fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) + minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) + independentGoals = fromFlag (freezeIndependentGoals freezeFlags) + shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) + strongFlags = fromFlag (freezeStrongFlags freezeFlags) + maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) + allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) + onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags) + + +-- | Remove all unneeded packages from an install plan. +-- +-- A package is unneeded if it is either +-- +-- 1) the package that we are freezing, or +-- +-- 2) not a dependency (directly or transitively) of the package we are +-- freezing. This is useful for removing previously installed packages +-- which are no longer required from the install plan. +-- +-- Invariant: @pkgSpecifiers@ must refer to packages which are not +-- 'PreExisting' in the 'SolverInstallPlan'. +pruneInstallPlan :: SolverInstallPlan + -> [PackageSpecifier UnresolvedSourcePackage] + -> [SolverPlanPackage] +pruneInstallPlan installPlan pkgSpecifiers = + removeSelf pkgIds $ + SolverInstallPlan.dependencyClosure installPlan pkgIds + where + pkgIds = [ PlannedId (packageId pkg) + | SpecificSourcePackage pkg <- pkgSpecifiers ] + removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) + removeSelf _ = error $ "internal error: 'pruneInstallPlan' given " + ++ "unexpected package specifiers!" + + +freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO () +freezePackages verbosity globalFlags pkgs = do + + pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ + loadUserConfig verbosity "" + (flagToMaybe . globalConstraintsFile $ globalFlags) + writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv + where + addFrozenConstraints config = + config { + savedConfigureExFlags = (savedConfigureExFlags config) { + configExConstraints = map constraint pkgs + } + } + constraint pkg = + (pkgIdToConstraint $ packageId pkg + ,ConstraintSourceUserConfig userPackageEnvironmentFile) + where + pkgIdToConstraint pkgId = + UserConstraint (UserQualified UserQualToplevel (packageName pkgId)) + (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) + createPkgEnv config = mempty { pkgEnvSavedConfig = config } + showPkgEnv = toUTF8LBS . showPackageEnvironment + + +formatPkgs :: Package pkg => [pkg] -> [String] +formatPkgs = map $ showPkg . packageId + where + showPkg pid = name pid ++ " == " ++ version pid + name = prettyShow . packageName + version = prettyShow . packageVersion diff --git a/src/Distribution/Client/GZipUtils.hs b/src/Distribution/Client/GZipUtils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/GZipUtils.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.GZipUtils +-- Copyright : (c) Dmitry Astapov 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Provides a convenience functions for working with files that may or may not +-- be zipped. +----------------------------------------------------------------------------- +module Distribution.Client.GZipUtils ( + maybeDecompress, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Codec.Compression.Zlib.Internal +import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) + +#ifndef MIN_VERSION_zlib +#define MIN_VERSION_zlib(x,y,z) 1 +#endif + +#if MIN_VERSION_zlib(0,6,0) +import Control.Exception (throw) +import Control.Monad.ST.Lazy (ST, runST) +import qualified Data.ByteString as Strict +#endif + +-- | Attempts to decompress the `bytes' under the assumption that +-- "data format" error at the very beginning of the stream means +-- that it is already decompressed. Caller should make sanity checks +-- to verify that it is not, in fact, garbage. +-- +-- This is to deal with http proxies that lie to us and transparently +-- decompress without removing the content-encoding header. See: +-- +-- +maybeDecompress :: ByteString -> ByteString +#if MIN_VERSION_zlib(0,6,0) +maybeDecompress bytes = runST (go bytes decompressor) + where + decompressor :: DecompressStream (ST s) + decompressor = decompressST gzipOrZlibFormat defaultDecompressParams + + -- DataError at the beginning of the stream probably means that stream is + -- not compressed, so we return it as-is. + -- TODO: alternatively, we might consider looking for the two magic bytes + -- at the beginning of the gzip header. (not an option for zlib, though.) + go :: Monad m => ByteString -> DecompressStream m -> m ByteString + go cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k + go _ (DecompressStreamEnd _bs ) = return Empty + go _ (DecompressStreamError _err ) = return bytes + go cs (DecompressInputRequired k) = go cs' =<< k c + where + (c, cs') = uncons cs + + -- Once we have received any output though we regard errors as actual errors + -- and we throw them (as pure exceptions). + -- TODO: We could (and should) avoid these pure exceptions. + go' :: Monad m => ByteString -> DecompressStream m -> m ByteString + go' cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k + go' _ (DecompressStreamEnd _bs ) = return Empty + go' _ (DecompressStreamError err ) = throw err + go' cs (DecompressInputRequired k) = go' cs' =<< k c + where + (c, cs') = uncons cs + + uncons :: ByteString -> (Strict.ByteString, ByteString) + uncons Empty = (Strict.empty, Empty) + uncons (Chunk c cs) = (c, cs) +#else +maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes + where + -- DataError at the beginning of the stream probably means that stream is not compressed. + -- Returning it as-is. + -- TODO: alternatively, we might consider looking for the two magic bytes + -- at the beginning of the gzip header. + foldStream (StreamError _ _) = bytes + foldStream somethingElse = doFold somethingElse + + doFold StreamEnd = BS.Empty + doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream) + doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg +#endif diff --git a/src/Distribution/Client/GenBounds.hs b/src/Distribution/Client/GenBounds.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/GenBounds.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.GenBounds +-- Copyright : (c) Doug Beardsley 2015 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The cabal gen-bounds command for generating PVP-compliant version bounds. +----------------------------------------------------------------------------- +module Distribution.Client.GenBounds ( + genBounds + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Init + ( incVersion ) +import Distribution.Client.Freeze + ( getFreezePkgs ) +import Distribution.Client.Setup + ( GlobalFlags(..), FreezeFlags(..), RepoContext ) +import Distribution.Package + ( Package(..), unPackageName, packageName, packageVersion ) +import Distribution.PackageDescription + ( enabledBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) +import Distribution.Types.ComponentRequestedSpec + ( defaultComponentRequestedSpec ) +import Distribution.Types.Dependency +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack, compilerInfo ) +import Distribution.Simple.Program + ( ProgramDb ) +import Distribution.Simple.Utils + ( tryFindPackageDesc ) +import Distribution.System + ( Platform ) +import Distribution.Version + ( Version, alterVersion, VersionInterval (..) + , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals + , orLaterVersion, earlierVersion, intersectVersionRanges, hasUpperBound) +import System.Directory + ( getCurrentDirectory ) + +-- | Given a version, return an API-compatible (according to PVP) version range. +-- +-- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@. +-- +-- This version is slightly different than the one in +-- 'Distribution.Client.Init'. This one uses a.b.c as the lower bound because +-- the user could be using a new function introduced in a.b.c which would make +-- ">= a.b" incorrect. +pvpize :: Version -> VersionRange +pvpize v = orLaterVersion (vn 3) + `intersectVersionRanges` + earlierVersion (incVersion 1 (vn 2)) + where + vn n = alterVersion (take n) v + +-- | Show the PVP-mandated version range for this package. The @padTo@ parameter +-- specifies the width of the package name column. +showBounds :: Package pkg => Int -> pkg -> String +showBounds padTo p = unwords $ + (padAfter padTo $ unPackageName $ packageName p) : + -- TODO: use normaliseVersionRange + map showInterval (asVersionIntervals $ pvpize $ packageVersion p) + where + padAfter :: Int -> String -> String + padAfter n str = str ++ replicate (n - length str) ' ' + + showInterval :: VersionInterval -> String + showInterval (VersionInterval (LowerBound _ _) NoUpperBound) = + error "Error: expected upper bound...this should never happen!" + showInterval (VersionInterval (LowerBound l _) (UpperBound u _)) = + unwords [">=", prettyShow l, "&& <", prettyShow u] + +-- | Entry point for the @gen-bounds@ command. +genBounds + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO () +genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do + let cinfo = compilerInfo comp + + cwd <- getCurrentDirectory + path <- tryFindPackageDesc verbosity cwd + gpd <- readGenericPackageDescription verbosity path + -- NB: We don't enable tests or benchmarks, since often they + -- don't really have useful bounds. + let epd = finalizePD mempty defaultComponentRequestedSpec + (const True) platform cinfo [] gpd + case epd of + Left _ -> putStrLn "finalizePD failed" + Right (pd,_) -> do + let needBounds = filter (not . hasUpperBound . depVersion) $ + enabledBuildDepends pd defaultComponentRequestedSpec + + if (null needBounds) + then putStrLn + "Congratulations, all your dependencies have upper bounds!" + else go needBounds + where + go needBounds = do + pkgs <- getFreezePkgs + verbosity packageDBs repoCtxt comp platform progdb + globalFlags freezeFlags + + putStrLn boundsNeededMsg + + let isNeeded pkg = unPackageName (packageName pkg) + `elem` map depName needBounds + let thePkgs = filter isNeeded pkgs + + let padTo = maximum $ map (length . unPackageName . packageName) pkgs + traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs + + depName :: Dependency -> String + depName (Dependency pn _ _) = unPackageName pn + + depVersion :: Dependency -> VersionRange + depVersion (Dependency _ vr _) = vr + +-- | The message printed when some dependencies are found to be lacking proper +-- PVP-mandated bounds. +boundsNeededMsg :: String +boundsNeededMsg = unlines + [ "" + , "The following packages need bounds and here is a suggested starting point." + , "You can copy and paste this into the build-depends section in your .cabal" + , "file and it should work (with the appropriate removal of commas)." + , "" + , "Note that version bounds are a statement that you've successfully built and" + , "tested your package and expect it to work with any of the specified package" + , "versions (PROVIDED that those packages continue to conform with the PVP)." + , "Therefore, the version bounds generated here are the most conservative" + , "based on the versions that you are currently building with. If you know" + , "your package will work with versions outside the ranges generated here," + , "feel free to widen them." + , "" + ] diff --git a/src/Distribution/Client/Get.hs b/src/Distribution/Client/Get.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Get.hs @@ -0,0 +1,333 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Get +-- Copyright : (c) Andrea Vezzosi 2008 +-- Duncan Coutts 2011 +-- John Millikin 2012 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'cabal get' command. +----------------------------------------------------------------------------- + +module Distribution.Client.Get ( + get, + + -- * Cloning 'SourceRepo's + -- | Mainly exported for testing purposes + clonePackagesFromSourceRepo, + ClonePackageException(..), + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get) +import Distribution.Compat.Directory + ( listDirectory ) +import Distribution.Package + ( PackageId, packageId, packageName ) +import Distribution.Simple.Setup + ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.Utils + ( notice, die', info, writeFileAtomic ) +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Program + ( programName ) +import Distribution.Types.SourceRepo (RepoKind (..)) +import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) + +import Distribution.Client.Setup + ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.Dependency +import Distribution.Client.VCS +import Distribution.Client.FetchUtils +import qualified Distribution.Client.Tar as Tar (extractTarGzFile) +import Distribution.Client.IndexUtils + ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos ) +import Distribution.Solver.Types.SourcePackage + +import qualified Data.Map as Map +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) +import System.FilePath + ( (), (<.>), addTrailingPathSeparator ) + + +-- | Entry point for the 'cabal get' command. +get :: Verbosity + -> RepoContext + -> GlobalFlags + -> GetFlags + -> [UserTarget] + -> IO () +get verbosity _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +get verbosity repoCtxt globalFlags getFlags userTargets = do + let useSourceRepo = case getSourceRepository getFlags of + NoFlag -> False + _ -> True + + unless useSourceRepo $ + traverse_ (checkTarget verbosity) userTargets + + let idxState :: Maybe TotalIndexState + idxState = flagToMaybe $ getIndexState getFlags + + activeRepos :: Maybe ActiveRepos + activeRepos = flagToMaybe $ getActiveRepos getFlags + + (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos + + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + userTargets + + pkgs <- either (die' verbosity . unlines . map show) return $ + resolveWithoutDependencies + (resolverParams sourcePkgDb pkgSpecifiers) + + unless (null prefix) $ + createDirectoryIfMissing True prefix + + if useSourceRepo + then clone pkgs + else unpack pkgs + + where + resolverParams sourcePkgDb pkgSpecifiers = + --TODO: add command-line constraint and preference args for unpack + standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + + prefix = fromFlagOrDefault "" (getDestDir getFlags) + + clone :: [UnresolvedSourcePackage] -> IO () + clone = clonePackagesFromSourceRepo verbosity prefix kind + . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) + where + kind = fromFlag . getSourceRepository $ getFlags + packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo] + packageSourceRepos = PD.sourceRepos + . PD.packageDescription + . srcpkgDescription + + unpack :: [UnresolvedSourcePackage] -> IO () + unpack pkgs = do + for_ pkgs $ \pkg -> do + location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg) + let pkgid = packageId pkg + descOverride | usePristine = Nothing + | otherwise = srcpkgDescrOverride pkg + case location of + LocalTarballPackage tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + RemoteTarballPackage _tarballURL tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + RepoTarballPackage _repo _pkgid tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + RemoteSourceRepoPackage _repo _ -> + die' verbosity $ "The 'get' command does no yet support targets " + ++ "that are remote source repositories." + + LocalUnpackedPackage _ -> + error "Distribution.Client.Get.unpack: the impossible happened." + where + usePristine = fromFlagOrDefault False (getPristine getFlags) + +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of + UserTargetLocalDir dir -> die' verbosity (notTarball dir) + UserTargetLocalCabalFile file -> die' verbosity (notTarball file) + _ -> return () + where + notTarball t = + "The 'get' command is for tarball packages. " + ++ "The target '" ++ t ++ "' is not a tarball." + +-- ------------------------------------------------------------ +-- * Unpacking the source tarball +-- ------------------------------------------------------------ + +unpackPackage :: Verbosity -> FilePath -> PackageId + -> PackageDescriptionOverride + -> FilePath -> IO () +unpackPackage verbosity prefix pkgid descOverride pkgPath = do + let pkgdirname = prettyShow pkgid + pkgdir = prefix pkgdirname + pkgdir' = addTrailingPathSeparator pkgdir + emptyDirectory directory = null <$> listDirectory directory + existsDir <- doesDirectoryExist pkgdir + when existsDir $ do + isEmpty <- emptyDirectory pkgdir + unless isEmpty $ + die' verbosity $ + "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking." + existsFile <- doesFileExist pkgdir + when existsFile $ die' verbosity $ + "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." + notice verbosity $ "Unpacking to " ++ pkgdir' + Tar.extractTarGzFile prefix pkgdirname pkgPath + + case descOverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = pkgdir prettyShow (packageName pkgid) <.> "cabal" + info verbosity $ + "Updating " ++ descFilePath + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt + + +-- ------------------------------------------------------------ +-- * Cloning packages from their declared source repositories +-- ------------------------------------------------------------ + + +data ClonePackageException = + ClonePackageNoSourceRepos PackageId + | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) + | ClonePackageNoRepoType PackageId PD.SourceRepo + | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType + | ClonePackageNoRepoLocation PackageId PD.SourceRepo + | ClonePackageDestinationExists PackageId FilePath Bool + | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode + deriving (Show, Eq) + +instance Exception ClonePackageException where + displayException (ClonePackageNoSourceRepos pkgid) = + "Cannot fetch a source repository for package " ++ prettyShow pkgid + ++ ". The package does not specify any source repositories." + + displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) = + "Cannot fetch a source repository for package " ++ prettyShow pkgid + ++ ". The package does not specify a source repository of the requested " + ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind + + displayException (ClonePackageNoRepoType pkgid _repo) = + "Cannot fetch the source repository for package " ++ prettyShow pkgid + ++ ". The package's description specifies a source repository but does " + ++ "not specify the repository 'type' field (e.g. git, darcs or hg)." + + displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) = + "Cannot fetch the source repository for package " ++ prettyShow pkgid + ++ ". The repository type '" ++ prettyShow repoType + ++ "' is not yet supported." + + displayException (ClonePackageNoRepoLocation pkgid _repo) = + "Cannot fetch the source repository for package " ++ prettyShow pkgid + ++ ". The package's description specifies a source repository but does " + ++ "not specify the repository 'location' field (i.e. the URL)." + + displayException (ClonePackageDestinationExists pkgid dest isdir) = + "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". " + ++ if isdir then "The destination directory " ++ dest ++ " already exists." + else "A file " ++ dest ++ " is in the way." + + displayException (ClonePackageFailedWithExitCode + pkgid repo vcsprogname exitcode) = + "Failed to fetch the source repository for package " ++ prettyShow pkgid + ++ ", repository location " ++ srpLocation repo ++ " (" + ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." + + +-- | Given a bunch of package ids and their corresponding available +-- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into +-- new subdirs of the given directory. +-- +clonePackagesFromSourceRepo :: Verbosity + -> FilePath -- ^ destination dir prefix + -> Maybe RepoKind -- ^ preferred 'RepoKind' + -> [(PackageId, [PD.SourceRepo])] + -- ^ the packages and their + -- available 'SourceRepo's + -> IO () +clonePackagesFromSourceRepo verbosity destDirPrefix + preferredRepoKind pkgrepos = do + + -- Do a bunch of checks and collect the required info + pkgrepos' <- traverse preCloneChecks pkgrepos + + -- Configure the VCS drivers for all the repository types we may need + vcss <- configureVCSs verbosity $ + Map.fromList [ (vcsRepoType vcs, vcs) + | (_, _, vcs, _) <- pkgrepos' ] + + -- Now execute all the required commands for each repo + sequence_ + [ cloneSourceRepo verbosity vcs' repo destDir + `catch` \exitcode -> + throwIO (ClonePackageFailedWithExitCode + pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode) + | (pkgid, repo, vcs, destDir) <- pkgrepos' + , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss + ] + + where + preCloneChecks :: (PackageId, [PD.SourceRepo]) + -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) + preCloneChecks (pkgid, repos) = do + repo <- case selectPackageSourceRepo preferredRepoKind repos of + Just repo -> return repo + Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid) + Nothing -> throwIO (ClonePackageNoSourceReposOfKind + pkgid preferredRepoKind) + + (repo', vcs) <- case validatePDSourceRepo repo of + Right (repo', _, _, vcs) -> return (repo', vcs) + Left SourceRepoRepoTypeUnspecified -> + throwIO (ClonePackageNoRepoType pkgid repo) + + Left (SourceRepoRepoTypeUnsupported repo' repoType) -> + throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) + + Left SourceRepoLocationUnspecified -> + throwIO (ClonePackageNoRepoLocation pkgid repo) + + let destDir = destDirPrefix prettyShow (packageName pkgid) + destDirExists <- doesDirectoryExist destDir + destFileExists <- doesFileExist destDir + when (destDirExists || destFileExists) $ + throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) + + return (pkgid, repo', vcs, destDir) + +------------------------------------------------------------------------------- +-- Selecting +------------------------------------------------------------------------------- + +-- | Pick the 'SourceRepo' to use to get the package sources from. +-- +-- Note that this does /not/ depend on what 'VCS' drivers we are able to +-- successfully configure. It is based only on the 'SourceRepo's declared +-- in the package, and optionally on a preferred 'RepoKind'. +-- +selectPackageSourceRepo :: Maybe RepoKind + -> [PD.SourceRepo] + -> Maybe PD.SourceRepo +selectPackageSourceRepo preferredRepoKind = + listToMaybe + -- Sort repositories by kind, from This to Head to Unknown. Repositories + -- with equivalent kinds are selected based on the order they appear in + -- the Cabal description file. + . sortBy (comparing thisFirst) + -- If the user has specified the repo kind, filter out the repositories + -- they're not interested in. + . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind) + where + thisFirst :: PD.SourceRepo -> Int + thisFirst r = case PD.repoKind r of + RepoThis -> 0 + RepoHead -> case PD.repoTag r of + -- If the type is 'head' but the author specified a tag, they + -- probably meant to create a 'this' repository but screwed up. + Just _ -> 0 + Nothing -> 1 + RepoKindUnknown _ -> 2 diff --git a/src/Distribution/Client/Glob.hs b/src/Distribution/Client/Glob.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Glob.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DeriveGeneric #-} + +--TODO: [code cleanup] plausibly much of this module should be merged with +-- similar functionality in Cabal. +module Distribution.Client.Glob + ( FilePathGlob(..) + , FilePathRoot(..) + , FilePathGlobRel(..) + , Glob + , GlobPiece(..) + , matchFileGlob + , matchFileGlobRel + , matchGlob + , isTrivialFilePathGlob + , getFilePathRootDirectory + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Data.List (stripPrefix) +import System.Directory +import System.FilePath + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + + +-- | A file path specified by globbing +-- +data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel + deriving (Eq, Show, Generic) + +data FilePathGlobRel + = GlobDir !Glob !FilePathGlobRel + | GlobFile !Glob + | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@ + deriving (Eq, Show, Generic) + +-- | A single directory or file component of a globbed path +type Glob = [GlobPiece] + +-- | A piece of a globbing pattern +data GlobPiece = WildCard + | Literal String + | Union [Glob] + deriving (Eq, Show, Generic) + +data FilePathRoot + = FilePathRelative + | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive' + | FilePathHomeDir + deriving (Eq, Show, Generic) + +instance Binary FilePathGlob +instance Binary FilePathRoot +instance Binary FilePathGlobRel +instance Binary GlobPiece + +instance Structured FilePathGlob +instance Structured FilePathRoot +instance Structured FilePathGlobRel +instance Structured GlobPiece + +-- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and +-- is in fact equivalent to a non-glob 'FilePath'. +-- +-- If it is trivial in this sense then the result is the equivalent constant +-- 'FilePath'. On the other hand if it is not trivial (so could in principle +-- match more than one file) then the result is @Nothing@. +-- +isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath +isTrivialFilePathGlob (FilePathGlob root pathglob) = + case root of + FilePathRelative -> go [] pathglob + FilePathRoot root' -> go [root'] pathglob + FilePathHomeDir -> Nothing + where + go paths (GlobDir [Literal path] globs) = go (path:paths) globs + go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths))) + go paths GlobDirTrailing = Just (addTrailingPathSeparator + (joinPath (reverse paths))) + go _ _ = Nothing + +-- | Get the 'FilePath' corresponding to a 'FilePathRoot'. +-- +-- The 'FilePath' argument is required to supply the path for the +-- 'FilePathRelative' case. +-- +getFilePathRootDirectory :: FilePathRoot + -> FilePath -- ^ root for relative paths + -> IO FilePath +getFilePathRootDirectory FilePathRelative root = return root +getFilePathRootDirectory (FilePathRoot root) _ = return root +getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory + + +------------------------------------------------------------------------------ +-- Matching +-- + +-- | Match a 'FilePathGlob' against the file system, starting from a given +-- root directory for relative paths. The results of relative globs are +-- relative to the given root. Matches for absolute globs are absolute. +-- +matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath] +matchFileGlob relroot (FilePathGlob globroot glob) = do + root <- getFilePathRootDirectory globroot relroot + matches <- matchFileGlobRel root glob + case globroot of + FilePathRelative -> return matches + _ -> return (map (root ) matches) + +-- | Match a 'FilePathGlobRel' against the file system, starting from a +-- given root directory. The results are all relative to the given root. +-- +matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath] +matchFileGlobRel root glob0 = go glob0 "" + where + go (GlobFile glob) dir = do + entries <- getDirectoryContents (root dir) + let files = filter (matchGlob glob) entries + return (map (dir ) files) + + go (GlobDir glob globPath) dir = do + entries <- getDirectoryContents (root dir) + subdirs <- filterM (\subdir -> doesDirectoryExist + (root dir subdir)) + $ filter (matchGlob glob) entries + concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs + + go GlobDirTrailing dir = return [dir] + + +-- | Match a globbing pattern against a file path component +-- +matchGlob :: Glob -> String -> Bool +matchGlob = goStart + where + -- From the man page, glob(7): + -- "If a filename starts with a '.', this character must be + -- matched explicitly." + + go, goStart :: [GlobPiece] -> String -> Bool + + goStart (WildCard:_) ('.':_) = False + goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs) + globs + goStart rest cs = go rest cs + + go [] "" = True + go (Literal lit:rest) cs + | Just cs' <- stripPrefix lit cs + = go rest cs' + | otherwise = False + go [WildCard] "" = True + go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs + go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs + go [] (_:_) = False + go (_:_) "" = False + + +------------------------------------------------------------------------------ +-- Parsing & printing +-- + +instance Pretty FilePathGlob where + pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob + +instance Parsec FilePathGlob where + parsec = do + root <- parsec + case root of + FilePathRelative -> FilePathGlob root <$> parsec + _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing) + +instance Pretty FilePathRoot where + pretty FilePathRelative = Disp.empty + pretty (FilePathRoot root) = Disp.text root + pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' + +instance Parsec FilePathRoot where + parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where + root = FilePathRoot "/" <$ P.char '/' + home = FilePathHomeDir <$ P.string "~/" + drive = do + dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') + _ <- P.char ':' + _ <- P.char '/' <|> P.char '\\' + return (FilePathRoot (toUpper dr : ":\\")) + +instance Pretty FilePathGlobRel where + pretty (GlobDir glob pathglob) = dispGlob glob + Disp.<> Disp.char '/' + Disp.<> pretty pathglob + pretty (GlobFile glob) = dispGlob glob + pretty GlobDirTrailing = Disp.empty + +instance Parsec FilePathGlobRel where + parsec = parsecPath where + parsecPath :: CabalParsing m => m FilePathGlobRel + parsecPath = do + glob <- parsecGlob + dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) + + dirSep :: CabalParsing m => m () + dirSep = () <$ P.char '/' <|> P.try (do + _ <- P.char '\\' + -- check this isn't an escape code + P.notFollowedBy (P.satisfy isGlobEscapedChar)) + +dispGlob :: Glob -> Disp.Doc +dispGlob = Disp.hcat . map dispPiece + where + dispPiece WildCard = Disp.char '*' + dispPiece (Literal str) = Disp.text (escape str) + dispPiece (Union globs) = Disp.braces + (Disp.hcat (Disp.punctuate + (Disp.char ',') + (map dispGlob globs))) + escape [] = [] + escape (c:cs) + | isGlobEscapedChar c = '\\' : c : escape cs + | otherwise = c : escape cs + +parsecGlob :: CabalParsing m => m Glob +parsecGlob = some parsecPiece where + parsecPiece = P.choice [ literal, wildcard, union ] + + wildcard = WildCard <$ P.char '*' + union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) + literal = Literal <$> some litchar + + litchar = normal <|> escape + + normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') + escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar + +isGlobEscapedChar :: Char -> Bool +isGlobEscapedChar '*' = True +isGlobEscapedChar '{' = True +isGlobEscapedChar '}' = True +isGlobEscapedChar ',' = True +isGlobEscapedChar _ = False diff --git a/src/Distribution/Client/GlobalFlags.hs b/src/Distribution/Client/GlobalFlags.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/GlobalFlags.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Client.GlobalFlags ( + GlobalFlags(..) + , defaultGlobalFlags + , RepoContext(..) + , withRepoContext + , withRepoContext' + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Types + ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) +import Distribution.Simple.Setup + ( Flag(..), fromFlag, flagToMaybe ) +import Distribution.Utils.NubList + ( NubList, fromNubList ) +import Distribution.Client.HttpUtils + ( HttpTransport, configureTransport ) +import Distribution.Simple.Utils + ( info, warn ) + +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) + +import Control.Concurrent + ( MVar, newMVar, modifyMVar ) +import System.FilePath + ( () ) +import Network.URI + ( URI, uriScheme, uriPath ) +import qualified Data.Map as Map + +import qualified Hackage.Security.Client as Sec +import qualified Hackage.Security.Util.Path as Sec +import qualified Hackage.Security.Util.Pretty as Sec +import qualified Hackage.Security.Client.Repository.Cache as Sec +import qualified Hackage.Security.Client.Repository.Local as Sec.Local +import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote +import qualified Distribution.Client.Security.HTTP as Sec.HTTP +import qualified Distribution.Client.Security.DNS as Sec.DNS + +import qualified System.FilePath.Posix as FilePath.Posix + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- | Flags that apply at the top level, not to any sub-command. + +data GlobalFlags = GlobalFlags + { globalVersion :: Flag Bool + , globalNumericVersion :: Flag Bool + , globalConfigFile :: Flag FilePath + , globalConstraintsFile :: Flag FilePath + , globalRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. + , globalCacheDir :: Flag FilePath + , globalLocalNoIndexRepos :: NubList LocalRepo + , globalActiveRepos :: Flag ActiveRepos + , globalLogsDir :: Flag FilePath + , globalWorldFile :: Flag FilePath + , globalIgnoreExpiry :: Flag Bool -- ^ Ignore security expiry dates + , globalHttpTransport :: Flag String + , globalNix :: Flag Bool -- ^ Integrate with Nix + , globalStoreDir :: Flag FilePath + , globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) + } deriving (Show, Generic) + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags + { globalVersion = Flag False + , globalNumericVersion = Flag False + , globalConfigFile = mempty + , globalConstraintsFile = mempty + , globalRemoteRepos = mempty + , globalCacheDir = mempty + , globalLocalNoIndexRepos = mempty + , globalActiveRepos = mempty + , globalLogsDir = mempty + , globalWorldFile = mempty + , globalIgnoreExpiry = Flag False + , globalHttpTransport = mempty + , globalNix = Flag False + , globalStoreDir = mempty + , globalProgPathExtra = mempty + } + +instance Monoid GlobalFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup GlobalFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Repo context +-- ------------------------------------------------------------ + +-- | Access to repositories +data RepoContext = RepoContext { + -- | All user-specified repositories + repoContextRepos :: [Repo] + + -- | Get the HTTP transport + -- + -- The transport will be initialized on the first call to this function. + -- + -- NOTE: It is important that we don't eagerly initialize the transport. + -- Initializing the transport is not free, and especially in contexts where + -- we don't know a-priori whether or not we need the transport (for instance + -- when using cabal in "nix mode") incurring the overhead of transport + -- initialization on _every_ invocation (eg @cabal build@) is undesirable. + , repoContextGetTransport :: IO HttpTransport + + -- | Get the (initialized) secure repo + -- + -- (the 'Repo' type itself is stateless and must remain so, because it + -- must be serializable) + , repoContextWithSecureRepo :: forall a. + Repo + -> (forall down. Sec.Repository down -> IO a) + -> IO a + + -- | Should we ignore expiry times (when checking security)? + , repoContextIgnoreExpiry :: Bool + } + +-- | Wrapper around 'Repository', hiding the type argument +data SecureRepo = forall down. SecureRepo (Sec.Repository down) + +withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a +withRepoContext verbosity globalFlags = + withRepoContext' + verbosity + (fromNubList (globalRemoteRepos globalFlags)) + (fromNubList (globalLocalNoIndexRepos globalFlags)) + (fromFlag (globalCacheDir globalFlags)) + (flagToMaybe (globalHttpTransport globalFlags)) + (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalProgPathExtra globalFlags)) + +withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo] + -> FilePath -> Maybe String -> Maybe Bool + -> [FilePath] + -> (RepoContext -> IO a) + -> IO a +withRepoContext' verbosity remoteRepos localNoIndexRepos + sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do + for_ localNoIndexRepos $ \local -> + unless (FilePath.Posix.isAbsolute (localRepoPath local)) $ + warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended" + + transportRef <- newMVar Nothing + let httpLib = Sec.HTTP.transportAdapter + verbosity + (getTransport transportRef) + initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> + callback RepoContext { + repoContextRepos = allRemoteRepos + ++ allLocalNoIndexRepos + , repoContextGetTransport = getTransport transportRef + , repoContextWithSecureRepo = withSecureRepo secureRepos' + , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry + } + where + secureRemoteRepos = + [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ] + + allRemoteRepos :: [Repo] + allRemoteRepos = + [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir + | remote <- remoteRepos + , let cacheDir = sharedCacheDir unRepoName (remoteRepoName remote) + isSecure = remoteRepoSecure remote == Just True + ] + + allLocalNoIndexRepos :: [Repo] + allLocalNoIndexRepos = + [ RepoLocalNoIndex local cacheDir + | local <- localNoIndexRepos + , let cacheDir | localRepoSharedCache local = sharedCacheDir localRepoCacheKey local + | otherwise = localRepoPath local + ] + + getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport + getTransport transportRef = + modifyMVar transportRef $ \mTransport -> do + transport <- case mTransport of + Just tr -> return tr + Nothing -> configureTransport verbosity extraPaths httpTransport + return (Just transport, transport) + + withSecureRepo :: Map Repo SecureRepo + -> Repo + -> (forall down. Sec.Repository down -> IO a) + -> IO a + withSecureRepo secureRepos repo callback = + case Map.lookup repo secureRepos of + Just (SecureRepo secureRepo) -> callback secureRepo + Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo" + +-- | Initialize the provided secure repositories +-- +-- Assumed invariant: `remoteRepoSecure` should be set for all these repos. +initSecureRepos :: forall a. Verbosity + -> Sec.HTTP.HttpLib + -> [(RemoteRepo, FilePath)] + -> (Map Repo SecureRepo -> IO a) + -> IO a +initSecureRepos verbosity httpLib repos callback = go Map.empty repos + where + go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a + go !acc [] = callback acc + go !acc ((r,cacheDir):rs) = do + cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir + initSecureRepo verbosity httpLib r cachePath $ \r' -> + go (Map.insert (RepoSecure r cacheDir) r' acc) rs + +-- | Initialize the given secure repo +-- +-- The security library has its own concept of a "local" repository, distinct +-- from @cabal-install@'s; these are secure repositories, but live in the local +-- file system. We use the convention that these repositories are identified by +-- URLs of the form @file:/path/to/local/repo@. +initSecureRepo :: Verbosity + -> Sec.HTTP.HttpLib + -> RemoteRepo -- ^ Secure repo ('remoteRepoSecure' assumed) + -> Sec.Path Sec.Absolute -- ^ Cache dir + -> (SecureRepo -> IO a) -- ^ Callback + -> IO a +initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do + requiresBootstrap <- withRepo [] Sec.requiresBootstrap + + mirrors <- if requiresBootstrap + then do + info verbosity $ "Trying to locate mirrors via DNS for " ++ + "initial bootstrap of secure " ++ + "repository '" ++ show remoteRepoURI ++ + "' ..." + + Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI + else pure [] + + withRepo mirrors $ \r -> do + when requiresBootstrap $ Sec.uncheckClientErrors $ + Sec.bootstrap r + (map Sec.KeyId remoteRepoRootKeys) + (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold)) + callback $ SecureRepo r + where + -- Initialize local or remote repo depending on the URI + withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a + withRepo _ callback | uriScheme remoteRepoURI == "file:" = do + dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI) + Sec.Local.withRepository dir + cache + Sec.hackageRepoLayout + Sec.hackageIndexLayout + logTUF + callback + withRepo mirrors callback = + Sec.Remote.withRepository httpLib + (remoteRepoURI:mirrors) + Sec.Remote.defaultRepoOpts + cache + Sec.hackageRepoLayout + Sec.hackageIndexLayout + logTUF + callback + + cache :: Sec.Cache + cache = Sec.Cache { + cacheRoot = cachePath + , cacheLayout = Sec.cabalCacheLayout { + Sec.cacheLayoutIndexTar = cacheFn "01-index.tar" + , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx" + , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz" + } + } + + cacheFn :: FilePath -> Sec.CachePath + cacheFn = Sec.rootPath . Sec.fragment + + -- We display any TUF progress only in verbose mode, including any transient + -- verification errors. If verification fails, then the final exception that + -- is thrown will of course be shown. + logTUF :: Sec.LogMessage -> IO () + logTUF = info verbosity . Sec.pretty diff --git a/src/Distribution/Client/Haddock.hs b/src/Distribution/Client/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Haddock.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Haddock +-- Copyright : (c) Andrea Vezzosi 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Interfacing with Haddock +-- +----------------------------------------------------------------------------- +module Distribution.Client.Haddock + ( + regenerateHaddockIndex + ) + where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Data.List (maximumBy) +import System.Directory (createDirectoryIfMissing, renameFile) +import System.FilePath ((), splitFileName) +import Distribution.Package + ( packageVersion ) +import Distribution.Simple.Haddock (haddockPackagePaths) +import Distribution.Simple.Program (haddockProgram, ProgramDb + , runProgram, requireProgramVersion) +import Distribution.Version (mkVersion, orLaterVersion) +import Distribution.Simple.PackageIndex + ( InstalledPackageIndex, allPackagesByName ) +import Distribution.Simple.Utils + ( debug, installDirectoryContents, withTempDirectory ) +import Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo(exposed) ) + +regenerateHaddockIndex :: Verbosity + -> InstalledPackageIndex -> ProgramDb + -> FilePath + -> IO () +regenerateHaddockIndex verbosity pkgs progdb index = do + (paths, warns) <- haddockPackagePaths pkgs' Nothing + let paths' = [ (interface, html) | (interface, Just html, _) <- paths] + for_ warns (debug verbosity) + + (confHaddock, _, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (mkVersion [0,6])) progdb + + createDirectoryIfMissing True destDir + + withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + + let flags = [ "--gen-contents" + , "--gen-index" + , "--odir=" ++ tempDir + , "--title=Haskell modules on this system" ] + ++ [ "--read-interface=" ++ html ++ "," ++ interface + | (interface, html) <- paths' ] + runProgram verbosity confHaddock flags + renameFile (tempDir "index.html") (tempDir destFile) + installDirectoryContents verbosity tempDir destDir + + where + (destDir,destFile) = splitFileName index + pkgs' = [ maximumBy (comparing packageVersion) pkgvers' + | (_pname, pkgvers) <- allPackagesByName pkgs + , let pkgvers' = filter exposed pkgvers + , not (null pkgvers') ] diff --git a/src/Distribution/Client/HashValue.hs b/src/Distribution/Client/HashValue.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/HashValue.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.HashValue ( + HashValue, + hashValue, + truncateHash, + showHashValue, + readFileHashValue, + hashFromTUF, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Hackage.Security.Client as Sec + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import System.IO (IOMode (..), withBinaryFile) + +----------------------------------------------- +-- The specific choice of hash implementation +-- + +-- Is a crypto hash necessary here? One thing to consider is who controls the +-- inputs and what's the result of a hash collision. Obviously we should not +-- install packages we don't trust because they can run all sorts of code, but +-- if I've checked there's no TH, no custom Setup etc, is there still a +-- problem? If someone provided us a tarball that hashed to the same value as +-- some other package and we installed it, we could end up re-using that +-- installed package in place of another one we wanted. So yes, in general +-- there is some value in preventing intentional hash collisions in installed +-- package ids. + +newtype HashValue = HashValue BS.ByteString + deriving (Eq, Generic, Show, Typeable) + +-- Cannot do any sensible validation here. Although we use SHA256 +-- for stuff we hash ourselves, we can also get hashes from TUF +-- and that can in principle use different hash functions in future. +-- +-- Therefore, we simply derive this structurally. +instance Binary HashValue +instance Structured HashValue + +-- | Hash some data. Currently uses SHA256. +-- +hashValue :: LBS.ByteString -> HashValue +hashValue = HashValue . SHA256.hashlazy + +showHashValue :: HashValue -> String +showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) + +-- | Hash the content of a file. Uses SHA256. +-- +readFileHashValue :: FilePath -> IO HashValue +readFileHashValue tarball = + withBinaryFile tarball ReadMode $ \hnd -> + evaluate . hashValue =<< LBS.hGetContents hnd + +-- | Convert a hash from TUF metadata into a 'PackageSourceHash'. +-- +-- Note that TUF hashes don't neessarily have to be SHA256, since it can +-- support new algorithms in future. +-- +hashFromTUF :: Sec.Hash -> HashValue +hashFromTUF (Sec.Hash hashstr) = + --TODO: [code cleanup] either we should get TUF to use raw bytestrings or + -- perhaps we should also just use a base16 string as the internal rep. + case Base16.decode (BS.pack hashstr) of +#if MIN_VERSION_base16_bytestring(1,0,0) + Right hash -> HashValue hash + Left _ -> error "hashFromTUF: cannot decode base16" +#else + (hash, trailing) | not (BS.null hash) && BS.null trailing + -> HashValue hash + _ -> error "hashFromTUF: cannot decode base16 hash" +#endif + +-- | Truncate a 32 byte SHA256 hash to +-- +-- For example 20 bytes render as 40 hex chars, which we use for unit-ids. +-- Or even 4 bytes for 'hashedInstalledPackageIdShort' +-- +truncateHash :: Int -> HashValue -> HashValue +truncateHash n (HashValue h) = HashValue (BS.take n h) diff --git a/src/Distribution/Client/HttpUtils.hs b/src/Distribution/Client/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/HttpUtils.hs @@ -0,0 +1,916 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | Separate module for HTTP actions, using a proxy server if one exists. +----------------------------------------------------------------------------- +module Distribution.Client.HttpUtils ( + DownloadResult(..), + configureTransport, + HttpTransport(..), + HttpCode, + downloadURI, + transportCheckHttps, + remoteRepoCheckHttps, + remoteRepoTryUpgradeToHttps, + isOldHackageURI + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (Proxy (..)) +import Distribution.Utils.Generic + +import Network.HTTP + ( Request (..), Response (..), RequestMethod (..) + , Header(..), HeaderName(..), lookupHeader ) +import Network.HTTP.Proxy ( Proxy(..), fetchProxy) +import Network.URI + ( URI (..), URIAuth (..), uriToString ) +import Network.Browser + ( browse, setOutHandler, setErrHandler, setProxy + , setAuthorityGen, request, setAllowBasicAuth, setUserAgent ) +import qualified Control.Exception as Exception +import Distribution.Simple.Utils + ( die', info, warn, debug, notice + , copyFileVerbose, withTempFile, IOData (..) ) +import Distribution.Client.Utils + ( withTempFileName, cabalInstallVersion ) +import Distribution.Client.Types + ( unRepoName, RemoteRepo(..) ) +import Distribution.System + ( buildOS, buildArch ) +import qualified System.FilePath.Posix as FilePath.Posix + ( splitDirectories ) +import System.FilePath + ( (<.>), takeFileName, takeDirectory ) +import System.Directory + ( doesFileExist, renameFile, canonicalizePath ) +import System.IO + ( withFile, IOMode(ReadMode), hGetContents, hClose ) +import System.IO.Error + ( isDoesNotExistError ) +import Distribution.Simple.Program + ( Program, simpleProgram, ConfiguredProgram, programPath + , ProgramInvocation(..), programInvocation + , ProgramSearchPathEntry(..) + , getProgramInvocationOutput ) +import Distribution.Simple.Program.Db + ( ProgramDb, emptyProgramDb, addKnownPrograms + , configureAllKnownPrograms + , requireProgram, lookupProgram + , modifyProgramSearchPath ) +import Distribution.Simple.Program.Run + ( getProgramInvocationOutputAndErrors ) +import Numeric (showHex) +import System.Random (randomRIO) + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Distribution.Compat.CharParsing as P +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 + +------------------------------------------------------------------------------ +-- Downloading a URI, given an HttpTransport +-- + +data DownloadResult = FileAlreadyInCache + | FileDownloaded FilePath + deriving (Eq) + +data DownloadCheck + = Downloaded -- ^ already downloaded and sha256 matches + | CheckETag String -- ^ already downloaded and we have etag + | NeedsDownload (Maybe BS.ByteString) -- ^ needs download with optional hash check + deriving Eq + +downloadURI :: HttpTransport + -> Verbosity + -> URI -- ^ What to download + -> FilePath -- ^ Where to put it + -> IO DownloadResult +downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do + copyFileVerbose verbosity (uriPath uri) path + return (FileDownloaded path) + -- Can we store the hash of the file so we can safely return path when the + -- hash matches to avoid unnecessary computation? + +downloadURI transport verbosity uri path = do + + targetExists <- doesFileExist path + + downloadCheck <- + -- if we have uriFrag, then we expect there to be #sha256=... + if not (null uriFrag) + then case sha256parsed of + -- we know the hash, and target exists + Right expected | targetExists -> do + contents <- LBS.readFile path + let actual = SHA256.hashlazy contents + if expected == actual + then return Downloaded + else return (NeedsDownload (Just expected)) + + -- we known the hash, target doesn't exist + Right expected -> return (NeedsDownload (Just expected)) + + -- we failed to parse uriFragment + Left err -> die' verbosity $ + "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err + + -- if there are no uri fragment, use ETag + else do + etagPathExists <- doesFileExist etagPath + -- In rare cases the target file doesn't exist, but the etag does. + if targetExists && etagPathExists + then return (CheckETag etagPath) + else return (NeedsDownload Nothing) + + -- Only use the external http transports if we actually have to + -- (or have been told to do so) + let transport' + | uriScheme uri == "http:" + , not (transportManuallySelected transport) + = plainHttpTransport + + | otherwise + = transport + + case downloadCheck of + Downloaded -> return FileAlreadyInCache + CheckETag etag -> makeDownload transport' Nothing (Just etag) + NeedsDownload hash -> makeDownload transport' hash Nothing + + where + makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do + result <- getHttp transport' verbosity uri etag tmpFile [] + + -- Only write the etag if we get a 200 response code. + -- A 304 still sends us an etag header. + case result of + -- if we have hash, we don't care about etag. + (200, _) | Just expected <- sha256 -> do + contents <- LBS.readFile tmpFile + let actual = SHA256.hashlazy contents + unless (actual == expected) $ + die' verbosity $ unwords + [ "Failed to download", show uri + , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected) + , "actual:", BS8.unpack (Base16.encode actual) + ] + + (200, Just newEtag) -> writeFile etagPath newEtag + _ -> return () + + case fst result of + 200 -> do + info verbosity ("Downloaded to " ++ path) + renameFile tmpFile path + return (FileDownloaded path) + 304 -> do + notice verbosity "Skipping download: local and remote files match." + return FileAlreadyInCache + errCode -> die' verbosity $ "failed to download " ++ show uri + ++ " : HTTP code " ++ show errCode + + etagPath = path <.> "etag" + uriFrag = uriFragment uri + + sha256parsed :: Either String BS.ByteString + sha256parsed = explicitEitherParsec fragmentParser uriFrag + + fragmentParser = do + _ <- P.string "#sha256=" + str <- some P.hexDigit + let bs = Base16.decode (BS8.pack str) +#if MIN_VERSION_base16_bytestring(1,0,0) + either fail return bs +#else + return (fst bs) +#endif + +------------------------------------------------------------------------------ +-- Utilities for repo url management +-- + +remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () +remoteRepoCheckHttps verbosity transport repo + | uriScheme (remoteRepoURI repo) == "https:" + , not (transportSupportsHttps transport) + = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo) + ++ "' specifies a URL that " ++ requiresHttpsErrorMessage + | otherwise = return () + +transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () +transportCheckHttps verbosity transport uri + | uriScheme uri == "https:" + , not (transportSupportsHttps transport) + = die' verbosity $ "The URL " ++ show uri + ++ " " ++ requiresHttpsErrorMessage + | otherwise = return () + +requiresHttpsErrorMessage :: String +requiresHttpsErrorMessage = + "requires HTTPS however the built-in HTTP implementation " + ++ "does not support HTTPS. The transport implementations with HTTPS " + ++ "support are " ++ intercalate ", " + [ name | (name, _, True, _ ) <- supportedTransports ] + ++ ". One of these will be selected automatically if the corresponding " + ++ "external program is available, or one can be selected specifically " + ++ "with the global flag --http-transport=" + +remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo +remoteRepoTryUpgradeToHttps verbosity transport repo + | remoteRepoShouldTryHttps repo + , uriScheme (remoteRepoURI repo) == "http:" + , not (transportSupportsHttps transport) + , not (transportManuallySelected transport) + = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using " + ++ "HTTPS for authenticated uploads is recommended. " + ++ "The transport implementations with HTTPS support are " + ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] + ++ "but they require the corresponding external program to be " + ++ "available. You can either make one available or use plain HTTP by " + ++ "using the global flag --http-transport=plain-http (or putting the " + ++ "equivalent in the config file). With plain HTTP, your password " + ++ "is sent using HTTP digest authentication so it cannot be easily " + ++ "intercepted, but it is not as secure as using HTTPS." + + | remoteRepoShouldTryHttps repo + , uriScheme (remoteRepoURI repo) == "http:" + , transportSupportsHttps transport + = return repo { + remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" } + } + + | otherwise + = return repo + +-- | Utility function for legacy support. +isOldHackageURI :: URI -> Bool +isOldHackageURI uri + = case uriAuthority uri of + Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> + FilePath.Posix.splitDirectories (uriPath uri) + == ["/","packages","archive"] + _ -> False + + +------------------------------------------------------------------------------ +-- Setting up a HttpTransport +-- + +data HttpTransport = HttpTransport { + -- | GET a URI, with an optional ETag (to do a conditional fetch), + -- write the resource to the given file and return the HTTP status code, + -- and optional ETag. + getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header] + -> IO (HttpCode, Maybe ETag), + + -- | POST a resource to a URI, with optional auth (username, password) + -- and return the HTTP status code and any redirect URL. + postHttp :: Verbosity -> URI -> String -> Maybe Auth + -> IO (HttpCode, String), + + -- | POST a file resource to a URI using multipart\/form-data encoding, + -- with optional auth (username, password) and return the HTTP status + -- code and any error string. + postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth + -> IO (HttpCode, String), + + -- | PUT a file resource to a URI, with optional auth + -- (username, password), extra headers and return the HTTP status code + -- and any error string. + putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header] + -> IO (HttpCode, String), + + -- | Whether this transport supports https or just http. + transportSupportsHttps :: Bool, + + -- | Whether this transport implementation was specifically chosen by + -- the user via configuration, or whether it was automatically selected. + -- Strictly speaking this is not a property of the transport itself but + -- about how it was chosen. Nevertheless it's convenient to keep here. + transportManuallySelected :: Bool + } + --TODO: why does postHttp return a redirect, but postHttpFile return errors? + +type HttpCode = Int +type ETag = String +type Auth = (String, String) + +noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) + -> IO (Int, String) +noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" + +supportedTransports :: [(String, Maybe Program, Bool, + ProgramDb -> Maybe HttpTransport)] +supportedTransports = + [ let prog = simpleProgram "curl" in + ( "curl", Just prog, True + , \db -> curlTransport <$> lookupProgram prog db ) + + , let prog = simpleProgram "wget" in + ( "wget", Just prog, True + , \db -> wgetTransport <$> lookupProgram prog db ) + + , let prog = simpleProgram "powershell" in + ( "powershell", Just prog, True + , \db -> powershellTransport <$> lookupProgram prog db ) + + , ( "plain-http", Nothing, False + , \_ -> Just plainHttpTransport ) + ] + +configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport + +configureTransport verbosity extraPath (Just name) = + -- the user specifically selected a transport by name so we'll try and + -- configure that one + + case find (\(name',_,_,_) -> name' == name) supportedTransports of + Just (_, mprog, _tls, mkTrans) -> do + + let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + progdb <- case mprog of + Nothing -> return emptyProgramDb + Just prog -> snd <$> requireProgram verbosity prog baseProgDb + -- ^^ if it fails, it'll fail here + + let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb + return transport { transportManuallySelected = True } + + Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name + ++ ". The supported transports are " + ++ intercalate ", " + [ name' | (name', _, _, _ ) <- supportedTransports ] + +configureTransport verbosity extraPath Nothing = do + -- the user hasn't selected a transport, so we'll pick the first one we + -- can configure successfully, provided that it supports tls + + -- for all the transports except plain-http we need to try and find + -- their external executable + let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + progdb <- configureAllKnownPrograms verbosity $ + addKnownPrograms + [ prog | (_, Just prog, _, _) <- supportedTransports ] + baseProgDb + + let availableTransports = + [ (name, transport) + | (name, _, _, mkTrans) <- supportedTransports + , transport <- maybeToList (mkTrans progdb) ] + let (name, transport) = + fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) + debug verbosity $ "Selected http transport implementation: " ++ name + + return transport { transportManuallySelected = False } + + +------------------------------------------------------------------------------ +-- The HttpTransports based on external programs +-- + +curlTransport :: ConfiguredProgram -> HttpTransport +curlTransport prog = + HttpTransport gethttp posthttp posthttpfile puthttpfile True False + where + gethttp verbosity uri etag destPath reqHeaders = do + withTempFile (takeDirectory destPath) + "curl-headers.txt" $ \tmpFile tmpHandle -> do + hClose tmpHandle + let args = [ show uri + , "--output", destPath + , "--location" + , "--write-out", "%{http_code}" + , "--user-agent", userAgent + , "--silent", "--show-error" + , "--dump-header", tmpFile ] + ++ concat + [ ["--header", "If-None-Match: " ++ t] + | t <- maybeToList etag ] + ++ concat + [ ["--header", show name ++ ": " ++ value] + | Header name value <- reqHeaders ] + + resp <- getProgramInvocationOutput verbosity + (programInvocation prog args) + withFile tmpFile ReadMode $ \hnd -> do + headers <- hGetContents hnd + (code, _err, etag') <- parseResponse verbosity uri resp headers + evaluate $ force (code, etag') + + posthttp = noPostYet + + addAuthConfig auth progInvocation = progInvocation + { progInvokeInput = do + (uname, passwd) <- auth + return $ IODataText $ unlines + [ "--digest" + , "--user " ++ uname ++ ":" ++ passwd + ] + , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation + } + + posthttpfile verbosity uri path auth = do + let args = [ show uri + , "--form", "package=@"++path + , "--write-out", "\n%{http_code}" + , "--user-agent", userAgent + , "--silent", "--show-error" + , "--header", "Accept: text/plain" + , "--location" + ] + resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth + (programInvocation prog args) + (code, err, _etag) <- parseResponse verbosity uri resp "" + return (code, err) + + puthttpfile verbosity uri path auth headers = do + let args = [ show uri + , "--request", "PUT", "--data-binary", "@"++path + , "--write-out", "\n%{http_code}" + , "--user-agent", userAgent + , "--silent", "--show-error" + , "--location" + , "--header", "Accept: text/plain" + ] + ++ concat + [ ["--header", show name ++ ": " ++ value] + | Header name value <- headers ] + resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth + (programInvocation prog args) + (code, err, _etag) <- parseResponse verbosity uri resp "" + return (code, err) + + -- on success these curl invocations produces an output like "200" + -- and on failure it has the server error response first + parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) + parseResponse verbosity uri resp headers = + let codeerr = + case reverse (lines resp) of + (codeLine:rerrLines) -> + case readMaybe (trim codeLine) of + Just i -> let errstr = mkErrstr rerrLines + in Just (i, errstr) + Nothing -> Nothing + [] -> Nothing + + mkErrstr = unlines . reverse . dropWhile (all isSpace) + + mb_etag :: Maybe ETag + mb_etag = listToMaybe $ reverse + [ etag + | ["ETag:", etag] <- map words (lines headers) ] + + in case codeerr of + Just (i, err) -> return (i, err, mb_etag) + _ -> statusParseFail verbosity uri resp + + +wgetTransport :: ConfiguredProgram -> HttpTransport +wgetTransport prog = + HttpTransport gethttp posthttp posthttpfile puthttpfile True False + where + gethttp verbosity uri etag destPath reqHeaders = do + resp <- runWGet verbosity uri args + + -- wget doesn't support range requests. + -- so, we not only ignore range request headers, + -- but we also dispay a warning message when we see them. + let hasRangeHeader = any isRangeHeader reqHeaders + warningMsg = "the 'wget' transport currently doesn't support" + ++ " range requests, which wastes network bandwidth." + ++ " To fix this, set 'http-transport' to 'curl' or" + ++ " 'plain-http' in '~/.cabal/config'." + ++ " Note that the 'plain-http' transport doesn't" + ++ " support HTTPS.\n" + + when (hasRangeHeader) $ warn verbosity warningMsg + (code, etag') <- parseOutput verbosity uri resp + return (code, etag') + where + args = [ "--output-document=" ++ destPath + , "--user-agent=" ++ userAgent + , "--tries=5" + , "--timeout=15" + , "--server-response" ] + ++ concat + [ ["--header", "If-None-Match: " ++ t] + | t <- maybeToList etag ] + ++ [ "--header=" ++ show name ++ ": " ++ value + | hdr@(Header name value) <- reqHeaders + , (not (isRangeHeader hdr)) ] + + -- wget doesn't support range requests. + -- so, we ignore range request headers, lest we get errors. + isRangeHeader :: Header -> Bool + isRangeHeader (Header HdrRange _) = True + isRangeHeader _ = False + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = + withTempFile (takeDirectory path) + (takeFileName path) $ \tmpFile tmpHandle -> + withTempFile (takeDirectory path) "response" $ + \responseFile responseHandle -> do + hClose responseHandle + (body, boundary) <- generateMultipartBody path + LBS.hPut tmpHandle body + hClose tmpHandle + let args = [ "--post-file=" ++ tmpFile + , "--user-agent=" ++ userAgent + , "--server-response" + , "--output-document=" ++ responseFile + , "--header=Accept: text/plain" + , "--header=Content-type: multipart/form-data; " ++ + "boundary=" ++ boundary ] + out <- runWGet verbosity (addUriAuth auth uri) args + (code, _etag) <- parseOutput verbosity uri out + withFile responseFile ReadMode $ \hnd -> do + resp <- hGetContents hnd + evaluate $ force (code, resp) + + puthttpfile verbosity uri path auth headers = + withTempFile (takeDirectory path) "response" $ + \responseFile responseHandle -> do + hClose responseHandle + let args = [ "--method=PUT", "--body-file="++path + , "--user-agent=" ++ userAgent + , "--server-response" + , "--output-document=" ++ responseFile + , "--header=Accept: text/plain" ] + ++ [ "--header=" ++ show name ++ ": " ++ value + | Header name value <- headers ] + + out <- runWGet verbosity (addUriAuth auth uri) args + (code, _etag) <- parseOutput verbosity uri out + withFile responseFile ReadMode $ \hnd -> do + resp <- hGetContents hnd + evaluate $ force (code, resp) + + addUriAuth Nothing uri = uri + addUriAuth (Just (user, pass)) uri = uri + { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" } + } + where + a = fromMaybe (URIAuth "" "" "") (uriAuthority uri) + + runWGet verbosity uri args = do + -- We pass the URI via STDIN because it contains the users' credentials + -- and sensitive data should not be passed via command line arguments. + let + invocation = (programInvocation prog ("--input-file=-" : args)) + { progInvokeInput = Just $ IODataText $ uriToString id uri "" + } + + -- wget returns its output on stderr rather than stdout + (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity + invocation + -- wget returns exit code 8 for server "errors" like "304 not modified" + if exitCode == ExitSuccess || exitCode == ExitFailure 8 + then return resp + else die' verbosity $ "'" ++ programPath prog + ++ "' exited with an error:\n" ++ resp + + -- With the --server-response flag, wget produces output with the full + -- http server response with all headers, we want to find a line like + -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple + -- requests due to redirects. + parseOutput verbosity uri resp = + let parsedCode = listToMaybe + [ code + | (protocol:codestr:_err) <- map words (reverse (lines resp)) + , "HTTP/" `isPrefixOf` protocol + , code <- maybeToList (readMaybe codestr) ] + mb_etag :: Maybe ETag + mb_etag = listToMaybe + [ etag + | ["ETag:", etag] <- map words (reverse (lines resp)) ] + in case parsedCode of + Just i -> return (i, mb_etag) + _ -> statusParseFail verbosity uri resp + + +powershellTransport :: ConfiguredProgram -> HttpTransport +powershellTransport prog = + HttpTransport gethttp posthttp posthttpfile puthttpfile True False + where + gethttp verbosity uri etag destPath reqHeaders = do + resp <- runPowershellScript verbosity $ + webclientScript + (escape (show uri)) + (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create") + :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))) + [ "$response = $request.GetResponse()" + , "$responseStream = $response.GetResponseStream()" + , "$buffer = new-object byte[] 10KB" + , "$count = $responseStream.Read($buffer, 0, $buffer.length)" + , "while ($count -gt 0)" + , "{" + , " $targetStream.Write($buffer, 0, $count)" + , " $count = $responseStream.Read($buffer, 0, $buffer.length)" + , "}" + , "Write-Host ($response.StatusCode -as [int]);" + , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')" + ] + [ "$targetStream.Flush()" + , "$targetStream.Close()" + , "$targetStream.Dispose()" + , "$responseStream.Dispose()" + ] + parseResponse resp + where + parseResponse :: String -> IO (HttpCode, Maybe ETag) + parseResponse x = + case lines $ trim x of + (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x + (code: _) -> fmap (\c -> (c, Nothing )) $ parseCode code x + _ -> statusParseFail verbosity uri x + parseCode :: String -> String -> IO HttpCode + parseCode code x = case readMaybe code of + Just i -> return i + Nothing -> statusParseFail verbosity uri x + etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = + withTempFile (takeDirectory path) + (takeFileName path) $ \tmpFile tmpHandle -> do + (body, boundary) <- generateMultipartBody path + LBS.hPut tmpHandle body + hClose tmpHandle + fullPath <- canonicalizePath tmpFile + + let contentHeader = Header HdrContentType + ("multipart/form-data; boundary=" ++ boundary) + resp <- runPowershellScript verbosity $ webclientScript + (escape (show uri)) + (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) + (uploadFileAction "POST" uri fullPath) + uploadFileCleanup + parseUploadResponse verbosity uri resp + + puthttpfile verbosity uri path auth headers = do + fullPath <- canonicalizePath path + resp <- runPowershellScript verbosity $ webclientScript + (escape (show uri)) + (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) + (uploadFileAction "PUT" uri fullPath) + uploadFileCleanup + parseUploadResponse verbosity uri resp + + runPowershellScript verbosity script = do + let args = + [ "-InputFormat", "None" + -- the default execution policy doesn't allow running + -- unsigned scripts, so we need to tell powershell to bypass it + , "-ExecutionPolicy", "bypass" + , "-NoProfile", "-NonInteractive" + , "-Command", "-" + ] + debug verbosity script + getProgramInvocationOutput verbosity (programInvocation prog args) + { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);" + } + + escape = show + + useragentHeader = Header HdrUserAgent userAgent + extraHeaders = [Header HdrAccept "text/plain", useragentHeader] + + setupHeaders headers = + [ "$request." ++ addHeader name value + | Header name value <- headers + ] + where + addHeader header value + = case header of + HdrAccept -> "Accept = " ++ escape value + HdrUserAgent -> "UserAgent = " ++ escape value + HdrConnection -> "Connection = " ++ escape value + HdrContentLength -> "ContentLength = " ++ escape value + HdrContentType -> "ContentType = " ++ escape value + HdrDate -> "Date = " ++ escape value + HdrExpect -> "Expect = " ++ escape value + HdrHost -> "Host = " ++ escape value + HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value + HdrReferer -> "Referer = " ++ escape value + HdrTransferEncoding -> "TransferEncoding = " ++ escape value + HdrRange -> let (start, end) = + if "bytes=" `isPrefixOf` value + then case break (== '-') value' of + (start', '-':end') -> (start', end') + _ -> error $ "Could not decode range: " ++ value + else error $ "Could not decode range: " ++ value + value' = drop 6 value + in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");" + name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");" + + setupAuth auth = + [ "$request.Credentials = new-object System.Net.NetworkCredential(" + ++ escape uname ++ "," ++ escape passwd ++ ",\"\");" + | (uname,passwd) <- maybeToList auth + ] + + uploadFileAction method _uri fullPath = + [ "$request.Method = " ++ show method + , "$requestStream = $request.GetRequestStream()" + , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")" + , "$bufSize=10000" + , "$chunk = New-Object byte[] $bufSize" + , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )" + , "{" + , " $requestStream.write($chunk, 0, $bytesRead)" + , " $requestStream.Flush()" + , "}" + , "" + , "$responseStream = $request.getresponse()" + , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()" + , "$code = $response.StatusCode -as [int]" + , "if ($code -eq 0) {" + , " $code = 200;" + , "}" + , "Write-Host $code" + , "Write-Host $responseReader.ReadToEnd()" + ] + + uploadFileCleanup = + [ "$fileStream.Close()" + , "$requestStream.Close()" + , "$responseStream.Close()" + ] + + parseUploadResponse verbosity uri resp = case lines (trim resp) of + (codeStr : message) + | Just code <- readMaybe codeStr -> return (code, unlines message) + _ -> statusParseFail verbosity uri resp + + webclientScript uri setup action cleanup = unlines + [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\"" + , "$uri = New-Object \"System.Uri\" " ++ uri + , "$request = [System.Net.HttpWebRequest]::Create($uri)" + , unlines setup + , "Try {" + , unlines (map (" " ++) action) + , "} Catch [System.Net.WebException] {" + , " $exception = $_.Exception;" + , " If ($exception.Status -eq " + ++ "[System.Net.WebExceptionStatus]::ProtocolError) {" + , " $response = $exception.Response -as [System.Net.HttpWebResponse];" + , " $reader = new-object " + ++ "System.IO.StreamReader($response.GetResponseStream());" + , " Write-Host ($response.StatusCode -as [int]);" + , " Write-Host $reader.ReadToEnd();" + , " } Else {" + , " Write-Host $exception.Message;" + , " }" + , "} Catch {" + , " Write-Host $_.Exception.Message;" + , "} finally {" + , unlines (map (" " ++) cleanup) + , "}" + ] + + +------------------------------------------------------------------------------ +-- The builtin plain HttpTransport +-- + +plainHttpTransport :: HttpTransport +plainHttpTransport = + HttpTransport gethttp posthttp posthttpfile puthttpfile False False + where + gethttp verbosity uri etag destPath reqHeaders = do + let req = Request{ + rqURI = uri, + rqMethod = GET, + rqHeaders = [ Header HdrIfNoneMatch t + | t <- maybeToList etag ] + ++ reqHeaders, + rqBody = LBS.empty + } + (_, resp) <- cabalBrowse verbosity Nothing (request req) + let code = convertRspCode (rspCode resp) + etag' = lookupHeader HdrETag (rspHeaders resp) + -- 206 Partial Content is a normal response to a range request; see #3385. + when (code==200 || code==206) $ + writeFileAtomic destPath $ rspBody resp + return (code, etag') + + posthttp = noPostYet + + posthttpfile verbosity uri path auth = do + (body, boundary) <- generateMultipartBody path + let headers = [ Header HdrContentType + ("multipart/form-data; boundary="++boundary) + , Header HdrContentLength (show (LBS8.length body)) + , Header HdrAccept ("text/plain") + ] + req = Request { + rqURI = uri, + rqMethod = POST, + rqHeaders = headers, + rqBody = body + } + (_, resp) <- cabalBrowse verbosity auth (request req) + return (convertRspCode (rspCode resp), rspErrorString resp) + + puthttpfile verbosity uri path auth headers = do + body <- LBS8.readFile path + let req = Request { + rqURI = uri, + rqMethod = PUT, + rqHeaders = Header HdrContentLength (show (LBS8.length body)) + : Header HdrAccept "text/plain" + : headers, + rqBody = body + } + (_, resp) <- cabalBrowse verbosity auth (request req) + return (convertRspCode (rspCode resp), rspErrorString resp) + + convertRspCode (a,b,c) = a*100 + b*10 + c + + rspErrorString resp = + case lookupHeader HdrContentType (rspHeaders resp) of + Just contenttype + | takeWhile (/= ';') contenttype == "text/plain" + -> LBS8.unpack (rspBody resp) + _ -> rspReason resp + + cabalBrowse verbosity auth act = do + p <- fixupEmptyProxy <$> fetchProxy True + Exception.handleJust + (guard . isDoesNotExistError) + (const . die' verbosity $ "Couldn't establish HTTP connection. " + ++ "Possible cause: HTTP proxy server is down.") $ + browse $ do + setProxy p + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + setUserAgent userAgent + setAllowBasicAuth False + setAuthorityGen (\_ _ -> return auth) + act + + fixupEmptyProxy (Proxy uri _) | null uri = NoProxy + fixupEmptyProxy p = p + + +------------------------------------------------------------------------------ +-- Common stuff used by multiple transport impls +-- + +userAgent :: String +userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion + , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")" + ] + +statusParseFail :: Verbosity -> URI -> String -> IO a +statusParseFail verbosity uri r = + die' verbosity $ "Failed to download " ++ show uri ++ " : " + ++ "No Status Code could be parsed from response: " ++ r + +-- Trim +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + + +------------------------------------------------------------------------------ +-- Multipart stuff partially taken from cgi package. +-- + +generateMultipartBody :: FilePath -> IO (LBS.ByteString, String) +generateMultipartBody path = do + content <- LBS.readFile path + boundary <- genBoundary + let !body = formatBody content (LBS8.pack boundary) + return (body, boundary) + where + formatBody content boundary = + LBS8.concat $ + [ crlf, dd, boundary, crlf ] + ++ [ LBS8.pack (show header) | header <- headers ] + ++ [ crlf + , content + , crlf, dd, boundary, dd, crlf ] + + headers = + [ Header (HdrCustom "Content-disposition") + ("form-data; name=package; " ++ + "filename=\"" ++ takeFileName path ++ "\"") + , Header HdrContentType "application/x-gzip" + ] + + crlf = LBS8.pack "\r\n" + dd = LBS8.pack "--" + +genBoundary :: IO String +genBoundary = do + i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" diff --git a/src/Distribution/Client/IndexUtils.hs b/src/Distribution/Client/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/IndexUtils.hs @@ -0,0 +1,1180 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Extra utils related to the package indexes. +----------------------------------------------------------------------------- +module Distribution.Client.IndexUtils ( + getIndexFileAge, + getInstalledPackages, + indexBaseName, + Configure.getInstalledPackagesMonitorFiles, + getSourcePackages, + getSourcePackagesMonitorFiles, + + TotalIndexState, + getSourcePackagesAtIndexState, + ActiveRepos, + filterSkippedActiveRepos, + + Index(..), + RepoIndexState (..), + PackageEntry(..), + parsePackageIndex, + updateRepoIndexCache, + updatePackageIndexCacheFile, + writeIndexTimestamp, + currentIndexTimestamp, + + BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Archive.Tar.Index as Tar +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.IndexUtils.ActiveRepos +import Distribution.Client.IndexUtils.IndexState +import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.Types +import Distribution.Verbosity +import Distribution.Parsec (simpleParsecBS) + +import Distribution.Package + ( PackageId, PackageIdentifier(..), mkPackageName + , Package(..), packageVersion, packageName ) +import Distribution.Types.Dependency +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.PackageDescription + ( GenericPackageDescription(..) + , PackageDescription(..), emptyPackageDescription ) +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program + ( ProgramDb ) +import qualified Distribution.Simple.Configure as Configure + ( getInstalledPackages, getInstalledPackagesMonitorFiles ) +import Distribution.Types.PackageName (PackageName) +import Distribution.Version + ( Version, VersionRange, mkVersion, intersectVersionRanges ) +import Distribution.Simple.Utils + ( die', warn, info, createDirectoryIfMissingVerbose ) +import Distribution.Client.Setup + ( RepoContext(..) ) + +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe ) +import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse + +import Distribution.Solver.Types.PackageIndex (PackageIndex) +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Exception +import Data.List (stripPrefix) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import qualified Data.ByteString.Char8 as BSS +import Data.ByteString.Lazy (ByteString) +import Distribution.Client.GZipUtils (maybeDecompress) +import Distribution.Client.Utils ( byteStringToFilePath + , tryFindAddSourcePackageDesc ) +import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail) +import Distribution.Compat.Time (getFileAge, getModTime) +import System.Directory (doesFileExist, doesDirectoryExist) +import System.FilePath + ( (), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory ) +import qualified System.FilePath.Posix as FilePath.Posix +import System.IO +import System.IO.Unsafe (unsafeInterleaveIO) +import System.IO.Error (isDoesNotExistError) +import Distribution.Compat.Directory (listDirectory) +import Distribution.Utils.Generic (fstOf3) + +import qualified Codec.Compression.GZip as GZip + +import qualified Hackage.Security.Client as Sec +import qualified Hackage.Security.Util.Some as Sec + +-- | Reduced-verbosity version of 'Configure.getInstalledPackages' +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp packageDbs progdb = + Configure.getInstalledPackages verbosity' comp packageDbs progdb + where + verbosity' = lessVerbose verbosity + + +-- | Get filename base (i.e. without file extension) for index-related files +-- +-- /Secure/ cabal repositories use a new extended & incremental +-- @01-index.tar@. In order to avoid issues resulting from clobbering +-- new/old-style index data, we save them locally to different names. +-- +-- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the +-- @00-index.tar.gz@/@01-index.tar.gz@ file. +indexBaseName :: Repo -> FilePath +indexBaseName repo = repoLocalDir repo fn + where + fn = case repo of + RepoSecure {} -> "01-index" + RepoRemote {} -> "00-index" + RepoLocalNoIndex {} -> "noindex" + +------------------------------------------------------------------------ +-- Reading the source package index +-- + +-- Note: 'data IndexState' is defined in +-- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles + +-- | 'IndexStateInfo' contains meta-information about the resulting +-- filtered 'Cache' 'after applying 'filterCache' according to a +-- requested 'IndexState'. +data IndexStateInfo = IndexStateInfo + { isiMaxTime :: !Timestamp + -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current + -- filtered view of the cache. + -- + -- The following property holds + -- + -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi) + -- + + , isiHeadTime :: !Timestamp + -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest + -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to + -- 'isiMaxTime'. + } + +emptyStateInfo :: IndexStateInfo +emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp + +-- | Filters a 'Cache' according to an 'IndexState' +-- specification. Also returns 'IndexStateInfo' describing the +-- resulting index cache. +-- +-- Note: 'filterCache' is idempotent in the 'Cache' value +filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo) +filterCache IndexStateHead cache = (cache, IndexStateInfo{..}) + where + isiMaxTime = cacheHeadTs cache + isiHeadTime = cacheHeadTs cache +filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..}) + where + cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime } + isiHeadTime = cacheHeadTs cache0 + isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents) + ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0) + +-- | Read a repository index from disk, from the local files specified by +-- a list of 'Repo's. +-- +-- All the 'SourcePackage's are marked as having come from the appropriate +-- 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb +getSourcePackages verbosity repoCtxt = + fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing + +-- | Variant of 'getSourcePackages' which allows getting the source +-- packages at a particular 'IndexState'. +-- +-- Current choices are either the latest (aka HEAD), or the index as +-- it was at a particular time. +-- +-- Returns also the total index where repositories' +-- RepoIndexState's are not HEAD. This is used in v2-freeze. +-- +getSourcePackagesAtIndexState + :: Verbosity + -> RepoContext + -> Maybe TotalIndexState + -> Maybe ActiveRepos + -> IO (SourcePackageDb, TotalIndexState, ActiveRepos) +getSourcePackagesAtIndexState verbosity repoCtxt _ _ + | null (repoContextRepos repoCtxt) = do + -- In the test suite, we routinely don't have any remote package + -- servers, so don't bleat about it + warn (verboseUnmarkOutput verbosity) $ + "No remote package servers have been specified. Usually " ++ + "you would have one specified in the config file." + return (SourcePackageDb { + packageIndex = mempty, + packagePreferences = mempty + }, headTotalIndexState, ActiveRepos []) +getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do + let describeState IndexStateHead = "most recent state" + describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time + + pkgss <- for (repoContextRepos repoCtxt) $ \r -> do + let rname :: RepoName + rname = repoName r + + info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...") + + idxState <- case mb_idxState of + Just totalIdxState -> do + let idxState = lookupIndexState rname totalIdxState + info verbosity $ "Using " ++ describeState idxState ++ + " as explicitly requested (via command line / project configuration)" + return idxState + Nothing -> do + mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r) + case mb_idxState' of + Nothing -> do + info verbosity "Using most recent state (could not read timestamp file)" + return IndexStateHead + Just idxState -> do + info verbosity $ "Using " ++ describeState idxState ++ + " specified from most recent cabal update" + return idxState + + unless (idxState == IndexStateHead) $ + case r of + RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" + RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')") + RepoSecure {} -> pure () + + let idxState' = case r of + RepoSecure {} -> idxState + _ -> IndexStateHead + + (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState' + + case idxState' of + IndexStateHead -> do + info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi)) + return () + IndexStateTime ts0 -> do + when (isiMaxTime isi /= ts0) $ + if ts0 > isiMaxTime isi + then warn verbosity $ + "Requested index-state " ++ prettyShow ts0 + ++ " is newer than '" ++ unRepoName rname ++ "'!" + ++ " Falling back to older state (" + ++ prettyShow (isiMaxTime isi) ++ ")." + else info verbosity $ + "Requested index-state " ++ prettyShow ts0 + ++ " does not exist in '"++ unRepoName rname ++"'!" + ++ " Falling back to older state (" + ++ prettyShow (isiMaxTime isi) ++ ")." + info verbosity ("index-state("++ unRepoName rname ++") = " ++ + prettyShow (isiMaxTime isi) ++ " (HEAD = " ++ + prettyShow (isiHeadTime isi) ++ ")") + + pure RepoData + { rdRepoName = rname + , rdTimeStamp = isiMaxTime isi + , rdIndex = pis + , rdPreferences = deps + } + + let activeRepos :: ActiveRepos + activeRepos = fromMaybe defaultActiveRepos mb_activeRepos + + pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of + Right x -> return x + Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss) + + let activeRepos' :: ActiveRepos + activeRepos' = ActiveRepos + [ ActiveRepo (rdRepoName rd) strategy + | (rd, strategy) <- pkgss' + ] + + let totalIndexState :: TotalIndexState + totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList + [ (n, IndexStateTime ts) + | (RepoData n ts _idx _prefs, _strategy) <- pkgss' + -- e.g. file+noindex have nullTimestamp as their timestamp + , ts /= nullTimestamp + ] + + let addIndex + :: PackageIndex UnresolvedSourcePackage + -> (RepoData, CombineStrategy) + -> PackageIndex UnresolvedSourcePackage + addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc + addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx + addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx + + let pkgs :: PackageIndex UnresolvedSourcePackage + pkgs = foldl' addIndex mempty pkgss' + + -- Note: preferences combined without using CombineStrategy + let prefs :: Map PackageName VersionRange + prefs = Map.fromListWith intersectVersionRanges + [ (name, range) + | (RepoData _n _ts _idx prefs', _strategy) <- pkgss' + , Dependency name range _ <- prefs' + ] + + _ <- evaluate pkgs + _ <- evaluate prefs + _ <- evaluate totalIndexState + return (SourcePackageDb { + packageIndex = pkgs, + packagePreferences = prefs + }, totalIndexState, activeRepos') + +-- auxiliary data used in getSourcePackagesAtIndexState +data RepoData = RepoData + { rdRepoName :: RepoName + , rdTimeStamp :: Timestamp + , rdIndex :: PackageIndex UnresolvedSourcePackage + , rdPreferences :: [Dependency] + } + +-- | Read a repository index from disk, from the local file specified by +-- the 'Repo'. +-- +-- All the 'SourcePackage's are marked as having come from the given 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState + -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) +readRepoIndex verbosity repoCtxt repo idxState = + handleNotFound $ do + when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo + updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) + readPackageIndexCacheFile verbosity mkAvailablePackage + (RepoIndex repoCtxt repo) + idxState + + where + mkAvailablePackage pkgEntry = SourcePackage + { srcpkgPackageId = pkgid + , srcpkgDescription = pkgdesc + , srcpkgSource = case pkgEntry of + NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing + BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path + , srcpkgDescrOverride = case pkgEntry of + NormalPackage _ _ pkgtxt _ -> Just pkgtxt + _ -> Nothing + } + where + pkgdesc = packageDesc pkgEntry + pkgid = packageId pkgEntry + + handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e + then do + case repo of + RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote + RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote + RepoLocalNoIndex local _ -> warn verbosity $ + "Error during construction of local+noindex " + ++ unRepoName (localRepoName local) ++ " repository index: " + ++ show e + return (mempty,mempty,emptyStateInfo) + else ioError e + + isOldThreshold = 15 --days + warnIfIndexIsOld dt = do + when (dt >= isOldThreshold) $ case repo of + RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt + RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt + RepoLocalNoIndex {} -> return () + + errMissingPackageList repoRemote = + "The package list for '" ++ unRepoName (remoteRepoName repoRemote) + ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote + errOutdatedPackageList repoRemote dt = + "The package list for '" ++ unRepoName (remoteRepoName repoRemote) + ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun " + ++ "'cabal update' to get the latest list of available packages." + +-- | Return the age of the index file in days (as a Double). +getIndexFileAge :: Repo -> IO Double +getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar" + +-- | A set of files (or directories) that can be monitored to detect when +-- there might have been a change in the source packages. +-- +getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] +getSourcePackagesMonitorFiles repos = + concat [ [ indexBaseName repo <.> "cache" + , indexBaseName repo <.> "timestamp" ] + | repo <- repos ] + +-- | It is not necessary to call this, as the cache will be updated when the +-- index is read normally. However you can do the work earlier if you like. +-- +updateRepoIndexCache :: Verbosity -> Index -> IO () +updateRepoIndexCache verbosity index = + whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index + +whenCacheOutOfDate :: Index -> IO () -> IO () +whenCacheOutOfDate index action = do + exists <- doesFileExist $ cacheFile index + if not exists + then action + else if localNoIndex index + then return () -- TODO: don't update cache for local+noindex repositories + else do + indexTime <- getModTime $ indexFile index + cacheTime <- getModTime $ cacheFile index + when (indexTime > cacheTime) action + +localNoIndex :: Index -> Bool +localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True +localNoIndex _ = False + +------------------------------------------------------------------------ +-- Reading the index file +-- + +-- | An index entry is either a normal package, or a local build tree reference. +data PackageEntry + = NormalPackage PackageId GenericPackageDescription ByteString BlockNo + | BuildTreeRef BuildTreeRefType + PackageId GenericPackageDescription FilePath BlockNo + +-- | A build tree reference is either a link or a snapshot. +data BuildTreeRefType = SnapshotRef | LinkRef + deriving (Eq,Show,Generic) + +instance Binary BuildTreeRefType +instance Structured BuildTreeRefType + +refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType +refTypeFromTypeCode t + | t == Tar.buildTreeRefTypeCode = LinkRef + | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef + | otherwise = + error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code" + +typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode +typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode +typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode + +instance Package PackageEntry where + packageId (NormalPackage pkgid _ _ _) = pkgid + packageId (BuildTreeRef _ pkgid _ _ _) = pkgid + +packageDesc :: PackageEntry -> GenericPackageDescription +packageDesc (NormalPackage _ descr _ _) = descr +packageDesc (BuildTreeRef _ _ descr _ _) = descr + +-- | Parse an uncompressed \"00-index.tar\" repository index file represented +-- as a 'ByteString'. +-- + +data PackageOrDep = Pkg PackageEntry | Dep Dependency + +-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files +-- +-- We read the index using 'Tar.read', which gives us a lazily constructed +-- 'TarEntries'. We translate it to a list of entries using 'tarEntriesList', +-- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a +-- function over this to translate it to a list of IO actions returning +-- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of +-- 'PackageOrDep's, still maintaining the lazy nature of the original tar read. +parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)] +parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read + where + extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)] + extract blockNo entry = tryExtractPkg ++ tryExtractPrefs + where + tryExtractPkg = do + mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo + return $ fmap (fmap Pkg) mkPkgEntry + + tryExtractPrefs = do + prefs' <- maybeToList $ extractPrefs entry + fmap (return . Just . Dep) prefs' + +-- | Turn the 'Entries' data structure from the @tar@ package into a list, +-- and pair each entry with its block number. +-- +-- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read +-- as far as the list is evaluated. +tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)] +tarEntriesList = go 0 + where + go !_ Tar.Done = [] + go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) + go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' + +extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) +extractPkg verbosity entry blockNo = case Tar.entryContent entry of + Tar.NormalFile content _ + | takeExtension fileName == ".cabal" + -> case splitDirectories (normalise fileName) of + [pkgname,vers,_] -> case simpleParsec vers of + Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) + where + pkgid = PackageIdentifier (mkPackageName pkgname) ver + parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) + descr = case parsed of + Just d -> d + Nothing -> error $ "Couldn't read cabal file " + ++ show fileName + _ -> Nothing + _ -> Nothing + + Tar.OtherEntryType typeCode content _ + | Tar.isBuildTreeRefTypeCode typeCode -> + Just $ do + let path = byteStringToFilePath content + dirExists <- doesDirectoryExist path + result <- if not dirExists then return Nothing + else do + cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." + descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile + return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) + descr path blockNo + return result + + _ -> Nothing + + where + fileName = Tar.entryPath entry + +extractPrefs :: Tar.Entry -> Maybe [Dependency] +extractPrefs entry = case Tar.entryContent entry of + Tar.NormalFile content _ + | FilePath.Posix.takeFileName entrypath == "preferred-versions" + -> Just prefs + where + entrypath = Tar.entryPath entry + prefs = parsePreferredVersions content + _ -> Nothing + +parsePreferredVersions :: ByteString -> [Dependency] +parsePreferredVersions = mapMaybe simpleParsec + . filter (not . isPrefixOf "--") + . lines + . BS.Char8.unpack -- TODO: Are we sure no unicode? + +------------------------------------------------------------------------ +-- Reading and updating the index cache +-- + +-- | Variation on 'sequence' which evaluates the actions lazily +-- +-- Pattern matching on the result list will execute just the first action; +-- more generally pattern matching on the first @n@ '(:)' nodes will execute +-- the first @n@ actions. +lazySequence :: [IO a] -> IO [a] +lazySequence = unsafeInterleaveIO . go + where + go [] = return [] + go (x:xs) = do x' <- x + xs' <- lazySequence xs + return (x' : xs') + +-- | A lazy unfolder for lookup operations which return the current +-- value and (possibly) the next key +lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)] +lazyUnfold step = goLazy . Just + where + goLazy s = unsafeInterleaveIO (go s) + + go Nothing = return [] + go (Just k) = do + (v, mk') <- step k + vs' <- goLazy mk' + return ((k,v):vs') + +-- | Which index do we mean? +data Index = + -- | The main index for the specified repository + RepoIndex RepoContext Repo + + -- | A sandbox-local repository + -- Argument is the location of the index file + | SandboxIndex FilePath + +indexFile :: Index -> FilePath +indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar" +indexFile (SandboxIndex index) = index + +cacheFile :: Index -> FilePath +cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" +cacheFile (SandboxIndex index) = index `replaceExtension` "cache" + +timestampFile :: Index -> FilePath +timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp" +timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp" + +-- | Return 'True' if 'Index' uses 01-index format (aka secure repo) +is01Index :: Index -> Bool +is01Index (RepoIndex _ repo) = case repo of + RepoSecure {} -> True + RepoRemote {} -> False + RepoLocalNoIndex {} -> True +is01Index (SandboxIndex _) = False + + +updatePackageIndexCacheFile :: Verbosity -> Index -> IO () +updatePackageIndexCacheFile verbosity index = do + info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") + withIndexEntries verbosity index callback callbackNoIndex + where + callback entries = do + let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) + cache = Cache { cacheHeadTs = maxTs + , cacheEntries = entries + } + writeIndexCache index cache + info verbosity ("Index cache updated to index-state " + ++ prettyShow (cacheHeadTs cache)) + + callbackNoIndex entries = do + writeNoIndexCache verbosity index $ NoIndexCache entries + info verbosity "Index cache updated" + +-- | Read the index (for the purpose of building a cache) +-- +-- The callback is provided with list of cache entries, which is guaranteed to +-- be lazily constructed. This list must ONLY be used in the scope of the +-- callback; when the callback is terminated the file handle to the index will +-- be closed and further attempts to read from the list will result in (pure) +-- I/O exceptions. +-- +-- In the construction of the index for a secure repo we take advantage of the +-- index built by the @hackage-security@ library to avoid reading the @.tar@ +-- file as much as possible (we need to read it only to extract preferred +-- versions). This helps performance, but is also required for correctness: +-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions +-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956); +-- by reading the already-built cache from the security library we will be sure +-- to only read the latest versions of all files. +-- +-- TODO: It would be nicer if we actually incrementally updated @cabal@'s +-- cache, rather than reconstruct it from zero on each update. However, this +-- would require a change in the cache format. +withIndexEntries + :: Verbosity -> Index + -> ([IndexCacheEntry] -> IO a) + -> ([NoIndexCacheEntry] -> IO a) + -> IO a +withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ = + repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> + Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do + -- Incrementally (lazily) read all the entries in the tar file in order, + -- including all revisions, not just the last revision of each file + indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory) + callback [ cacheEntry + | (dirEntry, indexEntry) <- indexEntries + , cacheEntry <- toCacheEntries dirEntry indexEntry ] + where + toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry + -> [IndexCacheEntry] + toCacheEntries dirEntry (Sec.Some sie) = + case Sec.indexEntryPathParsed sie of + Nothing -> [] -- skip unrecognized file + Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata + Just (Sec.IndexPkgCabal pkgId) -> force + [CachePackageId pkgId blockNo timestamp] + Just (Sec.IndexPkgPrefs _pkgName) -> force + [ CachePreference dep blockNo timestamp + | dep <- parsePreferredVersions (Sec.indexEntryContent sie) + ] + where + blockNo = Sec.directoryEntryBlockNo dirEntry + timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ + epochTimeToTimestamp $ Sec.indexEntryTime sie + +withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do + dirContents <- listDirectory localDir + let contentSet = Set.fromList dirContents + + entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do + case isTarGz file of + Nothing -> do + unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $ + info verbosity $ "Skipping " ++ file + return Nothing + Just pkgid | cabalPath `Set.member` contentSet -> do + contents <- BSS.readFile (localDir cabalPath) + for (parseGenericPackageDescriptionMaybe contents) $ \gpd -> + return (CacheGPD gpd contents) + where + cabalPath = prettyShow pkgid ++ ".cabal" + Just pkgId -> do + -- check for the right named .cabal file in the compressed tarball + tarGz <- BS.readFile (localDir file) + let tar = GZip.decompress tarGz + entries = Tar.read tar + + case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of + Just ce -> return (Just ce) + Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file + + info verbosity $ "Entries in file+noindex repository " ++ unRepoName name + for_ entries $ \(CacheGPD gpd _) -> + info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd) + + callback entries + where + handler :: IOException -> IO a + handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e + + isTarGz :: FilePath -> Maybe PackageIdentifier + isTarGz fp = do + pfx <- stripSuffix ".tar.gz" fp + simpleParsec pfx + + stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str)) + + -- look for /.cabal inside the tarball + readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry + readCabalEntry pkgId entry Nothing + | filename == Tar.entryPath entry + , Tar.NormalFile contents _ <- Tar.entryContent entry + = let bs = BS.toStrict contents + in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs + where + filename = prettyShow pkgId FilePath.Posix. prettyShow (packageName pkgId) ++ ".cabal" + readCabalEntry _ _ x = x + +withIndexEntries verbosity index callback _ = do -- non-secure repositories + withFile (indexFile index) ReadMode $ \h -> do + bs <- maybeDecompress `fmap` BS.hGetContents h + pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs + callback $ map toCache (catMaybes pkgsOrPrefs) + where + toCache :: PackageOrDep -> IndexCacheEntry + toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp + toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo + toCache (Dep d) = CachePreference d 0 nullTimestamp + +readPackageIndexCacheFile :: Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> Index + -> RepoIndexState + -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) +readPackageIndexCacheFile verbosity mkPkg index idxState + | localNoIndex index = do + cache0 <- readNoIndexCache verbosity index + pkgs <- packageNoIndexFromCache verbosity mkPkg cache0 + pure (pkgs, [], emptyStateInfo) + + | otherwise = do + cache0 <- readIndexCache verbosity index + indexHnd <- openFile (indexFile index) ReadMode + let (cache,isi) = filterCache idxState cache0 + (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache + pure (pkgs,deps,isi) + +packageIndexFromCache :: Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> Handle + -> Cache + -> IO (PackageIndex pkg, [Dependency]) +packageIndexFromCache verbosity mkPkg hnd cache = do + (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache + pkgIndex <- evaluate $ PackageIndex.fromList pkgs + return (pkgIndex, prefs) + +packageNoIndexFromCache + :: forall pkg. Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> NoIndexCache + -> IO (PackageIndex pkg) +packageNoIndexFromCache _verbosity mkPkg cache = + evaluate $ PackageIndex.fromList pkgs + where + pkgs = + [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0 + | CacheGPD gpd bs <- noIndexCacheEntries cache + , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd + ] + +-- | Read package list +-- +-- The result package releases and preference entries are guaranteed +-- to be unique. +-- +-- Note: 01-index.tar is an append-only index and therefore contains +-- all .cabal edits and preference-updates. The masking happens +-- here, i.e. the semantics that later entries in a tar file mask +-- earlier ones is resolved in this function. +packageListFromCache :: Verbosity + -> (PackageEntry -> pkg) + -> Handle + -> Cache + -> IO ([pkg], [Dependency]) +packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries + where + accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) + + accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do + -- Given the cache entry, make a package index entry. + -- The magic here is that we use lazy IO to read the .cabal file + -- from the index tarball if it turns out that we need it. + -- Most of the time we only need the package id. + ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do + pkgtxt <- getEntryContent blockno + pkg <- readPackageDescription pkgid pkgtxt + return (pkg, pkgtxt) + + let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) + accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries + + accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do + -- We have to read the .cabal file eagerly here because we can't cache the + -- package id for build tree references - the user might edit the .cabal + -- file after the reference was added to the index. + path <- liftM byteStringToFilePath . getEntryContent $ blockno + pkg <- do let err = "Error reading package index from cache." + file <- tryFindAddSourcePackageDesc verbosity path err + PackageDesc.Parse.readGenericPackageDescription normal file + let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) + accum srcpkgs (srcpkg:btrs) prefs entries + + accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) = + accum srcpkgs btrs (Map.insert pn pref prefs) entries + + getEntryContent :: BlockNo -> IO ByteString + getEntryContent blockno = do + entry <- Tar.hReadEntry hnd blockno + case Tar.entryContent entry of + Tar.NormalFile content _size -> return content + Tar.OtherEntryType typecode content _size + | Tar.isBuildTreeRefTypeCode typecode + -> return content + _ -> interror "unexpected tar entry type" + + readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription + readPackageDescription pkgid content = + case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of + Right gpd -> return gpd + Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer) + Left _ -> interror "failed to parse .cabal file" + where + dummyPackageDescription :: Version -> GenericPackageDescription + dummyPackageDescription specVer = GenericPackageDescription + { packageDescription = emptyPackageDescription + { package = pkgid + , synopsis = dummySynopsis + } + , gpdScannedVersion = Just specVer -- tells index scanner to skip this file. + , genPackageFlags = [] + , condLibrary = Nothing + , condSubLibraries = [] + , condForeignLibs = [] + , condExecutables = [] + , condTestSuites = [] + , condBenchmarks = [] + } + + dummySynopsis = "" + + interror :: String -> IO a + interror msg = die' verbosity $ "internal error when reading package index: " ++ msg + ++ "The package index or index cache is probably " + ++ "corrupt. Running cabal update might fix it." + + + +------------------------------------------------------------------------ +-- Index cache data structure -- + +-- | Read the 'Index' cache from the filesystem +-- +-- If a corrupted index cache is detected this function regenerates +-- the index cache and then reattempt to read the index once (and +-- 'die's if it fails again). +readIndexCache :: Verbosity -> Index -> IO Cache +readIndexCache verbosity index = do + cacheOrFail <- readIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ concat + [ "Parsing the index cache failed (", msg, "). " + , "Trying to regenerate the index cache..." + ] + + updatePackageIndexCacheFile verbosity index + + either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index + + Right res -> return (hashConsCache res) + +readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache +readNoIndexCache verbosity index = do + cacheOrFail <- readNoIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ concat + [ "Parsing the index cache failed (", msg, "). " + , "Trying to regenerate the index cache..." + ] + + updatePackageIndexCacheFile verbosity index + + either (die' verbosity) return =<< readNoIndexCache' index + + -- we don't hash cons local repository cache, they are hopefully small + Right res -> return res + +-- | Read the 'Index' cache from the filesystem without attempting to +-- regenerate on parsing failures. +readIndexCache' :: Index -> IO (Either String Cache) +readIndexCache' index + | is01Index index = structuredDecodeFileOrFail (cacheFile index) + | otherwise = liftM (Right .read00IndexCache) $ + BSS.readFile (cacheFile index) + +readNoIndexCache' :: Index -> IO (Either String NoIndexCache) +readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index) + +-- | Write the 'Index' cache to the filesystem +writeIndexCache :: Index -> Cache -> IO () +writeIndexCache index cache + | is01Index index = structuredEncodeFile (cacheFile index) cache + | otherwise = writeFile (cacheFile index) (show00IndexCache cache) + +writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO () +writeNoIndexCache verbosity index cache = do + let path = cacheFile index + createDirectoryIfMissingVerbose verbosity True (takeDirectory path) + structuredEncodeFile path cache + +-- | Write the 'IndexState' to the filesystem +writeIndexTimestamp :: Index -> RepoIndexState -> IO () +writeIndexTimestamp index st + = writeFile (timestampFile index) (prettyShow st) + +-- | Read out the "current" index timestamp, i.e., what +-- timestamp you would use to revert to this version +currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp +currentIndexTimestamp verbosity repoCtxt r = do + mb_is <- readIndexTimestamp (RepoIndex repoCtxt r) + case mb_is of + Just (IndexStateTime ts) -> return ts + _ -> do + (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead + return (isiHeadTime isi) + +-- | Read the 'IndexState' from the filesystem +readIndexTimestamp :: Index -> IO (Maybe RepoIndexState) +readIndexTimestamp index + = fmap simpleParsec (readFile (timestampFile index)) + `catchIO` \e -> + if isDoesNotExistError e + then return Nothing + else ioError e + +-- | Optimise sharing of equal values inside 'Cache' +-- +-- c.f. https://en.wikipedia.org/wiki/Hash_consing +hashConsCache :: Cache -> Cache +hashConsCache cache0 + = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) } + where + -- TODO/NOTE: + -- + -- If/when we redo the binary serialisation via e.g. CBOR and we + -- are able to use incremental decoding, we may want to move the + -- hash-consing into the incremental deserialisation, or + -- alterantively even do something like + -- http://cbor.schmorp.de/value-sharing + -- + go _ _ [] = [] + -- for now we only optimise only CachePackageIds since those + -- represent the vast majority + go !pns !pvs (CachePackageId pid bno ts : rest) + = CachePackageId pid' bno ts : go pns' pvs' rest + where + !pid' = PackageIdentifier pn' pv' + (!pn',!pns') = mapIntern pn pns + (!pv',!pvs') = mapIntern pv pvs + PackageIdentifier pn pv = pid + + go pns pvs (x:xs) = x : go pns pvs xs + + mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k) + mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m) + +-- | Cabal caches various information about the Hackage index +data Cache = Cache + { cacheHeadTs :: Timestamp + -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the + -- invariant of 'cacheEntries' being in chronological order is + -- violated, this corresponds to the last (seen) 'Timestamp' in + -- 'cacheEntries' + , cacheEntries :: [IndexCacheEntry] + } + deriving (Show, Generic) + +instance NFData Cache where + rnf = rnf . cacheEntries + +-- | Cache format for 'file+noindex' repositories +newtype NoIndexCache = NoIndexCache + { noIndexCacheEntries :: [NoIndexCacheEntry] + } + deriving (Show, Generic) + +instance NFData NoIndexCache where + rnf = rnf . noIndexCacheEntries + +-- | Tar files are block structured with 512 byte blocks. Every header and file +-- content starts on a block boundary. +-- +type BlockNo = Word32 -- Tar.TarEntryOffset + +data IndexCacheEntry + = CachePackageId PackageId !BlockNo !Timestamp + | CachePreference Dependency !BlockNo !Timestamp + | CacheBuildTreeRef !BuildTreeRefType !BlockNo + -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build + deriving (Eq,Show,Generic) + +data NoIndexCacheEntry + = CacheGPD GenericPackageDescription !BSS.ByteString + deriving (Eq,Show,Generic) + +instance NFData IndexCacheEntry where + rnf (CachePackageId pkgid _ _) = rnf pkgid + rnf (CachePreference dep _ _) = rnf dep + rnf (CacheBuildTreeRef _ _) = () + +instance NFData NoIndexCacheEntry where + rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs + +cacheEntryTimestamp :: IndexCacheEntry -> Timestamp +cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp +cacheEntryTimestamp (CachePreference _ _ ts) = ts +cacheEntryTimestamp (CachePackageId _ _ ts) = ts + +---------------------------------------------------------------------------- +-- new binary 01-index.cache format + +instance Binary Cache +instance Binary IndexCacheEntry +instance Binary NoIndexCache + +instance Structured Cache +instance Structured IndexCacheEntry +instance Structured NoIndexCache + +-- | We need to save only .cabal file contents +instance Binary NoIndexCacheEntry where + put (CacheGPD _ bs) = put bs + + get = do + bs <- get + case parseGenericPackageDescriptionMaybe bs of + Just gpd -> return (CacheGPD gpd bs) + Nothing -> fail "Failed to parse GPD" + +instance Structured NoIndexCacheEntry where + structure = nominalStructure + +---------------------------------------------------------------------------- +-- legacy 00-index.cache format + +packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String +packageKey = "pkg:" +blocknoKey = "b#" +buildTreeRefKey = "build-tree-ref:" +preferredVersionKey = "pref-ver:" + +-- legacy 00-index.cache format +read00IndexCache :: BSS.ByteString -> Cache +read00IndexCache bs = Cache + { cacheHeadTs = nullTimestamp + , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs + } + +read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry +read00IndexCacheEntry = \line -> + case BSS.words line of + [key, pkgnamestr, pkgverstr, sep, blocknostr] + | key == BSS.pack packageKey && sep == BSS.pack blocknoKey -> + case (parseName pkgnamestr, parseVer pkgverstr [], + parseBlockNo blocknostr) of + (Just pkgname, Just pkgver, Just blockno) + -> Just (CachePackageId (PackageIdentifier pkgname pkgver) + blockno nullTimestamp) + _ -> Nothing + [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey -> + case (parseRefType typecodestr, parseBlockNo blocknostr) of + (Just refType, Just blockno) + -> Just (CacheBuildTreeRef refType blockno) + _ -> Nothing + + (key: remainder) | key == BSS.pack preferredVersionKey -> do + pref <- simpleParsecBS (BSS.unwords remainder) + return $ CachePreference pref 0 nullTimestamp + + _ -> Nothing + where + parseName str + | BSS.all (\c -> isAlphaNum c || c == '-') str + = Just (mkPackageName (BSS.unpack str)) + | otherwise = Nothing + + parseVer str vs = + case BSS.readInt str of + Nothing -> Nothing + Just (v, str') -> case BSS.uncons str' of + Just ('.', str'') -> parseVer str'' (v:vs) + Just _ -> Nothing + Nothing -> Just (mkVersion (reverse (v:vs))) + + parseBlockNo str = + case BSS.readInt str of + Just (blockno, remainder) + | BSS.null remainder -> Just (fromIntegral blockno) + _ -> Nothing + + parseRefType str = + case BSS.uncons str of + Just (typeCode, remainder) + | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode + -> Just (refTypeFromTypeCode typeCode) + _ -> Nothing + +-- legacy 00-index.cache format +show00IndexCache :: Cache -> String +show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries + +show00IndexCacheEntry :: IndexCacheEntry -> String +show00IndexCacheEntry entry = unwords $ case entry of + CachePackageId pkgid b _ -> + [ packageKey + , prettyShow (packageName pkgid) + , prettyShow (packageVersion pkgid) + , blocknoKey + , show b + ] + CacheBuildTreeRef tr b -> + [ buildTreeRefKey + , [typeCodeFromRefType tr] + , show b + ] + CachePreference dep _ _ -> + [ preferredVersionKey + , prettyShow dep + ] diff --git a/src/Distribution/Client/IndexUtils/ActiveRepos.hs b/src/Distribution/Client/IndexUtils/ActiveRepos.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/IndexUtils/ActiveRepos.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Client.IndexUtils.ActiveRepos ( + ActiveRepos (..), + defaultActiveRepos, + filterSkippedActiveRepos, + ActiveRepoEntry (..), + CombineStrategy (..), + organizeByRepos, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Client.Types.RepoName (RepoName (..)) +import Prelude () + +import Distribution.Parsec (parsecLeadingCommaNonEmpty) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | Ordered list of active repositories. +newtype ActiveRepos = ActiveRepos [ActiveRepoEntry] + deriving (Eq, Show, Generic) + +defaultActiveRepos :: ActiveRepos +defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ] + +-- | Note, this does nothing if 'ActiveRepoRest' is present. +filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos +filterSkippedActiveRepos repos@(ActiveRepos entries) + | any isActiveRepoRest entries = repos + | otherwise = ActiveRepos (filter notSkipped entries) + where + isActiveRepoRest (ActiveRepoRest _) = True + isActiveRepoRest _ = False + + notSkipped (ActiveRepo _ CombineStrategySkip) = False + notSkipped _ = True + +instance Binary ActiveRepos +instance Structured ActiveRepos +instance NFData ActiveRepos + +instance Pretty ActiveRepos where + pretty (ActiveRepos []) + = Disp.text ":none" + pretty (ActiveRepos repos) + = Disp.hsep + $ Disp.punctuate Disp.comma + $ map pretty repos + +-- | Note: empty string is not valid 'ActiveRepos'. +-- +-- >>> simpleParsec "" :: Maybe ActiveRepos +-- Nothing +-- +-- >>> simpleParsec ":none" :: Maybe ActiveRepos +-- Just (ActiveRepos []) +-- +-- >>> simpleParsec ":rest" :: Maybe ActiveRepos +-- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) +-- +-- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos +-- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride]) +-- +instance Parsec ActiveRepos where + parsec = ActiveRepos [] <$ P.try (P.string ":none") + <|> do + repos <- parsecLeadingCommaNonEmpty parsec + return (ActiveRepos (toList repos)) + +data ActiveRepoEntry + = ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo' + | ActiveRepo RepoName CombineStrategy -- ^ explicit repository name + deriving (Eq, Show, Generic) + +instance Binary ActiveRepoEntry +instance Structured ActiveRepoEntry +instance NFData ActiveRepoEntry + +instance Pretty ActiveRepoEntry where + pretty (ActiveRepoRest s) = + Disp.text ":rest" <<>> Disp.colon <<>> pretty s + pretty (ActiveRepo r s) = + pretty r <<>> Disp.colon <<>> pretty s + +instance Parsec ActiveRepoEntry where + parsec = leadColon <|> leadRepo where + leadColon = do + _ <- P.char ':' + token <- P.munch1 isAlpha + case token of + "rest" -> ActiveRepoRest <$> strategyP + "repo" -> P.char ':' *> leadRepo + _ -> P.unexpected $ "Unknown active repository entry type: " ++ token + + leadRepo = do + r <- parsec + s <- strategyP + return (ActiveRepo r s) + + strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec) + +data CombineStrategy + = CombineStrategySkip -- ^ skip this repository + | CombineStrategyMerge -- ^ merge existing versions + | CombineStrategyOverride -- ^ if later repository specifies a package, + -- all package versions are replaced + deriving (Eq, Show, Enum, Bounded, Generic) + +instance Binary CombineStrategy +instance Structured CombineStrategy +instance NFData CombineStrategy + +instance Pretty CombineStrategy where + pretty CombineStrategySkip = Disp.text "skip" + pretty CombineStrategyMerge = Disp.text "merge" + pretty CombineStrategyOverride = Disp.text "override" + +instance Parsec CombineStrategy where + parsec = P.choice + [ CombineStrategySkip <$ P.string "skip" + , CombineStrategyMerge <$ P.string "merge" + , CombineStrategyOverride <$ P.string "override" + ] + +------------------------------------------------------------------------------- +-- Organisation +------------------------------------------------------------------------------- + +-- | Sort values 'RepoName' according to 'ActiveRepos' list. +-- +-- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"] +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos +-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos +-- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos +-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos +-- Left "no repository provided d" +-- +-- Note: currently if 'ActiveRepoRest' is provided more than once, +-- rest-repositories will be multiple times in the output. +-- +organizeByRepos + :: forall a. ActiveRepos + -> (a -> RepoName) + -> [a] + -> Either String [(a, CombineStrategy)] +organizeByRepos (ActiveRepos xs0) sel ys0 = + -- here we use lazyness to do only one traversal + let (rest, result) = case go rest xs0 ys0 of + Right (rest', result') -> (rest', Right result') + Left err -> ([], Left err) + in result + where + go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)]) + go _rest [] ys = Right (ys, []) + go rest (ActiveRepoRest s : xs) ys = + go rest xs ys <&> \(rest', result) -> + (rest', map (\x -> (x, s)) rest ++ result) + go rest (ActiveRepo r s : xs) ys = do + (z, zs) <- extract r ys + go rest xs zs <&> \(rest', result) -> + (rest', (z, s) : result) + + extract :: RepoName -> [a] -> Either String (a, [a]) + extract r = loop id where + loop _acc [] = Left $ "no repository provided " ++ prettyShow r + loop acc (x:xs) + | sel x == r = Right (x, acc xs) + | otherwise = loop (acc . (x :)) xs + + (<&>) + :: Either err ([s], b) + -> (([s], b) -> ([s], c)) + -> Either err ([s], c) + (<&>) = flip fmap diff --git a/src/Distribution/Client/IndexUtils/IndexState.hs b/src/Distribution/Client/IndexUtils/IndexState.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/IndexUtils/IndexState.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils.IndexUtils +-- Copyright : (c) 2016 Herbert Valerio Riedel +-- License : BSD3 +-- +-- Package repositories index state. +-- +module Distribution.Client.IndexUtils.IndexState ( + RepoIndexState(..), + TotalIndexState, + headTotalIndexState, + makeTotalIndexState, + lookupIndexState, + insertIndexState, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Client.IndexUtils.Timestamp (Timestamp) +import Distribution.Client.Types.RepoName (RepoName (..)) + +import Distribution.Parsec (parsecLeadingCommaNonEmpty) + +import qualified Data.Map.Strict as Map +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +------------------------------------------------------------------------------- +-- Total index state +------------------------------------------------------------------------------- + +-- | Index state of multiple repositories +data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState) + deriving (Eq, Show, Generic) + +instance Binary TotalIndexState +instance Structured TotalIndexState +instance NFData TotalIndexState + +instance Pretty TotalIndexState where + pretty (TIS IndexStateHead m) + | not (Map.null m) + = Disp.hsep $ Disp.punctuate Disp.comma + [ pretty rn Disp.<+> pretty idx + | (rn, idx) <- Map.toList m + ] + pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where + go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx + +-- | +-- +-- >>> simpleParsec "HEAD" :: Maybe TotalIndexState +-- Just (TIS IndexStateHead (fromList [])) +-- +-- >>> simpleParsec "" :: Maybe TotalIndexState +-- Nothing +-- +-- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState +-- Just (TIS IndexStateHead (fromList [])) +-- +-- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState +-- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)])) +-- +-- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState +-- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))])) +-- +instance Parsec TotalIndexState where + parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where + single0 = startsWithRepoName <|> TokTimestamp <$> parsec + startsWithRepoName = do + reponame <- parsec + -- the "HEAD" is technically a valid reponame... + if reponame == RepoName "HEAD" + then return TokHead + else do + P.spaces + TokRepo reponame <$> parsec + + add :: TotalIndexState -> Tok -> TotalIndexState + add _ TokHead = headTotalIndexState + add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty + add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m) + +-- used in Parsec TotalIndexState implementation +data Tok + = TokRepo RepoName RepoIndexState + | TokTimestamp Timestamp + | TokHead + +-- | Remove non-default values from 'TotalIndexState'. +normalise :: TotalIndexState -> TotalIndexState +normalise (TIS def m) = TIS def (Map.filter (/= def) m) + +-- | 'TotalIndexState' where all repositories are at @HEAD@ index state. +headTotalIndexState :: TotalIndexState +headTotalIndexState = TIS IndexStateHead Map.empty + +-- | Create 'TotalIndexState'. +makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState +makeTotalIndexState def m = normalise (TIS def m) + +-- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'. +lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState +lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m + +-- | Insert a 'RepoIndexState' to 'TotalIndexState'. +insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState +insertIndexState rn idx (TIS def m) + | idx == def = TIS def (Map.delete rn m) + | otherwise = TIS def (Map.insert rn idx m) + +------------------------------------------------------------------------------- +-- Repository index state +------------------------------------------------------------------------------- + +-- | Specification of the state of a specific repo package index +data RepoIndexState + = IndexStateHead -- ^ Use all available entries + | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time + deriving (Eq,Generic,Show) + +instance Binary RepoIndexState +instance Structured RepoIndexState +instance NFData RepoIndexState + +instance Pretty RepoIndexState where + pretty IndexStateHead = Disp.text "HEAD" + pretty (IndexStateTime ts) = pretty ts + +instance Parsec RepoIndexState where + parsec = parseHead <|> parseTime where + parseHead = IndexStateHead <$ P.string "HEAD" + parseTime = IndexStateTime <$> parsec diff --git a/src/Distribution/Client/IndexUtils/Timestamp.hs b/src/Distribution/Client/IndexUtils/Timestamp.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/IndexUtils/Timestamp.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils.Timestamp +-- Copyright : (c) 2016 Herbert Valerio Riedel +-- License : BSD3 +-- +-- Timestamp type used in package indexes + +module Distribution.Client.IndexUtils.Timestamp + ( Timestamp + , nullTimestamp + , epochTimeToTimestamp + , timestampToUTCTime + , utcTimeToTimestamp + , maximumTimestamp + ) where + +import Distribution.Client.Compat.Prelude + +-- read is needed for Text instance +import Prelude (read) + +import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) + +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). +newtype Timestamp = TS Int64 -- Tar.EpochTime + deriving (Eq,Ord,Enum,NFData,Show,Generic) + +epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp +epochTimeToTimestamp et + | ts == nullTimestamp = Nothing + | otherwise = Just ts + where + ts = TS et + +timestampToUTCTime :: Timestamp -> Maybe UTCTime +timestampToUTCTime (TS t) + | t == minBound = Nothing + | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t) + +utcTimeToTimestamp :: UTCTime -> Maybe Timestamp +utcTimeToTimestamp utct + | minTime <= t, t <= maxTime = Just (TS (fromIntegral t)) + | otherwise = Nothing + where + maxTime = toInteger (maxBound :: Int64) + minTime = toInteger (succ minBound :: Int64) + t :: Integer + t = round . utcTimeToPOSIXSeconds $ utct + +-- | Compute the maximum 'Timestamp' value +-- +-- Returns 'nullTimestamp' for the empty list. Also note that +-- 'nullTimestamp' compares as smaller to all non-'nullTimestamp' +-- values. +maximumTimestamp :: [Timestamp] -> Timestamp +maximumTimestamp [] = nullTimestamp +maximumTimestamp xs@(_:_) = maximum xs + +-- returns 'Nothing' if not representable as 'Timestamp' +posixSecondsToTimestamp :: Integer -> Maybe Timestamp +posixSecondsToTimestamp pt + | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt)) + | otherwise = Nothing + where + maxTs = toInteger (maxBound :: Int64) + minTs = toInteger (succ minBound :: Int64) + +-- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format +-- (e.g. @"2017-12-31T23:59:59Z"@) +-- +-- Returns empty string for 'nullTimestamp' in order for +-- +-- > null (display nullTimestamp) == True +-- +-- to hold. +showTimestamp :: Timestamp -> String +showTimestamp ts = case timestampToUTCTime ts of + Nothing -> "" + -- Note: we don't use 'formatTime' here to avoid incurring a + -- dependency on 'old-locale' for older `time` libs + Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z" + where + showTOD = show . timeToTimeOfDay + +instance Binary Timestamp +instance Structured Timestamp + +instance Pretty Timestamp where + pretty = Disp.text . showTimestamp + +instance Parsec Timestamp where + parsec = parsePosix <|> parseUTC + where + -- | Parses unix timestamps, e.g. @"\@1474626019"@ + parsePosix = do + _ <- P.char '@' + t <- P.integral -- note, no negative timestamps + maybe (fail (show t ++ " is not representable as timestamp")) return $ + posixSecondsToTimestamp t + + -- | Parses ISO8601/RFC3339-style UTC timestamps, + -- e.g. @"2017-12-31T23:59:59Z"@ + -- + -- TODO: support numeric tz offsets; allow to leave off seconds + parseUTC = do + -- Note: we don't use 'Data.Time.Format.parseTime' here since + -- we want more control over the accepted formats. + + ye <- parseYear + _ <- P.char '-' + mo <- parseTwoDigits + _ <- P.char '-' + da <- parseTwoDigits + _ <- P.char 'T' + + utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $ + fromGregorianValid ye mo da + + ho <- parseTwoDigits + _ <- P.char ':' + mi <- parseTwoDigits + _ <- P.char ':' + se <- parseTwoDigits + _ <- P.char 'Z' + + utctDayTime <- maybe (fail (show (ho,mi,se) ++ " is not valid time of day")) (return . timeOfDayToTime) $ + makeTimeOfDayValid ho mi (realToFrac (se::Int)) + + let utc = UTCTime {..} + + maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc + + parseTwoDigits = do + d1 <- P.satisfy isDigit + d2 <- P.satisfy isDigit + return (read [d1,d2]) + + -- A year must have at least 4 digits; e.g. "0097" is fine, + -- while "97" is not c.f. RFC3339 which + -- deprecates 2-digit years + parseYear = do + sign <- P.option ' ' (P.char '-') + ds <- P.munch1 isDigit + when (length ds < 4) $ fail "Year should have at least 4 digits" + return (read (sign:ds)) + +-- | Special timestamp value to be used when 'timestamp' is +-- missing/unknown/invalid +nullTimestamp :: Timestamp +nullTimestamp = TS minBound diff --git a/src/Distribution/Client/Init.hs b/src/Distribution/Client/Init.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init ( + + -- * Commands + initCabal + , incVersion + + ) where + +import Distribution.Client.Init.Command + ( initCabal, incVersion ) diff --git a/src/Distribution/Client/Init/Command.hs b/src/Distribution/Client/Init/Command.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init/Command.hs @@ -0,0 +1,749 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Command +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init.Command + ( -- * Commands + initCabal + , incVersion + + -- * Helpers + , getSimpleProject + , getLibOrExec + , getCabalVersion + , getPackageName + , getVersion + , getLicense + , getAuthorInfo + , getHomepage + , getSynopsis + , getCategory + , getExtraSourceFiles + , getAppDir + , getSrcDir + , getGenTests + , getTestDir + , getLanguage + , getGenComments + , getModulesBuildToolsAndDeps + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (empty) + +import System.IO + ( hSetBuffering, stdout, BufferMode(..) ) +import System.Directory + ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents ) +import System.FilePath + ( (), takeBaseName, equalFilePath ) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Control.Monad + ( (>=>) ) +import Control.Arrow + ( (&&&), (***) ) + +import Distribution.CabalSpecVersion + ( CabalSpecVersion (..), showCabalSpecVersion ) +import Distribution.Version + ( Version, mkVersion, alterVersion, majorBoundVersion + , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) +import Distribution.ModuleName + ( ModuleName ) -- And for the Text instance +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, exposed ) +import qualified Distribution.Package as P +import qualified Distribution.SPDX as SPDX +import Language.Haskell.Extension ( Language(..) ) + +import Distribution.Client.Init.Defaults + ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir ) +import Distribution.Client.Init.FileCreators + ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs + , createTestSuiteIfEligible, writeCabalFile ) +import Distribution.Client.Init.Prompt + ( prompt, promptYesNo, promptStr, promptList, maybePrompt + , promptListOptional ) +import Distribution.Client.Init.Utils + ( eligibleForTestSuite, message ) +import Distribution.Client.Init.Types + ( InitFlags(..), PackageType(..), Category(..) + , displayPackageType ) +import Distribution.Client.Init.Heuristics + ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, + SourceFileEntry(..), + scanForModules, neededBuildPrograms ) + +import Distribution.Simple.Flag + ( maybeToFlag ) +import Distribution.Simple.Setup + ( Flag(..), flagToMaybe ) +import Distribution.Simple.Configure + ( getInstalledPackages ) +import Distribution.Simple.Compiler + ( PackageDBStack, Compiler ) +import Distribution.Simple.Program + ( ProgramDb ) +import Distribution.Simple.PackageIndex + ( InstalledPackageIndex, moduleNameIndex ) +import Distribution.Simple.Utils + ( die' ) + +import Distribution.Solver.Types.PackageIndex + ( elemByPackageName ) + +import Distribution.Client.IndexUtils + ( getSourcePackages ) +import Distribution.Client.Types + ( SourcePackageDb(..) ) +import Distribution.Client.Setup + ( RepoContext(..) ) + +initCabal :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> ProgramDb + -> InitFlags + -> IO () +initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + + hSetBuffering stdout NoBuffering + + initFlags' <- extendFlags verbosity installedPkgIndex sourcePkgDb initFlags + + case license initFlags' of + Flag SPDX.NONE -> return () + _ -> writeLicense initFlags' + writeChangeLog initFlags' + createDirectories (sourceDirs initFlags') + createLibHs initFlags' + createDirectories (applicationDirs initFlags') + createMainHs initFlags' + createTestSuiteIfEligible initFlags' + success <- writeCabalFile initFlags' + + when success $ generateWarnings initFlags' + +--------------------------------------------------------------------------- +-- Flag acquisition ----------------------------------------------------- +--------------------------------------------------------------------------- + +-- | Fill in more details in InitFlags by guessing, discovering, or prompting +-- the user. +extendFlags :: Verbosity -> InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags +extendFlags verbosity pkgIx sourcePkgDb = + getSimpleProject + >=> getLibOrExec + >=> getCabalVersion + >=> getPackageName verbosity sourcePkgDb False + >=> getVersion + >=> getLicense + >=> getAuthorInfo + >=> getHomepage + >=> getSynopsis + >=> getCategory + >=> getExtraSourceFiles + >=> getAppDir + >=> getSrcDir + >=> getGenTests + >=> getTestDir + >=> getLanguage + >=> getGenComments + >=> getModulesBuildToolsAndDeps pkgIx + +-- | Combine two actions which may return a value, preferring the first. That +-- is, run the second action only if the first doesn't return a value. +infixr 1 ?>> +(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) +f ?>> g = do + ma <- f + if isJust ma + then return ma + else g + +-- | Ask if a simple project with sensible defaults should be created. +getSimpleProject :: InitFlags -> IO InitFlags +getSimpleProject flags = do + simpleProj <- return (flagToMaybe $ simpleProject flags) + ?>> maybePrompt flags + (promptYesNo + "Should I generate a simple project with sensible defaults" + (Just True)) + return $ case maybeToFlag simpleProj of + Flag True -> + flags { interactive = Flag False + , simpleProject = Flag True + , packageType = Flag LibraryAndExecutable + , cabalVersion = Flag defaultCabalVersion + } + simpleProjFlag@_ -> + flags { simpleProject = simpleProjFlag } + + +-- | Get the version of the cabal spec to use. +-- +-- The spec version can be specified by the InitFlags cabalVersion field. If +-- none is specified then the user is prompted to pick from a list of +-- supported versions (see code below). +getCabalVersion :: InitFlags -> IO InitFlags +getCabalVersion flags = do + cabVer <- return (flagToMaybe $ cabalVersion flags) + ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap` + promptList "Please choose version of the Cabal specification to use" + [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0] + (Just defaultCabalVersion) displayCabalVersion False) + ?>> return (Just defaultCabalVersion) + + return $ flags { cabalVersion = maybeToFlag cabVer } + + where + displayCabalVersion :: CabalSpecVersion -> String + displayCabalVersion v = case v of + CabalSpecV1_10 -> "1.10 (legacy)" + CabalSpecV2_0 -> "2.0 (+ support for Backpack, internal sub-libs, '^>=' operator)" + CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" + CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)" + CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)" + _ -> showCabalSpecVersion v + + + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. It looks at the SourcePackageDb to avoid +-- using an existing package name. +getPackageName :: Verbosity -> SourcePackageDb -> Bool -> InitFlags -> IO InitFlags +getPackageName verbosity sourcePkgDb forceAsk flags = do + guess <- maybe (getCurrentDirectory >>= guessPackageName) pure + =<< traverse guessPackageName (flagToMaybe $ packageDir flags) + + pkgName' <- case (flagToMaybe $ packageName flags) >>= maybeForceAsk of + Just pkgName -> return $ Just $ pkgName + _ -> maybePrompt flags (prompt "Package name" (Just guess)) + let pkgName = fromMaybe guess pkgName' + + chooseAgain <- if isPkgRegistered pkgName + then do + answer' <- maybePrompt flags (promptYesNo (promptOtherNameMsg pkgName) (Just True)) + case answer' of + Just answer -> return answer + _ -> die' verbosity $ inUseMsg pkgName + else + return False + + if chooseAgain + then getPackageName verbosity sourcePkgDb True flags + else return $ flags { packageName = Flag pkgName } + + where + maybeForceAsk x = if forceAsk then Nothing else Just x + + isPkgRegistered pkg = elemByPackageName (packageIndex sourcePkgDb) pkg + + inUseMsg pkgName = "The name " ++ (P.unPackageName pkgName) ++ + " is already in use by another package on Hackage." + + promptOtherNameMsg pkgName = (inUseMsg pkgName) ++ + " Do you want to choose a different name" + +-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user +-- if possible. +getVersion :: InitFlags -> IO InitFlags +getVersion flags = do + let v = Just $ mkVersion [0,1,0,0] + v' <- return (flagToMaybe $ version flags) + ?>> maybePrompt flags (prompt "Package version" v) + ?>> return v + return $ flags { version = maybeToFlag v' } + +-- | Choose a license for the package. +-- +-- The license can come from Initflags (license field), if it is not present +-- then prompt the user from a predefined list of licenses. +getLicense :: InitFlags -> IO InitFlags +getLicense flags = do + elic <- return (fmap Right $ flagToMaybe $ license flags) + ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True) + + case elic of + Nothing -> return flags { license = NoFlag } + Just (Right lic) -> return flags { license = Flag lic } + Just (Left str) -> case eitherParsec str of + Right lic -> return flags { license = Flag lic } + -- on error, loop + Left err -> do + putStrLn "The license must be a valid SPDX expression." + putStrLn err + getLicense flags + where + -- perfectly we'll have this and writeLicense (in FileCreators) + -- in a single file + listedLicenses = + SPDX.NONE : + map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) + [ SPDX.BSD_2_Clause + , SPDX.BSD_3_Clause + , SPDX.Apache_2_0 + , SPDX.MIT + , SPDX.MPL_2_0 + , SPDX.ISC + + , SPDX.GPL_2_0_only + , SPDX.GPL_3_0_only + , SPDX.LGPL_2_1_only + , SPDX.LGPL_3_0_only + , SPDX.AGPL_3_0_only + + , SPDX.GPL_2_0_or_later + , SPDX.GPL_3_0_or_later + , SPDX.LGPL_2_1_or_later + , SPDX.LGPL_3_0_or_later + , SPDX.AGPL_3_0_or_later + ] + +-- | The author's name and email. Prompt, or try to guess from an existing +-- darcs repo. +getAuthorInfo :: InitFlags -> IO InitFlags +getAuthorInfo flags = do + (authorName, authorEmail) <- + (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail + authorName' <- return (flagToMaybe $ author flags) + ?>> maybePrompt flags (promptStr "Author name" authorName) + ?>> return authorName + + authorEmail' <- return (flagToMaybe $ email flags) + ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) + ?>> return authorEmail + + return $ flags { author = maybeToFlag authorName' + , email = maybeToFlag authorEmail' + } + +-- | Prompt for a homepage URL for the package. +getHomepage :: InitFlags -> IO InitFlags +getHomepage flags = do + hp <- queryHomepage + hp' <- return (flagToMaybe $ homepage flags) + ?>> maybePrompt flags (promptStr "Project homepage URL" hp) + ?>> return hp + + return $ flags { homepage = maybeToFlag hp' } + +-- | Right now this does nothing, but it could be changed to do some +-- intelligent guessing. +queryHomepage :: IO (Maybe String) +queryHomepage = return Nothing -- get default remote darcs repo? + +-- | Prompt for a project synopsis. +getSynopsis :: InitFlags -> IO InitFlags +getSynopsis flags = do + syn <- return (flagToMaybe $ synopsis flags) + ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) + + return $ flags { synopsis = maybeToFlag syn } + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +getCategory :: InitFlags -> IO InitFlags +getCategory flags = do + cat <- return (flagToMaybe $ category flags) + ?>> fmap join (maybePrompt flags + (promptListOptional "Project category" [Codec ..])) + return $ flags { category = maybeToFlag cat } + +-- | Try to guess extra source files (don't prompt the user). +getExtraSourceFiles :: InitFlags -> IO InitFlags +getExtraSourceFiles flags = do + extraSrcFiles <- return (extraSrc flags) + ?>> Just `fmap` guessExtraSourceFiles flags + + return $ flags { extraSrc = extraSrcFiles } + +defaultChangeLog :: FilePath +defaultChangeLog = "CHANGELOG.md" + +-- | Try to guess things to include in the extra-source-files field. +-- For now, we just look for things in the root directory named +-- 'readme', 'changes', or 'changelog', with any sort of +-- capitalization and any extension. +guessExtraSourceFiles :: InitFlags -> IO [FilePath] +guessExtraSourceFiles flags = do + dir <- + maybe getCurrentDirectory return . flagToMaybe $ packageDir flags + files <- getDirectoryContents dir + let extraFiles = filter isExtra files + if any isLikeChangeLog extraFiles + then return extraFiles + else return (defaultChangeLog : extraFiles) + + where + isExtra = likeFileNameBase ("README" : changeLogLikeBases) + isLikeChangeLog = likeFileNameBase changeLogLikeBases + likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName + changeLogLikeBases = ["CHANGES", "CHANGELOG"] + +-- | Ask whether the project builds a library or executable. +getLibOrExec :: InitFlags -> IO InitFlags +getLibOrExec flags = do + pkgType <- return (flagToMaybe $ packageType flags) + ?>> maybePrompt flags (either (const Executable) id `fmap` + promptList "What does the package build" + [Executable, Library, LibraryAndExecutable] + Nothing displayPackageType False) + ?>> return (Just Executable) + + -- If this package contains an executable, get the main file name. + mainFile <- if pkgType == Just Library then return Nothing else + getMainFile flags + + return $ flags { packageType = maybeToFlag pkgType + , mainIs = maybeToFlag mainFile + } + + +-- | Try to guess the main file of the executable, and prompt the user to choose +-- one of them. Top-level modules including the word 'Main' in the file name +-- will be candidates, and shorter filenames will be preferred. +getMainFile :: InitFlags -> IO (Maybe FilePath) +getMainFile flags = + return (flagToMaybe $ mainIs flags) + ?>> do + candidates <- guessMainFileCandidates flags + let showCandidate = either (++" (does not yet exist, but will be created)") id + defaultFile = listToMaybe candidates + maybePrompt flags (either id (either id id) `fmap` + promptList "What is the main module of the executable" + candidates + defaultFile showCandidate True) + ?>> return (fmap (either id id) defaultFile) + +-- | Ask if a test suite should be generated for the library. +getGenTests :: InitFlags -> IO InitFlags +getGenTests flags = do + genTests <- return (flagToMaybe $ initializeTestSuite flags) + -- Only generate a test suite if the package contains a library. + ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing + ?>> maybePrompt flags + (promptYesNo + "Should I generate a test suite for the library" + (Just True)) + return $ flags { initializeTestSuite = maybeToFlag genTests } + +-- | Ask for the test suite root directory. +getTestDir :: InitFlags -> IO InitFlags +getTestDir flags = do + dirs <- return (testDirs flags) + -- Only need testDirs when test suite generation is enabled. + ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing + ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt + flags + (promptList "Test directory" ["test"] (Just "test") id True)) + + return $ flags { testDirs = dirs } + +-- | Ask for the Haskell base language of the package. +getLanguage :: InitFlags -> IO InitFlags +getLanguage flags = do + lang <- return (flagToMaybe $ language flags) + ?>> maybePrompt flags + (either UnknownLanguage id `fmap` + promptList "What base language is the package written in" + [Haskell2010, Haskell98] + (Just Haskell2010) prettyShow True) + ?>> return (Just Haskell2010) + + if invalidLanguage lang + then putStrLn invalidOtherLanguageMsg >> getLanguage flags + else return $ flags { language = maybeToFlag lang } + + where + invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t + invalidLanguage _ = False + + invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++ + "Please enter a different language." + +-- | Ask whether to generate explanatory comments. +getGenComments :: InitFlags -> IO InitFlags +getGenComments flags = do + genComments <- return (not <$> flagToMaybe (noComments flags)) + ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) + ?>> return (Just False) + return $ flags { noComments = maybeToFlag (fmap not genComments) } + where + promptMsg = "Add informative comments to each field in the cabal file (y/n)" + +-- | Ask for the application root directory. +getAppDir :: InitFlags -> IO InitFlags +getAppDir flags = do + appDirs <- noAppDirIfLibraryOnly + ?>> guessAppDir flags + ?>> promptUserForApplicationDir + ?>> setDefault + return $ flags { applicationDirs = appDirs } + where + -- If the packageType==Library, ignore defined appdir. + noAppDirIfLibraryOnly :: IO (Maybe [String]) + noAppDirIfLibraryOnly + | packageType flags == Flag Library = return $ Just [] + | otherwise = return $ applicationDirs flags + + -- Set the default application directory. + setDefault :: IO (Maybe [String]) + setDefault = pure (Just [defaultApplicationDir]) + + -- Prompt the user for the application directory (defaulting to "app"). + -- Returns 'Nothing' if in non-interactive mode, otherwise will always + -- return a 'Just' value ('Just []' if no separate application directory). + promptUserForApplicationDir :: IO (Maybe [String]) + promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt + flags + (promptList + ("Application " ++ mainFile ++ "directory") + [[defaultApplicationDir], ["src-exe"], []] + (Just [defaultApplicationDir]) + showOption True) + + showOption :: [String] -> String + showOption [] = "(none)" + showOption (x:_) = x + + -- The name + mainFile :: String + mainFile = case mainIs flags of + Flag mainPath -> "(" ++ mainPath ++ ") " + _ -> "" + +-- | Try to guess app directory. Could try harder; for the +-- moment just looks to see whether there is a directory called 'app'. +guessAppDir :: InitFlags -> IO (Maybe [String]) +guessAppDir flags = do + dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags + appIsDir <- doesDirectoryExist (dir "app") + return $ if appIsDir + then Just ["app"] + else Nothing + +-- | Ask for the source (library) root directory. +getSrcDir :: InitFlags -> IO InitFlags +getSrcDir flags = do + srcDirs <- noSourceDirIfExecutableOnly + ?>> guessSourceDir flags + ?>> promptUserForSourceDir + ?>> setDefault + + return $ flags { sourceDirs = srcDirs } + + where + -- If the packageType==Executable, then ignore source dir + noSourceDirIfExecutableOnly :: IO (Maybe [String]) + noSourceDirIfExecutableOnly + | packageType flags == Flag Executable = return $ Just [] + | otherwise = return $ sourceDirs flags + + -- Set the default source directory. + setDefault :: IO (Maybe [String]) + setDefault = pure (Just [defaultSourceDir]) + + -- Prompt the user for the source directory (defaulting to "app"). + -- Returns 'Nothing' if in non-interactive mode, otherwise will always + -- return a 'Just' value ('Just []' if no separate application directory). + promptUserForSourceDir :: IO (Maybe [String]) + promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt + flags + (promptList + ("Library source directory") + [[defaultSourceDir], ["lib"], ["src-lib"], []] + (Just [defaultSourceDir]) + showOption True) + + showOption :: [String] -> String + showOption [] = "(none)" + showOption (x:_) = x + + +-- | Try to guess source directory. Could try harder; for the +-- moment just looks to see whether there is a directory called 'src'. +guessSourceDir :: InitFlags -> IO (Maybe [String]) +guessSourceDir flags = do + dir <- + maybe getCurrentDirectory return . flagToMaybe $ packageDir flags + srcIsDir <- doesDirectoryExist (dir "src") + return $ if srcIsDir + then Just ["src"] + else Nothing + +-- | Check whether a potential source file is located in one of the +-- source directories. +isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool +isSourceFile Nothing sf = isSourceFile (Just ["."]) sf +isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs + +-- | Get the list of exposed modules and extra tools needed to build them. +getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags +getModulesBuildToolsAndDeps pkgIx flags = do + dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags + + sourceFiles0 <- scanForModules dir + + let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0 + + Just mods <- return (exposedModules flags) + ?>> (return . Just . map moduleName $ sourceFiles) + + tools <- return (buildTools flags) + ?>> (return . Just . neededBuildPrograms $ sourceFiles) + + deps <- return (dependencies flags) + ?>> Just <$> importsToDeps flags + (fromString "Prelude" : -- to ensure we get base as a dep + ( nub -- only need to consider each imported package once + . filter (`notElem` mods) -- don't consider modules from + -- this package itself + . concatMap imports + $ sourceFiles + ) + ) + pkgIx + + exts <- return (otherExts flags) + ?>> (return . Just . nub . concatMap extensions $ sourceFiles) + + -- If we're initializing a library and there were no modules discovered + -- then create an empty 'MyLib' module. + -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because + -- then the executable needs to set 'other-modules: MyLib' or else the build + -- fails. + let (finalModsList, otherMods) = case (packageType flags, mods) of + + -- For an executable leave things as they are. + (Flag Executable, _) -> (mods, otherModules flags) + + -- If a non-empty module list exists don't change anything. + (_, (_:_)) -> (mods, otherModules flags) + + -- Library only: 'MyLib' in 'other-modules' only. + (Flag Library, _) -> ([myLibModule], Nothing) + + -- For a 'LibraryAndExecutable' we need to have special handling. + -- If we don't have a module list (Nothing or empty), then create a Lib. + (_, []) -> + if sourceDirs flags == applicationDirs flags + then ([myLibModule], Just [myLibModule]) + else ([myLibModule], Nothing) + + return $ flags { exposedModules = Just finalModsList + , otherModules = otherMods + , buildTools = tools + , dependencies = deps + , otherExts = exts + } + +-- | Given a list of imported modules, retrieve the list of dependencies that +-- provide those modules. +importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency] +importsToDeps flags mods pkgIx = do + + let modMap :: M.Map ModuleName [InstalledPackageInfo] + modMap = M.map (filter exposed) $ moduleNameIndex pkgIx + + modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])] + modDeps = map (id &&& flip M.lookup modMap) mods + + message flags "\nGuessing dependencies..." + nub . catMaybes <$> traverse (chooseDep flags) modDeps + +-- Given a module and a list of installed packages providing it, +-- choose a dependency (i.e. package + version range) to use for that +-- module. +chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo]) + -> IO (Maybe P.Dependency) + +chooseDep flags (m, Nothing) + = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") + >> return Nothing + +chooseDep flags (m, Just []) + = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".") + >> return Nothing + + -- We found some packages: group them by name. +chooseDep flags (m, Just ps) + = case pkgGroups of + -- if there's only one group, i.e. multiple versions of a single package, + -- we make it into a dependency, choosing the latest-ish version (see toDep). + [grp] -> Just <$> toDep grp + -- otherwise, we refuse to choose between different packages and make the user + -- do it. + grps -> do message flags ("\nWarning: multiple packages found providing " + ++ prettyShow m + ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps)) + message flags "You will need to pick one and manually add it to the Build-depends: field." + return Nothing + where + pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) + + desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags) + + -- Given a list of available versions of the same package, pick a dependency. + toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency + + -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* + toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries + + -- Otherwise, choose the latest version and issue a warning. + toDep pids = do + message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.") + return $ P.Dependency (P.pkgName . NE.head $ pids) + (pvpize desugar . maximum . fmap P.pkgVersion $ pids) + P.mainLibSet --TODO take into account sublibraries + +-- | Given a version, return an API-compatible (according to PVP) version range. +-- +-- If the boolean argument denotes whether to use a desugared +-- representation (if 'True') or the new-style @^>=@-form (if +-- 'False'). +-- +-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the +-- same as @0.4.*@). +pvpize :: Bool -> Version -> VersionRange +pvpize False v = majorBoundVersion v +pvpize True v = orLaterVersion v' + `intersectVersionRanges` + earlierVersion (incVersion 1 v') + where v' = alterVersion (take 2) v + +-- | Increment the nth version component (counting from 0). +incVersion :: Int -> Version -> Version +incVersion n = alterVersion (incVersion' n) + where + incVersion' 0 [] = [1] + incVersion' 0 (v:_) = [v+1] + incVersion' m [] = replicate m 0 ++ [1] + incVersion' m (v:vs) = v : incVersion' (m-1) vs + +-- | Generate warnings for missing fields etc. +generateWarnings :: InitFlags -> IO () +generateWarnings flags = do + message flags "" + when (synopsis flags `elem` [NoFlag, Flag ""]) + (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") + + message flags "You may want to edit the .cabal file and add a Description field." diff --git a/src/Distribution/Client/Init/Defaults.hs b/src/Distribution/Client/Init/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init/Defaults.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Defaults +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Default values to use in cabal init (if not specified in config/flags). +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init.Defaults ( + defaultApplicationDir + , defaultSourceDir + , defaultCabalVersion + , myLibModule + ) where + +import Prelude (String) + +import Distribution.ModuleName + ( ModuleName ) -- And for the Text instance +import qualified Distribution.ModuleName as ModuleName + ( fromString ) +import Distribution.CabalSpecVersion + ( CabalSpecVersion (..)) + +defaultApplicationDir :: String +defaultApplicationDir = "app" + +defaultSourceDir :: String +defaultSourceDir = "src" + +defaultCabalVersion :: CabalSpecVersion +defaultCabalVersion = CabalSpecV2_4 + +myLibModule :: ModuleName +myLibModule = ModuleName.fromString "MyLib" diff --git a/src/Distribution/Client/Init/FileCreators.hs b/src/Distribution/Client/Init/FileCreators.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init/FileCreators.hs @@ -0,0 +1,651 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.FileCreators +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Functions to create files during 'cabal init'. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init.FileCreators ( + + -- * Commands + writeLicense + , writeChangeLog + , createDirectories + , createLibHs + , createMainHs + , createTestSuiteIfEligible + , writeCabalFile + + -- * For testing + , generateCabalFile + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (empty) + +import System.FilePath + ( (), (<.>), takeExtension ) + +import Distribution.Types.Dependency +import Distribution.Types.VersionRange + +import Data.Time + ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) +import System.Directory + ( getCurrentDirectory, doesFileExist, copyFile + , createDirectoryIfMissing ) + +import Text.PrettyPrint hiding ((<>), mode, cat) + +import Distribution.Client.Init.Defaults + ( defaultCabalVersion, myLibModule ) +import Distribution.Client.Init.Licenses + ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) +import Distribution.Client.Init.Utils + ( eligibleForTestSuite, message ) +import Distribution.Client.Init.Types + ( InitFlags(..), BuildType(..), PackageType(..) ) + +import Distribution.CabalSpecVersion +import Distribution.Compat.Newtype + ( Newtype ) +import Distribution.Fields.Field + ( FieldName ) +import Distribution.License + ( licenseFromSPDX ) +import qualified Distribution.ModuleName as ModuleName + ( toFilePath ) +import Distribution.FieldGrammar.Newtypes + ( SpecVersion(..) ) +import Distribution.PackageDescription.FieldGrammar + ( formatDependencyList, formatExposedModules, formatHsSourceDirs, + formatOtherExtensions, formatOtherModules, formatExtraSourceFiles ) +import Distribution.Simple.Flag + ( maybeToFlag ) +import Distribution.Simple.Setup + ( Flag(..), flagToMaybe ) +import Distribution.Simple.Utils + ( toUTF8BS ) +import Distribution.Fields.Pretty + ( PrettyField(..), showFields' ) + +import qualified Distribution.SPDX as SPDX + +import Distribution.Utils.Path -- TODO + +--------------------------------------------------------------------------- +-- File generation ------------------------------------------------------ +--------------------------------------------------------------------------- + +-- | Write the LICENSE file, as specified in the InitFlags license field. +-- +-- For licences that contain the author's name(s), the values are taken +-- from the 'authors' field of 'InitFlags', and if not specified will +-- be the string "???". +-- +-- If the license type is unknown no license file will be created and +-- a warning will be raised. +writeLicense :: InitFlags -> IO () +writeLicense flags = do + message flags "\nGenerating LICENSE..." + year <- show <$> getCurrentYear + let authors = fromMaybe "???" . flagToMaybe . author $ flags + let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId + isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid + isSimpleLicense _ = Nothing + let licenseFile = + case flagToMaybe (license flags) >>= isSimpleLicense of + Just SPDX.BSD_2_Clause -> Just $ bsd2 authors year + Just SPDX.BSD_3_Clause -> Just $ bsd3 authors year + Just SPDX.Apache_2_0 -> Just apache20 + Just SPDX.MIT -> Just $ mit authors year + Just SPDX.MPL_2_0 -> Just mpl20 + Just SPDX.ISC -> Just $ isc authors year + + -- GNU license come in "only" and "or-later" flavours + -- license file used are the same. + Just SPDX.GPL_2_0_only -> Just gplv2 + Just SPDX.GPL_3_0_only -> Just gplv3 + Just SPDX.LGPL_2_1_only -> Just lgpl21 + Just SPDX.LGPL_3_0_only -> Just lgpl3 + Just SPDX.AGPL_3_0_only -> Just agplv3 + + Just SPDX.GPL_2_0_or_later -> Just gplv2 + Just SPDX.GPL_3_0_or_later -> Just gplv3 + Just SPDX.LGPL_2_1_or_later -> Just lgpl21 + Just SPDX.LGPL_3_0_or_later -> Just lgpl3 + Just SPDX.AGPL_3_0_or_later -> Just agplv3 + + _ -> Nothing + + case licenseFile of + Just licenseText -> writeFileSafe flags "LICENSE" licenseText + Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." + +-- | Returns the current calendar year. +getCurrentYear :: IO Integer +getCurrentYear = do + u <- getCurrentTime + z <- getCurrentTimeZone + let l = utcToLocalTime z u + (y, _, _) = toGregorian $ localDay l + return y + +defaultChangeLog :: FilePath +defaultChangeLog = "CHANGELOG.md" + +-- | Writes the changelog to the current directory. +writeChangeLog :: InitFlags -> IO () +writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do + message flags ("Generating "++ defaultChangeLog ++"...") + writeFileSafe flags defaultChangeLog changeLog + where + changeLog = unlines + [ "# Revision history for " ++ pname + , "" + , "## " ++ pver ++ " -- YYYY-mm-dd" + , "" + , "* First version. Released on an unsuspecting world." + ] + pname = maybe "" prettyShow $ flagToMaybe $ packageName flags + pver = maybe "" prettyShow $ flagToMaybe $ version flags + +-- | Creates and writes the initialized .cabal file. +-- +-- Returns @False@ if no package name is specified, @True@ otherwise. +writeCabalFile :: InitFlags -> IO Bool +writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do + message flags "Error: no package name provided." + return False +writeCabalFile flags@(InitFlags{packageName = Flag p}) = do + let cabalFileName = prettyShow p ++ ".cabal" + message flags $ "Generating " ++ cabalFileName ++ "..." + writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags) + return True + +-- | Write a file \"safely\", backing up any existing version (unless +-- the overwrite flag is set). +writeFileSafe :: InitFlags -> FilePath -> String -> IO () +writeFileSafe flags fileName content = do + moveExistingFile flags fileName + writeFile fileName content + +-- | Create directories, if they were given, and don't already exist. +createDirectories :: Maybe [String] -> IO () +createDirectories mdirs = case mdirs of + Just dirs -> for_ dirs (createDirectoryIfMissing True) + Nothing -> return () + +-- | Create MyLib.hs file, if its the only module in the liste. +createLibHs :: InitFlags -> IO () +createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do + let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs" + case sourceDirs flags of + Just (srcPath:_) -> writeLibHs flags (srcPath modFilePath) + _ -> writeLibHs flags modFilePath + +-- | Write a MyLib.hs file if it doesn't already exist. +writeLibHs :: InitFlags -> FilePath -> IO () +writeLibHs flags libPath = do + dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) + let libFullPath = dir libPath + exists <- doesFileExist libFullPath + unless exists $ do + message flags $ "Generating " ++ libPath ++ "..." + writeFileSafe flags libFullPath myLibHs + +-- | Default MyLib.hs file. Used when no Lib.hs exists. +myLibHs :: String +myLibHs = unlines + [ "module MyLib (someFunc) where" + , "" + , "someFunc :: IO ()" + , "someFunc = putStrLn \"someFunc\"" + ] + +-- | Create Main.hs, but only if we are init'ing an executable and +-- the mainIs flag has been provided. +createMainHs :: InitFlags -> IO () +createMainHs flags = + if hasMainHs flags then + case applicationDirs flags of + Just (appPath:_) -> writeMainHs flags (appPath mainFile) + _ -> writeMainHs flags mainFile + else return () + where + mainFile = case mainIs flags of + Flag x -> x + NoFlag -> error "createMainHs: no mainIs" + +-- | Write a main file if it doesn't already exist. +writeMainHs :: InitFlags -> FilePath -> IO () +writeMainHs flags mainPath = do + dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) + let mainFullPath = dir mainPath + exists <- doesFileExist mainFullPath + unless exists $ do + message flags $ "Generating " ++ mainPath ++ "..." + writeFileSafe flags mainFullPath (mainHs flags) + +-- | Returns true if a main file exists. +hasMainHs :: InitFlags -> Bool +hasMainHs flags = case mainIs flags of + Flag _ -> (packageType flags == Flag Executable + || packageType flags == Flag LibraryAndExecutable) + _ -> False + +-- | Default Main.(l)hs file. Used when no Main.(l)hs exists. +-- +-- If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'. +mainHs :: InitFlags -> String +mainHs flags = (unlines . map prependPrefix) $ case packageType flags of + Flag LibraryAndExecutable -> + [ "module Main where" + , "" + , "import qualified MyLib (someFunc)" + , "" + , "main :: IO ()" + , "main = do" + , " putStrLn \"Hello, Haskell!\"" + , " MyLib.someFunc" + ] + _ -> + [ "module Main where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Hello, Haskell!\"" + ] + where + prependPrefix :: String -> String + prependPrefix "" = "" + prependPrefix line + | isLiterate = "> " ++ line + | otherwise = line + isLiterate = case mainIs flags of + Flag mainPath -> takeExtension mainPath == ".lhs" + _ -> False + +-- | Create a test suite for the package if eligible. +createTestSuiteIfEligible :: InitFlags -> IO () +createTestSuiteIfEligible flags = + when (eligibleForTestSuite flags) $ do + createDirectories (testDirs flags) + createTestHs flags + +-- | The name of the test file to generate (if --tests is specified). +testFile :: String +testFile = "MyLibTest.hs" + +-- | Create MyLibTest.hs, but only if we are init'ing a library and +-- the initializeTestSuite flag has been set. +-- +-- It is up to the caller to verify that the package is eligible +-- for test suite initialization (see eligibleForTestSuite). +createTestHs :: InitFlags -> IO () +createTestHs flags = + case testDirs flags of + Just (testPath:_) -> writeTestHs flags (testPath testFile) + _ -> writeMainHs flags testFile + +-- | Write a test file. +writeTestHs :: InitFlags -> FilePath -> IO () +writeTestHs flags testPath = do + dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) + let testFullPath = dir testPath + exists <- doesFileExist testFullPath + unless exists $ do + message flags $ "Generating " ++ testPath ++ "..." + writeFileSafe flags testFullPath testHs + +-- | Default MyLibTest.hs file. +testHs :: String +testHs = unlines + [ "module Main (main) where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Test suite not yet implemented.\"" + ] + + +-- | Move an existing file, if there is one, and the overwrite flag is +-- not set. +moveExistingFile :: InitFlags -> FilePath -> IO () +moveExistingFile flags fileName = + unless (overwrite flags == Flag True) $ do + e <- doesFileExist fileName + when e $ do + newName <- findNewName fileName + message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName + copyFile fileName newName + + +-- | Given a file path find a new name for the file that does not +-- already exist. +findNewName :: FilePath -> IO FilePath +findNewName oldName = findNewName' 0 + where + findNewName' :: Integer -> IO FilePath + findNewName' n = do + let newName = oldName <.> ("save" ++ show n) + e <- doesFileExist newName + if e then findNewName' (n+1) else return newName + + +-- | Generate a .cabal file from an InitFlags structure. +generateCabalFile :: String -> InitFlags -> String +generateCabalFile fileName c = + showFields' annCommentLines postProcessFieldLines 4 $ catMaybes + [ fieldP "cabal-version" (Flag . SpecVersion $ specVer) + [] + False + + , field "name" (packageName c) + ["Initial package description '" ++ fileName ++ "' generated by", + "'cabal init'. For further documentation, see:", + " http://haskell.org/cabal/users-guide/", + "", + "The name of the package."] + True + + , field "version" (version c) + ["The package version.", + "See the Haskell package versioning policy (PVP) for standards", + "guiding when and how versions should be incremented.", + "https://pvp.haskell.org", + "PVP summary: +-+------- breaking API changes", + " | | +----- non-breaking API additions", + " | | | +--- code changes with no API change"] + True + + , fieldS "synopsis" (synopsis c) + ["A short (one-line) description of the package."] + True + + , fieldS "description" NoFlag + ["A longer description of the package."] + True + + , fieldS "homepage" (homepage c) + ["URL for the project homepage or repository."] + False + + , fieldS "bug-reports" NoFlag + ["A URL where users can report bugs."] + True + + , fieldS "license" licenseStr + ["The license under which the package is released."] + True + + , case license c of + NoFlag -> Nothing + Flag SPDX.NONE -> Nothing + _ -> fieldS "license-file" (Flag "LICENSE") + ["The file containing the license text."] + True + + , fieldS "author" (author c) + ["The package author(s)."] + True + + , fieldS "maintainer" (email c) + ["An email address to which users can send suggestions, bug reports, and patches."] + True + + , fieldS "copyright" NoFlag + ["A copyright notice."] + True + + , fieldS "category" (either id prettyShow `fmap` category c) + [] + True + + , fieldS "build-type" (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple") + [] + False + + , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c)) + ["Extra files to be distributed with the package, such as examples or a README."] + True + ] + ++ + (case packageType c of + Flag Executable -> [executableStanza] + Flag Library -> [libraryStanza] + Flag LibraryAndExecutable -> [libraryStanza, executableStanza] + _ -> []) + ++ + if eligibleForTestSuite c then [testSuiteStanza] else [] + + where + specVer :: CabalSpecVersion + specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c) + + licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c + | otherwise = prettyShow <$> license c + + generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation] + generateBuildInfo buildType c' = catMaybes + [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods) + [ case buildType of + LibBuild -> "Modules included in this library but not exported." + ExecBuild -> "Modules included in this executable, other than Main."] + True + + , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c)) + ["LANGUAGE extensions used by modules in this package."] + True + + , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies) + ["Other library packages from which modules are imported."] + True + + , fieldPAla "hs-source-dirs" formatHsSourceDirs + (maybeToFlag $ fmap (fmap unsafeMakeSymbolicPath) $ case buildType of + LibBuild -> sourceDirs c + ExecBuild -> applicationDirs c) + ["Directories containing source files."] + True + + , fieldS "build-tools" (listFieldS $ buildTools c) + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + + , field "default-language" (language c) + ["Base language which the package is written in."] + True + ] + -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?). + where + buildDependencies :: Maybe [Dependency] + buildDependencies = (++ myLibDep) <$> dependencies c' + + myLibDep :: [Dependency] + myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild + then case packageName c' of + Flag pkgName -> + [mkDependency pkgName anyVersion mainLibSet] + _ -> [] + else [] + + -- Only include 'MyLib' in 'other-modules' of the executable. + otherModsFromFlag = otherModules c' + otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule] + then Nothing + else otherModsFromFlag + + listFieldS :: Maybe [String] -> Flag String + listFieldS Nothing = NoFlag + listFieldS (Just []) = NoFlag + listFieldS (Just xs) = Flag . intercalate ", " $ xs + + -- | Construct a 'PrettyField' from a field that can be automatically + -- converted to a 'Doc' via 'display'. + field :: Pretty t + => FieldName + -> Flag t + -> [String] + -> Bool + -> Maybe (PrettyField FieldAnnotation) + field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag) + + -- | Construct a 'PrettyField' from a 'String' field. + fieldS :: FieldName -- ^ Name of the field + -> Flag String -- ^ Field contents + -> [String] -- ^ Comment to explain the field + -> Bool -- ^ Should the field be included (commented out) even if blank? + -> Maybe (PrettyField FieldAnnotation) + fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag) + + -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied. + fieldP :: Pretty a + => FieldName + -> Flag a + -> [String] + -> Bool + -> Maybe (PrettyField FieldAnnotation) + fieldP fieldName fieldContentsFlag fieldComments includeField = + fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField + + -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper. + fieldPAla + :: (Pretty b, Newtype a b) + => FieldName + -> (a -> b) + -> Flag a + -> [String] + -> Bool + -> Maybe (PrettyField FieldAnnotation) + fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField = + fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField + + -- | Construct a 'PrettyField' from a 'Doc' Flag. + fieldD :: FieldName -- ^ Name of the field + -> Flag Doc -- ^ Field contents + -> [String] -- ^ Comment to explain the field + -> Bool -- ^ Should the field be included (commented out) even if blank? + -> Maybe (PrettyField FieldAnnotation) + fieldD fieldName fieldContentsFlag fieldComments includeField = + case fieldContentsFlag of + NoFlag -> + -- If there is no content, optionally produce a commented out field. + fieldSEmptyContents fieldName fieldComments includeField + + Flag fieldContents -> + if isEmpty fieldContents + then + -- If the doc is empty, optionally produce a commented out field. + fieldSEmptyContents fieldName fieldComments includeField + else + -- If the doc is not empty, produce a field. + Just $ case (noComments c, minimal c) of + -- If the "--no-comments" flag is set, strip comments. + (Flag True, _) -> + fieldSWithContents fieldName fieldContents [] + -- If the "--minimal" flag is set, strip comments. + (_, Flag True) -> + fieldSWithContents fieldName fieldContents [] + -- Otherwise, include comments. + (_, _) -> + fieldSWithContents fieldName fieldContents fieldComments + + -- | Optionally produce a field with no content (depending on flags). + fieldSEmptyContents :: FieldName + -> [String] + -> Bool + -> Maybe (PrettyField FieldAnnotation) + fieldSEmptyContents fieldName fieldComments includeField + | not includeField || (minimal c == Flag True) = + Nothing + | otherwise = + Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty) + + -- | Produce a field with content. + fieldSWithContents :: FieldName + -> Doc + -> [String] + -> PrettyField FieldAnnotation + fieldSWithContents fieldName fieldContents fieldComments = + PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents + + executableStanza :: PrettyField FieldAnnotation + executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes + [ fieldS "main-is" (mainIs c) + [".hs or .lhs file containing the Main module."] + True + ] + ++ + generateBuildInfo ExecBuild c + where + exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c) + + libraryStanza :: PrettyField FieldAnnotation + libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes + [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c)) + ["Modules exported by the library."] + True + ] + ++ + generateBuildInfo LibBuild c + + + testSuiteStanza :: PrettyField FieldAnnotation + testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes + [ field "default-language" (language c) + ["Base language which the package is written in."] + True + + , fieldS "type" (Flag "exitcode-stdio-1.0") + ["The interface type and version of the test suite."] + True + + , fieldPAla "hs-source-dirs" formatHsSourceDirs + (maybeToFlag $ fmap (fmap unsafeMakeSymbolicPath) $ testDirs c) -- TODO + ["Directories containing source files."] + True + + , fieldS "main-is" (Flag testFile) + ["The entrypoint to the test suite."] + True + + , fieldPAla "build-depends" formatDependencyList (maybeToFlag (dependencies c)) + ["Test dependencies."] + True + ] + where + testSuiteName = + text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c) + +-- | Annotations for cabal file PrettyField. +data FieldAnnotation = FieldAnnotation + { annCommentedOut :: Bool + -- ^ True iif the field and its contents should be commented out. + , annCommentLines :: [String] + -- ^ Comment lines to place before the field or section. + } + +-- | A field annotation instructing the pretty printer to comment out the field +-- and any contents, with no comments. +commentedOutWithComments :: [String] -> FieldAnnotation +commentedOutWithComments = FieldAnnotation True . map ("-- " ++) + +-- | A field annotation with the specified comment lines. +withComments :: [String] -> FieldAnnotation +withComments = FieldAnnotation False + +-- | A field annotation with no comments. +annNoComments :: FieldAnnotation +annNoComments = FieldAnnotation False [] + +postProcessFieldLines :: FieldAnnotation -> [String] -> [String] +postProcessFieldLines ann + | annCommentedOut ann = map ("-- " ++) + | otherwise = id diff --git a/src/Distribution/Client/Init/Heuristics.hs b/src/Distribution/Client/Init/Heuristics.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init/Heuristics.hs @@ -0,0 +1,396 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Heuristics +-- Copyright : (c) Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Heuristics for creating initial cabal files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Heuristics ( + guessPackageName, + scanForModules, SourceFileEntry(..), + neededBuildPrograms, + guessMainFileCandidates, + guessAuthorNameMail, + knownCategories, +) where + +import Prelude () +import qualified Data.ByteString as BS +import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeHead, safeTail, safeLast) + +import Distribution.Simple.Setup (Flag(..), flagToMaybe) +import Distribution.Simple.Utils (fromUTF8BS) +import Distribution.ModuleName + ( ModuleName, toFilePath ) +import qualified Distribution.Package as P +import qualified Distribution.PackageDescription as PD + ( category, packageDescription ) +import Distribution.Client.Utils + ( tryCanonicalizePath ) +import Language.Haskell.Extension ( Extension ) + +import Distribution.Solver.Types.PackageIndex + ( allPackagesByName ) +import Distribution.Solver.Types.SourcePackage + ( srcpkgDescription ) + +import Distribution.Client.Types ( SourcePackageDb(..) ) +import Data.Char ( isLower ) +import Data.List ( isInfixOf ) +import qualified Data.Set as Set ( fromList, toList ) +import System.Directory ( getCurrentDirectory, getDirectoryContents, + doesDirectoryExist, doesFileExist, getHomeDirectory, ) +import Distribution.Compat.Environment ( getEnvironment ) +import System.FilePath ( takeExtension, takeBaseName, dropExtension, + (), (<.>), splitDirectories, makeRelative ) + +import Distribution.Client.Init.Types ( InitFlags(..) ) +import Distribution.Client.Compat.Process ( readProcessWithExitCode ) + +import qualified Distribution.Utils.ShortText as ShortText + +-- | Return a list of candidate main files for this executable: top-level +-- modules including the word 'Main' in the file name. The list is sorted in +-- order of preference, shorter file names are preferred. 'Right's are existing +-- candidates and 'Left's are those that do not yet exist. +guessMainFileCandidates :: InitFlags -> IO [Either FilePath FilePath] +guessMainFileCandidates flags = do + dir <- + maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) + files <- getDirectoryContents dir + let existingCandidates = filter isMain files + -- We always want to give the user at least one default choice. If either + -- Main.hs or Main.lhs has already been created, then we don't want to + -- suggest the other; however, if neither has been created, then we + -- suggest both. + newCandidates = + if any (`elem` existingCandidates) ["Main.hs", "Main.lhs"] + then [] + else ["Main.hs", "Main.lhs"] + candidates = + sortBy (\x y -> comparing (length . either id id) x y + `mappend` compare x y) + (map Left newCandidates ++ map Right existingCandidates) + return candidates + + where + isMain f = (isInfixOf "Main" f || isInfixOf "main" f) + && (isSuffixOf ".hs" f || isSuffixOf ".lhs" f) + +-- | Guess the package name based on the given root directory. +guessPackageName :: FilePath -> IO P.PackageName +guessPackageName = liftM (P.mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) + . tryCanonicalizePath + where + -- Treat each span of non-alphanumeric characters as a hyphen. Each + -- hyphenated component of a package name must contain at least one + -- alphabetic character. An arbitrary character ('x') will be prepended if + -- this is not the case for the first component, and subsequent components + -- will simply be run together. For example, "1+2_foo-3" will become + -- "x12-foo3". + repair = repair' ('x' :) id + repair' invalid valid x = case dropWhile (not . isAlphaNum) x of + "" -> repairComponent "" + x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x' + in c ++ repairRest r + where + repairComponent c | all isDigit c = invalid c + | otherwise = valid c + repairRest = repair' id ('-' :) + +-- |Data type of source files found in the working directory +data SourceFileEntry = SourceFileEntry + { relativeSourcePath :: FilePath + , moduleName :: ModuleName + , fileExtension :: String + , imports :: [ModuleName] + , extensions :: [Extension] + } deriving Show + +sfToFileName :: FilePath -> SourceFileEntry -> FilePath +sfToFileName projectRoot (SourceFileEntry relPath m ext _ _) + = projectRoot relPath toFilePath m <.> ext + +-- |Search for source files in the given directory +-- and return pairs of guessed Haskell source path and +-- module names. +scanForModules :: FilePath -> IO [SourceFileEntry] +scanForModules rootDir = scanForModulesIn rootDir rootDir + +scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] +scanForModulesIn projectRoot srcRoot = scan srcRoot [] + where + scan dir hierarchy = do + entries <- getDirectoryContents (projectRoot dir) + (files, dirs) <- liftM partitionEithers (traverse (tagIsDir dir) entries) + let modules = catMaybes [ guessModuleName hierarchy file + | file <- files + , maybe False isUpper (safeHead file) ] + modules' <- traverse (findImportsAndExts projectRoot) modules + recMods <- traverse (scanRecursive dir hierarchy) dirs + return $ concat (modules' : recMods) + tagIsDir parent entry = do + isDir <- doesDirectoryExist (parent entry) + return $ (if isDir then Right else Left) entry + guessModuleName hierarchy entry + | takeBaseName entry == "Setup" = Nothing + | ext `elem` sourceExtensions = + SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure [] + | otherwise = Nothing + where + relRoot = makeRelative projectRoot srcRoot + unqualModName = dropExtension entry + modName = simpleParsec + $ intercalate "." . reverse $ (unqualModName : hierarchy) + ext = case takeExtension entry of '.':e -> e; e -> e + scanRecursive parent hierarchy entry + | maybe False isUpper (safeHead entry) = scan (parent entry) (entry : hierarchy) + | maybe False isLower (safeHead entry) && not (ignoreDir entry) = + scanForModulesIn projectRoot $ foldl () srcRoot (reverse (entry : hierarchy)) + | otherwise = return [] + ignoreDir ('.':_) = True + ignoreDir dir = dir `elem` ["dist", "_darcs"] + +-- | Read the contents of the handle and parse for Language pragmas +-- and other module names that might be part of this project. +findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry +findImportsAndExts projectRoot sf = do + s <- fromUTF8BS <$> BS.readFile (sfToFileName projectRoot sf) + + let modules = mapMaybe + ( getModName + . drop 1 + . filter (not . null) + . dropWhile (/= "import") + . words + ) + . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering + . lines + $ s + + -- TODO: We should probably make a better attempt at parsing + -- comments above. Unfortunately we can't use a full-fledged + -- Haskell parser since cabal's dependencies must be kept at a + -- minimum. + + -- A poor man's LANGUAGE pragma parser. + exts = mapMaybe simpleParsec + . concatMap getPragmas + . filter isLANGUAGEPragma + . map fst + . drop 1 + . takeWhile (not . null . snd) + . iterate (takeBraces . snd) + $ ("",s) + + takeBraces = break (== '}') . dropWhile (/= '{') + + isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`) + + getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13 + + splitCommas "" = [] + splitCommas xs = x : splitCommas (drop 1 y) + where (x,y) = break (==',') xs + + return sf { imports = modules + , extensions = exts + } + + where getModName :: [String] -> Maybe ModuleName + getModName [] = Nothing + getModName ("qualified":ws) = getModName ws + getModName (ms:_) = simpleParsec ms + + + +-- Unfortunately we cannot use the version exported by Distribution.Simple.Program +knownSuffixHandlers :: [(String,String)] +knownSuffixHandlers = + [ ("gc", "greencard") + , ("chs", "chs") + , ("hsc", "hsc2hs") + , ("x", "alex") + , ("y", "happy") + , ("ly", "happy") + , ("cpphs", "cpp") + ] + +sourceExtensions :: [String] +sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers + +neededBuildPrograms :: [SourceFileEntry] -> [String] +neededBuildPrograms entries = + [ handler + | ext <- nubSet (map fileExtension entries) + , handler <- maybeToList (lookup ext knownSuffixHandlers) + ] + +-- | Guess author and email using darcs and git configuration options. Use +-- the following in decreasing order of preference: +-- +-- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*) +-- 2. Local repo configs +-- 3. Global vcs configs +-- 4. The generic $EMAIL +-- +-- Name and email are processed separately, so the guess might end up being +-- a name from DARCS_EMAIL and an email from git config. +-- +-- Darcs has preference, for tradition's sake. +guessAuthorNameMail :: IO (Flag String, Flag String) +guessAuthorNameMail = fmap authorGuessPure authorGuessIO + +-- Ordered in increasing preference, since Flag-as-monoid is identical to +-- Last. +authorGuessPure :: AuthorGuessIO -> AuthorGuess +authorGuessPure (AuthorGuessIO { authorGuessEnv = env + , authorGuessLocalDarcs = darcsLocalF + , authorGuessGlobalDarcs = darcsGlobalF + , authorGuessLocalGit = gitLocal + , authorGuessGlobalGit = gitGlobal }) + = mconcat + [ emailEnv env + , gitGlobal + , darcsCfg darcsGlobalF + , gitLocal + , darcsCfg darcsLocalF + , gitEnv env + , darcsEnv env + ] + +authorGuessIO :: IO AuthorGuessIO +authorGuessIO = AuthorGuessIO + <$> getEnvironment + <*> (maybeReadFile $ "_darcs" "prefs" "author") + <*> (maybeReadFile =<< liftM ( (".darcs" "author")) getHomeDirectory) + <*> gitCfg Local + <*> gitCfg Global + +-- Types and functions used for guessing the author are now defined: + +type AuthorGuess = (Flag String, Flag String) +type Enviro = [(String, String)] +data GitLoc = Local | Global +data AuthorGuessIO = AuthorGuessIO { + authorGuessEnv :: Enviro, -- ^ Environment lookup table + authorGuessLocalDarcs :: (Maybe String), -- ^ Contents of local darcs author info + authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info + authorGuessLocalGit :: AuthorGuess, -- ^ Git config --local + authorGuessGlobalGit :: AuthorGuess -- ^ Git config --global + } + +darcsEnv :: Enviro -> AuthorGuess +darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL" + +gitEnv :: Enviro -> AuthorGuess +gitEnv env = (name, mail) + where + name = maybeFlag "GIT_AUTHOR_NAME" env + mail = maybeFlag "GIT_AUTHOR_EMAIL" env + +darcsCfg :: Maybe String -> AuthorGuess +darcsCfg = maybe mempty nameAndMail + +emailEnv :: Enviro -> AuthorGuess +emailEnv env = (mempty, mail) + where + mail = maybeFlag "EMAIL" env + +gitCfg :: GitLoc -> IO AuthorGuess +gitCfg which = do + name <- gitVar which "user.name" + mail <- gitVar which "user.email" + return (name, mail) + +gitVar :: GitLoc -> String -> IO (Flag String) +gitVar which = fmap happyOutput . gitConfigQuery which + +happyOutput :: (ExitCode, a, t) -> Flag a +happyOutput v = case v of + (ExitSuccess, s, _) -> Flag s + _ -> mempty + +gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String) +gitConfigQuery which key = + fmap trim' $ readProcessWithExitCode "git" ["config", w, key] "" + where + w = case which of + Local -> "--local" + Global -> "--global" + trim' (a, b, c) = (a, trim b, c) + +maybeFlag :: String -> Enviro -> Flag String +maybeFlag k = maybe mempty Flag . lookup k + +-- | Read the first non-comment, non-trivial line of a file, if it exists +maybeReadFile :: String -> IO (Maybe String) +maybeReadFile f = do + exists <- doesFileExist f + if exists + then fmap getFirstLine $ readFile f + else return Nothing + where + getFirstLine content = + let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content + in case nontrivialLines of + [] -> Nothing + (l:_) -> Just l + +-- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached +knownCategories :: SourcePackageDb -> [String] +knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet + [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex) + , let catList = (PD.category . PD.packageDescription . srcpkgDescription) pkg + , cat <- splitString ',' $ ShortText.fromShortText catList + ] + +-- Parse name and email, from darcs pref files or environment variable +nameAndMail :: String -> (Flag String, Flag String) +nameAndMail str + | all isSpace nameOrEmail = mempty + | null erest = (mempty, Flag $ trim nameOrEmail) + | otherwise = (Flag $ trim nameOrEmail, Flag mail) + where + (nameOrEmail,erest) = break (== '<') str + (mail,_) = break (== '>') (safeTail erest) + +trim :: String -> String +trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse + where + removeLeadingSpace = dropWhile isSpace + +-- split string at given character, and remove whitespace +splitString :: Char -> String -> [String] +splitString sep str = go str where + go s = if null s' then [] else tok : go rest where + s' = dropWhile (\c -> c == sep || isSpace c) s + (tok,rest) = break (==sep) s' + +nubSet :: (Ord a) => [a] -> [a] +nubSet = Set.toList . Set.fromList + +{- +test db testProjectRoot = do + putStrLn "Guessed package name" + (guessPackageName >=> print) testProjectRoot + putStrLn "Guessed name and email" + guessAuthorNameMail >>= print + + mods <- scanForModules testProjectRoot + + putStrLn "Guessed modules" + mapM_ print mods + putStrLn "Needed build programs" + print (neededBuildPrograms mods) + + putStrLn "List of known categories" + print $ knownCategories db +-} diff --git a/src/Distribution/Client/Init/Licenses.hs b/src/Distribution/Client/Init/Licenses.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init/Licenses.hs @@ -0,0 +1,3077 @@ +{-| +Module : Distribution.Client.Init.Licenses + +Description : Factory functions for producing known license types. + +License : BSD-like +Maintainer : cabal-devel@haskell.org +Stability : provisional +Portability : portable +-} +module Distribution.Client.Init.Licenses + ( License + , bsd2 + , bsd3 + , gplv2 + , gplv3 + , lgpl21 + , lgpl3 + , agplv3 + , apache20 + , mit + , mpl20 + , isc + ) where + +import Prelude (String, unlines, (++)) + +type License = String + +bsd2 :: String -> String -> License +bsd2 authors year = unlines + [ "Copyright (c) " ++ year ++ ", " ++ authors + , "All rights reserved." + , "" + , "Redistribution and use in source and binary forms, with or without" + , "modification, are permitted provided that the following conditions are" + , "met:" + , "" + , "1. Redistributions of source code must retain the above copyright" + , " notice, this list of conditions and the following disclaimer." + , "" + , "2. Redistributions in binary form must reproduce the above copyright" + , " notice, this list of conditions and the following disclaimer in the" + , " documentation and/or other materials provided with the" + , " distribution." + , "" + , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" + , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" + , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" + , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" + , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," + , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" + , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," + , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" + , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" + , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" + , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + ] + +bsd3 :: String -> String -> License +bsd3 authors year = unlines + [ "Copyright (c) " ++ year ++ ", " ++ authors + , "" + , "All rights reserved." + , "" + , "Redistribution and use in source and binary forms, with or without" + , "modification, are permitted provided that the following conditions are met:" + , "" + , " * Redistributions of source code must retain the above copyright" + , " notice, this list of conditions and the following disclaimer." + , "" + , " * Redistributions in binary form must reproduce the above" + , " copyright notice, this list of conditions and the following" + , " disclaimer in the documentation and/or other materials provided" + , " with the distribution." + , "" + , " * Neither the name of " ++ authors ++ " nor the names of other" + , " contributors may be used to endorse or promote products derived" + , " from this software without specific prior written permission." + , "" + , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" + , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" + , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" + , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" + , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," + , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" + , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," + , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" + , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" + , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" + , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + ] + +gplv2 :: License +gplv2 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "License is intended to guarantee your freedom to share and change free" + , "software--to make sure the software is free for all its users. This" + , "General Public License applies to most of the Free Software" + , "Foundation's software and to any other program whose authors commit to" + , "using it. (Some other Free Software Foundation software is covered by" + , "the GNU Lesser General Public License instead.) You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if you" + , "distribute copies of the software, or if you modify it." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must give the recipients all the rights that" + , "you have. You must make sure that they, too, receive or can get the" + , "source code. And you must show them these terms so they know their" + , "rights." + , "" + , " We protect your rights with two steps: (1) copyright the software, and" + , "(2) offer you this license which gives you legal permission to copy," + , "distribute and/or modify the software." + , "" + , " Also, for each author's protection and ours, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "software. If the software is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original, so" + , "that any problems introduced by others will not reflect on the original" + , "authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that redistributors of a free" + , "program will individually obtain patent licenses, in effect making the" + , "program proprietary. To prevent this, we have made it clear that any" + , "patent must be licensed for everyone's free use or not licensed at all." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " GNU GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License applies to any program or other work which contains" + , "a notice placed by the copyright holder saying it may be distributed" + , "under the terms of this General Public License. The \"Program\", below," + , "refers to any such program or work, and a \"work based on the Program\"" + , "means either the Program or any derivative work under copyright law:" + , "that is to say, a work containing the Program or a portion of it," + , "either verbatim or with modifications and/or translated into another" + , "language. (Hereinafter, translation is included without limitation in" + , "the term \"modification\".) Each licensee is addressed as \"you\"." + , "" + , "Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running the Program is not restricted, and the output from the Program" + , "is covered only if its contents constitute a work based on the" + , "Program (independent of having been made by running the Program)." + , "Whether that is true depends on what the Program does." + , "" + , " 1. You may copy and distribute verbatim copies of the Program's" + , "source code as you receive it, in any medium, provided that you" + , "conspicuously and appropriately publish on each copy an appropriate" + , "copyright notice and disclaimer of warranty; keep intact all the" + , "notices that refer to this License and to the absence of any warranty;" + , "and give any other recipients of the Program a copy of this License" + , "along with the Program." + , "" + , "You may charge a fee for the physical act of transferring a copy, and" + , "you may at your option offer warranty protection in exchange for a fee." + , "" + , " 2. You may modify your copy or copies of the Program or any portion" + , "of it, thus forming a work based on the Program, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) You must cause the modified files to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " b) You must cause any work that you distribute or publish, that in" + , " whole or in part contains or is derived from the Program or any" + , " part thereof, to be licensed as a whole at no charge to all third" + , " parties under the terms of this License." + , "" + , " c) If the modified program normally reads commands interactively" + , " when run, you must cause it, when started running for such" + , " interactive use in the most ordinary way, to print or display an" + , " announcement including an appropriate copyright notice and a" + , " notice that there is no warranty (or else, saying that you provide" + , " a warranty) and that users may redistribute the program under" + , " these conditions, and telling the user how to view a copy of this" + , " License. (Exception: if the Program itself is interactive but" + , " does not normally print such an announcement, your work based on" + , " the Program is not required to print an announcement.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Program," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Program, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Program." + , "" + , "In addition, mere aggregation of another work not based on the Program" + , "with the Program (or with a work based on the Program) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may copy and distribute the Program (or a work based on it," + , "under Section 2) in object code or executable form under the terms of" + , "Sections 1 and 2 above provided that you also do one of the following:" + , "" + , " a) Accompany it with the complete corresponding machine-readable" + , " source code, which must be distributed under the terms of Sections" + , " 1 and 2 above on a medium customarily used for software interchange; or," + , "" + , " b) Accompany it with a written offer, valid for at least three" + , " years, to give any third party, for a charge no more than your" + , " cost of physically performing source distribution, a complete" + , " machine-readable copy of the corresponding source code, to be" + , " distributed under the terms of Sections 1 and 2 above on a medium" + , " customarily used for software interchange; or," + , "" + , " c) Accompany it with the information you received as to the offer" + , " to distribute corresponding source code. (This alternative is" + , " allowed only for noncommercial distribution and only if you" + , " received the program in object code or executable form with such" + , " an offer, in accord with Subsection b above.)" + , "" + , "The source code for a work means the preferred form of the work for" + , "making modifications to it. For an executable work, complete source" + , "code means all the source code for all modules it contains, plus any" + , "associated interface definition files, plus the scripts used to" + , "control compilation and installation of the executable. However, as a" + , "special exception, the source code distributed need not include" + , "anything that is normally distributed (in either source or binary" + , "form) with the major components (compiler, kernel, and so on) of the" + , "operating system on which the executable runs, unless that component" + , "itself accompanies the executable." + , "" + , "If distribution of executable or object code is made by offering" + , "access to copy from a designated place, then offering equivalent" + , "access to copy the source code from the same place counts as" + , "distribution of the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 4. You may not copy, modify, sublicense, or distribute the Program" + , "except as expressly provided under this License. Any attempt" + , "otherwise to copy, modify, sublicense or distribute the Program is" + , "void, and will automatically terminate your rights under this License." + , "However, parties who have received copies, or rights, from you under" + , "this License will not have their licenses terminated so long as such" + , "parties remain in full compliance." + , "" + , " 5. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Program or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Program (or any work based on the" + , "Program), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Program or works based on it." + , "" + , " 6. Each time you redistribute the Program (or any work based on the" + , "Program), the recipient automatically receives a license from the" + , "original licensor to copy, distribute or modify the Program subject to" + , "these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 7. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Program at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Program by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Program." + , "" + , "If any portion of this section is held invalid or unenforceable under" + , "any particular circumstance, the balance of the section is intended to" + , "apply and the section as a whole is intended to apply in other" + , "circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system, which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 8. If the distribution and/or use of the Program is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Program under this License" + , "may add an explicit geographical distribution limitation excluding" + , "those countries, so that distribution is permitted only in or among" + , "countries not thus excluded. In such case, this License incorporates" + , "the limitation as if written in the body of this License." + , "" + , " 9. The Free Software Foundation may publish revised and/or new versions" + , "of the General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Program" + , "specifies a version number of this License which applies to it and \"any" + , "later version\", you have the option of following the terms and conditions" + , "either of that version or of any later version published by the Free" + , "Software Foundation. If the Program does not specify a version number of" + , "this License, you may choose any version ever published by the Free Software" + , "Foundation." + , "" + , " 10. If you wish to incorporate parts of the Program into other free" + , "programs whose distribution conditions are different, write to the author" + , "to ask for permission. For software which is copyrighted by the Free" + , "Software Foundation, write to the Free Software Foundation; we sometimes" + , "make exceptions for this. Our decision will be guided by the two goals" + , "of preserving the free status of all derivatives of our free software and" + , "of promoting the sharing and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" + , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" + , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" + , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" + , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" + , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" + , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" + , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," + , "REPAIR OR CORRECTION." + , "" + , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" + , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," + , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" + , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" + , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" + , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" + , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" + , "POSSIBILITY OF SUCH DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software; you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation; either version 2 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License along" + , " with this program; if not, write to the Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "If the program is interactive, make it output a short notice like this" + , "when it starts in an interactive mode:" + , "" + , " Gnomovision version 69, Copyright (C) year name of author" + , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, the commands you use may" + , "be called something other than `show w' and `show c'; they could even be" + , "mouse-clicks or menu items--whatever suits your program." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the program, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" + , " `Gnomovision' (which makes passes at compilers) written by James Hacker." + , "" + , " , 1 April 1989" + , " Ty Coon, President of Vice" + , "" + , "This General Public License does not permit incorporating your program into" + , "proprietary programs. If your program is a subroutine library, you may" + , "consider it more useful to permit linking proprietary applications with the" + , "library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License." + ] + +gplv3 :: License +gplv3 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU General Public License is a free, copyleft license for" + , "software and other kinds of works." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "the GNU General Public License is intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users. We, the Free Software Foundation, use the" + , "GNU General Public License for most of our software; it applies also to" + , "any other work released this way by its authors. You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " To protect your rights, we need to prevent others from denying you" + , "these rights or asking you to surrender the rights. Therefore, you have" + , "certain responsibilities if you distribute copies of the software, or if" + , "you modify it: responsibilities to respect the freedom of others." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must pass on to the recipients the same" + , "freedoms that you received. You must make sure that they, too, receive" + , "or can get the source code. And you must show them these terms so they" + , "know their rights." + , "" + , " Developers that use the GNU GPL protect your rights with two steps:" + , "(1) assert copyright on the software, and (2) offer you this License" + , "giving you legal permission to copy, distribute and/or modify it." + , "" + , " For the developers' and authors' protection, the GPL clearly explains" + , "that there is no warranty for this free software. For both users' and" + , "authors' sake, the GPL requires that modified versions be marked as" + , "changed, so that their problems will not be attributed erroneously to" + , "authors of previous versions." + , "" + , " Some devices are designed to deny users access to install or run" + , "modified versions of the software inside them, although the manufacturer" + , "can do so. This is fundamentally incompatible with the aim of" + , "protecting users' freedom to change the software. The systematic" + , "pattern of such abuse occurs in the area of products for individuals to" + , "use, which is precisely where it is most unacceptable. Therefore, we" + , "have designed this version of the GPL to prohibit the practice for those" + , "products. If such problems arise substantially in other domains, we" + , "stand ready to extend this provision to those domains in future versions" + , "of the GPL, as needed to protect the freedom of users." + , "" + , " Finally, every program is threatened constantly by software patents." + , "States should not allow patents to restrict development and use of" + , "software on general-purpose computers, but in those that do, we wish to" + , "avoid the special danger that patents applied to a free program could" + , "make it effectively proprietary. To prevent this, the GPL assures that" + , "patents cannot be used to render the program non-free." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , "" + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , "" + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Use with the GNU Affero General Public License." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU Affero General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the special requirements of the GNU Affero General Public License," + , "section 13, concerning interaction through a network will apply to the" + , "combination as such." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If the program does terminal interaction, make it output a short" + , "notice like this when it starts in an interactive mode:" + , "" + , " Copyright (C) " + , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, your program's commands" + , "might be different; for a GUI interface, you would use an \"about box\"." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU GPL, see" + , "." + , "" + , " The GNU General Public License does not permit incorporating your program" + , "into proprietary programs. If your program is a subroutine library, you" + , "may consider it more useful to permit linking proprietary applications with" + , "the library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License. But first, please read" + , "." + ] + +agplv3 :: License +agplv3 = unlines + [ " GNU AFFERO GENERAL PUBLIC LICENSE" + , " Version 3, 19 November 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU Affero General Public License is a free, copyleft license for" + , "software and other kinds of works, specifically designed to ensure" + , "cooperation with the community in the case of network server software." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "our General Public Licenses are intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " Developers that use our General Public Licenses protect your rights" + , "with two steps: (1) assert copyright on the software, and (2) offer" + , "you this License which gives you legal permission to copy, distribute" + , "and/or modify the software." + , "" + , " A secondary benefit of defending all users' freedom is that" + , "improvements made in alternate versions of the program, if they" + , "receive widespread use, become available for other developers to" + , "incorporate. Many developers of free software are heartened and" + , "encouraged by the resulting cooperation. However, in the case of" + , "software used on network servers, this result may fail to come about." + , "The GNU General Public License permits making a modified version and" + , "letting the public access it on a server without ever releasing its" + , "source code to the public." + , "" + , " The GNU Affero General Public License is designed specifically to" + , "ensure that, in such cases, the modified source code becomes available" + , "to the community. It requires the operator of a network server to" + , "provide the source code of the modified version running there to the" + , "users of that server. Therefore, public use of a modified version, on" + , "a publicly accessible server, gives the public access to the source" + , "code of the modified version." + , "" + , " An older license, called the Affero General Public License and" + , "published by Affero, was designed to accomplish similar goals. This is" + , "a different license, not a version of the Affero GPL, but Affero has" + , "released a new version of the Affero GPL which permits relicensing under" + , "this license." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU Affero General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , "" + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , "" + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Remote Network Interaction; Use with the GNU General Public License." + , "" + , " Notwithstanding any other provision of this License, if you modify the" + , "Program, your modified version must prominently offer all users" + , "interacting with it remotely through a computer network (if your version" + , "supports such interaction) an opportunity to receive the Corresponding" + , "Source of your version by providing access to the Corresponding Source" + , "from a network server at no charge, through some standard or customary" + , "means of facilitating copying of software. This Corresponding Source" + , "shall include the Corresponding Source for any work covered by version 3" + , "of the GNU General Public License that is incorporated pursuant to the" + , "following paragraph." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the work with which it is combined will remain governed by version" + , "3 of the GNU General Public License." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU Affero General Public License from time to time. Such new versions" + , "will be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU Affero General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU Affero General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU Affero General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU Affero General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU Affero General Public License for more details." + , "" + , " You should have received a copy of the GNU Affero General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If your software can interact with users remotely through a computer" + , "network, you should also make sure that it provides a way for users to" + , "get its source. For example, if your program is a web application, its" + , "interface could display a \"Source\" link that leads users to an archive" + , "of the code. There are many ways you could offer source, and different" + , "solutions will be better for different programs; see section 13 for the" + , "specific requirements." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU AGPL, see" + , "." + ] + +lgpl21 :: License +lgpl21 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 2.1, February 1999" + , "" + , " Copyright (C) 1991, 1999 Free Software Foundation, Inc." + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "[This is the first released version of the Lesser GPL. It also counts" + , " as the successor of the GNU Library Public License, version 2, hence" + , " the version number 2.1.]" + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "Licenses are intended to guarantee your freedom to share and change" + , "free software--to make sure the software is free for all its users." + , "" + , " This license, the Lesser General Public License, applies to some" + , "specially designated software packages--typically libraries--of the" + , "Free Software Foundation and other authors who decide to use it. You" + , "can use it too, but we suggest you first think carefully about whether" + , "this license or the ordinary General Public License is the better" + , "strategy to use in any particular case, based on the explanations below." + , "" + , " When we speak of free software, we are referring to freedom of use," + , "not price. Our General Public Licenses are designed to make sure that" + , "you have the freedom to distribute copies of free software (and charge" + , "for this service if you wish); that you receive source code or can get" + , "it if you want it; that you can change the software and use pieces of" + , "it in new free programs; and that you are informed that you can do" + , "these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "distributors to deny you these rights or to ask you to surrender these" + , "rights. These restrictions translate to certain responsibilities for" + , "you if you distribute copies of the library or if you modify it." + , "" + , " For example, if you distribute copies of the library, whether gratis" + , "or for a fee, you must give the recipients all the rights that we gave" + , "you. You must make sure that they, too, receive or can get the source" + , "code. If you link other code with the library, you must provide" + , "complete object files to the recipients, so that they can relink them" + , "with the library after making changes to the library and recompiling" + , "it. And you must show them these terms so they know their rights." + , "" + , " We protect your rights with a two-step method: (1) we copyright the" + , "library, and (2) we offer you this license, which gives you legal" + , "permission to copy, distribute and/or modify the library." + , "" + , " To protect each distributor, we want to make it very clear that" + , "there is no warranty for the free library. Also, if the library is" + , "modified by someone else and passed on, the recipients should know" + , "that what they have is not the original version, so that the original" + , "author's reputation will not be affected by problems that might be" + , "introduced by others." + , "" + , " Finally, software patents pose a constant threat to the existence of" + , "any free program. We wish to make sure that a company cannot" + , "effectively restrict the users of a free program by obtaining a" + , "restrictive license from a patent holder. Therefore, we insist that" + , "any patent license obtained for a version of the library must be" + , "consistent with the full freedom of use specified in this license." + , "" + , " Most GNU software, including some libraries, is covered by the" + , "ordinary GNU General Public License. This license, the GNU Lesser" + , "General Public License, applies to certain designated libraries, and" + , "is quite different from the ordinary General Public License. We use" + , "this license for certain libraries in order to permit linking those" + , "libraries into non-free programs." + , "" + , " When a program is linked with a library, whether statically or using" + , "a shared library, the combination of the two is legally speaking a" + , "combined work, a derivative of the original library. The ordinary" + , "General Public License therefore permits such linking only if the" + , "entire combination fits its criteria of freedom. The Lesser General" + , "Public License permits more lax criteria for linking other code with" + , "the library." + , "" + , " We call this license the \"Lesser\" General Public License because it" + , "does Less to protect the user's freedom than the ordinary General" + , "Public License. It also provides other free software developers Less" + , "of an advantage over competing non-free programs. These disadvantages" + , "are the reason we use the ordinary General Public License for many" + , "libraries. However, the Lesser license provides advantages in certain" + , "special circumstances." + , "" + , " For example, on rare occasions, there may be a special need to" + , "encourage the widest possible use of a certain library, so that it becomes" + , "a de-facto standard. To achieve this, non-free programs must be" + , "allowed to use the library. A more frequent case is that a free" + , "library does the same job as widely used non-free libraries. In this" + , "case, there is little to gain by limiting the free library to free" + , "software only, so we use the Lesser General Public License." + , "" + , " In other cases, permission to use a particular library in non-free" + , "programs enables a greater number of people to use a large body of" + , "free software. For example, permission to use the GNU C Library in" + , "non-free programs enables many more people to use the whole GNU" + , "operating system, as well as its variant, the GNU/Linux operating" + , "system." + , "" + , " Although the Lesser General Public License is Less protective of the" + , "users' freedom, it does ensure that the user of a program that is" + , "linked with the Library has the freedom and the wherewithal to run" + , "that program using a modified version of the Library." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow. Pay close attention to the difference between a" + , "\"work based on the library\" and a \"work that uses the library\". The" + , "former contains code derived from the library, whereas the latter must" + , "be combined with the library in order to run." + , "" + , " GNU LESSER GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License Agreement applies to any software library or other" + , "program which contains a notice placed by the copyright holder or" + , "other authorized party saying it may be distributed under the terms of" + , "this Lesser General Public License (also called \"this License\")." + , "Each licensee is addressed as \"you\"." + , "" + , " A \"library\" means a collection of software functions and/or data" + , "prepared so as to be conveniently linked with application programs" + , "(which use some of those functions and data) to form executables." + , "" + , " The \"Library\", below, refers to any such software library or work" + , "which has been distributed under these terms. A \"work based on the" + , "Library\" means either the Library or any derivative work under" + , "copyright law: that is to say, a work containing the Library or a" + , "portion of it, either verbatim or with modifications and/or translated" + , "straightforwardly into another language. (Hereinafter, translation is" + , "included without limitation in the term \"modification\".)" + , "" + , " \"Source code\" for a work means the preferred form of the work for" + , "making modifications to it. For a library, complete source code means" + , "all the source code for all modules it contains, plus any associated" + , "interface definition files, plus the scripts used to control compilation" + , "and installation of the library." + , "" + , " Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running a program using the Library is not restricted, and output from" + , "such a program is covered only if its contents constitute a work based" + , "on the Library (independent of the use of the Library in a tool for" + , "writing it). Whether that is true depends on what the Library does" + , "and what the program that uses the Library does." + , "" + , " 1. You may copy and distribute verbatim copies of the Library's" + , "complete source code as you receive it, in any medium, provided that" + , "you conspicuously and appropriately publish on each copy an" + , "appropriate copyright notice and disclaimer of warranty; keep intact" + , "all the notices that refer to this License and to the absence of any" + , "warranty; and distribute a copy of this License along with the" + , "Library." + , "" + , " You may charge a fee for the physical act of transferring a copy," + , "and you may at your option offer warranty protection in exchange for a" + , "fee." + , "" + , " 2. You may modify your copy or copies of the Library or any portion" + , "of it, thus forming a work based on the Library, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) The modified work must itself be a software library." + , "" + , " b) You must cause the files modified to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " c) You must cause the whole of the work to be licensed at no" + , " charge to all third parties under the terms of this License." + , "" + , " d) If a facility in the modified Library refers to a function or a" + , " table of data to be supplied by an application program that uses" + , " the facility, other than as an argument passed when the facility" + , " is invoked, then you must make a good faith effort to ensure that," + , " in the event an application does not supply such function or" + , " table, the facility still operates, and performs whatever part of" + , " its purpose remains meaningful." + , "" + , " (For example, a function in a library to compute square roots has" + , " a purpose that is entirely well-defined independent of the" + , " application. Therefore, Subsection 2d requires that any" + , " application-supplied function or table used by this function must" + , " be optional: if the application does not supply it, the square" + , " root function must still compute square roots.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Library," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Library, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote" + , "it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Library." + , "" + , "In addition, mere aggregation of another work not based on the Library" + , "with the Library (or with a work based on the Library) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may opt to apply the terms of the ordinary GNU General Public" + , "License instead of this License to a given copy of the Library. To do" + , "this, you must alter all the notices that refer to this License, so" + , "that they refer to the ordinary GNU General Public License, version 2," + , "instead of to this License. (If a newer version than version 2 of the" + , "ordinary GNU General Public License has appeared, then you can specify" + , "that version instead if you wish.) Do not make any other change in" + , "these notices." + , "" + , " Once this change is made in a given copy, it is irreversible for" + , "that copy, so the ordinary GNU General Public License applies to all" + , "subsequent copies and derivative works made from that copy." + , "" + , " This option is useful when you wish to copy part of the code of" + , "the Library into a program that is not a library." + , "" + , " 4. You may copy and distribute the Library (or a portion or" + , "derivative of it, under Section 2) in object code or executable form" + , "under the terms of Sections 1 and 2 above provided that you accompany" + , "it with the complete corresponding machine-readable source code, which" + , "must be distributed under the terms of Sections 1 and 2 above on a" + , "medium customarily used for software interchange." + , "" + , " If distribution of object code is made by offering access to copy" + , "from a designated place, then offering equivalent access to copy the" + , "source code from the same place satisfies the requirement to" + , "distribute the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 5. A program that contains no derivative of any portion of the" + , "Library, but is designed to work with the Library by being compiled or" + , "linked with it, is called a \"work that uses the Library\". Such a" + , "work, in isolation, is not a derivative work of the Library, and" + , "therefore falls outside the scope of this License." + , "" + , " However, linking a \"work that uses the Library\" with the Library" + , "creates an executable that is a derivative of the Library (because it" + , "contains portions of the Library), rather than a \"work that uses the" + , "library\". The executable is therefore covered by this License." + , "Section 6 states terms for distribution of such executables." + , "" + , " When a \"work that uses the Library\" uses material from a header file" + , "that is part of the Library, the object code for the work may be a" + , "derivative work of the Library even though the source code is not." + , "Whether this is true is especially significant if the work can be" + , "linked without the Library, or if the work is itself a library. The" + , "threshold for this to be true is not precisely defined by law." + , "" + , " If such an object file uses only numerical parameters, data" + , "structure layouts and accessors, and small macros and small inline" + , "functions (ten lines or less in length), then the use of the object" + , "file is unrestricted, regardless of whether it is legally a derivative" + , "work. (Executables containing this object code plus portions of the" + , "Library will still fall under Section 6.)" + , "" + , " Otherwise, if the work is a derivative of the Library, you may" + , "distribute the object code for the work under the terms of Section 6." + , "Any executables containing that work also fall under Section 6," + , "whether or not they are linked directly with the Library itself." + , "" + , " 6. As an exception to the Sections above, you may also combine or" + , "link a \"work that uses the Library\" with the Library to produce a" + , "work containing portions of the Library, and distribute that work" + , "under terms of your choice, provided that the terms permit" + , "modification of the work for the customer's own use and reverse" + , "engineering for debugging such modifications." + , "" + , " You must give prominent notice with each copy of the work that the" + , "Library is used in it and that the Library and its use are covered by" + , "this License. You must supply a copy of this License. If the work" + , "during execution displays copyright notices, you must include the" + , "copyright notice for the Library among them, as well as a reference" + , "directing the user to the copy of this License. Also, you must do one" + , "of these things:" + , "" + , " a) Accompany the work with the complete corresponding" + , " machine-readable source code for the Library including whatever" + , " changes were used in the work (which must be distributed under" + , " Sections 1 and 2 above); and, if the work is an executable linked" + , " with the Library, with the complete machine-readable \"work that" + , " uses the Library\", as object code and/or source code, so that the" + , " user can modify the Library and then relink to produce a modified" + , " executable containing the modified Library. (It is understood" + , " that the user who changes the contents of definitions files in the" + , " Library will not necessarily be able to recompile the application" + , " to use the modified definitions.)" + , "" + , " b) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (1) uses at run time a" + , " copy of the library already present on the user's computer system," + , " rather than copying library functions into the executable, and (2)" + , " will operate properly with a modified version of the library, if" + , " the user installs one, as long as the modified version is" + , " interface-compatible with the version that the work was made with." + , "" + , " c) Accompany the work with a written offer, valid for at" + , " least three years, to give the same user the materials" + , " specified in Subsection 6a, above, for a charge no more" + , " than the cost of performing this distribution." + , "" + , " d) If distribution of the work is made by offering access to copy" + , " from a designated place, offer equivalent access to copy the above" + , " specified materials from the same place." + , "" + , " e) Verify that the user has already received a copy of these" + , " materials or that you have already sent this user a copy." + , "" + , " For an executable, the required form of the \"work that uses the" + , "Library\" must include any data and utility programs needed for" + , "reproducing the executable from it. However, as a special exception," + , "the materials to be distributed need not include anything that is" + , "normally distributed (in either source or binary form) with the major" + , "components (compiler, kernel, and so on) of the operating system on" + , "which the executable runs, unless that component itself accompanies" + , "the executable." + , "" + , " It may happen that this requirement contradicts the license" + , "restrictions of other proprietary libraries that do not normally" + , "accompany the operating system. Such a contradiction means you cannot" + , "use both them and the Library together in an executable that you" + , "distribute." + , "" + , " 7. You may place library facilities that are a work based on the" + , "Library side-by-side in a single library together with other library" + , "facilities not covered by this License, and distribute such a combined" + , "library, provided that the separate distribution of the work based on" + , "the Library and of the other library facilities is otherwise" + , "permitted, and provided that you do these two things:" + , "" + , " a) Accompany the combined library with a copy of the same work" + , " based on the Library, uncombined with any other library" + , " facilities. This must be distributed under the terms of the" + , " Sections above." + , "" + , " b) Give prominent notice with the combined library of the fact" + , " that part of it is a work based on the Library, and explaining" + , " where to find the accompanying uncombined form of the same work." + , "" + , " 8. You may not copy, modify, sublicense, link with, or distribute" + , "the Library except as expressly provided under this License. Any" + , "attempt otherwise to copy, modify, sublicense, link with, or" + , "distribute the Library is void, and will automatically terminate your" + , "rights under this License. However, parties who have received copies," + , "or rights, from you under this License will not have their licenses" + , "terminated so long as such parties remain in full compliance." + , "" + , " 9. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Library or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Library (or any work based on the" + , "Library), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Library or works based on it." + , "" + , " 10. Each time you redistribute the Library (or any work based on the" + , "Library), the recipient automatically receives a license from the" + , "original licensor to copy, distribute, link with or modify the Library" + , "subject to these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties with" + , "this License." + , "" + , " 11. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Library at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Library by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Library." + , "" + , "If any portion of this section is held invalid or unenforceable under any" + , "particular circumstance, the balance of the section is intended to apply," + , "and the section as a whole is intended to apply in other circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 12. If the distribution and/or use of the Library is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Library under this License may add" + , "an explicit geographical distribution limitation excluding those countries," + , "so that distribution is permitted only in or among countries not thus" + , "excluded. In such case, this License incorporates the limitation as if" + , "written in the body of this License." + , "" + , " 13. The Free Software Foundation may publish revised and/or new" + , "versions of the Lesser General Public License from time to time." + , "Such new versions will be similar in spirit to the present version," + , "but may differ in detail to address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Library" + , "specifies a version number of this License which applies to it and" + , "\"any later version\", you have the option of following the terms and" + , "conditions either of that version or of any later version published by" + , "the Free Software Foundation. If the Library does not specify a" + , "license version number, you may choose any version ever published by" + , "the Free Software Foundation." + , "" + , " 14. If you wish to incorporate parts of the Library into other free" + , "programs whose distribution conditions are incompatible with these," + , "write to the author to ask for permission. For software which is" + , "copyrighted by the Free Software Foundation, write to the Free" + , "Software Foundation; we sometimes make exceptions for this. Our" + , "decision will be guided by the two goals of preserving the free status" + , "of all derivatives of our free software and of promoting the sharing" + , "and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" + , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." + , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" + , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" + , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" + , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" + , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" + , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" + , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" + , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" + , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" + , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" + , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" + , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" + , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" + , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" + , "DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Libraries" + , "" + , " If you develop a new library, and you want it to be of the greatest" + , "possible use to the public, we recommend making it free software that" + , "everyone can redistribute and change. You can do so by permitting" + , "redistribution under these terms (or, alternatively, under the terms of the" + , "ordinary General Public License)." + , "" + , " To apply these terms, attach the following notices to the library. It is" + , "safest to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least the" + , "\"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This library is free software; you can redistribute it and/or" + , " modify it under the terms of the GNU Lesser General Public" + , " License as published by the Free Software Foundation; either" + , " version 2.1 of the License, or (at your option) any later version." + , "" + , " This library is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" + , " Lesser General Public License for more details." + , "" + , " You should have received a copy of the GNU Lesser General Public" + , " License along with this library; if not, write to the Free Software" + , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the library, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" + , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." + , "" + , " , 1 April 1990" + , " Ty Coon, President of Vice" + , "" + , "That's all there is to it!" + ] + +lgpl3 :: License +lgpl3 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "" + , " This version of the GNU Lesser General Public License incorporates" + , "the terms and conditions of version 3 of the GNU General Public" + , "License, supplemented by the additional permissions listed below." + , "" + , " 0. Additional Definitions." + , "" + , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" + , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" + , "General Public License." + , "" + , " \"The Library\" refers to a covered work governed by this License," + , "other than an Application or a Combined Work as defined below." + , "" + , " An \"Application\" is any work that makes use of an interface provided" + , "by the Library, but which is not otherwise based on the Library." + , "Defining a subclass of a class defined by the Library is deemed a mode" + , "of using an interface provided by the Library." + , "" + , " A \"Combined Work\" is a work produced by combining or linking an" + , "Application with the Library. The particular version of the Library" + , "with which the Combined Work was made is also called the \"Linked" + , "Version\"." + , "" + , " The \"Minimal Corresponding Source\" for a Combined Work means the" + , "Corresponding Source for the Combined Work, excluding any source code" + , "for portions of the Combined Work that, considered in isolation, are" + , "based on the Application, and not on the Linked Version." + , "" + , " The \"Corresponding Application Code\" for a Combined Work means the" + , "object code and/or source code for the Application, including any data" + , "and utility programs needed for reproducing the Combined Work from the" + , "Application, but excluding the System Libraries of the Combined Work." + , "" + , " 1. Exception to Section 3 of the GNU GPL." + , "" + , " You may convey a covered work under sections 3 and 4 of this License" + , "without being bound by section 3 of the GNU GPL." + , "" + , " 2. Conveying Modified Versions." + , "" + , " If you modify a copy of the Library, and, in your modifications, a" + , "facility refers to a function or data to be supplied by an Application" + , "that uses the facility (other than as an argument passed when the" + , "facility is invoked), then you may convey a copy of the modified" + , "version:" + , "" + , " a) under this License, provided that you make a good faith effort to" + , " ensure that, in the event an Application does not supply the" + , " function or data, the facility still operates, and performs" + , " whatever part of its purpose remains meaningful, or" + , "" + , " b) under the GNU GPL, with none of the additional permissions of" + , " this License applicable to that copy." + , "" + , " 3. Object Code Incorporating Material from Library Header Files." + , "" + , " The object code form of an Application may incorporate material from" + , "a header file that is part of the Library. You may convey such object" + , "code under terms of your choice, provided that, if the incorporated" + , "material is not limited to numerical parameters, data structure" + , "layouts and accessors, or small macros, inline functions and templates" + , "(ten or fewer lines in length), you do both of the following:" + , "" + , " a) Give prominent notice with each copy of the object code that the" + , " Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the object code with a copy of the GNU GPL and this license" + , " document." + , "" + , " 4. Combined Works." + , "" + , " You may convey a Combined Work under terms of your choice that," + , "taken together, effectively do not restrict modification of the" + , "portions of the Library contained in the Combined Work and reverse" + , "engineering for debugging such modifications, if you also do each of" + , "the following:" + , "" + , " a) Give prominent notice with each copy of the Combined Work that" + , " the Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" + , " document." + , "" + , " c) For a Combined Work that displays copyright notices during" + , " execution, include the copyright notice for the Library among" + , " these notices, as well as a reference directing the user to the" + , " copies of the GNU GPL and this license document." + , "" + , " d) Do one of the following:" + , "" + , " 0) Convey the Minimal Corresponding Source under the terms of this" + , " License, and the Corresponding Application Code in a form" + , " suitable for, and under terms that permit, the user to" + , " recombine or relink the Application with a modified version of" + , " the Linked Version to produce a modified Combined Work, in the" + , " manner specified by section 6 of the GNU GPL for conveying" + , " Corresponding Source." + , "" + , " 1) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (a) uses at run time" + , " a copy of the Library already present on the user's computer" + , " system, and (b) will operate properly with a modified version" + , " of the Library that is interface-compatible with the Linked" + , " Version." + , "" + , " e) Provide Installation Information, but only if you would otherwise" + , " be required to provide such information under section 6 of the" + , " GNU GPL, and only to the extent that such information is" + , " necessary to install and execute a modified version of the" + , " Combined Work produced by recombining or relinking the" + , " Application with a modified version of the Linked Version. (If" + , " you use option 4d0, the Installation Information must accompany" + , " the Minimal Corresponding Source and Corresponding Application" + , " Code. If you use option 4d1, you must provide the Installation" + , " Information in the manner specified by section 6 of the GNU GPL" + , " for conveying Corresponding Source.)" + , "" + , " 5. Combined Libraries." + , "" + , " You may place library facilities that are a work based on the" + , "Library side by side in a single library together with other library" + , "facilities that are not Applications and are not covered by this" + , "License, and convey such a combined library under terms of your" + , "choice, if you do both of the following:" + , "" + , " a) Accompany the combined library with a copy of the same work based" + , " on the Library, uncombined with any other library facilities," + , " conveyed under the terms of this License." + , "" + , " b) Give prominent notice with the combined library that part of it" + , " is a work based on the Library, and explaining where to find the" + , " accompanying uncombined form of the same work." + , "" + , " 6. Revised Versions of the GNU Lesser General Public License." + , "" + , " The Free Software Foundation may publish revised and/or new versions" + , "of the GNU Lesser General Public License from time to time. Such new" + , "versions will be similar in spirit to the present version, but may" + , "differ in detail to address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Library as you received it specifies that a certain numbered version" + , "of the GNU Lesser General Public License \"or any later version\"" + , "applies to it, you have the option of following the terms and" + , "conditions either of that published version or of any later version" + , "published by the Free Software Foundation. If the Library as you" + , "received it does not specify a version number of the GNU Lesser" + , "General Public License, you may choose any version of the GNU Lesser" + , "General Public License ever published by the Free Software Foundation." + , "" + , " If the Library as you received it specifies that a proxy can decide" + , "whether future versions of the GNU Lesser General Public License shall" + , "apply, that proxy's public statement of acceptance of any version is" + , "permanent authorization for you to choose that version for the" + , "Library." + ] + +apache20 :: License +apache20 = unlines + [ "" + , " Apache License" + , " Version 2.0, January 2004" + , " http://www.apache.org/licenses/" + , "" + , " TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION" + , "" + , " 1. Definitions." + , "" + , " \"License\" shall mean the terms and conditions for use, reproduction," + , " and distribution as defined by Sections 1 through 9 of this document." + , "" + , " \"Licensor\" shall mean the copyright owner or entity authorized by" + , " the copyright owner that is granting the License." + , "" + , " \"Legal Entity\" shall mean the union of the acting entity and all" + , " other entities that control, are controlled by, or are under common" + , " control with that entity. For the purposes of this definition," + , " \"control\" means (i) the power, direct or indirect, to cause the" + , " direction or management of such entity, whether by contract or" + , " otherwise, or (ii) ownership of fifty percent (50%) or more of the" + , " outstanding shares, or (iii) beneficial ownership of such entity." + , "" + , " \"You\" (or \"Your\") shall mean an individual or Legal Entity" + , " exercising permissions granted by this License." + , "" + , " \"Source\" form shall mean the preferred form for making modifications," + , " including but not limited to software source code, documentation" + , " source, and configuration files." + , "" + , " \"Object\" form shall mean any form resulting from mechanical" + , " transformation or translation of a Source form, including but" + , " not limited to compiled object code, generated documentation," + , " and conversions to other media types." + , "" + , " \"Work\" shall mean the work of authorship, whether in Source or" + , " Object form, made available under the License, as indicated by a" + , " copyright notice that is included in or attached to the work" + , " (an example is provided in the Appendix below)." + , "" + , " \"Derivative Works\" shall mean any work, whether in Source or Object" + , " form, that is based on (or derived from) the Work and for which the" + , " editorial revisions, annotations, elaborations, or other modifications" + , " represent, as a whole, an original work of authorship. For the purposes" + , " of this License, Derivative Works shall not include works that remain" + , " separable from, or merely link (or bind by name) to the interfaces of," + , " the Work and Derivative Works thereof." + , "" + , " \"Contribution\" shall mean any work of authorship, including" + , " the original version of the Work and any modifications or additions" + , " to that Work or Derivative Works thereof, that is intentionally" + , " submitted to Licensor for inclusion in the Work by the copyright owner" + , " or by an individual or Legal Entity authorized to submit on behalf of" + , " the copyright owner. For the purposes of this definition, \"submitted\"" + , " means any form of electronic, verbal, or written communication sent" + , " to the Licensor or its representatives, including but not limited to" + , " communication on electronic mailing lists, source code control systems," + , " and issue tracking systems that are managed by, or on behalf of, the" + , " Licensor for the purpose of discussing and improving the Work, but" + , " excluding communication that is conspicuously marked or otherwise" + , " designated in writing by the copyright owner as \"Not a Contribution.\"" + , "" + , " \"Contributor\" shall mean Licensor and any individual or Legal Entity" + , " on behalf of whom a Contribution has been received by Licensor and" + , " subsequently incorporated within the Work." + , "" + , " 2. Grant of Copyright License. Subject to the terms and conditions of" + , " this License, each Contributor hereby grants to You a perpetual," + , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" + , " copyright license to reproduce, prepare Derivative Works of," + , " publicly display, publicly perform, sublicense, and distribute the" + , " Work and such Derivative Works in Source or Object form." + , "" + , " 3. Grant of Patent License. Subject to the terms and conditions of" + , " this License, each Contributor hereby grants to You a perpetual," + , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" + , " (except as stated in this section) patent license to make, have made," + , " use, offer to sell, sell, import, and otherwise transfer the Work," + , " where such license applies only to those patent claims licensable" + , " by such Contributor that are necessarily infringed by their" + , " Contribution(s) alone or by combination of their Contribution(s)" + , " with the Work to which such Contribution(s) was submitted. If You" + , " institute patent litigation against any entity (including a" + , " cross-claim or counterclaim in a lawsuit) alleging that the Work" + , " or a Contribution incorporated within the Work constitutes direct" + , " or contributory patent infringement, then any patent licenses" + , " granted to You under this License for that Work shall terminate" + , " as of the date such litigation is filed." + , "" + , " 4. Redistribution. You may reproduce and distribute copies of the" + , " Work or Derivative Works thereof in any medium, with or without" + , " modifications, and in Source or Object form, provided that You" + , " meet the following conditions:" + , "" + , " (a) You must give any other recipients of the Work or" + , " Derivative Works a copy of this License; and" + , "" + , " (b) You must cause any modified files to carry prominent notices" + , " stating that You changed the files; and" + , "" + , " (c) You must retain, in the Source form of any Derivative Works" + , " that You distribute, all copyright, patent, trademark, and" + , " attribution notices from the Source form of the Work," + , " excluding those notices that do not pertain to any part of" + , " the Derivative Works; and" + , "" + , " (d) If the Work includes a \"NOTICE\" text file as part of its" + , " distribution, then any Derivative Works that You distribute must" + , " include a readable copy of the attribution notices contained" + , " within such NOTICE file, excluding those notices that do not" + , " pertain to any part of the Derivative Works, in at least one" + , " of the following places: within a NOTICE text file distributed" + , " as part of the Derivative Works; within the Source form or" + , " documentation, if provided along with the Derivative Works; or," + , " within a display generated by the Derivative Works, if and" + , " wherever such third-party notices normally appear. The contents" + , " of the NOTICE file are for informational purposes only and" + , " do not modify the License. You may add Your own attribution" + , " notices within Derivative Works that You distribute, alongside" + , " or as an addendum to the NOTICE text from the Work, provided" + , " that such additional attribution notices cannot be construed" + , " as modifying the License." + , "" + , " You may add Your own copyright statement to Your modifications and" + , " may provide additional or different license terms and conditions" + , " for use, reproduction, or distribution of Your modifications, or" + , " for any such Derivative Works as a whole, provided Your use," + , " reproduction, and distribution of the Work otherwise complies with" + , " the conditions stated in this License." + , "" + , " 5. Submission of Contributions. Unless You explicitly state otherwise," + , " any Contribution intentionally submitted for inclusion in the Work" + , " by You to the Licensor shall be under the terms and conditions of" + , " this License, without any additional terms or conditions." + , " Notwithstanding the above, nothing herein shall supersede or modify" + , " the terms of any separate license agreement you may have executed" + , " with Licensor regarding such Contributions." + , "" + , " 6. Trademarks. This License does not grant permission to use the trade" + , " names, trademarks, service marks, or product names of the Licensor," + , " except as required for reasonable and customary use in describing the" + , " origin of the Work and reproducing the content of the NOTICE file." + , "" + , " 7. Disclaimer of Warranty. Unless required by applicable law or" + , " agreed to in writing, Licensor provides the Work (and each" + , " Contributor provides its Contributions) on an \"AS IS\" BASIS," + , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or" + , " implied, including, without limitation, any warranties or conditions" + , " of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A" + , " PARTICULAR PURPOSE. You are solely responsible for determining the" + , " appropriateness of using or redistributing the Work and assume any" + , " risks associated with Your exercise of permissions under this License." + , "" + , " 8. Limitation of Liability. In no event and under no legal theory," + , " whether in tort (including negligence), contract, or otherwise," + , " unless required by applicable law (such as deliberate and grossly" + , " negligent acts) or agreed to in writing, shall any Contributor be" + , " liable to You for damages, including any direct, indirect, special," + , " incidental, or consequential damages of any character arising as a" + , " result of this License or out of the use or inability to use the" + , " Work (including but not limited to damages for loss of goodwill," + , " work stoppage, computer failure or malfunction, or any and all" + , " other commercial damages or losses), even if such Contributor" + , " has been advised of the possibility of such damages." + , "" + , " 9. Accepting Warranty or Additional Liability. While redistributing" + , " the Work or Derivative Works thereof, You may choose to offer," + , " and charge a fee for, acceptance of support, warranty, indemnity," + , " or other liability obligations and/or rights consistent with this" + , " License. However, in accepting such obligations, You may act only" + , " on Your own behalf and on Your sole responsibility, not on behalf" + , " of any other Contributor, and only if You agree to indemnify," + , " defend, and hold each Contributor harmless for any liability" + , " incurred by, or claims asserted against, such Contributor by reason" + , " of your accepting any such warranty or additional liability." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " APPENDIX: How to apply the Apache License to your work." + , "" + , " To apply the Apache License to your work, attach the following" + , " boilerplate notice, with the fields enclosed by brackets \"[]\"" + , " replaced with your own identifying information. (Don't include" + , " the brackets!) The text should be enclosed in the appropriate" + , " comment syntax for the file format. We also recommend that a" + , " file or class name and description of purpose be included on the" + , " same \"printed page\" as the copyright notice for easier" + , " identification within third-party archives." + , "" + , " Copyright [yyyy] [name of copyright owner]" + , "" + , " Licensed under the Apache License, Version 2.0 (the \"License\");" + , " you may not use this file except in compliance with the License." + , " You may obtain a copy of the License at" + , "" + , " http://www.apache.org/licenses/LICENSE-2.0" + , "" + , " Unless required by applicable law or agreed to in writing, software" + , " distributed under the License is distributed on an \"AS IS\" BASIS," + , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied." + , " See the License for the specific language governing permissions and" + , " limitations under the License." + ] + +mit :: String -> String -> License +mit authors year = unlines + [ "Copyright (c) " ++ year ++ " " ++ authors + , "" + , "Permission is hereby granted, free of charge, to any person obtaining" + , "a copy of this software and associated documentation files (the" + , "\"Software\"), to deal in the Software without restriction, including" + , "without limitation the rights to use, copy, modify, merge, publish," + , "distribute, sublicense, and/or sell copies of the Software, and to" + , "permit persons to whom the Software is furnished to do so, subject to" + , "the following conditions:" + , "" + , "The above copyright notice and this permission notice shall be included" + , "in all copies or substantial portions of the Software." + , "" + , "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND," + , "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF" + , "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT." + , "IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY" + , "CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT," + , "TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE" + , "SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE." + ] + +mpl20 :: License +mpl20 = unlines + [ "Mozilla Public License Version 2.0" + , "==================================" + , "" + , "1. Definitions" + , "--------------" + , "" + , "1.1. \"Contributor\"" + , " means each individual or legal entity that creates, contributes to" + , " the creation of, or owns Covered Software." + , "" + , "1.2. \"Contributor Version\"" + , " means the combination of the Contributions of others (if any) used" + , " by a Contributor and that particular Contributor's Contribution." + , "" + , "1.3. \"Contribution\"" + , " means Covered Software of a particular Contributor." + , "" + , "1.4. \"Covered Software\"" + , " means Source Code Form to which the initial Contributor has attached" + , " the notice in Exhibit A, the Executable Form of such Source Code" + , " Form, and Modifications of such Source Code Form, in each case" + , " including portions thereof." + , "" + , "1.5. \"Incompatible With Secondary Licenses\"" + , " means" + , "" + , " (a) that the initial Contributor has attached the notice described" + , " in Exhibit B to the Covered Software; or" + , "" + , " (b) that the Covered Software was made available under the terms of" + , " version 1.1 or earlier of the License, but not also under the" + , " terms of a Secondary License." + , "" + , "1.6. \"Executable Form\"" + , " means any form of the work other than Source Code Form." + , "" + , "1.7. \"Larger Work\"" + , " means a work that combines Covered Software with other material, in" + , " a separate file or files, that is not Covered Software." + , "" + , "1.8. \"License\"" + , " means this document." + , "" + , "1.9. \"Licensable\"" + , " means having the right to grant, to the maximum extent possible," + , " whether at the time of the initial grant or subsequently, any and" + , " all of the rights conveyed by this License." + , "" + , "1.10. \"Modifications\"" + , " means any of the following:" + , "" + , " (a) any file in Source Code Form that results from an addition to," + , " deletion from, or modification of the contents of Covered" + , " Software; or" + , "" + , " (b) any new file in Source Code Form that contains any Covered" + , " Software." + , "" + , "1.11. \"Patent Claims\" of a Contributor" + , " means any patent claim(s), including without limitation, method," + , " process, and apparatus claims, in any patent Licensable by such" + , " Contributor that would be infringed, but for the grant of the" + , " License, by the making, using, selling, offering for sale, having" + , " made, import, or transfer of either its Contributions or its" + , " Contributor Version." + , "" + , "1.12. \"Secondary License\"" + , " means either the GNU General Public License, Version 2.0, the GNU" + , " Lesser General Public License, Version 2.1, the GNU Affero General" + , " Public License, Version 3.0, or any later versions of those" + , " licenses." + , "" + , "1.13. \"Source Code Form\"" + , " means the form of the work preferred for making modifications." + , "" + , "1.14. \"You\" (or \"Your\")" + , " means an individual or a legal entity exercising rights under this" + , " License. For legal entities, \"You\" includes any entity that" + , " controls, is controlled by, or is under common control with You. For" + , " purposes of this definition, \"control\" means (a) the power, direct" + , " or indirect, to cause the direction or management of such entity," + , " whether by contract or otherwise, or (b) ownership of more than" + , " fifty percent (50%) of the outstanding shares or beneficial" + , " ownership of such entity." + , "" + , "2. License Grants and Conditions" + , "--------------------------------" + , "" + , "2.1. Grants" + , "" + , "Each Contributor hereby grants You a world-wide, royalty-free," + , "non-exclusive license:" + , "" + , "(a) under intellectual property rights (other than patent or trademark)" + , " Licensable by such Contributor to use, reproduce, make available," + , " modify, display, perform, distribute, and otherwise exploit its" + , " Contributions, either on an unmodified basis, with Modifications, or" + , " as part of a Larger Work; and" + , "" + , "(b) under Patent Claims of such Contributor to make, use, sell, offer" + , " for sale, have made, import, and otherwise transfer either its" + , " Contributions or its Contributor Version." + , "" + , "2.2. Effective Date" + , "" + , "The licenses granted in Section 2.1 with respect to any Contribution" + , "become effective for each Contribution on the date the Contributor first" + , "distributes such Contribution." + , "" + , "2.3. Limitations on Grant Scope" + , "" + , "The licenses granted in this Section 2 are the only rights granted under" + , "this License. No additional rights or licenses will be implied from the" + , "distribution or licensing of Covered Software under this License." + , "Notwithstanding Section 2.1(b) above, no patent license is granted by a" + , "Contributor:" + , "" + , "(a) for any code that a Contributor has removed from Covered Software;" + , " or" + , "" + , "(b) for infringements caused by: (i) Your and any other third party's" + , " modifications of Covered Software, or (ii) the combination of its" + , " Contributions with other software (except as part of its Contributor" + , " Version); or" + , "" + , "(c) under Patent Claims infringed by Covered Software in the absence of" + , " its Contributions." + , "" + , "This License does not grant any rights in the trademarks, service marks," + , "or logos of any Contributor (except as may be necessary to comply with" + , "the notice requirements in Section 3.4)." + , "" + , "2.4. Subsequent Licenses" + , "" + , "No Contributor makes additional grants as a result of Your choice to" + , "distribute the Covered Software under a subsequent version of this" + , "License (see Section 10.2) or under the terms of a Secondary License (if" + , "permitted under the terms of Section 3.3)." + , "" + , "2.5. Representation" + , "" + , "Each Contributor represents that the Contributor believes its" + , "Contributions are its original creation(s) or it has sufficient rights" + , "to grant the rights to its Contributions conveyed by this License." + , "" + , "2.6. Fair Use" + , "" + , "This License is not intended to limit any rights You have under" + , "applicable copyright doctrines of fair use, fair dealing, or other" + , "equivalents." + , "" + , "2.7. Conditions" + , "" + , "Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted" + , "in Section 2.1." + , "" + , "3. Responsibilities" + , "-------------------" + , "" + , "3.1. Distribution of Source Form" + , "" + , "All distribution of Covered Software in Source Code Form, including any" + , "Modifications that You create or to which You contribute, must be under" + , "the terms of this License. You must inform recipients that the Source" + , "Code Form of the Covered Software is governed by the terms of this" + , "License, and how they can obtain a copy of this License. You may not" + , "attempt to alter or restrict the recipients' rights in the Source Code" + , "Form." + , "" + , "3.2. Distribution of Executable Form" + , "" + , "If You distribute Covered Software in Executable Form then:" + , "" + , "(a) such Covered Software must also be made available in Source Code" + , " Form, as described in Section 3.1, and You must inform recipients of" + , " the Executable Form how they can obtain a copy of such Source Code" + , " Form by reasonable means in a timely manner, at a charge no more" + , " than the cost of distribution to the recipient; and" + , "" + , "(b) You may distribute such Executable Form under the terms of this" + , " License, or sublicense it under different terms, provided that the" + , " license for the Executable Form does not attempt to limit or alter" + , " the recipients' rights in the Source Code Form under this License." + , "" + , "3.3. Distribution of a Larger Work" + , "" + , "You may create and distribute a Larger Work under terms of Your choice," + , "provided that You also comply with the requirements of this License for" + , "the Covered Software. If the Larger Work is a combination of Covered" + , "Software with a work governed by one or more Secondary Licenses, and the" + , "Covered Software is not Incompatible With Secondary Licenses, this" + , "License permits You to additionally distribute such Covered Software" + , "under the terms of such Secondary License(s), so that the recipient of" + , "the Larger Work may, at their option, further distribute the Covered" + , "Software under the terms of either this License or such Secondary" + , "License(s)." + , "" + , "3.4. Notices" + , "" + , "You may not remove or alter the substance of any license notices" + , "(including copyright notices, patent notices, disclaimers of warranty," + , "or limitations of liability) contained within the Source Code Form of" + , "the Covered Software, except that You may alter any license notices to" + , "the extent required to remedy known factual inaccuracies." + , "" + , "3.5. Application of Additional Terms" + , "" + , "You may choose to offer, and to charge a fee for, warranty, support," + , "indemnity or liability obligations to one or more recipients of Covered" + , "Software. However, You may do so only on Your own behalf, and not on" + , "behalf of any Contributor. You must make it absolutely clear that any" + , "such warranty, support, indemnity, or liability obligation is offered by" + , "You alone, and You hereby agree to indemnify every Contributor for any" + , "liability incurred by such Contributor as a result of warranty, support," + , "indemnity or liability terms You offer. You may include additional" + , "disclaimers of warranty and limitations of liability specific to any" + , "jurisdiction." + , "" + , "4. Inability to Comply Due to Statute or Regulation" + , "---------------------------------------------------" + , "" + , "If it is impossible for You to comply with any of the terms of this" + , "License with respect to some or all of the Covered Software due to" + , "statute, judicial order, or regulation then You must: (a) comply with" + , "the terms of this License to the maximum extent possible; and (b)" + , "describe the limitations and the code they affect. Such description must" + , "be placed in a text file included with all distributions of the Covered" + , "Software under this License. Except to the extent prohibited by statute" + , "or regulation, such description must be sufficiently detailed for a" + , "recipient of ordinary skill to be able to understand it." + , "" + , "5. Termination" + , "--------------" + , "" + , "5.1. The rights granted under this License will terminate automatically" + , "if You fail to comply with any of its terms. However, if You become" + , "compliant, then the rights granted under this License from a particular" + , "Contributor are reinstated (a) provisionally, unless and until such" + , "Contributor explicitly and finally terminates Your grants, and (b) on an" + , "ongoing basis, if such Contributor fails to notify You of the" + , "non-compliance by some reasonable means prior to 60 days after You have" + , "come back into compliance. Moreover, Your grants from a particular" + , "Contributor are reinstated on an ongoing basis if such Contributor" + , "notifies You of the non-compliance by some reasonable means, this is the" + , "first time You have received notice of non-compliance with this License" + , "from such Contributor, and You become compliant prior to 30 days after" + , "Your receipt of the notice." + , "" + , "5.2. If You initiate litigation against any entity by asserting a patent" + , "infringement claim (excluding declaratory judgment actions," + , "counter-claims, and cross-claims) alleging that a Contributor Version" + , "directly or indirectly infringes any patent, then the rights granted to" + , "You by any and all Contributors for the Covered Software under Section" + , "2.1 of this License shall terminate." + , "" + , "5.3. In the event of termination under Sections 5.1 or 5.2 above, all" + , "end user license agreements (excluding distributors and resellers) which" + , "have been validly granted by You or Your distributors under this License" + , "prior to termination shall survive termination." + , "" + , "************************************************************************" + , "* *" + , "* 6. Disclaimer of Warranty *" + , "* ------------------------- *" + , "* *" + , "* Covered Software is provided under this License on an \"as is\" *" + , "* basis, without warranty of any kind, either expressed, implied, or *" + , "* statutory, including, without limitation, warranties that the *" + , "* Covered Software is free of defects, merchantable, fit for a *" + , "* particular purpose or non-infringing. The entire risk as to the *" + , "* quality and performance of the Covered Software is with You. *" + , "* Should any Covered Software prove defective in any respect, You *" + , "* (not any Contributor) assume the cost of any necessary servicing, *" + , "* repair, or correction. This disclaimer of warranty constitutes an *" + , "* essential part of this License. No use of any Covered Software is *" + , "* authorized under this License except under this disclaimer. *" + , "* *" + , "************************************************************************" + , "" + , "************************************************************************" + , "* *" + , "* 7. Limitation of Liability *" + , "* -------------------------- *" + , "* *" + , "* Under no circumstances and under no legal theory, whether tort *" + , "* (including negligence), contract, or otherwise, shall any *" + , "* Contributor, or anyone who distributes Covered Software as *" + , "* permitted above, be liable to You for any direct, indirect, *" + , "* special, incidental, or consequential damages of any character *" + , "* including, without limitation, damages for lost profits, loss of *" + , "* goodwill, work stoppage, computer failure or malfunction, or any *" + , "* and all other commercial damages or losses, even if such party *" + , "* shall have been informed of the possibility of such damages. This *" + , "* limitation of liability shall not apply to liability for death or *" + , "* personal injury resulting from such party's negligence to the *" + , "* extent applicable law prohibits such limitation. Some *" + , "* jurisdictions do not allow the exclusion or limitation of *" + , "* incidental or consequential damages, so this exclusion and *" + , "* limitation may not apply to You. *" + , "* *" + , "************************************************************************" + , "" + , "8. Litigation" + , "-------------" + , "" + , "Any litigation relating to this License may be brought only in the" + , "courts of a jurisdiction where the defendant maintains its principal" + , "place of business and such litigation shall be governed by laws of that" + , "jurisdiction, without reference to its conflict-of-law provisions." + , "Nothing in this Section shall prevent a party's ability to bring" + , "cross-claims or counter-claims." + , "" + , "9. Miscellaneous" + , "----------------" + , "" + , "This License represents the complete agreement concerning the subject" + , "matter hereof. If any provision of this License is held to be" + , "unenforceable, such provision shall be reformed only to the extent" + , "necessary to make it enforceable. Any law or regulation which provides" + , "that the language of a contract shall be construed against the drafter" + , "shall not be used to construe this License against a Contributor." + , "" + , "10. Versions of the License" + , "---------------------------" + , "" + , "10.1. New Versions" + , "" + , "Mozilla Foundation is the license steward. Except as provided in Section" + , "10.3, no one other than the license steward has the right to modify or" + , "publish new versions of this License. Each version will be given a" + , "distinguishing version number." + , "" + , "10.2. Effect of New Versions" + , "" + , "You may distribute the Covered Software under the terms of the version" + , "of the License under which You originally received the Covered Software," + , "or under the terms of any subsequent version published by the license" + , "steward." + , "" + , "10.3. Modified Versions" + , "" + , "If you create software not governed by this License, and you want to" + , "create a new license for such software, you may create and use a" + , "modified version of this License if you rename the license and remove" + , "any references to the name of the license steward (except to note that" + , "such modified license differs from this License)." + , "" + , "10.4. Distributing Source Code Form that is Incompatible With Secondary" + , "Licenses" + , "" + , "If You choose to distribute Source Code Form that is Incompatible With" + , "Secondary Licenses under the terms of this version of the License, the" + , "notice described in Exhibit B of this License must be attached." + , "" + , "Exhibit A - Source Code Form License Notice" + , "-------------------------------------------" + , "" + , " This Source Code Form is subject to the terms of the Mozilla Public" + , " License, v. 2.0. If a copy of the MPL was not distributed with this" + , " file, You can obtain one at http://mozilla.org/MPL/2.0/." + , "" + , "If it is not possible or desirable to put the notice in a particular" + , "file, then You may include the notice in a location (such as a LICENSE" + , "file in a relevant directory) where a recipient would be likely to look" + , "for such a notice." + , "" + , "You may add additional accurate notices of copyright ownership." + , "" + , "Exhibit B - \"Incompatible With Secondary Licenses\" Notice" + , "---------------------------------------------------------" + , "" + , " This Source Code Form is \"Incompatible With Secondary Licenses\", as" + , " defined by the Mozilla Public License, v. 2.0." + ] + +isc :: String -> String -> License +isc authors year = unlines + [ "Copyright (c) " ++ year ++ " " ++ authors + , "" + , "Permission to use, copy, modify, and/or distribute this software for any purpose" + , "with or without fee is hereby granted, provided that the above copyright notice" + , "and this permission notice appear in all copies." + , "" + , "THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH" + , "REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND" + , "FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT," + , "INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS" + , "OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER" + , "TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF" + , "THIS SOFTWARE." + ] diff --git a/src/Distribution/Client/Init/Prompt.hs b/src/Distribution/Client/Init/Prompt.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init/Prompt.hs @@ -0,0 +1,145 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Prompt +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- User prompt utility functions for use by the 'cabal init' command. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init.Prompt ( + + -- * Commands + prompt + , promptYesNo + , promptStr + , promptList + , promptListOptional + , maybePrompt + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (empty) + +import Distribution.Client.Init.Types + ( InitFlags(..) ) +import Distribution.Simple.Setup + ( Flag(..) ) + + +-- | Run a prompt or not based on the interactive flag of the +-- InitFlags structure. +maybePrompt :: InitFlags -> IO t -> IO (Maybe t) +maybePrompt flags p = + case interactive flags of + Flag True -> Just `fmap` p + _ -> return Nothing + +-- | Create a prompt with optional default value that returns a +-- String. +promptStr :: String -> Maybe String -> IO String +promptStr = promptDefault' Just id + +-- | Create a yes/no prompt with optional default value. +promptYesNo :: String -- ^ prompt message + -> Maybe Bool -- ^ optional default value + -> IO Bool +promptYesNo = + promptDefault' recogniseYesNo showYesNo + where + recogniseYesNo s | s == "y" || s == "Y" = Just True + | s == "n" || s == "N" = Just False + | otherwise = Nothing + showYesNo True = "y" + showYesNo False = "n" + +-- | Create a prompt with optional default value that returns a value +-- of some Text instance. +prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t +prompt = promptDefault' simpleParsec prettyShow + +-- | Create a prompt with an optional default value. +promptDefault' :: (String -> Maybe t) -- ^ parser + -> (t -> String) -- ^ pretty-printer + -> String -- ^ prompt message + -> Maybe t -- ^ optional default value + -> IO t +promptDefault' parser ppr pr def = do + putStr $ mkDefPrompt pr (ppr `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return d + _ -> case parser inp of + Just t -> return t + Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" + promptDefault' parser ppr pr def + +-- | Create a prompt from a prompt string and a String representation +-- of an optional default value. +mkDefPrompt :: String -> Maybe String -> String +mkDefPrompt pr def = pr ++ "?" ++ defStr def + where defStr Nothing = " " + defStr (Just s) = " [default: " ++ s ++ "] " + +-- | Create a prompt from a list of items, where no selected items is +-- valid and will be represented as a return value of 'Nothing'. +promptListOptional :: (Pretty t, Eq t) + => String -- ^ prompt + -> [t] -- ^ choices + -> IO (Maybe (Either String t)) +promptListOptional pr choices = promptListOptional' pr choices prettyShow + +promptListOptional' :: Eq t + => String -- ^ prompt + -> [t] -- ^ choices + -> (t -> String) -- ^ show an item + -> IO (Maybe (Either String t)) +promptListOptional' pr choices displayItem = + fmap rearrange + $ promptList pr (Nothing : map Just choices) (Just Nothing) + (maybe "(none)" displayItem) True + where + rearrange = either (Just . Left) (fmap Right) + +-- | Create a prompt from a list of items. +promptList :: Eq t + => String -- ^ prompt + -> [t] -- ^ choices + -> Maybe t -- ^ optional default value + -> (t -> String) -- ^ show an item + -> Bool -- ^ whether to allow an 'other' option + -> IO (Either String t) +promptList pr choices def displayItem other = do + putStrLn $ pr ++ ":" + let options1 = map (\c -> (Just c == def, displayItem c)) choices + options2 = zip ([1..]::[Int]) + (options1 ++ [(False, "Other (specify)") | other]) + traverse_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 + promptList' displayItem (length options2) choices def other + where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest + | otherwise = " " ++ star i ++ rest + where rest = show n ++ ") " + star True = "*" + star False = " " + +promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t) +promptList' displayItem numChoices choices def other = do + putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return $ Right d + _ -> case readMaybe inp of + Nothing -> invalidChoice inp + Just n -> getChoice n + where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." + promptList' displayItem numChoices choices def other + getChoice n | n < 1 || n > numChoices = invalidChoice (show n) + | n < numChoices || + (n == numChoices && not other) + = return . Right $ choices !! (n-1) + | otherwise = Left `fmap` promptStr "Please specify" Nothing diff --git a/src/Distribution/Client/Init/Types.hs b/src/Distribution/Client/Init/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init/Types.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Types +-- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Some types used by the 'cabal init' command. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Types where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Simple.Setup (Flag(..), toFlag ) + +import Distribution.Types.Dependency as P +import Distribution.Version +import Distribution.Verbosity +import qualified Distribution.Package as P +import Distribution.SPDX.License (License) +import Distribution.ModuleName +import Distribution.CabalSpecVersion +import Language.Haskell.Extension ( Language(..), Extension ) + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.CharParsing as P +import qualified Data.Map as Map + +-- | InitFlags is really just a simple type to represent certain +-- portions of a .cabal file. Rather than have a flag for EVERY +-- possible field, we just have one for each field that the user is +-- likely to want and/or that we are likely to be able to +-- intelligently guess. +data InitFlags = + InitFlags { interactive :: Flag Bool + , quiet :: Flag Bool + , packageDir :: Flag FilePath + , noComments :: Flag Bool + , minimal :: Flag Bool + , simpleProject :: Flag Bool + + , packageName :: Flag P.PackageName + , version :: Flag Version + , cabalVersion :: Flag CabalSpecVersion + , license :: Flag License + , author :: Flag String + , email :: Flag String + , homepage :: Flag String + + , synopsis :: Flag String + , category :: Flag (Either String Category) + , extraSrc :: Maybe [String] + + , packageType :: Flag PackageType + , mainIs :: Flag FilePath + , language :: Flag Language + + , exposedModules :: Maybe [ModuleName] + , otherModules :: Maybe [ModuleName] + , otherExts :: Maybe [Extension] + + , dependencies :: Maybe [P.Dependency] + , applicationDirs :: Maybe [String] + , sourceDirs :: Maybe [String] + , buildTools :: Maybe [String] + + , initializeTestSuite :: Flag Bool + , testDirs :: Maybe [String] + + , initHcPath :: Flag FilePath + + , initVerbosity :: Flag Verbosity + , overwrite :: Flag Bool + } + deriving (Eq, Show, Generic) + + -- the Monoid instance for Flag has later values override earlier + -- ones, which is why we want Maybe [foo] for collecting foo values, + -- not Flag [foo]. + +data BuildType = LibBuild | ExecBuild + deriving Eq + +-- The type of package to initialize. +data PackageType = Library | Executable | LibraryAndExecutable + deriving (Show, Read, Eq) + +displayPackageType :: PackageType -> String +displayPackageType LibraryAndExecutable = "Library and Executable" +displayPackageType pkgtype = show pkgtype + +instance Monoid InitFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InitFlags where + (<>) = gmappend + +defaultInitFlags :: InitFlags +defaultInitFlags = mempty + { initVerbosity = toFlag normal + } + +-- | Some common package categories (non-exhaustive list). +data Category + = Codec + | Concurrency + | Control + | Data + | Database + | Development + | Distribution + | Game + | Graphics + | Language + | Math + | Network + | Sound + | System + | Testing + | Text + | Web + deriving (Read, Show, Eq, Ord, Bounded, Enum) + +instance Pretty Category where + pretty = Disp.text . show + +instance Parsec Category where + parsec = do + name <- P.munch1 isAlpha + case Map.lookup name names of + Just cat -> pure cat + _ -> P.unexpected $ "Category: " ++ name + where + names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ] diff --git a/src/Distribution/Client/Init/Utils.hs b/src/Distribution/Client/Init/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Init/Utils.hs @@ -0,0 +1,38 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Utils +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Shared utilities used by multiple cabal init modules. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init.Utils ( + eligibleForTestSuite + , message + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Simple.Setup + ( Flag(..) ) +import Distribution.Client.Init.Types + ( InitFlags(..), PackageType(..) ) + +-- | Returns true if this package is eligible for test suite initialization. +eligibleForTestSuite :: InitFlags -> Bool +eligibleForTestSuite flags = + Flag True == initializeTestSuite flags + && Flag Executable /= packageType flags + +-- | Possibly generate a message to stdout, taking into account the +-- --quiet flag. +message :: InitFlags -> String -> IO () +message (InitFlags{quiet = Flag True}) _ = return () +message _ s = putStrLn s diff --git a/src/Distribution/Client/Install.hs b/src/Distribution/Client/Install.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Install.hs @@ -0,0 +1,1584 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Install +-- Copyright : (c) 2005 David Himmelstrup +-- 2007 Bjorn Bringert +-- 2007-2010 Duncan Coutts +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- High level interface to package installation. +----------------------------------------------------------------------------- +module Distribution.Client.Install ( + -- * High-level interface + install, + + -- * Lower-level interface that allows to manipulate the install plan + makeInstallContext, + makeInstallPlan, + processInstallPlan, + InstallArgs, + InstallContext, + + -- * Prune certain packages from the install plan + pruneInstallPlan + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic(safeLast) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Control.Exception as Exception + ( bracket, catches, Handler(Handler), handleJust ) +import System.Directory + ( getTemporaryDirectory, doesDirectoryExist, doesFileExist, + createDirectoryIfMissing, removeFile, renameDirectory, + getDirectoryContents ) +import System.FilePath + ( (), (<.>), equalFilePath, takeDirectory ) +import System.IO + ( openFile, IOMode(AppendMode), hClose ) +import System.IO.Error + ( isDoesNotExistError, ioeGetFileName ) + +import Distribution.Client.Targets +import Distribution.Client.Configure + ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types + ( Solver(..) ) +import Distribution.Client.FetchUtils +import Distribution.Client.HttpUtils + ( HttpTransport (..) ) +import Distribution.Solver.Types.PackageFixedDeps +import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackagesAtIndexState, getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import Distribution.Client.Setup + ( GlobalFlags(..), RepoContext(..) + , ConfigFlags(..), configureCommand, filterConfigureFlags + , ConfigExFlags(..), InstallFlags(..) + , filterTestFlags ) +import Distribution.Client.Config + ( getCabalDir, defaultUserInstall ) +import Distribution.Client.Tar (extractTarGzFile) +import Distribution.Client.Types as Source +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.BuildReports.Anonymous (showBuildReport) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReports +import qualified Distribution.Client.BuildReports.Storage as BuildReports + ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) +import qualified Distribution.Client.InstallSymlink as InstallSymlink + ( symlinkBinaries ) +import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import qualified Distribution.Client.World as World +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Client.JobControl + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb, readPkgConfigDb ) +import Distribution.Solver.Types.SourcePackage as SourcePackage + +import Distribution.Utils.NubList +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId), compilerFlavor + , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramDb) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Setup + ( haddockCommand, HaddockFlags(..) + , buildCommand, BuildFlags(..), emptyBuildFlags + , TestFlags, BenchmarkFlags + , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) +import qualified Distribution.Simple.Setup as Cabal + ( Flag(..) + , copyCommand, CopyFlags(..), emptyCopyFlags + , registerCommand, RegisterFlags(..), emptyRegisterFlags + , testCommand, TestFlags(..) ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, writeFileAtomic ) +import Distribution.Simple.InstallDirs as InstallDirs + ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate + , initialPathTemplateEnv, installDirsTemplateEnv ) +import Distribution.Simple.Configure (interpretPackageDbFlags) +import Distribution.Simple.Register (registerPackage, defaultRegisterOptions) +import Distribution.Package + ( PackageIdentifier(..), PackageId, packageName, packageVersion + , Package(..), HasMungedPackageId(..), HasUnitId(..) + , UnitId ) +import Distribution.Types.Dependency + ( Dependency (..), mainLibSet ) +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..), thisPackageVersionConstraint ) +import Distribution.Types.MungedPackageId +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription, GenericPackageDescription(..) ) +import Distribution.Types.Flag + ( PackageFlag(..), FlagAssignment, mkFlagAssignment + , showFlagAssignment, diffFlagAssignment, nullFlagAssignment ) +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Version + ( Version, VersionRange, foldVersionRange ) +import Distribution.Simple.Utils as Utils + ( notice, info, warn, debug, debugNoWrap, die' + , withTempDirectory ) +import Distribution.Client.Utils + ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) + , ProgressPhase(..), progressMessage ) +import Distribution.System + ( Platform, OS(Windows), buildOS, buildPlatform ) +import Distribution.Verbosity as Verbosity + ( modifyVerbosity, normal, verbose ) +import Distribution.Simple.BuildPaths ( exeExtension ) + +import qualified Data.ByteString as BS + +--TODO: +-- * assign flags to packages individually +-- * complain about flags that do not apply to any package given as target +-- so flags do not apply to dependencies, only listed, can use flag +-- constraints for dependencies +-- * only record applicable flags in world file +-- * allow flag constraints +-- * allow installed constraints +-- * allow flag and installed preferences +-- * change world file to use cabal section syntax +-- * allow persistent configure flags for each package individually + +-- ------------------------------------------------------------ +-- * Top level user actions +-- ------------------------------------------------------------ + +-- | Installs the packages needed to satisfy a list of dependencies. +-- +install + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> HaddockFlags + -> TestFlags + -> BenchmarkFlags + -> [UserTarget] + -> IO () +install verbosity packageDBs repos comp platform progdb + globalFlags configFlags configExFlags installFlags + haddockFlags testFlags benchmarkFlags userTargets0 = do + + unless (installRootCmd installFlags == Cabal.NoFlag) $ + warn verbosity $ "--root-cmd is no longer supported, " + ++ "see https://github.com/haskell/cabal/issues/3353" + ++ " (if you didn't type --root-cmd, comment out root-cmd" + ++ " in your ~/.cabal/config file)" + let userOrSandbox = fromFlag (configUserInstall configFlags) + unless userOrSandbox $ + warn verbosity $ "the --global flag is deprecated -- " + ++ "it is generally considered a bad idea to install packages " + ++ "into the global store" + + installContext <- makeInstallContext verbosity args (Just userTargets0) + planResult <- foldProgress logMsg (return . Left) (return . Right) =<< + makeInstallPlan verbosity args installContext + + case planResult of + Left message -> do + reportPlanningFailure verbosity args installContext message + die'' message + Right installPlan -> + processInstallPlan verbosity args installContext installPlan + where + args :: InstallArgs + args = (packageDBs, repos, comp, platform, progdb, + globalFlags, configFlags, configExFlags, + installFlags, haddockFlags, testFlags, benchmarkFlags) + + die'' = die' verbosity + + logMsg message rest = debugNoWrap verbosity message >> rest + +-- TODO: Make InstallContext a proper data type with documented fields. +-- | Common context for makeInstallPlan and processInstallPlan. +type InstallContext = ( InstalledPackageIndex, SourcePackageDb + , PkgConfigDb + , [UserTarget], [PackageSpecifier UnresolvedSourcePackage] + , HttpTransport ) + +-- TODO: Make InstallArgs a proper data type with documented fields or just get +-- rid of it completely. +-- | Initial arguments given to 'install' or 'makeInstallContext'. +type InstallArgs = ( PackageDBStack + , RepoContext + , Compiler + , Platform + , ProgramDb + , GlobalFlags + , ConfigFlags + , ConfigExFlags + , InstallFlags + , HaddockFlags + , TestFlags + , BenchmarkFlags ) + +-- | Make an install context given install arguments. +makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] + -> IO InstallContext +makeInstallContext verbosity + (packageDBs, repoCtxt, comp, _, progdb, + globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do + + let idxState = flagToMaybe (installIndexState installFlags) + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing + pkgConfigDb <- readPkgConfigDb verbosity progdb + + checkConfigExFlags verbosity installedPkgIndex + (packageIndex sourcePkgDb) configExFlags + transport <- repoContextGetTransport repoCtxt + + (userTargets, pkgSpecifiers) <- case mUserTargets of + Nothing -> + -- We want to distinguish between the case where the user has given an + -- empty list of targets on the command-line and the case where we + -- specifically want to have an empty list of targets. + return ([], []) + Just userTargets0 -> do + -- For install, if no target is given it means we use the current + -- directory as the single target. + let userTargets | null userTargets0 = [UserTargetLocalDir "."] + | otherwise = userTargets0 + + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + userTargets + return (userTargets, pkgSpecifiers) + + return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets + ,pkgSpecifiers, transport) + +-- | Make an install plan given install context and install arguments. +makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext + -> IO (Progress String String SolverInstallPlan) +makeInstallPlan verbosity + (_, _, comp, platform,_, + _, configFlags, configExFlags, installFlags, + _, _, _) + (installedPkgIndex, sourcePkgDb, pkgConfigDb, + _, pkgSpecifiers, _) = do + + solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) + (compilerInfo comp) + notice verbosity "Resolving dependencies..." + return $ planPackages verbosity comp platform solver + configFlags configExFlags installFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + +-- | Given an install plan, perform the actual installations. +processInstallPlan :: Verbosity -> InstallArgs -> InstallContext + -> SolverInstallPlan + -> IO () +processInstallPlan verbosity + args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _) + (installedPkgIndex, sourcePkgDb, _, + userTargets, pkgSpecifiers, _) installPlan0 = do + + checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb + installFlags pkgSpecifiers + + unless (dryRun || nothingToInstall) $ do + buildOutcomes <- performInstallations verbosity + args installedPkgIndex installPlan + postInstallActions verbosity args userTargets installPlan buildOutcomes + where + installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 + dryRun = fromFlag (installDryRun installFlags) + nothingToInstall = null (fst (InstallPlan.ready installPlan)) + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +planPackages :: Verbosity + -> Compiler + -> Platform + -> Solver + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> Progress String String SolverInstallPlan +planPackages verbosity comp platform solver + configFlags configExFlags installFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = + + resolveDependencies + platform (compilerInfo comp) pkgConfigDb + solver + resolverParams + + >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return + + where + resolverParams = + + setMaxBackjumps (if maxBackjumps < 0 then Nothing + else Just maxBackjumps) + + . setIndependentGoals independentGoals + + . setReorderGoals reorderGoals + + . setCountConflicts countConflicts + + . setFineGrainedConflicts fineGrainedConflicts + + . setMinimizeConflictSet minimizeConflictSet + + . setAvoidReinstalls avoidReinstalls + + . setShadowPkgs shadowPkgs + + . setStrongFlags strongFlags + + . setAllowBootLibInstalls allowBootLibInstalls + + . setOnlyConstrained onlyConstrained + + . setSolverVerbosity verbosity + + . setPreferenceDefault (if upgradeDeps then PreferAllLatest + else PreferLatestForSelected) + + . removeLowerBounds allowOlder + . removeUpperBounds allowNewer + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- configPreferences configExFlags ] + + . addConstraints + -- version constraints from the config file or command line + [ LabeledPackageConstraint (userToPackageConstraint pc) src + | (pc, src) <- configExConstraints configExFlags ] + + . addConstraints + --FIXME: this just applies all flags to all targets which + -- is silly. We should check if the flags are appropriate + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyFlags flags) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | let flags = configConfigurationsFlags configFlags + , not (nullFlagAssignment flags) + , pkgSpecifier <- pkgSpecifiers ] + + . addConstraints + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | pkgSpecifier <- pkgSpecifiers ] + + . (if reinstall then reinstallTargets else id) + + -- Don't solve for executables, the legacy install codepath + -- doesn't understand how to install them + . setSolveExecutables (SolveExecutables False) + + $ standardInstallPolicy + installedPkgIndex sourcePkgDb pkgSpecifiers + + stanzas = [ TestStanzas | testsEnabled ] + ++ [ BenchStanzas | benchmarksEnabled ] + testsEnabled = fromFlagOrDefault False $ configTests configFlags + benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags + + reinstall = fromFlag (installOverrideReinstall installFlags) || + fromFlag (installReinstall installFlags) + reorderGoals = fromFlag (installReorderGoals installFlags) + countConflicts = fromFlag (installCountConflicts installFlags) + fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) + minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) + independentGoals = fromFlag (installIndependentGoals installFlags) + avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) + shadowPkgs = fromFlag (installShadowPkgs installFlags) + strongFlags = fromFlag (installStrongFlags installFlags) + maxBackjumps = fromFlag (installMaxBackjumps installFlags) + allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) + onlyConstrained = fromFlag (installOnlyConstrained installFlags) + upgradeDeps = fromFlag (installUpgradeDeps installFlags) + onlyDeps = fromFlag (installOnlyDeps installFlags) + + allowOlder = fromMaybe (AllowOlder mempty) + (configAllowOlder configExFlags) + allowNewer = fromMaybe (AllowNewer mempty) + (configAllowNewer configExFlags) + +-- | Remove the provided targets from the install plan. +pruneInstallPlan :: Package targetpkg + => [PackageSpecifier targetpkg] + -> SolverInstallPlan + -> Progress String String SolverInstallPlan +pruneInstallPlan pkgSpecifiers = + -- TODO: this is a general feature and should be moved to D.C.Dependency + -- Also, the InstallPlan.remove should return info more precise to the + -- problem, rather than the very general PlanProblem type. + either (Fail . explain) Done + . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) + where + explain :: [SolverInstallPlan.SolverPlanProblem] -> String + explain problems = + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ (case pkgids of + [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " + _ -> "the packages " + ++ intercalate ", " (map prettyShow pkgids) ++ " are ") + ++ "required by a dependency of one of the other targets." + where + pkgids = + nub [ depid + | SolverInstallPlan.PackageMissingDeps _ depids <- problems + , depid <- depids + , packageName depid `elem` targetnames ] + + targetnames = map pkgSpecifierTarget pkgSpecifiers + +-- ------------------------------------------------------------ +-- * Informational messages +-- ------------------------------------------------------------ + +-- | Perform post-solver checks of the install plan and print it if +-- either requested or needed. +checkPrintPlan :: Verbosity + -> InstalledPackageIndex + -> InstallPlan + -> SourcePackageDb + -> InstallFlags + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO () +checkPrintPlan verbosity installed installPlan sourcePkgDb + installFlags pkgSpecifiers = do + + -- User targets that are already installed. + let preExistingTargets = + [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, + InstallPlan.PreExisting p <- InstallPlan.toList installPlan, + packageName p `elem` tgts ] + + -- If there's nothing to install, we print the already existing + -- target packages as an explanation. + when nothingToInstall $ + notice verbosity $ unlines $ + "All the requested packages are already installed:" + : map (prettyShow . packageId) preExistingTargets + ++ ["Use --reinstall if you want to reinstall anyway."] + + let lPlan = + [ (pkg, status) + | pkg <- InstallPlan.executionOrder installPlan + , let status = packageStatus installed pkg ] + -- Are any packages classified as reinstalls? + let reinstalledPkgs = + [ ipkg + | (_pkg, status) <- lPlan + , ipkg <- extractReinstalls status ] + -- Packages that are already broken. + let oldBrokenPkgs = + map Installed.installedUnitId + . PackageIndex.reverseDependencyClosure installed + . map (Installed.installedUnitId . fst) + . PackageIndex.brokenPackages + $ installed + let excluded = reinstalledPkgs ++ oldBrokenPkgs + -- Packages that are reverse dependencies of replaced packages are very + -- likely to be broken. We exclude packages that are already broken. + let newBrokenPkgs = + filter (\ p -> not (Installed.installedUnitId p `elem` excluded)) + (PackageIndex.reverseDependencyClosure installed reinstalledPkgs) + let containsReinstalls = not (null reinstalledPkgs) + let breaksPkgs = not (null newBrokenPkgs) + + let adaptedVerbosity + | containsReinstalls + , not overrideReinstall = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + -- We print the install plan if we are in a dry-run or if we are confronted + -- with a dangerous install plan. + when (dryRun || containsReinstalls && not overrideReinstall) $ + printPlan (dryRun || breaksPkgs && not overrideReinstall) + adaptedVerbosity lPlan sourcePkgDb + + -- If the install plan is dangerous, we print various warning messages. In + -- particular, if we can see that packages are likely to be broken, we even + -- bail out (unless installation has been forced with --force-reinstalls). + when containsReinstalls $ do + if breaksPkgs + then do + (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ + "The following packages are likely to be broken by the reinstalls:" + : map (prettyShow . mungedId) newBrokenPkgs + ++ if overrideReinstall + then if dryRun then [] else + ["Continuing even though " ++ + "the plan contains dangerous reinstalls."] + else + ["Use --force-reinstalls if you want to install anyway."] + else unless dryRun $ warn verbosity + "Note that reinstalls are always dangerous. Continuing anyway..." + + -- If we are explicitly told to not download anything, check that all packages + -- are already fetched. + let offline = fromFlagOrDefault False (installOfflineMode installFlags) + when offline $ do + let pkgs = [ confPkgSource cpkg + | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ] + notFetched <- fmap (map packageId) + . filterM (fmap isNothing . checkFetched . srcpkgSource) + $ pkgs + unless (null notFetched) $ + die' verbosity $ "Can't download packages in offline mode. " + ++ "Must download the following packages to proceed:\n" + ++ intercalate ", " (map prettyShow notFetched) + ++ "\nTry using 'cabal fetch'." + + where + nothingToInstall = null (fst (InstallPlan.ready installPlan)) + + dryRun = fromFlag (installDryRun installFlags) + overrideReinstall = fromFlag (installOverrideReinstall installFlags) + +data PackageStatus = NewPackage + | NewVersion [Version] + | Reinstall [UnitId] [PackageChange] + +type PackageChange = MergeResult MungedPackageId MungedPackageId + +extractReinstalls :: PackageStatus -> [UnitId] +extractReinstalls (Reinstall ipids _) = ipids +extractReinstalls _ = [] + +packageStatus :: InstalledPackageIndex + -> ReadyPackage + -> PackageStatus +packageStatus installedPkgIndex cpkg = + case PackageIndex.lookupPackageName installedPkgIndex + (packageName cpkg) of + [] -> NewPackage + ps -> case filter ((== mungedId cpkg) + . mungedId) (concatMap snd ps) of + [] -> NewVersion (map fst ps) + pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs) + (changes pkg cpkg) + + where + + changes :: Installed.InstalledPackageInfo + -> ReadyPackage + -> [PackageChange] + changes pkg (ReadyPackage pkg') = filter changed $ + mergeBy (comparing mungedName) + -- deps of installed pkg + (resolveInstalledIds $ Installed.depends pkg) + -- deps of configured pkg + (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) + + -- convert to source pkg ids via index + resolveInstalledIds :: [UnitId] -> [MungedPackageId] + resolveInstalledIds = + nub + . sort + . map mungedId + . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex) + + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +printPlan :: Bool -- is dry run + -> Verbosity + -> [(ReadyPackage, PackageStatus)] + -> SourcePackageDb + -> IO () +printPlan dryRun verbosity plan sourcePkgDb = case plan of + [] -> return () + pkgs + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ + ("In order, the following " ++ wouldWill ++ " be installed:") + : map showPkgAndReason pkgs + | otherwise -> notice verbosity $ unlines $ + ("In order, the following " ++ wouldWill + ++ " be installed (use -v for more details):") + : map showPkg pkgs + where + wouldWill | dryRun = "would" + | otherwise = "will" + + showPkg (pkg, _) = prettyShow (packageId pkg) ++ + showLatest (pkg) + + showPkgAndReason (ReadyPackage pkg', pr) = unwords + [ prettyShow (packageId pkg') + , showLatest pkg' + , showFlagAssignment (nonDefaultFlags pkg') + , showStanzas (confPkgStanzas pkg') + , showDep pkg' + , case pr of + NewPackage -> "(new package)" + NewVersion _ -> "(new version)" + Reinstall _ cs -> "(reinstall)" ++ case cs of + [] -> "" + diff -> "(changes: " ++ intercalate ", " (map change diff) + ++ ")" + ] + + showLatest :: Package srcpkg => srcpkg -> String + showLatest pkg = case mLatestVersion of + Just latestVersion -> + if packageVersion pkg < latestVersion + then ("(latest: " ++ prettyShow latestVersion ++ ")") + else "" + Nothing -> "" + where + mLatestVersion :: Maybe Version + mLatestVersion = fmap packageVersion $ + safeLast $ + SourcePackageIndex.lookupPackageName + (packageIndex sourcePkgDb) + (packageName pkg) + + toFlagAssignment :: [PackageFlag] -> FlagAssignment + toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) + + nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment + nonDefaultFlags cpkg = + let defaultAssignment = + toFlagAssignment + (genPackageFlags (SourcePackage.srcpkgDescription $ + confPkgSource cpkg)) + in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment + + change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed" + change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> " + ++ prettyShow (mungedVersion pkgid') + change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added" + + showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps + = " (via: " ++ unwords (map prettyShow rdeps) ++ ")" + | otherwise = "" + + revDepGraphEdges :: [(PackageId, PackageId)] + revDepGraphEdges = [ (rpid, packageId cpkg) + | (ReadyPackage cpkg, _) <- plan + , ConfiguredId + rpid + (Just + (PackageDescription.CLibName + PackageDescription.LMainLibName)) + _ + <- CD.flatDeps (confPkgDeps cpkg) ] + + revDeps :: Map.Map PackageId [PackageId] + revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges) + +-- ------------------------------------------------------------ +-- * Post installation stuff +-- ------------------------------------------------------------ + +-- | Report a solver failure. This works slightly differently to +-- 'postInstallActions', as (by definition) we don't have an install plan. +reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String + -> IO () +reportPlanningFailure verbosity + (_, _, comp, platform, _ + ,_, configFlags, _, installFlags, _, _, _) + (_, sourcePkgDb, _, _, pkgSpecifiers, _) + message = do + + when reportFailure $ do + + -- Only create reports for explicitly named packages + let pkgids = filter + (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $ + mapMaybe theSpecifiedPackage pkgSpecifiers + + buildReports = BuildReports.fromPlanningFailure platform + (compilerId comp) pkgids + (configConfigurationsFlags configFlags) + + unless (null buildReports) $ + info verbosity $ + "Solver failure will be reported for " + ++ intercalate "," (map prettyShow pkgids) + + -- Save reports + BuildReports.storeLocal (compilerInfo comp) + (fromNubList $ installSummaryFile installFlags) + buildReports platform + + -- Save solver log + case logFile of + Nothing -> return () + Just template -> for_ pkgids $ \pkgid -> + let env = initialPathTemplateEnv pkgid dummyIpid + (compilerInfo comp) platform + path = fromPathTemplate $ substPathTemplate env template + in writeFile path message + + where + reportFailure = fromFlag (installReportPlanningFailure installFlags) + logFile = flagToMaybe (installLogFile installFlags) + + -- A IPID is calculated from the transitive closure of + -- dependencies, but when the solver fails we don't have that. + -- So we fail. + dummyIpid = error "reportPlanningFailure: installed package ID not available" + +-- | If a 'PackageSpecifier' refers to a single package, return Just that +-- package. +theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId +theSpecifiedPackage pkgSpec = + case pkgSpec of + NamedPackage name [PackagePropertyVersion version] + -> PackageIdentifier name <$> trivialRange version + NamedPackage _ _ -> Nothing + SpecificSourcePackage pkg -> Just $ packageId pkg + where + -- | If a range includes only a single version, return Just that version. + trivialRange :: VersionRange -> Maybe Version + trivialRange = foldVersionRange + Nothing + Just -- "== v" + (\_ -> Nothing) + (\_ -> Nothing) + (\_ _ -> Nothing) + (\_ _ -> Nothing) + +-- | Various stuff we do after successful or unsuccessfully installing a bunch +-- of packages. This includes: +-- +-- * build reporting, local and remote +-- * symlinking binaries +-- * updating indexes +-- * updating world file +-- * error reporting +-- +postInstallActions :: Verbosity + -> InstallArgs + -> [UserTarget] + -> InstallPlan + -> BuildOutcomes + -> IO () +postInstallActions verbosity + (packageDBs, _, comp, platform, progdb + ,globalFlags, configFlags, _, installFlags, _, _, _) + targets installPlan buildOutcomes = do + + unless oneShot $ + World.insert verbosity worldFile + --FIXME: does not handle flags + [ World.WorldPkgInfo (Dependency pn vr mainLibSet) mempty + | UserTargetNamed (PackageVersionConstraint pn vr) <- targets ] + + let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) + installPlan buildOutcomes + BuildReports.storeLocal (compilerInfo comp) + (fromNubList $ installSummaryFile installFlags) + buildReports + platform + when (reportingLevel >= AnonymousReports) $ + BuildReports.storeAnonymous buildReports + when (reportingLevel == DetailedReports) $ + storeDetailedBuildReports verbosity logsDir buildReports + + regenerateHaddockIndex verbosity packageDBs comp platform progdb + configFlags installFlags buildOutcomes + + symlinkBinaries verbosity platform comp configFlags installFlags + installPlan buildOutcomes + + printBuildFailures verbosity buildOutcomes + + where + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + oneShot = fromFlag (installOneShot installFlags) + worldFile = fromFlag $ globalWorldFile globalFlags + +storeDetailedBuildReports :: Verbosity -> FilePath + -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () +storeDetailedBuildReports verbosity logsDir reports = sequence_ + [ do dotCabal <- getCabalDir + let logFileName = prettyShow (BuildReports.package report) <.> "log" + logFile = logsDir logFileName + reportsDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) + reportFile = reportsDir logFileName + + handleMissingLogFile $ do + buildLog <- readFile logFile + createDirectoryIfMissing True reportsDir -- FIXME + writeFile reportFile (show (showBuildReport report, buildLog)) + + | (report, Just repo) <- reports + , Just remoteRepo <- [maybeRepoRemote repo] + , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] + + where + isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True + isLikelyToHaveLogFile BuildReports.BuildFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallOk {} = True + isLikelyToHaveLogFile _ = False + + handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> + warn verbosity $ "Missing log file for build report: " + ++ fromMaybe "" (ioeGetFileName ioe) + + missingFile ioe + | isDoesNotExistError ioe = Just ioe + missingFile _ = Nothing + + +regenerateHaddockIndex :: Verbosity + -> [PackageDB] + -> Compiler + -> Platform + -> ProgramDb + -> ConfigFlags + -> InstallFlags + -> BuildOutcomes + -> IO () +regenerateHaddockIndex verbosity packageDBs comp platform progdb + configFlags installFlags buildOutcomes + | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do + + defaultDirs <- InstallDirs.defaultInstallDirs + (compilerFlavor comp) + (fromFlag (configUserInstall configFlags)) + True + let indexFileTemplate = fromFlag (installHaddockIndex installFlags) + indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate + + notice verbosity $ + "Updating documentation index " ++ indexFile + + --TODO: might be nice if the install plan gave us the new InstalledPackageInfo + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile + + | otherwise = return () + where + haddockIndexFileIsRequested = + fromFlag (installDocumentation installFlags) + && isJust (flagToMaybe (installHaddockIndex installFlags)) + + -- We want to regenerate the index if some new documentation was actually + -- installed. Since the index can be only per-user or per-sandbox (see + -- #1337), we don't do it for global installs or special cases where we're + -- installing into a specific db. + shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes + where + someDocsWereInstalled = any installedDocs . Map.elems + installedDocs (Right (BuildResult DocsOk _ _)) = True + installedDocs _ = False + + normalUserInstall = (UserPackageDB `elem` packageDBs) + && all (not . isSpecificPackageDB) packageDBs + isSpecificPackageDB (SpecificPackageDB _) = True + isSpecificPackageDB _ = False + + substHaddockIndexFileName defaultDirs = fromPathTemplate + . substPathTemplate env + where + env = env0 ++ installDirsTemplateEnv absoluteDirs + env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp) + ++ InstallDirs.platformTemplateEnv platform + ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform + absoluteDirs = InstallDirs.substituteInstallDirTemplates + env0 templateDirs + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + + +symlinkBinaries :: Verbosity + -> Platform -> Compiler + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> BuildOutcomes + -> IO () +symlinkBinaries verbosity platform comp configFlags installFlags + plan buildOutcomes = do + failed <- InstallSymlink.symlinkBinaries platform comp + NeverOverwrite + configFlags installFlags + plan buildOutcomes + case failed of + [] -> return () + [(_, exe, path)] -> + warn verbosity $ + "could not create a symlink in " ++ bindir ++ " for " + ++ prettyShow exe ++ " because the file exists there already but is not " + ++ "managed by cabal. You can create a symlink for this executable " + ++ "manually if you wish. The executable file has been installed at " + ++ path + exes -> + warn verbosity $ + "could not create symlinks in " ++ bindir ++ " for " + ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ] + ++ " because the files exist there already and are not " + ++ "managed by cabal. You can create symlinks for these executables " + ++ "manually if you wish. The executable files have been installed at " + ++ intercalate ", " [ path | (_, _, path) <- exes ] + where + bindir = fromFlag (installSymlinkBinDir installFlags) + + +printBuildFailures :: Verbosity -> BuildOutcomes -> IO () +printBuildFailures verbosity buildOutcomes = + case [ (pkgid, failure) + | (pkgid, Left failure) <- Map.toList buildOutcomes ] of + [] -> return () + failed -> die' verbosity . unlines + $ "Error: some packages failed to install:" + : [ prettyShow pkgid ++ printFailureReason reason + | (pkgid, reason) <- failed ] + where + printFailureReason reason = case reason of + DependentFailed pkgid -> " depends on " ++ prettyShow pkgid + ++ " which failed to install." + DownloadFailed e -> " failed while downloading the package." + ++ showException e + UnpackFailed e -> " failed while unpacking the package." + ++ showException e + ConfigureFailed e -> " failed during the configure step." + ++ showException e + BuildFailed e -> " failed during the building phase." + ++ showException e + TestsFailed e -> " failed during the tests phase." + ++ showException e + InstallFailed e -> " failed during the final install step." + ++ showException e + + -- This will never happen, but we include it for completeness + PlanningFailed -> " failed during the planning phase." + + showException e = " The exception was:\n " ++ show e ++ maybeOOM e +#ifdef mingw32_HOST_OS + maybeOOM _ = "" +#else + maybeOOM e = maybe "" onExitFailure (fromException e) + onExitFailure (ExitFailure n) + | n == 9 || n == -9 = + "\nThis may be due to an out-of-memory condition." + onExitFailure _ = "" +#endif + +-- ------------------------------------------------------------ +-- * Actually do the installations +-- ------------------------------------------------------------ + +data InstallMisc = InstallMisc { + libVersion :: Maybe Version + } + +-- | If logging is enabled, contains location of the log file and the verbosity +-- level for logging. +type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity) + +performInstallations :: Verbosity + -> InstallArgs + -> InstalledPackageIndex + -> InstallPlan + -> IO BuildOutcomes +performInstallations verbosity + (packageDBs, repoCtxt, comp, platform, progdb, + globalFlags, configFlags, configExFlags, installFlags, + haddockFlags, testFlags, _) + installedPkgIndex installPlan = do + + info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." + + jobControl <- if parallelInstall then newParallelJobControl numJobs + else newSerialJobControl + fetchLimit <- newJobLimit (min numJobs numFetchJobs) + installLock <- newLock -- serialise installation + cacheLock <- newLock -- serialise access to setup exe cache + + executeInstallPlan verbosity jobControl keepGoing useLogFile + installPlan $ \rpkg -> + installReadyPackage platform cinfo configFlags + rpkg $ \configFlags' src pkg pkgoverride -> + fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' -> + installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath -> + installUnpackedPackage verbosity installLock numJobs + (setupScriptOptions installedPkgIndex + cacheLock rpkg) + configFlags' + installFlags haddockFlags testFlags + comp progdb + platform pkg rpkg pkgoverride mpath useLogFile + + where + cinfo = compilerInfo comp + + numJobs = determineNumJobs (installNumJobs installFlags) + numFetchJobs = 2 + parallelInstall = numJobs >= 2 + keepGoing = fromFlag (installKeepGoing installFlags) + distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags) + + setupScriptOptions index lock rpkg = + configureSetupScript + packageDBs + comp + platform + progdb + distPref + (chooseCabalVersion configExFlags (libVersion miscOptions)) + (Just lock) + parallelInstall + index + (Just rpkg) + + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + + -- Should the build output be written to a log file instead of stdout? + useLogFile :: UseLogFile + useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName) + logFileTemplate + where + installLogFile' = flagToMaybe $ installLogFile installFlags + defaultTemplate = toPathTemplate $ + logsDir "$compiler" "$libname" <.> "log" + + -- If the user has specified --remote-build-reporting=detailed, use the + -- default log file location. If the --build-log option is set, use the + -- provided location. Otherwise don't use logging, unless building in + -- parallel (in which case the default location is used). + logFileTemplate :: Maybe PathTemplate + logFileTemplate + | useDefaultTemplate = Just defaultTemplate + | otherwise = installLogFile' + + -- If the user has specified --remote-build-reporting=detailed or + -- --build-log, use more verbose logging. + loggingVerbosity :: Verbosity + loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + useDefaultTemplate :: Bool + useDefaultTemplate + | reportingLevel == DetailedReports = True + | isJust installLogFile' = False + | parallelInstall = True + | otherwise = False + + overrideVerbosity :: Bool + overrideVerbosity + | reportingLevel == DetailedReports = True + | isJust installLogFile' = True + | parallelInstall = False + | otherwise = False + + substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath + substLogFileName template pkg uid = fromPathTemplate + . substPathTemplate env + $ template + where env = initialPathTemplateEnv (packageId pkg) uid + (compilerInfo comp) platform + + miscOptions = InstallMisc { + libVersion = flagToMaybe (configCabalVersion configExFlags) + } + + +executeInstallPlan :: Verbosity + -> JobControl IO (UnitId, BuildOutcome) + -> Bool + -> UseLogFile + -> InstallPlan + -> (ReadyPackage -> IO BuildOutcome) + -> IO BuildOutcomes +executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = + InstallPlan.execute + jobCtl keepGoing depsFailure plan0 $ \pkg -> do + buildOutcome <- installPkg pkg + printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome + return buildOutcome + + where + depsFailure = DependentFailed . packageId + + -- Print build log if something went wrong, and 'Installed $PKGID' + -- otherwise. + printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () + printBuildResult pkgid uid buildOutcome = case buildOutcome of + (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid) + (Left _) -> do + notice verbosity $ "Failed to install " ++ prettyShow pkgid + when (verbosity >= normal) $ + case useLogFile of + Nothing -> return () + Just (mkLogFileName, _) -> do + let logName = mkLogFileName pkgid uid + putStr $ "Build log ( " ++ logName ++ " ):\n" + printFile logName + + printFile :: FilePath -> IO () + printFile path = readFile path >>= putStr + +-- | Call an installer for an 'SourcePackage' but override the configure +-- flags with the ones given by the 'ReadyPackage'. In particular the +-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +-- NB: when updating this function, don't forget to also update +-- 'configurePackage' in D.C.Configure. +installReadyPackage :: Platform -> CompilerInfo + -> ConfigFlags + -> ReadyPackage + -> (ConfigFlags -> UnresolvedPkgLoc + -> PackageDescription + -> PackageDescriptionOverride + -> a) + -> a +installReadyPackage platform cinfo configFlags + (ReadyPackage (ConfiguredPackage ipid + (SourcePackage _ gpkg source pkgoverride) + flags stanzas deps)) + installPkg = + installPkg configFlags { + configIPID = toFlag (prettyShow ipid), + configConfigurationsFlags = flags, + -- We generate the legacy constraints as well as the new style precise deps. + -- In the end only one set gets passed to Setup.hs configure, depending on + -- the Cabal version we are talking to. + configConstraints = [ thisPackageVersionConstraint srcid + | ConfiguredId + srcid + (Just + (PackageDescription.CLibName + PackageDescription.LMainLibName)) + _ipid + <- CD.nonSetupDeps deps ], + configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid + | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid + <- CD.nonSetupDeps deps ], + -- Use '--exact-configuration' if supported. + configExactConfiguration = toFlag True, + configBenchmarks = toFlag False, + configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas) + } source pkg pkgoverride + where + pkg = case finalizePD flags (enableStanzas stanzas) + (const True) + platform cinfo [] gpkg of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc + +fetchSourcePackage + :: Verbosity + -> RepoContext + -> JobLimit + -> UnresolvedPkgLoc + -> (ResolvedPkgLoc -> IO BuildOutcome) + -> IO BuildOutcome +fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do + fetched <- checkFetched src + case fetched of + Just src' -> installPkg src' + Nothing -> onFailure DownloadFailed $ do + loc <- withJobLimit fetchLimit $ + fetchPackage verbosity repoCtxt src + installPkg loc + + +installLocalPackage + :: Verbosity + -> PackageIdentifier -> ResolvedPkgLoc -> FilePath + -> (Maybe FilePath -> IO BuildOutcome) + -> IO BuildOutcome +installLocalPackage verbosity pkgid location distPref installPkg = + + case location of + + LocalUnpackedPackage dir -> + installPkg (Just dir) + + RemoteSourceRepoPackage _repo dir -> + installPkg (Just dir) + + LocalTarballPackage tarballPath -> + installLocalTarballPackage verbosity + pkgid tarballPath distPref installPkg + + RemoteTarballPackage _ tarballPath -> + installLocalTarballPackage verbosity + pkgid tarballPath distPref installPkg + + RepoTarballPackage _ _ tarballPath -> + installLocalTarballPackage verbosity + pkgid tarballPath distPref installPkg + +installLocalTarballPackage + :: Verbosity + -> PackageIdentifier -> FilePath -> FilePath + -> (Maybe FilePath -> IO BuildOutcome) + -> IO BuildOutcome +installLocalTarballPackage verbosity pkgid + tarballPath distPref installPkg = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> + onFailure UnpackFailed $ do + let relUnpackedPath = prettyShow pkgid + absUnpackedPath = tmpDirPath relUnpackedPath + descFilePath = absUnpackedPath + prettyShow (packageName pkgid) <.> "cabal" + info verbosity $ "Extracting " ++ tarballPath + ++ " to " ++ tmpDirPath ++ "..." + extractTarGzFile tmpDirPath relUnpackedPath tarballPath + exists <- doesFileExist descFilePath + unless exists $ + die' verbosity $ "Package .cabal file not found: " ++ show descFilePath + maybeRenameDistDir absUnpackedPath + installPkg (Just absUnpackedPath) + + where + -- 'cabal sdist' puts pre-generated files in the 'dist' + -- directory. This fails when a nonstandard build directory name + -- is used (as is the case with sandboxes), so we need to rename + -- the 'dist' dir here. + -- + -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still + -- fails even with this workaround. We probably can live with that. + maybeRenameDistDir :: FilePath -> IO () + maybeRenameDistDir absUnpackedPath = do + let distDirPath = absUnpackedPath defaultDistPref + distDirPathTmp = absUnpackedPath (defaultDistPref ++ "-tmp") + distDirPathNew = absUnpackedPath distPref + distDirExists <- doesDirectoryExist distDirPath + when (distDirExists + && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do + -- NB: we need to handle the case when 'distDirPathNew' is a + -- subdirectory of 'distDirPath' (e.g. the former is + -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist'). + debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '" + ++ distDirPathTmp ++ "'." + renameDirectory distDirPath distDirPathTmp + when (distDirPath `isPrefixOf` distDirPathNew) $ + createDirectoryIfMissingVerbose verbosity False distDirPath + debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '" + ++ distDirPathNew ++ "'." + renameDirectory distDirPathTmp distDirPathNew + +installUnpackedPackage + :: Verbosity + -> Lock + -> Int + -> SetupScriptOptions + -> ConfigFlags + -> InstallFlags + -> HaddockFlags + -> TestFlags + -> Compiler + -> ProgramDb + -> Platform + -> PackageDescription + -> ReadyPackage + -> PackageDescriptionOverride + -> Maybe FilePath -- ^ Directory to change to before starting the installation. + -> UseLogFile -- ^ File to log output to (if any) + -> IO BuildOutcome +installUnpackedPackage verbosity installLock numJobs + scriptOptions + configFlags installFlags haddockFlags testFlags comp progdb + platform pkg rpkg pkgoverride workingDir useLogFile = do + -- Override the .cabal file if necessary + case pkgoverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = fromMaybe "." workingDir + prettyShow (packageName pkgid) <.> "cabal" + info verbosity $ + "Updating " ++ prettyShow (packageName pkgid) <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt + + -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if + -- the setup script was compiled against an old version of the Cabal lib). + configFlags' <- addDefaultInstallDirs configFlags + -- Filter out flags not supported by the old versions of the Cabal lib. + let configureFlags :: Version -> ConfigFlags + configureFlags = filterConfigureFlags configFlags' { + configVerbosity = toFlag verbosity' + } + + -- Path to the optional log file. + mLogPath <- maybeLogPath + + logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do + -- Configure phase + onFailure ConfigureFailed $ do + noticeProgress ProgressStarting + setup configureCommand configureFlags mLogPath + + -- Build phase + onFailure BuildFailed $ do + noticeProgress ProgressBuilding + setup buildCommand' buildFlags mLogPath + + -- Doc generation phase + docsResult <- if shouldHaddock + then (do setup haddockCommand haddockFlags' mLogPath + return DocsOk) + `catchIO` (\_ -> return DocsFailed) + `catchExit` (\_ -> return DocsFailed) + else return DocsNotTried + + -- Tests phase + onFailure TestsFailed $ do + when (testsEnabled && PackageDescription.hasTests pkg) $ + setup Cabal.testCommand testFlags' mLogPath + + let testsResult | testsEnabled = TestsOk + | otherwise = TestsNotTried + + -- Install phase + onFailure InstallFailed $ criticalSection installLock $ do + -- Actual installation + withWin32SelfUpgrade verbosity uid configFlags + cinfo platform pkg $ do + setup Cabal.copyCommand copyFlags mLogPath + + -- Capture installed package configuration file, so that + -- it can be incorporated into the final InstallPlan + ipkgs <- genPkgConfs mLogPath + let ipkgs' = case ipkgs of + [ipkg] -> [ipkg { Installed.installedUnitId = uid }] + _ -> ipkgs + let packageDBs = interpretPackageDbFlags + (fromFlag (configUserInstall configFlags)) + (configPackageDBs configFlags) + for_ ipkgs' $ \ipkg' -> + registerPackage verbosity comp progdb + packageDBs ipkg' + defaultRegisterOptions + + return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs'))) + + where + pkgid = packageId pkg + uid = installedUnitId rpkg + cinfo = compilerInfo comp + buildCommand' = buildCommand progdb + dispname = prettyShow pkgid + isParallelBuild = numJobs >= 2 + + noticeProgress phase = when isParallelBuild $ + progressMessage verbosity phase dispname + + buildFlags _ = emptyBuildFlags { + buildDistPref = configDistPref configFlags, + buildVerbosity = toFlag verbosity' + } + shouldHaddock = fromFlag (installDocumentation installFlags) + haddockFlags' _ = haddockFlags { + haddockVerbosity = toFlag verbosity', + haddockDistPref = configDistPref configFlags + } + testsEnabled = fromFlag (configTests configFlags) + && fromFlagOrDefault False (installRunTests installFlags) + testFlags' = filterTestFlags testFlags { + Cabal.testDistPref = configDistPref configFlags + } + copyFlags _ = Cabal.emptyCopyFlags { + Cabal.copyDistPref = configDistPref configFlags, + Cabal.copyDest = toFlag InstallDirs.NoCopyDest, + Cabal.copyVerbosity = toFlag verbosity' + } + shouldRegister = PackageDescription.hasLibs pkg + registerFlags _ = Cabal.emptyRegisterFlags { + Cabal.regDistPref = configDistPref configFlags, + Cabal.regVerbosity = toFlag verbosity' + } + verbosity' = maybe verbosity snd useLogFile + tempTemplate name = name ++ "-" ++ prettyShow pkgid + + addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags + addDefaultInstallDirs configFlags' = do + defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False + return $ configFlags' { + configInstallDirs = fmap Cabal.Flag . + InstallDirs.substituteInstallDirTemplates env $ + InstallDirs.combineInstallDirs fromFlagOrDefault + defInstallDirs (configInstallDirs configFlags) + } + where + CompilerId flavor _ = compilerInfoId cinfo + env = initialPathTemplateEnv pkgid uid cinfo platform + userInstall = fromFlagOrDefault defaultUserInstall + (configUserInstall configFlags') + + genPkgConfs :: Maybe FilePath + -> IO [Installed.InstalledPackageInfo] + genPkgConfs mLogPath = + if shouldRegister then do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do + let pkgConfDest = dir "pkgConf" + registerFlags' version = (registerFlags version) { + Cabal.regGenPkgConf = toFlag (Just pkgConfDest) + } + setup Cabal.registerCommand registerFlags' mLogPath + is_dir <- doesDirectoryExist pkgConfDest + let notHidden = not . isHidden + isHidden name = "." `isPrefixOf` name + if is_dir + -- Sort so that each prefix of the package + -- configurations is well formed + then traverse (readPkgConf pkgConfDest) . sort . filter notHidden + =<< getDirectoryContents pkgConfDest + else fmap (:[]) $ readPkgConf "." pkgConfDest + else return [] + + readPkgConf :: FilePath -> FilePath + -> IO Installed.InstalledPackageInfo + readPkgConf pkgConfDir pkgConfFile = do + pkgConfText <- BS.readFile (pkgConfDir pkgConfFile) + case Installed.parseInstalledPackageInfo pkgConfText of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, pkgConf) -> do + unless (null warns) $ + warn verbosity $ unlines warns + return pkgConf + + pkgConfParseFailed :: String -> IO a + pkgConfParseFailed perror = + die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + ++ show perror + + maybeLogPath :: IO (Maybe FilePath) + maybeLogPath = + case useLogFile of + Nothing -> return Nothing + Just (mkLogFileName, _) -> do + let logFileName = mkLogFileName (packageId pkg) uid + logDir = takeDirectory logFileName + unless (null logDir) $ createDirectoryIfMissing True logDir + logFileExists <- doesFileExist logFileName + when logFileExists $ removeFile logFileName + return (Just logFileName) + + setup cmd flags mLogPath = + Exception.bracket + (traverse (\path -> openFile path AppendMode) mLogPath) + (traverse_ hClose) + (\logFileHandle -> + setupWrapper verbosity + scriptOptions { useLoggingHandle = logFileHandle + , useWorkingDir = workingDir } + (Just pkg) + cmd flags (const [])) + + +-- helper +onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome +onFailure result action = + action `catches` + [ Handler $ \ioe -> handler (ioe :: IOException) + , Handler $ \exit -> handler (exit :: ExitCode) + ] + where + handler :: Exception e => e -> IO BuildOutcome + handler = return . Left . result . toException + + +-- ------------------------------------------------------------ +-- * Weird windows hacks +-- ------------------------------------------------------------ + +withWin32SelfUpgrade :: Verbosity + -> UnitId + -> ConfigFlags + -> CompilerInfo + -> Platform + -> PackageDescription + -> IO a -> IO a +withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do + + defaultDirs <- InstallDirs.defaultInstallDirs + compFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + + Win32SelfUpgrade.possibleSelfUpgrade verbosity + (exeInstallPaths defaultDirs) action + + where + pkgid = packageId pkg + (CompilerId compFlavor _) = compilerInfoId cinfo + + exeInstallPaths defaultDirs = + [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension buildPlatform + | exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) + , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix + prefix = substTemplate prefixTemplate + suffix = substTemplate suffixTemplate ] + where + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + pkgid uid + cinfo InstallDirs.NoCopyDest + platform templateDirs + substTemplate = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid uid + cinfo platform diff --git a/src/Distribution/Client/InstallPlan.hs b/src/Distribution/Client/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/InstallPlan.hs @@ -0,0 +1,957 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Package installation plan +-- +----------------------------------------------------------------------------- +module Distribution.Client.InstallPlan ( + InstallPlan, + GenericInstallPlan, + PlanPackage, + GenericPlanPackage(..), + foldPlanPackage, + IsUnit, + + -- * Operations on 'InstallPlan's + new, + toGraph, + toList, + toMap, + keys, + keysSet, + planIndepGoals, + depends, + + fromSolverInstallPlan, + fromSolverInstallPlanWithProgress, + configureInstallPlan, + remove, + installed, + lookup, + directDeps, + revDirectDeps, + + -- * Traversal + executionOrder, + execute, + BuildOutcomes, + lookupBuildOutcome, + -- ** Traversal helpers + -- $traversal + Processing, + ready, + completed, + failed, + + -- * Display + showPlanGraph, + showInstallPlan, + + -- * Graph-like operations + dependencyClosure, + reverseTopologicalOrder, + reverseDependencyClosure, + ) where + +import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail) +import Prelude (tail) +import Distribution.Compat.Stack (WithCallStack) + +import Distribution.Client.Types hiding (BuildOutcomes) +import qualified Distribution.PackageDescription as PD +import qualified Distribution.Simple.Configure as Configure +import qualified Distribution.Simple.Setup as Cabal + +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Package + ( Package(..), HasMungedPackageId(..) + , HasUnitId(..), UnitId ) +import Distribution.Solver.Types.SolverPackage +import Distribution.Client.JobControl +import Distribution.Pretty (defaultStyle) +import Text.PrettyPrint +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.InstSolverPackage + +import Distribution.Utils.LogProgress +import Distribution.Utils.Structured (Structured (..), Structure(Nominal)) + +-- TODO: Need this when we compute final UnitIds +-- import qualified Distribution.Simple.Configure as Configure + +import qualified Data.Foldable as Foldable (all, toList) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (Graph, IsNode(..)) +import Control.Exception + ( assert ) +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- When cabal tries to install a number of packages, including all their +-- dependencies it has a non-trivial problem to solve. +-- +-- The Problem: +-- +-- In general we start with a set of installed packages and a set of source +-- packages. +-- +-- Installed packages have fixed dependencies. They have already been built and +-- we know exactly what packages they were built against, including their exact +-- versions. +-- +-- Source package have somewhat flexible dependencies. They are specified as +-- version ranges, though really they're predicates. To make matters worse they +-- have conditional flexible dependencies. Configuration flags can affect which +-- packages are required and can place additional constraints on their +-- versions. +-- +-- These two sets of package can and usually do overlap. There can be installed +-- packages that are also available as source packages which means they could +-- be re-installed if required, though there will also be packages which are +-- not available as source and cannot be re-installed. Very often there will be +-- extra versions available than are installed. Sometimes we may like to prefer +-- installed packages over source ones or perhaps always prefer the latest +-- available version whether installed or not. +-- +-- The goal is to calculate an installation plan that is closed, acyclic and +-- consistent and where every configured package is valid. +-- +-- An installation plan is a set of packages that are going to be used +-- together. It will consist of a mixture of installed packages and source +-- packages along with their exact version dependencies. An installation plan +-- is closed if for every package in the set, all of its dependencies are +-- also in the set. It is consistent if for every package in the set, all +-- dependencies which target that package have the same version. + +-- Note that plans do not necessarily compose. You might have a valid plan for +-- package A and a valid plan for package B. That does not mean the composition +-- is simultaneously valid for A and B. In particular you're most likely to +-- have problems with inconsistent dependencies. +-- On the other hand it is true that every closed sub plan is valid. + +-- | Packages in an install plan +-- +-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage' +-- intentionally have no 'PackageInstalled' instance. `This is important: +-- PackageInstalled returns only library dependencies, but for package that +-- aren't yet installed we know many more kinds of dependencies (setup +-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on +-- dependencies in cabal-install should consider what to do with these +-- dependencies; if we give a 'PackageInstalled' instance it would be too easy +-- to get this wrong (and, for instance, call graph traversal functions from +-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'. +data GenericPlanPackage ipkg srcpkg + = PreExisting ipkg + | Configured srcpkg + | Installed srcpkg + deriving (Eq, Show, Generic) + +displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String +displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) + +-- | Convenience combinator for destructing 'GenericPlanPackage'. +-- This is handy because if you case manually, you have to handle +-- 'Configured' and 'Installed' separately (where often you want +-- them to be the same.) +foldPlanPackage :: (ipkg -> a) + -> (srcpkg -> a) + -> GenericPlanPackage ipkg srcpkg + -> a +foldPlanPackage f _ (PreExisting ipkg) = f ipkg +foldPlanPackage _ g (Configured srcpkg) = g srcpkg +foldPlanPackage _ g (Installed srcpkg) = g srcpkg + +type IsUnit a = (IsNode a, Key a ~ UnitId) + +depends :: IsUnit a => a -> [UnitId] +depends = nodeNeighbors + +-- NB: Expanded constraint synonym here to avoid undecidable +-- instance errors in GHC 7.8 and earlier. +instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) + => IsNode (GenericPlanPackage ipkg srcpkg) where + type Key (GenericPlanPackage ipkg srcpkg) = UnitId + nodeKey (PreExisting ipkg) = nodeKey ipkg + nodeKey (Configured spkg) = nodeKey spkg + nodeKey (Installed spkg) = nodeKey spkg + nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg + nodeNeighbors (Configured spkg) = nodeNeighbors spkg + nodeNeighbors (Installed spkg) = nodeNeighbors spkg + +instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) +instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg) + +type PlanPackage = GenericPlanPackage + InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) + +instance (Package ipkg, Package srcpkg) => + Package (GenericPlanPackage ipkg srcpkg) where + packageId (PreExisting ipkg) = packageId ipkg + packageId (Configured spkg) = packageId spkg + packageId (Installed spkg) = packageId spkg + +instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) => + HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where + mungedId (PreExisting ipkg) = mungedId ipkg + mungedId (Configured spkg) = mungedId spkg + mungedId (Installed spkg) = mungedId spkg + +instance (HasUnitId ipkg, HasUnitId srcpkg) => + HasUnitId + (GenericPlanPackage ipkg srcpkg) where + installedUnitId (PreExisting ipkg) = installedUnitId ipkg + installedUnitId (Configured spkg) = installedUnitId spkg + installedUnitId (Installed spkg) = installedUnitId spkg + +instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) => + HasConfiguredId (GenericPlanPackage ipkg srcpkg) where + configuredId (PreExisting ipkg) = configuredId ipkg + configuredId (Configured spkg) = configuredId spkg + configuredId (Installed spkg) = configuredId spkg + +data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { + planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)), + planIndepGoals :: !IndependentGoals + } + deriving (Typeable) + +-- | 'GenericInstallPlan' specialised to most commonly used types. +type InstallPlan = GenericInstallPlan + InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) + +-- | Smart constructor that deals with caching the 'Graph' representation. +-- +mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg) + => String + -> Graph (GenericPlanPackage ipkg srcpkg) + -> IndependentGoals + -> GenericInstallPlan ipkg srcpkg +mkInstallPlan loc graph indepGoals = + assert (valid loc graph) + GenericInstallPlan { + planGraph = graph, + planIndepGoals = indepGoals + } + +internalError :: WithCallStack (String -> String -> a) +internalError loc msg = error $ "internal error in InstallPlan." ++ loc + ++ if null msg then "" else ": " ++ msg + +instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where + structure p = Nominal (typeRep p) 0 "GenericInstallPlan" + [ structure (Proxy :: Proxy ipkg) + , structure (Proxy :: Proxy srcpkg) + ] + +instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, + Binary ipkg, Binary srcpkg) + => Binary (GenericInstallPlan ipkg srcpkg) where + put GenericInstallPlan { + planGraph = graph, + planIndepGoals = indepGoals + } = put graph >> put indepGoals + + get = do + graph <- get + indepGoals <- get + return $! mkInstallPlan "(instance Binary)" graph indepGoals + +showPlanGraph :: (Package ipkg, Package srcpkg, + IsUnit ipkg, IsUnit srcpkg) + => Graph (GenericPlanPackage ipkg srcpkg) -> String +showPlanGraph graph = renderStyle defaultStyle $ + vcat (map dispPlanPackage (Foldable.toList graph)) + where dispPlanPackage p = + hang (hsep [ text (showPlanPackageTag p) + , pretty (packageId p) + , parens (pretty (nodeKey p))]) 2 + (vcat (map pretty (nodeNeighbors p))) + +showInstallPlan :: (Package ipkg, Package srcpkg, + IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg -> String +showInstallPlan = showPlanGraph . planGraph + +showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String +showPlanPackageTag (PreExisting _) = "PreExisting" +showPlanPackageTag (Configured _) = "Configured" +showPlanPackageTag (Installed _) = "Installed" + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: (IsUnit ipkg, IsUnit srcpkg) + => IndependentGoals + -> Graph (GenericPlanPackage ipkg srcpkg) + -> GenericInstallPlan ipkg srcpkg +new indepGoals graph = mkInstallPlan "new" graph indepGoals + +toGraph :: GenericInstallPlan ipkg srcpkg + -> Graph (GenericPlanPackage ipkg srcpkg) +toGraph = planGraph + +toList :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] +toList = Foldable.toList . planGraph + +toMap :: GenericInstallPlan ipkg srcpkg + -> Map UnitId (GenericPlanPackage ipkg srcpkg) +toMap = Graph.toMap . planGraph + +keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] +keys = Graph.keys . planGraph + +keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId +keysSet = Graph.keysSet . planGraph + +-- | Remove packages from the install plan. This will result in an +-- error if there are remaining packages that depend on any matching +-- package. This is primarily useful for obtaining an install plan for +-- the dependencies of a package or set of packages without actually +-- installing the package itself, as when doing development. +-- +remove :: (IsUnit ipkg, IsUnit srcpkg) + => (GenericPlanPackage ipkg srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg +remove shouldRemove plan = + mkInstallPlan "remove" newGraph (planIndepGoals plan) + where + newGraph = Graph.fromDistinctList $ + filter (not . shouldRemove) (toList plan) + +-- | Change a number of packages in the 'Configured' state to the 'Installed' +-- state. +-- +-- To preserve invariants, the package must have all of its dependencies +-- already installed too (that is 'PreExisting' or 'Installed'). +-- +installed :: (IsUnit ipkg, IsUnit srcpkg) + => (srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg +installed shouldBeInstalled installPlan = + foldl' markInstalled installPlan + [ pkg + | Configured pkg <- reverseTopologicalOrder installPlan + , shouldBeInstalled pkg ] + where + markInstalled plan pkg = + assert (all isInstalled (directDeps plan (nodeKey pkg))) $ + plan { + planGraph = Graph.insert (Installed pkg) (planGraph plan) + } + +-- | Lookup a package in the plan. +-- +lookup :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> UnitId + -> Maybe (GenericPlanPackage ipkg srcpkg) +lookup plan pkgid = Graph.lookup pkgid (planGraph plan) + +-- | Find all the direct dependencies of the given package. +-- +-- Note that the package must exist in the plan or it is an error. +-- +directDeps :: GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] +directDeps plan pkgid = + case Graph.neighbors (planGraph plan) pkgid of + Just deps -> deps + Nothing -> internalError "directDeps" "package not in graph" + +-- | Find all the direct reverse dependencies of the given package. +-- +-- Note that the package must exist in the plan or it is an error. +-- +revDirectDeps :: GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] +revDirectDeps plan pkgid = + case Graph.revNeighbors (planGraph plan) pkgid of + Just deps -> deps + Nothing -> internalError "revDirectDeps" "package not in graph" + +-- | Return all the packages in the 'InstallPlan' in reverse topological order. +-- That is, for each package, all dependencies of the package appear first. +-- +-- Compared to 'executionOrder', this function returns all the installed and +-- source packages rather than just the source ones. Also, while both this +-- and 'executionOrder' produce reverse topological orderings of the package +-- dependency graph, it is not necessarily exactly the same order. +-- +reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] +reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) + + +-- | Return the packages in the plan that are direct or indirect dependencies of +-- the given packages. +-- +dependencyClosure :: GenericInstallPlan ipkg srcpkg + -> [UnitId] + -> [GenericPlanPackage ipkg srcpkg] +dependencyClosure plan = fromMaybe [] + . Graph.closure (planGraph plan) + +-- | Return the packages in the plan that depend directly or indirectly on the +-- given packages. +-- +reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg + -> [UnitId] + -> [GenericPlanPackage ipkg srcpkg] +reverseDependencyClosure plan = fromMaybe [] + . Graph.revClosure (planGraph plan) + + +-- Alert alert! Why does SolverId map to a LIST of plan packages? +-- The sordid story has to do with 'build-depends' on a package +-- with libraries and executables. In an ideal world, we would +-- ONLY depend on the library in this situation. But c.f. #3661 +-- some people rely on the build-depends to ALSO implicitly +-- depend on an executable. +-- +-- I don't want to commit to a strategy yet, so the only possible +-- thing you can do in this case is return EVERYTHING and let +-- the client filter out what they want (executables? libraries? +-- etc). This similarly implies we can't return a 'ConfiguredId' +-- because that's not enough information. + +fromSolverInstallPlan :: + (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> [GenericPlanPackage ipkg srcpkg] ) + -> SolverInstallPlan + -> GenericInstallPlan ipkg srcpkg +fromSolverInstallPlan f plan = + mkInstallPlan "fromSolverInstallPlan" + (Graph.fromDistinctList pkgs'') + (SolverInstallPlan.planIndepGoals plan) + where + (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) + + f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs) + where + pkgs' = f (mapDep pidMap ipiMap) pkg + + (pidMap', ipiMap') + = case nodeKey pkg of + PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) + PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + + mapDep _ ipiMap (PreExistingId _pid uid) + | Just pkgs <- Map.lookup uid ipiMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) + mapDep pidMap _ (PlannedId pid) + | Just pkgs <- Map.lookup pid pidMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) + -- This shouldn't happen, since mapDep should only be called + -- on neighbor SolverId, which must have all been done already + -- by the reverse top-sort (we assume the graph is not broken). + + +fromSolverInstallPlanWithProgress :: + (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> LogProgress [GenericPlanPackage ipkg srcpkg] ) + -> SolverInstallPlan + -> LogProgress (GenericInstallPlan ipkg srcpkg) +fromSolverInstallPlanWithProgress f plan = do + (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) + return $ mkInstallPlan "fromSolverInstallPlanWithProgress" + (Graph.fromDistinctList pkgs'') + (SolverInstallPlan.planIndepGoals plan) + where + f' (pidMap, ipiMap, pkgs) pkg = do + pkgs' <- f (mapDep pidMap ipiMap) pkg + let (pidMap', ipiMap') + = case nodeKey pkg of + PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) + PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + return (pidMap', ipiMap', pkgs' ++ pkgs) + + mapDep _ ipiMap (PreExistingId _pid uid) + | Just pkgs <- Map.lookup uid ipiMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) + mapDep pidMap _ (PlannedId pid) + | Just pkgs <- Map.lookup pid pidMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) + -- This shouldn't happen, since mapDep should only be called + -- on neighbor SolverId, which must have all been done already + -- by the reverse top-sort (we assume the graph is not broken). + +-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. +-- Similar to 'elaboratedInstallPlan' +configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan +configureInstallPlan configFlags solverPlan = + flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> + [case planpkg of + SolverInstallPlan.PreExisting pkg -> + PreExisting (instSolverPkgIPI pkg) + + SolverInstallPlan.Configured pkg -> + Configured (configureSolverPackage mapDep pkg) + ] + where + configureSolverPackage :: (SolverId -> [PlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ConfiguredPackage UnresolvedPkgLoc + configureSolverPackage mapDep spkg = + ConfiguredPackage { + confPkgId = Configure.computeComponentId + (Cabal.fromFlagOrDefault False + (Cabal.configDeterministic configFlags)) + Cabal.NoFlag + Cabal.NoFlag + (packageId spkg) + (PD.CLibName PD.LMainLibName) + (Just (map confInstId (CD.libraryDeps deps), + solverPkgFlags spkg)), + confPkgSource = solverPkgSource spkg, + confPkgFlags = solverPkgFlags spkg, + confPkgStanzas = solverPkgStanzas spkg, + confPkgDeps = deps + -- NB: no support for executable dependencies + } + where + deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg) + + +-- ------------------------------------------------------------ +-- * Primitives for traversing plans +-- ------------------------------------------------------------ + +-- $traversal +-- +-- Algorithms to traverse or execute an 'InstallPlan', especially in parallel, +-- may make use of the 'Processing' type and the associated operations +-- 'ready', 'completed' and 'failed'. +-- +-- The 'Processing' type is used to keep track of the state of a traversal and +-- includes the set of packages that are in the processing state, e.g. in the +-- process of being installed, plus those that have been completed and those +-- where processing failed. +-- +-- Traversal algorithms start with an 'InstallPlan': +-- +-- * Initially there will be certain packages that can be processed immediately +-- (since they are configured source packages and have all their dependencies +-- installed already). The function 'ready' returns these packages plus a +-- 'Processing' state that marks these same packages as being in the +-- processing state. +-- +-- * The algorithm must now arrange for these packages to be processed +-- (possibly in parallel). When a package has completed processing, the +-- algorithm needs to know which other packages (if any) are now ready to +-- process as a result. The 'completed' function marks a package as completed +-- and returns any packages that are newly in the processing state (ie ready +-- to process), along with the updated 'Processing' state. +-- +-- * If failure is possible then when processing a package fails, the algorithm +-- needs to know which other packages have also failed as a result. The +-- 'failed' function marks the given package as failed as well as all the +-- other packages that depend on the failed package. In addition it returns +-- the other failed packages. + + +-- | The 'Processing' type is used to keep track of the state of a traversal +-- and includes the set of packages that are in the processing state, e.g. in +-- the process of being installed, plus those that have been completed and +-- those where processing failed. +-- +data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) + -- processing, completed, failed + +-- | The packages in the plan that are initially ready to be installed. +-- That is they are in the configured state and have all their dependencies +-- installed already. +-- +-- The result is both the packages that are now ready to be installed and also +-- a 'Processing' state containing those same packages. The assumption is that +-- all the packages that are ready will now be processed and so we can consider +-- them to be in the processing state. +-- +ready :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> ([GenericReadyPackage srcpkg], Processing) +ready plan = + assert (processingInvariant plan processing) $ + (readyPackages, processing) + where + !processing = + Processing + (Set.fromList [ nodeKey pkg | pkg <- readyPackages ]) + (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ]) + Set.empty + readyPackages = + [ ReadyPackage pkg + | Configured pkg <- toList plan + , all isInstalled (directDeps plan (nodeKey pkg)) + ] + +isInstalled :: GenericPlanPackage a b -> Bool +isInstalled (PreExisting {}) = True +isInstalled (Installed {}) = True +isInstalled _ = False + +-- | Given a package in the processing state, mark the package as completed +-- and return any packages that are newly in the processing state (ie ready to +-- process), along with the updated 'Processing' state. +-- +completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> UnitId + -> ([GenericReadyPackage srcpkg], Processing) +completed plan (Processing processingSet completedSet failedSet) pkgid = + assert (pkgid `Set.member` processingSet) $ + assert (processingInvariant plan processing') $ + + ( map asReadyPackage newlyReady + , processing' ) + where + completedSet' = Set.insert pkgid completedSet + + -- each direct reverse dep where all direct deps are completed + newlyReady = [ dep + | dep <- revDirectDeps plan pkgid + , all ((`Set.member` completedSet') . nodeKey) + (directDeps plan (nodeKey dep)) + ] + + processingSet' = foldl' (flip Set.insert) + (Set.delete pkgid processingSet) + (map nodeKey newlyReady) + processing' = Processing processingSet' completedSet' failedSet + + asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg + asReadyPackage (Configured pkg) = ReadyPackage pkg + asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg + +failed :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> UnitId + -> ([srcpkg], Processing) +failed plan (Processing processingSet completedSet failedSet) pkgid = + assert (pkgid `Set.member` processingSet) $ + assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $ + assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ + -- but note that some newlyFailed may already be in the failed set + -- since one package can depend on two packages that both fail and + -- so would be in the rev-dep closure for both. + assert (processingInvariant plan processing') $ + + ( map asConfiguredPackage (tail newlyFailed) + , processing' ) + where + processingSet' = Set.delete pkgid processingSet + failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds + newlyFailedIds = map nodeKey newlyFailed + newlyFailed = fromMaybe (internalError "failed" "package not in graph") + $ Graph.revClosure (planGraph plan) [pkgid] + processing' = Processing processingSet' completedSet failedSet' + + asConfiguredPackage (Configured pkg) = pkg + asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg + +processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> Bool +processingInvariant plan (Processing processingSet completedSet failedSet) = + + -- All the packages in the three sets are actually in the graph + assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $ + assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $ + assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $ + + -- The processing, completed and failed sets are disjoint from each other + assert (noIntersection processingSet completedSet) $ + assert (noIntersection processingSet failedSet) $ + assert (noIntersection failedSet completedSet) $ + + -- Packages that depend on a package that's still processing cannot be + -- completed + assert (noIntersection (reverseClosure processingSet) completedSet) $ + + -- On the other hand, packages that depend on a package that's still + -- processing /can/ have failed (since they may have depended on multiple + -- packages that were processing, but it only takes one to fail to cause + -- knock-on failures) so it is quite possible to have an + -- intersection (reverseClosure processingSet) failedSet + + -- The failed set is upwards closed, i.e. equal to its own rev dep closure + assert (failedSet == reverseClosure failedSet) $ + + -- All immediate reverse deps of packges that are currently processing + -- are not currently being processed (ie not in the processing set). + assert (and [ rdeppkgid `Set.notMember` processingSet + | pkgid <- Set.toList processingSet + , rdeppkgid <- maybe (internalError "processingInvariant" "") + (map nodeKey) + (Graph.revNeighbors (planGraph plan) pkgid) + ]) $ + + -- Packages from the processing or failed sets are only ever in the + -- configured state. + assert (and [ case Graph.lookup pkgid (planGraph plan) of + Just (Configured _) -> True + Just (PreExisting _) -> False + Just (Installed _) -> False + Nothing -> False + | pkgid <- Set.toList processingSet ++ Set.toList failedSet ]) + + -- We use asserts rather than returning False so that on failure we get + -- better details on which bit of the invariant was violated. + True + where + reverseClosure = Set.fromList + . map nodeKey + . fromMaybe (internalError "processingInvariant" "") + . Graph.revClosure (planGraph plan) + . Set.toList + noIntersection a b = Set.null (Set.intersection a b) + + +-- ------------------------------------------------------------ +-- * Traversing plans +-- ------------------------------------------------------------ + +-- | Flatten an 'InstallPlan', producing the sequence of source packages in +-- the order in which they would be processed when the plan is executed. This +-- can be used for simultations or presenting execution dry-runs. +-- +-- It is guaranteed to give the same order as using 'execute' (with a serial +-- in-order 'JobControl'), which is a reverse topological orderings of the +-- source packages in the dependency graph, albeit not necessarily exactly the +-- same ordering as that produced by 'reverseTopologicalOrder'. +-- +executionOrder :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> [GenericReadyPackage srcpkg] +executionOrder plan = + let (newpkgs, processing) = ready plan + in tryNewTasks processing newpkgs + where + tryNewTasks _processing [] = [] + tryNewTasks processing (p:todo) = waitForTasks processing p todo + + waitForTasks processing p todo = + p : tryNewTasks processing' (todo++nextpkgs) + where + (nextpkgs, processing') = completed plan processing (nodeKey p) + + +-- ------------------------------------------------------------ +-- * Executing plans +-- ------------------------------------------------------------ + +-- | The set of results we get from executing an install plan. +-- +type BuildOutcomes failure result = Map UnitId (Either failure result) + +-- | Lookup the build result for a single package. +-- +lookupBuildOutcome :: HasUnitId pkg + => pkg -> BuildOutcomes failure result + -> Maybe (Either failure result) +lookupBuildOutcome = Map.lookup . installedUnitId + +-- | Execute an install plan. This traverses the plan in dependency order. +-- +-- Executing each individual package can fail and if so all dependents fail +-- too. The result for each package is collected as a 'BuildOutcomes' map. +-- +-- Visiting each package happens with optional parallelism, as determined by +-- the 'JobControl'. By default, after any failure we stop as soon as possible +-- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour +-- can be reversed to keep going and build as many packages as possible. +-- +-- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages +-- in the plan. In particular in the default mode where we stop as soon as +-- possible after a failure then there may be packages which are skipped and +-- these will have no 'BuildOutcome'. +-- +execute :: forall m ipkg srcpkg result failure. + (IsUnit ipkg, IsUnit srcpkg, + Monad m) + => JobControl m (UnitId, Either failure result) + -> Bool -- ^ Keep going after failure + -> (srcpkg -> failure) -- ^ Value for dependents of failed packages + -> GenericInstallPlan ipkg srcpkg + -> (GenericReadyPackage srcpkg -> m (Either failure result)) + -> m (BuildOutcomes failure result) +execute jobCtl keepGoing depFailure plan installPkg = + let (newpkgs, processing) = ready plan + in tryNewTasks Map.empty False False processing newpkgs + where + tryNewTasks :: BuildOutcomes failure result + -> Bool -> Bool -> Processing + -> [GenericReadyPackage srcpkg] + -> m (BuildOutcomes failure result) + + tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs + -- we were in the process of cancelling and now we're finished + | tasksFailed && not keepGoing && not tasksRemaining + = return results + + -- we are still in the process of cancelling, wait for remaining tasks + | tasksFailed && not keepGoing && tasksRemaining + = waitForTasks results tasksFailed processing + + -- no new tasks to do and all tasks are done so we're finished + | null newpkgs && not tasksRemaining + = return results + + -- no new tasks to do, remaining tasks to wait for + | null newpkgs + = waitForTasks results tasksFailed processing + + -- new tasks to do, spawn them, then wait for tasks to complete + | otherwise + = do sequence_ [ spawnJob jobCtl $ do + result <- installPkg pkg + return (nodeKey pkg, result) + | pkg <- newpkgs ] + waitForTasks results tasksFailed processing + + waitForTasks :: BuildOutcomes failure result + -> Bool -> Processing + -> m (BuildOutcomes failure result) + waitForTasks !results tasksFailed !processing = do + (pkgid, result) <- collectJob jobCtl + + case result of + + Right _success -> do + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' tasksFailed tasksRemaining + processing' nextpkgs + where + results' = Map.insert pkgid result results + (nextpkgs, processing') = completed plan processing pkgid + + Left _failure -> do + -- if this is the first failure and we're not trying to keep going + -- then try to cancel as many of the remaining jobs as possible + when (not tasksFailed && not keepGoing) $ + cancelJobs jobCtl + + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' True tasksRemaining processing' [] + where + (depsfailed, processing') = failed plan processing pkgid + results' = Map.insert pkgid result results `Map.union` depResults + depResults = Map.fromList + [ (nodeKey deppkg, Left (depFailure deppkg)) + | deppkg <- depsfailed ] + +-- ------------------------------------------------------------ +-- * Checking validity of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is closed, acyclic +-- and respects the package state relation. +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: (IsUnit ipkg, IsUnit srcpkg) + => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool +valid loc graph = + case problems graph of + [] -> True + ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) + +data PlanProblem ipkg srcpkg = + PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] + | PackageCycle [GenericPlanPackage ipkg srcpkg] + | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) + (GenericPlanPackage ipkg srcpkg) + +showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg) + => PlanProblem ipkg srcpkg -> String +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ prettyShow (nodeKey pkg) + ++ " depends on the following packages which are missing from the plan: " + ++ intercalate ", " (map prettyShow missingDeps) + +showPlanProblem (PackageCycle cycleGroup) = + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup) +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ prettyShow (nodeKey pkg) + ++ " is in the " ++ showPlanPackageTag pkg + ++ " state but it depends on package " ++ prettyShow (nodeKey pkg') + ++ " which is in the " ++ showPlanPackageTag pkg' + ++ " state" + +-- | For an invalid plan, produce a detailed list of problems as human readable +-- error messages. This is mainly intended for debugging purposes. +-- Use 'showPlanProblem' for a human readable explanation. +-- +problems :: (IsUnit ipkg, IsUnit srcpkg) + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +problems graph = + + [ PackageMissingDeps pkg + (mapMaybe + (fmap nodeKey . flip Graph.lookup graph) + missingDeps) + | (pkg, missingDeps) <- Graph.broken graph ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- Graph.cycles graph ] +{- + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- + dependencyInconsistencies indepGoals graph ] + --TODO: consider re-enabling this one, see SolverInstallPlan +-} + ++ [ PackageStateInvalid pkg pkg' + | pkg <- Foldable.toList graph + , Just pkg' <- map (flip Graph.lookup graph) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') ] + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @stateDependencyRelation a b = True@. +-- +stateDependencyRelation :: GenericPlanPackage ipkg srcpkg + -> GenericPlanPackage ipkg srcpkg -> Bool +stateDependencyRelation PreExisting{} PreExisting{} = True + +stateDependencyRelation Installed{} PreExisting{} = True +stateDependencyRelation Installed{} Installed{} = True + +stateDependencyRelation Configured{} PreExisting{} = True +stateDependencyRelation Configured{} Installed{} = True +stateDependencyRelation Configured{} Configured{} = True + +stateDependencyRelation _ _ = False diff --git a/src/Distribution/Client/InstallSymlink.hs b/src/Distribution/Client/InstallSymlink.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/InstallSymlink.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallSymlink +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Managing installing binaries with symlinks. +----------------------------------------------------------------------------- +module Distribution.Client.InstallSymlink ( + symlinkBinaries, + symlinkBinary, + trySymlink, + ) where + +import Distribution.Client.Compat.Prelude hiding (ioError) +import Prelude () + +import Distribution.Client.Types + ( ConfiguredPackage(..), BuildOutcomes ) +import Distribution.Client.Setup + ( InstallFlags(installSymlinkBinDir) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) + +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Package + ( PackageIdentifier, Package(packageId), UnitId, installedUnitId ) +import Distribution.Types.UnqualComponentName +import Distribution.Compiler + ( CompilerId(..) ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePD ) +import Distribution.Simple.Setup + ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Compiler + ( Compiler, compilerInfo, CompilerInfo(..) ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils ( info, withTempDirectory ) + +import System.Directory + ( canonicalizePath, getTemporaryDirectory, removeFile ) +import System.FilePath + ( (), splitPath, joinPath, isAbsolute ) + +import System.IO.Error + ( isDoesNotExistError, ioError ) +import Control.Exception + ( assert ) + +import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink ) +import Distribution.Client.Types.OverwritePolicy + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +-- | We would like by default to install binaries into some location that is on +-- the user's PATH. For per-user installations on Unix systems that basically +-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ +-- directory will be on the user's PATH. However some people are a bit nervous +-- about letting a package manager install programs into @~/bin/@. +-- +-- A compromise solution is that instead of installing binaries directly into +-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ +-- and then create symlinks in @~/bin/@. We can be careful when setting up the +-- symlinks that we do not overwrite any binary that the user installed. We can +-- check if it was a symlink we made because it would point to the private dir +-- where we install our binaries. This means we can install normally without +-- worrying and in a later phase set up symlinks, and if that fails then we +-- report it to the user, but even in this case the package is still in an OK +-- installed state. +-- +-- This is an optional feature that users can choose to use or not. It is +-- controlled from the config file. Of course it only works on POSIX systems +-- with symlinks so is not available to Windows users. +-- +symlinkBinaries :: Platform -> Compiler + -> OverwritePolicy + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> BuildOutcomes + -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] +symlinkBinaries platform comp overwritePolicy + configFlags installFlags + plan buildOutcomes = + case flagToMaybe (installSymlinkBinDir installFlags) of + Nothing -> return [] + Just symlinkBinDir + | null exes -> return [] + | otherwise -> do + publicBinDir <- canonicalizePath symlinkBinDir +-- TODO: do we want to do this here? : +-- createDirectoryIfMissing True publicBinDir + fmap catMaybes $ sequenceA + [ do privateBinDir <- pkgBinDir pkg ipid + ok <- symlinkBinary + overwritePolicy + publicBinDir privateBinDir + (prettyShow publicExeName) privateExeName + if ok + then return Nothing + else return (Just (pkgid, publicExeName, + privateBinDir privateExeName)) + | (rpkg, pkg, exe) <- exes + , let pkgid = packageId pkg + -- This is a bit dodgy; probably won't work for Backpack packages + ipid = installedUnitId rpkg + publicExeName = PackageDescription.exeName exe + privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix + prefix = substTemplate pkgid ipid prefixTemplate + suffix = substTemplate pkgid ipid suffixTemplate ] + where + exes = + [ (cpkg, pkg, exe) + | InstallPlan.Configured cpkg <- InstallPlan.toList plan + , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of + Just (Right _success) -> True + _ -> False + , let pkg :: PackageDescription + pkg = pkgDescription cpkg + , exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) ] + + pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _) + flags stanzas _) = + case finalizePD flags (enableStanzas stanzas) + (const True) + platform cinfo [] gpd of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc + + -- This is sadly rather complicated. We're kind of re-doing part of the + -- configuration for the package. :-( + pkgBinDir :: PackageDescription -> UnitId -> IO FilePath + pkgBinDir pkg ipid = do + defaultDirs <- InstallDirs.defaultInstallDirs + compilerFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + (packageId pkg) ipid + cinfo InstallDirs.NoCopyDest + platform templateDirs + canonicalizePath (InstallDirs.bindir absoluteDirs) + + substTemplate pkgid ipid = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid ipid + cinfo platform + + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + cinfo = compilerInfo comp + (CompilerId compilerFlavor _) = compilerInfoId cinfo + +-- | Symlink binary. +-- +-- The paths are take in pieces, so we can make relative link when possible. +-- +symlinkBinary :: + OverwritePolicy -- ^ Whether to force overwrite an existing file + -> FilePath -- ^ The canonical path of the public bin dir eg + -- @/home/user/bin@ + -> FilePath -- ^ The canonical path of the private bin dir eg + -- @/home/user/.cabal/bin@ + -> FilePath -- ^ The name of the executable to go in the public bin + -- dir, eg @foo@ + -> String -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool -- ^ If creating the symlink was successful. @False@ if + -- there was another file there already that we did + -- not own. Other errors like permission errors just + -- propagate as exceptions. +symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do + ok <- targetOkToOverwrite (publicBindir publicName) + (privateBindir privateName) + case ok of + NotExists -> mkLink >> return True + OkToOverwrite -> rmLink >> mkLink >> return True + NotOurFile -> + case overwritePolicy of + NeverOverwrite -> return False + AlwaysOverwrite -> rmLink >> mkLink >> return True + where + relativeBindir = makeRelative publicBindir privateBindir + mkLink = createFileLink (relativeBindir privateName) (publicBindir publicName) + rmLink = removeFile (publicBindir publicName) + +-- | Check a file path of a symlink that we would like to create to see if it +-- is OK. For it to be OK to overwrite it must either not already exist yet or +-- be a symlink to our target (in which case we can assume ownership). +-- +targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private + -- binary that we would like to create + -> FilePath -- ^ The canonical path of the private binary. + -- Use 'canonicalizePath' to make this. + -> IO SymlinkStatus +targetOkToOverwrite symlink target = handleNotExist $ do + isLink <- pathIsSymbolicLink symlink + if not isLink + then return NotOurFile + else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink + -- This partially relies on canonicalizePath handling symlinks + if target == target' + then return OkToOverwrite + else return NotOurFile + + where + handleNotExist action = catchIO action $ \ioexception -> + -- If the target doesn't exist then there's no problem overwriting it! + if isDoesNotExistError ioexception + then return NotExists + else ioError ioexception + +data SymlinkStatus + = NotExists -- ^ The file doesn't exist so we can make a symlink. + | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll + -- have to delete it first before we make a new symlink. + | NotOurFile -- ^ A file already exists and it is not one of our existing + -- symlinks (either because it is not a symlink or because + -- it points somewhere other than our managed space). + deriving Show + +-- | Take two canonical paths and produce a relative path to get from the first +-- to the second, even if it means adding @..@ path components. +-- +makeRelative :: FilePath -> FilePath -> FilePath +makeRelative a b = assert (isAbsolute a && isAbsolute b) $ + let as = splitPath a + bs = splitPath b + commonLen = length $ takeWhile id $ zipWith (==) as bs + in joinPath $ [ ".." | _ <- drop commonLen as ] + ++ drop commonLen bs + +-- | Try to make a symlink in a temporary directory. +-- +-- If this works, we can try to symlink: even on Windows. +-- +trySymlink :: Verbosity -> IO Bool +trySymlink verbosity = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do + let from = tmpDirPath "file.txt" + let to = tmpDirPath "file2.txt" + + -- create a file + BS.writeFile from (BS8.pack "TEST") + + -- create a symbolic link + let create :: IO Bool + create = do + createFileLink from to + info verbosity $ "Symlinking seems to work" + return True + + create `catchIO` \exc -> do + info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc + return False diff --git a/src/Distribution/Client/JobControl.hs b/src/Distribution/Client/JobControl.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/JobControl.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.JobControl +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A job control concurrency abstraction +----------------------------------------------------------------------------- +module Distribution.Client.JobControl ( + JobControl, + newSerialJobControl, + newParallelJobControl, + spawnJob, + collectJob, + remainingJobs, + cancelJobs, + + JobLimit, + newJobLimit, + withJobLimit, + + Lock, + newLock, + criticalSection + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Control.Monad (forever, replicateM_) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TChan +import Control.Exception (bracket_, try) +import Distribution.Compat.Stack +import Distribution.Client.Compat.Semaphore + + +-- | A simple concurrency abstraction. Jobs can be spawned and can complete +-- in any order. This allows both serial and parallel implementations. +-- +data JobControl m a = JobControl { + -- | Add a new job to the pool of jobs + spawnJob :: m a -> m (), + + -- | Wait until one job is complete + collectJob :: m a, + + -- | Returns True if there are any outstanding jobs + -- (ie spawned but yet to be collected) + remainingJobs :: m Bool, + + -- | Try to cancel any outstanding but not-yet-started jobs. + -- Call 'remainingJobs' after this to find out if any jobs are left + -- (ie could not be cancelled). + cancelJobs :: m () + } + + +-- | Make a 'JobControl' that executes all jobs serially and in order. +-- It only executes jobs on demand when they are collected, not eagerly. +-- +-- Cancelling will cancel /all/ jobs that have not been collected yet. +-- +newSerialJobControl :: IO (JobControl IO a) +newSerialJobControl = do + qVar <- newTChanIO + return JobControl { + spawnJob = spawn qVar, + collectJob = collect qVar, + remainingJobs = remaining qVar, + cancelJobs = cancel qVar + } + where + spawn :: TChan (IO a) -> IO a -> IO () + spawn qVar job = atomically $ writeTChan qVar job + + collect :: TChan (IO a) -> IO a + collect qVar = + join $ atomically $ readTChan qVar + + remaining :: TChan (IO a) -> IO Bool + remaining qVar = fmap not $ atomically $ isEmptyTChan qVar + + cancel :: TChan (IO a) -> IO () + cancel qVar = do + _ <- atomically $ readAllTChan qVar + return () + +-- | Make a 'JobControl' that eagerly executes jobs in parallel, with a given +-- maximum degree of parallelism. +-- +-- Cancelling will cancel jobs that have not yet begun executing, but jobs +-- that have already been executed or are currently executing cannot be +-- cancelled. +-- +newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a)) +newParallelJobControl n | n < 1 || n > 1000 = + error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n +newParallelJobControl maxJobLimit = do + inqVar <- newTChanIO + outqVar <- newTChanIO + countVar <- newTVarIO 0 + replicateM_ maxJobLimit $ + forkIO $ + worker inqVar outqVar + return JobControl { + spawnJob = spawn inqVar countVar, + collectJob = collect outqVar countVar, + remainingJobs = remaining countVar, + cancelJobs = cancel inqVar countVar + } + where + worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO () + worker inqVar outqVar = + forever $ do + job <- atomically $ readTChan inqVar + res <- try job + atomically $ writeTChan outqVar res + + spawn :: TChan (IO a) -> TVar Int -> IO a -> IO () + spawn inqVar countVar job = + atomically $ do + modifyTVar' countVar (+1) + writeTChan inqVar job + + collect :: TChan (Either SomeException a) -> TVar Int -> IO a + collect outqVar countVar = do + res <- atomically $ do + modifyTVar' countVar (subtract 1) + readTChan outqVar + either throwIO return res + + remaining :: TVar Int -> IO Bool + remaining countVar = fmap (/=0) $ atomically $ readTVar countVar + + cancel :: TChan (IO a) -> TVar Int -> IO () + cancel inqVar countVar = + atomically $ do + xs <- readAllTChan inqVar + modifyTVar' countVar (subtract (length xs)) + +readAllTChan :: TChan a -> STM [a] +readAllTChan qvar = go [] + where + go xs = do + mx <- tryReadTChan qvar + case mx of + Nothing -> return (reverse xs) + Just x -> go (x:xs) + +------------------------- +-- Job limits and locks +-- + +data JobLimit = JobLimit QSem + +newJobLimit :: Int -> IO JobLimit +newJobLimit n = + fmap JobLimit (newQSem n) + +withJobLimit :: JobLimit -> IO a -> IO a +withJobLimit (JobLimit sem) = + bracket_ (waitQSem sem) (signalQSem sem) + +newtype Lock = Lock (MVar ()) + +newLock :: IO Lock +newLock = fmap Lock $ newMVar () + +criticalSection :: Lock -> IO a -> IO a +criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act diff --git a/src/Distribution/Client/List.hs b/src/Distribution/Client/List.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/List.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.List +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2008-2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- +-- Search for and print information about packages +----------------------------------------------------------------------------- +module Distribution.Client.List ( + list, info + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Package + ( PackageName, Package(..), packageName + , packageVersion, UnitId ) +import Distribution.Types.Dependency +import Distribution.Types.UnqualComponentName +import Distribution.ModuleName (ModuleName) +import Distribution.License (License) +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.PackageDescription as Source +import Distribution.PackageDescription + ( PackageFlag(..), unFlagName ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) + +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program (ProgramDb) +import Distribution.Simple.Utils + ( equating, die', notice ) +import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import Distribution.Version + ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion + , intersectVersionRanges, simplifyVersionRange ) + +import qualified Distribution.SPDX as SPDX + +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + +import Distribution.Client.Types + ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage ) +import Distribution.Client.Targets + ( UserTarget, resolveUserTargets ) +import Distribution.Client.Setup + ( GlobalFlags(..), ListFlags(..), InfoFlags(..) + , RepoContext(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.FetchUtils + ( isFetched ) + +import Data.Bits ((.|.)) +import Data.List + ( maximumBy ) +import Data.List.NonEmpty (groupBy) +import qualified Data.List as L +import Data.Maybe + ( fromJust ) +import qualified Data.Map as Map +import Data.Tree as Tree +import Control.Exception + ( assert ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint + ( lineLength, ribbonsPerLine, Doc, renderStyle, char + , nest, ($+$), text, vcat, style, parens, fsep) +import System.Directory + ( doesDirectoryExist ) + +import Distribution.Utils.ShortText (ShortText) +import qualified Distribution.Utils.ShortText as ShortText +import qualified Text.Regex.Base as Regex +import qualified Text.Regex.Posix.String as Regex + + +-- | Return a list of packages matching given search strings. +getPkgList :: Verbosity + -> PackageDBStack + -> RepoContext + -> Maybe (Compiler, ProgramDb) + -> ListFlags + -> [String] + -> IO [PackageDisplayInfo] +getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do + installedPkgIndex <- for mcompprogdb $ \(comp, progdb) -> + getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + + regexps <- for pats $ \pat -> do + e <- Regex.compile compOption Regex.execBlank pat + case e of + Right r -> return r + Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err + + let sourcePkgIndex = packageIndex sourcePkgDb + prefs name = fromMaybe anyVersion + (Map.lookup name (packagePreferences sourcePkgDb)) + + pkgsInfoMatching :: + [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] + pkgsInfoMatching = + let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex + matchingSource = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex + in mergePackages matchingInstalled matchingSource + + pkgsInfo :: + [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] + pkgsInfo + -- gather info for all packages + | null regexps = mergePackages + (maybe [] InstalledPackageIndex.allPackages installedPkgIndex) + ( PackageIndex.allPackages sourcePkgIndex) + + -- gather info for packages matching search term + | otherwise = pkgsInfoMatching + + matches :: [PackageDisplayInfo] + matches = [ mergePackageInfo pref + installedPkgs sourcePkgs selectedPkg False + | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo + , not onlyInstalled || not (null installedPkgs) + , let pref = prefs pkgname + selectedPkg = latestWithPref pref sourcePkgs ] + return matches + where + onlyInstalled = fromFlagOrDefault False (listInstalled listFlags) + caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags) + + compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase + | otherwise = Regex.compExtended + + matchingPackages search regexps index = + [ pkg + | re <- regexps + , pkg <- search index (Regex.matchTest re) ] + + +-- | Show information about packages. +list :: Verbosity + -> PackageDBStack + -> RepoContext + -> Maybe (Compiler, ProgramDb) + -> ListFlags + -> [String] + -> IO () +list verbosity packageDBs repos mcompProgdb listFlags pats = do + matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats + + if simpleOutput + then putStr $ unlines + [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version + | pkg <- matches + , version <- if onlyInstalled + then installedVersions pkg + else nub . sort $ installedVersions pkg + ++ sourceVersions pkg ] + -- Note: this only works because for 'list', one cannot currently + -- specify any version constraints, so listing all installed + -- and source ones works. + else + if null matches + then notice verbosity "No matches found." + else putStr $ unlines (map showPackageSummaryInfo matches) + where + onlyInstalled = fromFlag (listInstalled listFlags) + simpleOutput = fromFlag (listSimpleOutput listFlags) + +info :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> ProgramDb + -> GlobalFlags + -> InfoFlags + -> [UserTarget] + -> IO () +info verbosity _ _ _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +info verbosity packageDBs repoCtxt comp progdb + globalFlags _listFlags userTargets = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + let sourcePkgIndex = packageIndex sourcePkgDb + prefs name = fromMaybe anyVersion + (Map.lookup name (packagePreferences sourcePkgDb)) + + -- Users may specify names of packages that are only installed, not + -- just available source packages, so we must resolve targets using + -- the combination of installed and source packages. + let sourcePkgs' = PackageIndex.fromList + $ map packageId + (InstalledPackageIndex.allPackages installedPkgIndex) + ++ map packageId + (PackageIndex.allPackages sourcePkgIndex) + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt + (fromFlag $ globalWorldFile globalFlags) + sourcePkgs' userTargets + + pkgsinfo <- sequenceA + [ do pkginfo <- either (die' verbosity) return $ + gatherPkgInfo prefs + installedPkgIndex sourcePkgIndex + pkgSpecifier + updateFileSystemPackageDetails pkginfo + | pkgSpecifier <- pkgSpecifiers ] + + putStr $ unlines (map showPackageDetailedInfo pkgsinfo) + + where + gatherPkgInfo :: (PackageName -> VersionRange) -> + InstalledPackageIndex -> + PackageIndex.PackageIndex UnresolvedSourcePackage -> + PackageSpecifier UnresolvedSourcePackage -> + Either String PackageDisplayInfo + gatherPkgInfo prefs installedPkgIndex sourcePkgIndex + (NamedPackage name props) + | null (selectedInstalledPkgs) && null (selectedSourcePkgs) + = Left $ "There is no available version of " ++ prettyShow name + ++ " that satisfies " + ++ prettyShow (simplifyVersionRange verConstraint) + + | otherwise + = Right $ mergePackageInfo pref installedPkgs + sourcePkgs selectedSourcePkg' + showPkgVersion + where + (pref, installedPkgs, sourcePkgs) = + sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex + + selectedInstalledPkgs = InstalledPackageIndex.lookupDependency + installedPkgIndex + name verConstraint + selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex + name verConstraint + selectedSourcePkg' = latestWithPref pref selectedSourcePkgs + + -- display a specific package version if the user + -- supplied a non-trivial version constraint + showPkgVersion = not (null verConstraints) + verConstraint = foldr intersectVersionRanges anyVersion verConstraints + verConstraints = [ vr | PackagePropertyVersion vr <- props ] + + gatherPkgInfo prefs installedPkgIndex sourcePkgIndex + (SpecificSourcePackage pkg) = + Right $ mergePackageInfo pref installedPkgs sourcePkgs + selectedPkg True + where + name = packageName pkg + selectedPkg = Just pkg + (pref, installedPkgs, sourcePkgs) = + sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex + +sourcePkgsInfo :: + (PackageName -> VersionRange) + -> PackageName + -> InstalledPackageIndex + -> PackageIndex.PackageIndex UnresolvedSourcePackage + -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage]) +sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex = + (pref, installedPkgs, sourcePkgs) + where + pref = prefs name + installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName + installedPkgIndex name) + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name + + +-- | The info that we can display for each package. It is information per +-- package name and covers all installed and available versions. +-- +data PackageDisplayInfo = PackageDisplayInfo { + pkgName :: PackageName, + selectedVersion :: Maybe Version, + selectedSourcePkg :: Maybe UnresolvedSourcePackage, + installedVersions :: [Version], + sourceVersions :: [Version], + preferredVersions :: VersionRange, + homepage :: ShortText, + bugReports :: ShortText, + sourceRepo :: String, -- TODO + synopsis :: ShortText, + description :: ShortText, + category :: ShortText, + license :: Either SPDX.License License, + author :: ShortText, + maintainer :: ShortText, + dependencies :: [ExtDependency], + flags :: [PackageFlag], + hasLib :: Bool, + hasExe :: Bool, + executables :: [UnqualComponentName], + modules :: [ModuleName], + haddockHtml :: FilePath, + haveTarball :: Bool + } + +-- | Covers source dependencies and installed dependencies in +-- one type. +data ExtDependency = SourceDependency Dependency + | InstalledDependency UnitId + +showPackageSummaryInfo :: PackageDisplayInfo -> String +showPackageSummaryInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> pretty (pkgName pkginfo) + $+$ + (nest 4 $ vcat [ + maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs + , text "Default available version:" <+> + case selectedSourcePkg pkginfo of + Nothing -> text "[ Not available from any configured repository ]" + Just pkg -> pretty (packageVersion pkg) + , text "Installed versions:" <+> + case installedVersions pkginfo of + [] | hasLib pkginfo -> text "[ Not installed ]" + | otherwise -> text "[ Unknown ]" + versions -> dispTopVersions 4 + (preferredVersions pkginfo) versions + , maybeShowST (homepage pkginfo) "Homepage:" text + , text "License: " <+> either pretty pretty (license pkginfo) + ]) + $+$ text "" + where + maybeShowST l s f + | ShortText.null l = Disp.empty + | otherwise = text s <+> f (ShortText.fromShortText l) + +showPackageDetailedInfo :: PackageDisplayInfo -> String +showPackageDetailedInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> pretty (pkgName pkginfo) + <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo) + <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ') + <<>> parens pkgkind + $+$ + (nest 4 $ vcat [ + entryST "Synopsis" synopsis hideIfNull reflowParagraphs + , entry "Versions available" sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry "Versions installed" installedVersions + (altText null (if hasLib pkginfo then "[ Not installed ]" + else "[ Unknown ]")) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entryST "Homepage" homepage orNotSpecified text + , entryST "Bug reports" bugReports orNotSpecified text + , entryST "Description" description hideIfNull reflowParagraphs + , entryST "Category" category hideIfNull text + , entry "License" license alwaysShow (either pretty pretty) + , entryST "Author" author hideIfNull reflowLines + , entryST "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep pretty) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) then mempty else + text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo)) + ]) + $+$ text "" + where + entry fname field cond format = case cond (field pkginfo) of + Nothing -> label <+> format (field pkginfo) + Just Nothing -> mempty + Just (Just other) -> label <+> text other + where + label = text fname Disp.<> char ':' Disp.<> padding + padding = text (replicate (13 - length fname ) ' ') + + entryST fname field = entry fname (ShortText.fromShortText . field) + + normal = Nothing + hide = Just Nothing + replace msg = Just (Just msg) + + alwaysShow = const normal + hideIfNull v = if null v then hide else normal + showIfInstalled v + | not isInstalled = hide + | null v = replace "[ Not installed ]" + | otherwise = normal + altText nul msg v = if nul v then replace msg else normal + orNotSpecified = altText null "[ Not specified ]" + + commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f + dispFlag = text . unFlagName . flagName + dispYesNo True = text "Yes" + dispYesNo False = text "No" + + dispExtDep (SourceDependency dep) = pretty dep + dispExtDep (InstalledDependency dep) = pretty dep + + isInstalled = not (null (installedVersions pkginfo)) + hasExes = length (executables pkginfo) >= 2 + --TODO: exclude non-buildable exes + pkgkind | hasLib pkginfo && hasExes = text "programs and library" + | hasLib pkginfo && hasExe pkginfo = text "program and library" + | hasLib pkginfo = text "library" + | hasExes = text "programs" + | hasExe pkginfo = text "program" + | otherwise = mempty + + +reflowParagraphs :: String -> Doc +reflowParagraphs = + vcat + . intersperse (text "") -- re-insert blank lines + . map (fsep . map text . concatMap words) -- reflow paragraphs + . filter (/= [""]) + . L.groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines + . lines + +reflowLines :: String -> Doc +reflowLines = vcat . map text . lines + +-- | We get the 'PackageDisplayInfo' by combining the info for the installed +-- and available versions of a package. +-- +-- * We're building info about a various versions of a single named package so +-- the input package info records are all supposed to refer to the same +-- package name. +-- +mergePackageInfo :: VersionRange + -> [Installed.InstalledPackageInfo] + -> [UnresolvedSourcePackage] + -> Maybe UnresolvedSourcePackage + -> Bool + -> PackageDisplayInfo +mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer = + assert (length installedPkgs + length sourcePkgs > 0) $ + PackageDisplayInfo { + pkgName = combine packageName source + packageName installed, + selectedVersion = if showVer then fmap packageVersion selectedPkg + else Nothing, + selectedSourcePkg = sourceSelected, + installedVersions = map packageVersion installedPkgs, + sourceVersions = map packageVersion sourcePkgs, + preferredVersions = versionPref, + + license = combine Source.licenseRaw source + Installed.license installed, + maintainer = combine Source.maintainer source + Installed.maintainer installed, + author = combine Source.author source + Installed.author installed, + homepage = combine Source.homepage source + Installed.homepage installed, + bugReports = maybe mempty Source.bugReports source, + sourceRepo = fromMaybe mempty . join + . fmap (uncons Nothing Source.repoLocation + . sortBy (comparing Source.repoKind) + . Source.sourceRepos) + $ source, + --TODO: installed package info is missing synopsis + synopsis = maybe mempty Source.synopsis source, + description = combine Source.description source + Installed.description installed, + category = combine Source.category source + Installed.category installed, + flags = maybe [] Source.genPackageFlags sourceGeneric, + hasLib = isJust installed + || maybe False (isJust . Source.condLibrary) sourceGeneric, + hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric, + executables = map fst (maybe [] Source.condExecutables sourceGeneric), + modules = combine (map Installed.exposedName . Installed.exposedModules) + installed + -- NB: only for the PUBLIC library + (concatMap getListOfExposedModules . maybeToList . Source.library) + source, + dependencies = + combine (map (SourceDependency . simplifyDependency) + . Source.allBuildDepends) source + (map InstalledDependency . Installed.depends) installed, + haddockHtml = fromMaybe "" . join + . fmap (listToMaybe . Installed.haddockHTMLs) + $ installed, + haveTarball = False + } + where + combine f x g y = fromJust (fmap f x `mplus` fmap g y) + installed :: Maybe Installed.InstalledPackageInfo + installed = latestWithPref versionPref installedPkgs + + getListOfExposedModules lib = Source.exposedModules lib + ++ map Source.moduleReexportName + (Source.reexportedModules lib) + + sourceSelected + | isJust selectedPkg = selectedPkg + | otherwise = latestWithPref versionPref sourcePkgs + sourceGeneric = fmap srcpkgDescription sourceSelected + source = fmap flattenPackageDescription sourceGeneric + + uncons :: b -> (a -> b) -> [a] -> b + uncons z _ [] = z + uncons _ f (x:_) = f x + + +-- | Not all the info is pure. We have to check if the docs really are +-- installed, because the registered package info lies. Similarly we have to +-- check if the tarball has indeed been fetched. +-- +updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo +updateFileSystemPackageDetails pkginfo = do + fetched <- maybe (return False) (isFetched . srcpkgSource) + (selectedSourcePkg pkginfo) + docsExist <- doesDirectoryExist (haddockHtml pkginfo) + return pkginfo { + haveTarball = fetched, + haddockHtml = if docsExist then haddockHtml pkginfo else "" + } + +latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg +latestWithPref _ [] = Nothing +latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs) + where + prefThenVersion pkg = let ver = packageVersion pkg + in (withinRange ver pref, ver) + + +-- | Rearrange installed and source packages into groups referring to the +-- same package by name. In the result pairs, the lists are guaranteed to not +-- both be empty. +-- +mergePackages :: [Installed.InstalledPackageInfo] + -> [UnresolvedSourcePackage] + -> [( PackageName + , [Installed.InstalledPackageInfo] + , [UnresolvedSourcePackage] )] +mergePackages installedPkgs sourcePkgs = + map collect + $ mergeBy (\i a -> fst i `compare` fst a) + (groupOn packageName installedPkgs) + (groupOn packageName sourcePkgs) + where + collect (OnlyInLeft (name,is) ) = (name, is, []) + collect ( InBoth (_,is) (name,as)) = (name, is, as) + collect (OnlyInRight (name,as)) = (name, [], as) + +groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] +groupOn key = map (\xs -> (key (head xs), toList xs)) + . groupBy (equating key) + . sortBy (comparing key) + +dispTopVersions :: Int -> VersionRange -> [Version] -> Doc +dispTopVersions n pref vs = + (Disp.fsep . Disp.punctuate (Disp.char ',') + . map (\ver -> if ispref ver then pretty ver else parens (pretty ver)) + . sort . take n . interestingVersions ispref + $ vs) + <+> trailingMessage + + where + ispref ver = withinRange ver pref + extra = length vs - n + trailingMessage + | extra <= 0 = Disp.empty + | otherwise = Disp.parens $ Disp.text "and" + <+> Disp.int (length vs - n) + <+> if extra == 1 then Disp.text "other" + else Disp.text "others" + +-- | Reorder a bunch of versions to put the most interesting / significant +-- versions first. A preferred version range is taken into account. +-- +-- This may be used in a user interface to select a small number of versions +-- to present to the user, e.g. +-- +-- > let selectVersions = sort . take 5 . interestingVersions pref +-- +interestingVersions :: (Version -> Bool) -> [Version] -> [Version] +interestingVersions pref = + map (mkVersion . fst) . filter snd + . concat . Tree.levels + . swizzleTree + . reorderTree (\(Node (v,_) _) -> pref (mkVersion v)) + . reverseTree + . mkTree + . map (or0 . versionNumbers) + + where + or0 [] = 0 :| [] + or0 (x:xs) = x :| xs + + swizzleTree = unfoldTree (spine []) + where + spine ts' (Node x []) = (x, ts') + spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t + + reorderTree _ (Node x []) = Node x [] + reorderTree p (Node x ts) = Node x (ts' ++ ts'') + where + (ts',ts'') = partition p (map (reorderTree p) ts) + + reverseTree (Node x cs) = Node x (reverse (map reverseTree cs)) + + mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool) + mkTree xs = unfoldTree step (False, [], xs) + where + step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])]) + step (node,ns,vs) = + ( (reverse ns, node) + , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs')) + | (n, vs') <- groups vs + ] + ) + + groups :: [NonEmpty a] -> [(a, NonEmpty [a])] + groups = map (\g -> (head (head g), fmap tail g)) + . groupBy (equating head) diff --git a/src/Distribution/Client/Manpage.hs b/src/Distribution/Client/Manpage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Manpage.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Manpage +-- Copyright : (c) Maciek Makowski 2015 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Functions for building the manual page. + +module Distribution.Client.Manpage + ( -- * Manual page generation + manpage + , manpageCmd + , ManpageFlags + , defaultManpageFlags + , manpageOptions + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ManpageFlags +import Distribution.Client.Setup (globalCommand) +import Distribution.Compat.Process (createProcess) +import Distribution.Simple.Command +import Distribution.Simple.Flag (fromFlagOrDefault) +import System.IO (hClose, hPutStr) + +import qualified System.Process as Process + +data FileInfo = FileInfo String String -- ^ path, description + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +-- | A list of files that should be documented in the manual page. +files :: [FileInfo] +files = + [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.") + , (FileInfo "~/.cabal/world" "A list of all packages whose installation has been explicitly requested.") + ] + +manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO () +manpageCmd pname commands flags + | fromFlagOrDefault False (manpageRaw flags) + = putStrLn contents + | otherwise + = do + let cmd = "man" + args = ["-l", "-"] + + (mb_in, _, _, ph) <- createProcess (Process.proc cmd args) + { Process.std_in = Process.CreatePipe + , Process.std_out = Process.Inherit + , Process.std_err = Process.Inherit + } + + -- put contents + for_ mb_in $ \hin -> do + hPutStr hin contents + hClose hin + + -- wait for process to exit, propagate exit code + ec <- Process.waitForProcess ph + exitWith ec + where + contents :: String + contents = manpage pname commands + +-- | Produces a manual page with @troff@ markup. +manpage :: String -> [CommandSpec a] -> String +manpage pname commands = unlines $ + [ ".TH " ++ map toUpper pname ++ " 1" + , ".SH NAME" + , pname ++ " \\- a system for building and packaging Haskell libraries and programs" + , ".SH SYNOPSIS" + , ".B " ++ pname + , ".I command" + , ".RI < arguments |[ options ]>..." + , "" + , "Where the" + , ".I commands" + , "are" + , "" + ] ++ + concatMap (commandSynopsisLines pname) commands ++ + [ ".SH DESCRIPTION" + , "Cabal is the standard package system for Haskell software. It helps people to configure, " + , "build and install Haskell software and to distribute it easily to other users and developers." + , "" + , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with " + , "installing existing packages and developing new packages. " + , "It can be used to work with local packages or to install packages from online package archives, " + , "including automatically installing dependencies. By default it is configured to use Hackage, " + , "which is Haskell's central package archive that contains thousands of libraries and applications " + , "in the Cabal package format." + , ".SH OPTIONS" + , "Global options:" + , "" + ] ++ + optionsLines (globalCommand []) ++ + [ ".SH COMMANDS" + ] ++ + concatMap (commandDetailsLines pname) commands ++ + [ ".SH FILES" + ] ++ + concatMap fileLines files ++ + [ ".SH BUGS" + , "To browse the list of known issues or report a new one please see " + , "https://github.com/haskell/cabal/labels/cabal-install." + ] + +commandSynopsisLines :: String -> CommandSpec action -> [String] +commandSynopsisLines pname (CommandSpec ui _ NormalCommand) = + [ ".B " ++ pname ++ " " ++ (commandName ui) + , ".R - " ++ commandSynopsis ui + , ".br" + ] +commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = [] + +commandDetailsLines :: String -> CommandSpec action -> [String] +commandDetailsLines pname (CommandSpec ui _ NormalCommand) = + [ ".B " ++ pname ++ " " ++ (commandName ui) + , "" + , commandUsage ui pname + , "" + ] ++ + optional commandDescription ++ + optional commandNotes ++ + [ "Flags:" + , ".RS" + ] ++ + optionsLines ui ++ + [ ".RE" + , "" + ] + where + optional field = + case field ui of + Just text -> [text pname, ""] + Nothing -> [] +commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = [] + +optionsLines :: CommandUI flags -> [String] +optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs)) + +data ArgumentRequired = Optional | Required +type OptionArg = (ArgumentRequired, ArgPlaceHolder) + +optionLines :: OptDescr flags -> [String] +optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) = + argOptionLines description optionChars optionStrings (Required, placeHolder) +optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) = + argOptionLines description optionChars optionStrings (Optional, placeHolder) +optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) = + optionLinesIfPresent trueChars trueStrings ++ + optionLinesIfPresent falseChars falseStrings ++ + optionDescriptionLines description +optionLines (ChoiceOpt options) = + concatMap choiceLines options + where + choiceLines (description, (optionChars, optionStrings), _, _) = + [ optionsLine optionChars optionStrings ] ++ + optionDescriptionLines description + +argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String] +argOptionLines description optionChars optionStrings arg = + [ optionsLine optionChars optionStrings + , optionArgLine arg + ] ++ + optionDescriptionLines description + +optionLinesIfPresent :: [Char] -> [String] -> [String] +optionLinesIfPresent optionChars optionStrings = + if null optionChars && null optionStrings then [] + else [ optionsLine optionChars optionStrings, ".br" ] + +optionDescriptionLines :: String -> [String] +optionDescriptionLines description = + [ ".RS" + , description + , ".RE" + , "" + ] + +optionsLine :: [Char] -> [String] -> String +optionsLine optionChars optionStrings = + intercalate ", " (shortOptions optionChars ++ longOptions optionStrings) + +shortOptions :: [Char] -> [String] +shortOptions = map (\c -> "\\-" ++ [c]) + +longOptions :: [String] -> [String] +longOptions = map (\s -> "\\-\\-" ++ s) + +optionArgLine :: OptionArg -> String +optionArgLine (Required, placeHolder) = ".I " ++ placeHolder +optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]" + +fileLines :: FileInfo -> [String] +fileLines (FileInfo path description) = + [ path + , ".RS" + , description + , ".RE" + , "" + ] diff --git a/src/Distribution/Client/ManpageFlags.hs b/src/Distribution/Client/ManpageFlags.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ManpageFlags.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.ManpageFlags +( ManpageFlags (..) +, defaultManpageFlags +, manpageOptions, +) where + +import Distribution.Client.Compat.Prelude + +import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) +import Distribution.Simple.Setup (Flag (..), toFlag, trueArg, optionVerbosity) +import Distribution.Verbosity (normal) + +data ManpageFlags = ManpageFlags + { manpageVerbosity :: Flag Verbosity + , manpageRaw :: Flag Bool + } deriving (Eq, Show, Generic) + +instance Monoid ManpageFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ManpageFlags where + (<>) = gmappend + +defaultManpageFlags :: ManpageFlags +defaultManpageFlags = ManpageFlags + { manpageVerbosity = toFlag normal + , manpageRaw = toFlag False + } + +manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags] +manpageOptions _ = + [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v }) + , option "" ["raw"] + "Output raw troff content" + manpageRaw (\v flags -> flags { manpageRaw = v }) + trueArg + ] diff --git a/src/Distribution/Client/Nix.hs b/src/Distribution/Client/Nix.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Nix.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +module Distribution.Client.Nix + ( findNixExpr + , inNixShell + , nixInstantiate + , nixShell + ) where + +import Distribution.Client.Compat.Prelude + +import Control.Exception (bracket) +import System.Directory + ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist + , doesFileExist, removeDirectoryRecursive, removeFile ) +import System.Environment (getArgs, getExecutablePath) +import System.FilePath + ( (), replaceExtension, takeDirectory, takeFileName ) +import System.IO (IOMode(..), hClose, openFile) +import System.IO.Error (isDoesNotExistError) +import System.Process (showCommandForUser) + +import Distribution.Compat.Environment + ( lookupEnv, setEnv, unsetEnv ) + +import Distribution.Simple.Program + ( Program(..), ProgramDb + , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput + , runDbProgram, simpleProgram ) +import Distribution.Simple.Setup (fromFlagOrDefault) +import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan) + +import Distribution.Client.Config (SavedConfig(..)) +import Distribution.Client.GlobalFlags (GlobalFlags(..)) + + +configureOneProgram :: Verbosity -> Program -> IO ProgramDb +configureOneProgram verb prog = + configureProgram verb prog (addKnownProgram prog emptyProgramDb) + + +touchFile :: FilePath -> IO () +touchFile path = do + catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ())) + createDirectoryIfMissing True (takeDirectory path) + openFile path WriteMode >>= hClose + + +findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath) +findNixExpr globalFlags config = do + -- criteria for deciding to run nix-shell + let nixEnabled = + fromFlagOrDefault False + (globalNix (savedGlobalFlags config) <> globalNix globalFlags) + + if nixEnabled + then do + let exprPaths = [ "shell.nix", "default.nix" ] + filterM doesFileExist exprPaths >>= \case + [] -> return Nothing + (path : _) -> return (Just path) + else return Nothing + + +-- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell +inFakeNixShell :: IO a -> IO a +inFakeNixShell f = + bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f) + where + fakeEnv var new = do + old <- lookupEnv var + setEnv var new + return old + resetEnv var = maybe (unsetEnv var) (setEnv var) + + +nixInstantiate + :: Verbosity + -> FilePath + -> Bool + -> GlobalFlags + -> SavedConfig + -> IO () +nixInstantiate verb dist force' globalFlags config = + findNixExpr globalFlags config >>= \case + Nothing -> return () + Just shellNix -> do + alreadyInShell <- inNixShell + shellDrv <- drvPath dist shellNix + instantiated <- doesFileExist shellDrv + -- an extra timestamp file is necessary because the derivation lives in + -- the store so its mtime is always 1. + let timestamp = timestampPath dist shellNix + upToDate <- existsAndIsMoreRecentThan timestamp shellNix + + let ready = alreadyInShell || (instantiated && upToDate && not force') + unless ready $ do + + let prog = simpleProgram "nix-instantiate" + progdb <- configureOneProgram verb prog + + removeGCRoots verb dist + touchFile timestamp + + _ <- inFakeNixShell + (getDbProgramOutput verb prog progdb + [ "--add-root", shellDrv, "--indirect", shellNix ]) + return () + + +nixShell + :: Verbosity + -> FilePath + -> GlobalFlags + -> SavedConfig + -> IO () + -- ^ The action to perform inside a nix-shell. This is also the action + -- that will be performed immediately if Nix is disabled. + -> IO () +nixShell verb dist globalFlags config go = do + + alreadyInShell <- inNixShell + + if alreadyInShell + then go + else do + findNixExpr globalFlags config >>= \case + Nothing -> go + Just shellNix -> do + + let prog = simpleProgram "nix-shell" + progdb <- configureOneProgram verb prog + + cabal <- getExecutablePath + + -- alreadyInShell == True in child process + setEnv "CABAL_IN_NIX_SHELL" "1" + + -- Run cabal with the same arguments inside nix-shell. + -- When the child process reaches the top of nixShell, it will + -- detect that it is running inside the shell and fall back + -- automatically. + shellDrv <- drvPath dist shellNix + args <- getArgs + runDbProgram verb prog progdb + [ "--add-root", gcrootPath dist "result", "--indirect", shellDrv + , "--run", showCommandForUser cabal args + ] + + +drvPath :: FilePath -> FilePath -> IO FilePath +drvPath dist path = do + -- We do not actually care about canonicity, but makeAbsolute is only + -- available in newer versions of directory. + -- We expect the path to be a symlink if it exists, so we do not canonicalize + -- the entire path because that would dereference the symlink. + distNix <- canonicalizePath (dist "nix") + -- Nix garbage collector roots must be absolute paths + return (distNix replaceExtension (takeFileName path) "drv") + + +timestampPath :: FilePath -> FilePath -> FilePath +timestampPath dist path = + dist "nix" replaceExtension (takeFileName path) "drv.timestamp" + + +gcrootPath :: FilePath -> FilePath +gcrootPath dist = dist "nix" "gcroots" + + +inNixShell :: IO Bool +inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL" + + +removeGCRoots :: Verbosity -> FilePath -> IO () +removeGCRoots verb dist = do + let tgt = gcrootPath dist + exists <- doesDirectoryExist tgt + when exists $ do + debug verb ("removing Nix gcroots from " ++ tgt) + removeDirectoryRecursive tgt diff --git a/src/Distribution/Client/NixStyleOptions.hs b/src/Distribution/Client/NixStyleOptions.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/NixStyleOptions.hs @@ -0,0 +1,85 @@ +-- | Command line options for nix-style / v2 commands. +-- +-- The commands take a lot of the same options, which affect how install plan +-- is constructed. +module Distribution.Client.NixStyleOptions ( + NixStyleFlags (..), + nixStyleOptions, + defaultNixStyleFlags, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs) +import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) + +import Distribution.Client.ProjectFlags + (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions) +import Distribution.Client.Setup + (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions, + configureOptions, haddockOptions, installOptions, liftOptions, testOptions) + +data NixStyleFlags a = NixStyleFlags + { configFlags :: ConfigFlags + , configExFlags :: ConfigExFlags + , installFlags :: InstallFlags + , haddockFlags :: HaddockFlags + , testFlags :: TestFlags + , benchmarkFlags :: BenchmarkFlags + , projectFlags :: ProjectFlags + , extraFlags :: a + } + +nixStyleOptions + :: (ShowOrParseArgs -> [OptionField a]) + -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)] +nixStyleOptions commandOptions showOrParseArgs = + liftOptions configFlags set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. + (filter ((`notElem` ["constraint", "dependency" + , "exact-configuration"]) + . optionName) $ configureOptions showOrParseArgs) + ++ liftOptions configExFlags set2 (configureExOptions showOrParseArgs + ConstraintSourceCommandlineFlag) + ++ liftOptions installFlags set3 + -- hide "target-package-db" and "symlink-bindir" flags from the + -- install options. + -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags + (filter ((`notElem` ["target-package-db", "symlink-bindir"]) + . optionName) $ + installOptions showOrParseArgs) + ++ liftOptions haddockFlags set4 + -- hide "verbose" and "builddir" flags from the + -- haddock options. + (filter ((`notElem` ["v", "verbose", "builddir"]) + . optionName) $ + haddockOptions showOrParseArgs) + ++ liftOptions testFlags set5 (testOptions showOrParseArgs) + ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs) + ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs) + ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs) + where + set1 x flags = flags { configFlags = x } + set2 x flags = flags { configExFlags = x } + set3 x flags = flags { installFlags = x } + set4 x flags = flags { haddockFlags = x } + set5 x flags = flags { testFlags = x } + set6 x flags = flags { benchmarkFlags = x } + set7 x flags = flags { projectFlags = x } + set8 x flags = flags { extraFlags = x } + +defaultNixStyleFlags :: a -> NixStyleFlags a +defaultNixStyleFlags x = NixStyleFlags + { configFlags = mempty + , configExFlags = mempty + , installFlags = mempty + , haddockFlags = mempty + , testFlags = mempty + , benchmarkFlags = mempty + , projectFlags = defaultProjectFlags + , extraFlags = x + } diff --git a/src/Distribution/Client/Outdated.hs b/src/Distribution/Client/Outdated.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Outdated.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Outdated +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'outdated' command. Checks for outdated +-- dependencies in the package description file or freeze file. +----------------------------------------------------------------------------- + +module Distribution.Client.Outdated ( outdated + , ListOutdatedSettings(..), listOutdated ) +where + +import Prelude () +import Distribution.Client.Config +import Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.Compat.Prelude +import Distribution.Client.ProjectConfig +import Distribution.Client.DistDirLayout +import Distribution.Client.RebuildMonad +import Distribution.Client.Setup hiding (quiet) +import Distribution.Client.Targets +import Distribution.Client.Types +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackageIndex +import Distribution.Client.Sandbox.PackageEnvironment +import Distribution.Utils.Generic + +import Distribution.Package (PackageName, packageVersion) +import Distribution.PackageDescription (allBuildDepends) +import Distribution.PackageDescription.Configuration (finalizePD) +import Distribution.Simple.Compiler (Compiler, compilerInfo) +import Distribution.Simple.Setup + (fromFlagOrDefault, flagToMaybe) +import Distribution.Simple.Utils + (die', notice, debug, tryFindPackageDesc) +import Distribution.System (Platform) +import Distribution.Types.ComponentRequestedSpec + (ComponentRequestedSpec(..)) +import Distribution.Types.Dependency + (Dependency(..)) +import Distribution.Verbosity (silent) +import Distribution.Version + (Version, VersionInterval (..), VersionRange, LowerBound(..), UpperBound(..) + ,asVersionIntervals, majorBoundVersion) +import Distribution.PackageDescription.Parsec + (readGenericPackageDescription) +import Distribution.Types.PackageVersionConstraint + (PackageVersionConstraint (..), simplifyPackageVersionConstraint) + +import qualified Data.Set as S +import System.Directory (getCurrentDirectory) + +-- | Entry point for the 'outdated' command. +outdated :: Verbosity -> OutdatedFlags -> RepoContext + -> Compiler -> Platform + -> IO () +outdated verbosity0 outdatedFlags repoContext comp platform = do + let freezeFile = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags) + newFreezeFile = fromFlagOrDefault False + (outdatedNewFreezeFile outdatedFlags) + mprojectFile = flagToMaybe + (outdatedProjectFile outdatedFlags) + simpleOutput = fromFlagOrDefault False + (outdatedSimpleOutput outdatedFlags) + quiet = fromFlagOrDefault False (outdatedQuiet outdatedFlags) + exitCode = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags) + ignorePred = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags) + in \pkgname -> pkgname `S.member` ignoreSet + minorPred = case outdatedMinor outdatedFlags of + Nothing -> const False + Just IgnoreMajorVersionBumpsNone -> const False + Just IgnoreMajorVersionBumpsAll -> const True + Just (IgnoreMajorVersionBumpsSome pkgs) -> + let minorSet = S.fromList pkgs + in \pkgname -> pkgname `S.member` minorSet + verbosity = if quiet then silent else verbosity0 + + when (not newFreezeFile && isJust mprojectFile) $ + die' verbosity $ + "--project-file must only be used with --v2-freeze-file." + + sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext + let pkgIndex = packageIndex sourcePkgDb + deps <- if freezeFile + then depsFromFreezeFile verbosity + else if newFreezeFile + then depsFromNewFreezeFile verbosity mprojectFile + else depsFromPkgDesc verbosity comp platform + debug verbosity $ "Dependencies loaded: " + ++ (intercalate ", " $ map prettyShow deps) + let outdatedDeps = listOutdated deps pkgIndex + (ListOutdatedSettings ignorePred minorPred) + when (not quiet) $ + showResult verbosity outdatedDeps simpleOutput + if (exitCode && (not . null $ outdatedDeps)) + then exitFailure + else return () + +-- | Print either the list of all outdated dependencies, or a message +-- that there are none. +showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO () +showResult verbosity outdatedDeps simpleOutput = + if (not . null $ outdatedDeps) + then + do when (not simpleOutput) $ + notice verbosity "Outdated dependencies:" + for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) -> + let outdatedDep = if simpleOutput then prettyShow pn + else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")" + in notice verbosity outdatedDep + else notice verbosity "All dependencies are up to date." + +-- | Convert a list of 'UserConstraint's to a 'Dependency' list. +userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint] +userConstraintsToDependencies ucnstrs = + mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs + +-- | Read the list of dependencies from the freeze file. +depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint] +depsFromFreezeFile verbosity = do + cwd <- getCurrentDirectory + userConfig <- loadUserConfig verbosity cwd Nothing + let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ + userConfig + deps = userConstraintsToDependencies ucnstrs + debug verbosity "Reading the list of dependencies from the freeze file" + return deps + +-- | Read the list of dependencies from the new-style freeze file. +depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [PackageVersionConstraint] +depsFromNewFreezeFile verbosity mprojectFile = do + projectRoot <- either throwIO return =<< + findProjectRoot Nothing mprojectFile + let distDirLayout = defaultDistDirLayout projectRoot + {- TODO: Support dist dir override -} Nothing + projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ + readProjectLocalFreezeConfig verbosity distDirLayout + let ucnstrs = map fst . projectConfigConstraints . projectConfigShared + $ projectConfig + deps = userConstraintsToDependencies ucnstrs + debug verbosity $ + "Reading the list of dependencies from the new-style freeze file " ++ distProjectFile distDirLayout "freeze" + return deps + +-- | Read the list of dependencies from the package description. +depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint] +depsFromPkgDesc verbosity comp platform = do + cwd <- getCurrentDirectory + path <- tryFindPackageDesc verbosity cwd + gpd <- readGenericPackageDescription verbosity path + let cinfo = compilerInfo comp + epd = finalizePD mempty (ComponentRequestedSpec True True) + (const True) platform cinfo [] gpd + case epd of + Left _ -> die' verbosity "finalizePD failed" + Right (pd, _) -> do + let bd = allBuildDepends pd + debug verbosity + "Reading the list of dependencies from the package description" + return $ map toPVC bd + where + toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr + +-- | Various knobs for customising the behaviour of 'listOutdated'. +data ListOutdatedSettings = ListOutdatedSettings { + -- | Should this package be ignored? + listOutdatedIgnorePred :: PackageName -> Bool, + -- | Should major version bumps should be ignored for this package? + listOutdatedMinorPred :: PackageName -> Bool + } + +-- | Find all outdated dependencies. +listOutdated :: [PackageVersionConstraint] + -> PackageIndex UnresolvedSourcePackage + -> ListOutdatedSettings + -> [(PackageVersionConstraint, Version)] +listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) = + mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps + where + isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version) + isOutdated dep@(PackageVersionConstraint pname vr) + | ignorePred pname = Nothing + | otherwise = + let this = map packageVersion $ lookupDependency pkgIndex pname vr + latest = lookupLatest dep + in (\v -> (dep, v)) `fmap` isOutdated' this latest + + isOutdated' :: [Version] -> [Version] -> Maybe Version + isOutdated' [] _ = Nothing + isOutdated' _ [] = Nothing + isOutdated' this latest = + let this' = maximum this + latest' = maximum latest + in if this' < latest' then Just latest' else Nothing + + lookupLatest :: PackageVersionConstraint -> [Version] + lookupLatest (PackageVersionConstraint pname vr) + | minorPred pname = + map packageVersion $ lookupDependency pkgIndex pname (relaxMinor vr) + | otherwise = + map packageVersion $ lookupPackageName pkgIndex pname + + relaxMinor :: VersionRange -> VersionRange + relaxMinor vr = + let vis = asVersionIntervals vr + in maybe vr relax (safeLast vis) + where relax (VersionInterval (LowerBound v0 _) upper) = + case upper of + NoUpperBound -> vr + UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/src/Distribution/Client/PackageHash.hs b/src/Distribution/Client/PackageHash.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/PackageHash.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} + +-- | Functions to calculate nix-style hashes for package ids. +-- +-- The basic idea is simple, hash the combination of: +-- +-- * the package tarball +-- * the ids of all the direct dependencies +-- * other local configuration (flags, profiling, etc) +-- +module Distribution.Client.PackageHash ( + -- * Calculating package hashes + PackageHashInputs(..), + PackageHashConfigInputs(..), + PackageSourceHash, + hashedInstalledPackageId, + hashPackageHashInputs, + renderPackageHashInputs, + -- ** Platform-specific variations + hashedInstalledPackageIdLong, + hashedInstalledPackageIdShort, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Package + ( PackageId, PackageIdentifier(..), mkComponentId + , PkgconfigName ) +import Distribution.System + ( Platform, OS(Windows, OSX), buildOS ) +import Distribution.Types.Flag + ( FlagAssignment, showFlagAssignment ) +import Distribution.Simple.Compiler + ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) + , ProfDetailLevel(..), showProfDetailLevel ) +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate ) +import Distribution.Types.PkgconfigVersion (PkgconfigVersion) +import Distribution.Client.HashValue +import Distribution.Client.Types + ( InstalledPackageId ) +import qualified Distribution.Solver.Types.ComponentDeps as CD + +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Map as Map +import qualified Data.Set as Set + +------------------------------- +-- Calculating package hashes +-- + +-- | Calculate a 'InstalledPackageId' for a package using our nix-style +-- inputs hashing method. +-- +-- Note that due to path length limitations on Windows, this function uses +-- a different method on Windows that produces shorted package ids. +-- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'. +-- +hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageId + | buildOS == Windows = hashedInstalledPackageIdShort + | buildOS == OSX = hashedInstalledPackageIdVeryShort + | otherwise = hashedInstalledPackageIdLong + +-- | Calculate a 'InstalledPackageId' for a package using our nix-style +-- inputs hashing method. +-- +-- This produces large ids with big hashes. It is only suitable for systems +-- without significant path length limitations (ie not Windows). +-- +hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageIdLong + pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent} + = mkComponentId $ + prettyShow pkgHashPkgId -- to be a bit user friendly + ++ maybe "" displayComponent pkgHashComponent + ++ "-" + ++ showHashValue (hashPackageHashInputs pkghashinputs) + where + displayComponent :: CD.Component -> String + displayComponent CD.ComponentLib = "" + displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s + displayComponent (CD.ComponentFLib s) = "-f-" ++ prettyShow s + displayComponent (CD.ComponentExe s) = "-e-" ++ prettyShow s + displayComponent (CD.ComponentTest s) = "-t-" ++ prettyShow s + displayComponent (CD.ComponentBench s) = "-b-" ++ prettyShow s + displayComponent CD.ComponentSetup = "-setup" + +-- | On Windows we have serious problems with path lengths. Windows imposes a +-- maximum path length of 260 chars, and even if we can use the windows long +-- path APIs ourselves, we cannot guarantee that ghc, gcc, ld, ar, etc etc all +-- do so too. +-- +-- So our only choice is to limit the lengths of the paths, and the only real +-- way to do that is to limit the size of the 'InstalledPackageId's that we +-- generate. We do this by truncating the package names and versions and also +-- by truncating the hash sizes. +-- +-- Truncating the package names and versions is technically ok because they are +-- just included for human convenience, the full source package id is included +-- in the hash. +-- +-- Truncating the hash size is disappointing but also technically ok. We +-- rely on the hash primarily for collision avoidance not for any security +-- properties (at least for now). +-- +hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = + mkComponentId $ + intercalate "-" + -- max length now 64 + [ truncateStr 14 (prettyShow name) + , truncateStr 8 (prettyShow version) + , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) + ] + where + PackageIdentifier name version = pkgHashPkgId + + -- Truncate a string, with a visual indication that it is truncated. + truncateStr n s | length s <= n = s + | otherwise = take (n-1) s ++ "_" + +-- | On macOS we shorten the name very aggressively. The mach-o linker on +-- macOS has a limited load command size, to which the name of the library +-- as well as its relative path (\@rpath) entry count. To circumvent this, +-- on macOS the libraries are not stored as +-- @store//libHS.dylib@ +-- where libraryname contains the libraries name, version and abi hash, but in +-- @store/lib/libHS.dylib@ +-- where the very short library name drops all vowels from the package name, +-- and truncates the hash to 4 bytes. +-- +-- We therefore we only need one \@rpath entry to @store/lib@ instead of one +-- \@rpath entry for each library. And the reduced library name saves some +-- additional space. +-- +-- This however has two major drawbacks: +-- 1) Packages can collide more easily due to the shortened hash. +-- 2) The libraries are *not* prefix relocatable anymore as they all end up +-- in the same @store/lib@ folder. +-- +-- The ultimate solution would have to include generating proxy dynamic +-- libraries on macOS, such that the proxy libraries and the linked libraries +-- stay under the load command limit, and the recursive linker is still able +-- to link all of them. +hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = + mkComponentId $ + intercalate "-" + [ filter (not . flip elem "aeiou") (prettyShow name) + , prettyShow version + , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs)) + ] + where + PackageIdentifier name version = pkgHashPkgId + +-- | All the information that contribues to a package's hash, and thus its +-- 'InstalledPackageId'. +-- +data PackageHashInputs = PackageHashInputs { + pkgHashPkgId :: PackageId, + pkgHashComponent :: Maybe CD.Component, + pkgHashSourceHash :: PackageSourceHash, + pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion), + pkgHashDirectDeps :: Set InstalledPackageId, + pkgHashOtherConfig :: PackageHashConfigInputs + } + +type PackageSourceHash = HashValue + +-- | Those parts of the package configuration that contribute to the +-- package hash. +-- +data PackageHashConfigInputs = PackageHashConfigInputs { + pkgHashCompilerId :: CompilerId, + pkgHashPlatform :: Platform, + pkgHashFlagAssignment :: FlagAssignment, -- complete not partial + pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure + pkgHashVanillaLib :: Bool, + pkgHashSharedLib :: Bool, + pkgHashDynExe :: Bool, + pkgHashFullyStaticExe :: Bool, + pkgHashGHCiLib :: Bool, + pkgHashProfLib :: Bool, + pkgHashProfExe :: Bool, + pkgHashProfLibDetail :: ProfDetailLevel, + pkgHashProfExeDetail :: ProfDetailLevel, + pkgHashCoverage :: Bool, + pkgHashOptimization :: OptimisationLevel, + pkgHashSplitObjs :: Bool, + pkgHashSplitSections :: Bool, + pkgHashStripLibs :: Bool, + pkgHashStripExes :: Bool, + pkgHashDebugInfo :: DebugInfoLevel, + pkgHashProgramArgs :: Map String [String], + pkgHashExtraLibDirs :: [FilePath], + pkgHashExtraFrameworkDirs :: [FilePath], + pkgHashExtraIncludeDirs :: [FilePath], + pkgHashProgPrefix :: Maybe PathTemplate, + pkgHashProgSuffix :: Maybe PathTemplate, + + -- Haddock options + pkgHashDocumentation :: Bool, + pkgHashHaddockHoogle :: Bool, + pkgHashHaddockHtml :: Bool, + pkgHashHaddockHtmlLocation :: Maybe String, + pkgHashHaddockForeignLibs :: Bool, + pkgHashHaddockExecutables :: Bool, + pkgHashHaddockTestSuites :: Bool, + pkgHashHaddockBenchmarks :: Bool, + pkgHashHaddockInternal :: Bool, + pkgHashHaddockCss :: Maybe FilePath, + pkgHashHaddockLinkedSource :: Bool, + pkgHashHaddockQuickJump :: Bool, + pkgHashHaddockContents :: Maybe PathTemplate + +-- TODO: [required eventually] pkgHashToolsVersions ? +-- TODO: [required eventually] pkgHashToolsExtraOptions ? + } + deriving Show + + +-- | Calculate the overall hash to be used for an 'InstalledPackageId'. +-- +hashPackageHashInputs :: PackageHashInputs -> HashValue +hashPackageHashInputs = hashValue . renderPackageHashInputs + +-- | Render a textual representation of the 'PackageHashInputs'. +-- +-- The 'hashValue' of this text is the overall package hash. +-- +renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString +renderPackageHashInputs PackageHashInputs{ + pkgHashPkgId, + pkgHashComponent, + pkgHashSourceHash, + pkgHashDirectDeps, + pkgHashPkgConfigDeps, + pkgHashOtherConfig = + PackageHashConfigInputs{..} + } = + -- The purpose of this somewhat laboured rendering (e.g. why not just + -- use show?) is so that existing package hashes do not change + -- unnecessarily when new configuration inputs are added into the hash. + + -- In particular, the assumption is that when a new configuration input + -- is included into the hash, that existing packages will typically get + -- the default value for that feature. So if we avoid adding entries with + -- the default value then most of the time adding new features will not + -- change the hashes of existing packages and so fewer packages will need + -- to be rebuilt. + + --TODO: [nice to have] ultimately we probably want to put this config info + -- into the ghc-pkg db. At that point this should probably be changed to + -- use the config file infrastructure so it can be read back in again. + LBS.pack $ unlines $ catMaybes $ + [ entry "pkgid" prettyShow pkgHashPkgId + , mentry "component" show pkgHashComponent + , entry "src" showHashValue pkgHashSourceHash + , entry "pkg-config-deps" + (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++ + case mb_v of + Nothing -> "" + Just v -> " " ++ prettyShow v) + . Set.toList) pkgHashPkgConfigDeps + , entry "deps" (intercalate ", " . map prettyShow + . Set.toList) pkgHashDirectDeps + -- and then all the config + , entry "compilerid" prettyShow pkgHashCompilerId + , entry "platform" prettyShow pkgHashPlatform + , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment + , opt "configure-script" [] unwords pkgHashConfigureScriptArgs + , opt "vanilla-lib" True prettyShow pkgHashVanillaLib + , opt "shared-lib" False prettyShow pkgHashSharedLib + , opt "dynamic-exe" False prettyShow pkgHashDynExe + , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe + , opt "ghci-lib" False prettyShow pkgHashGHCiLib + , opt "prof-lib" False prettyShow pkgHashProfLib + , opt "prof-exe" False prettyShow pkgHashProfExe + , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail + , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail + , opt "hpc" False prettyShow pkgHashCoverage + , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization + , opt "split-objs" False prettyShow pkgHashSplitObjs + , opt "split-sections" False prettyShow pkgHashSplitSections + , opt "stripped-lib" False prettyShow pkgHashStripLibs + , opt "stripped-exe" True prettyShow pkgHashStripExes + , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo + , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs + , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs + , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs + , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix + , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix + + , opt "documentation" False prettyShow pkgHashDocumentation + , opt "haddock-hoogle" False prettyShow pkgHashHaddockHoogle + , opt "haddock-html" False prettyShow pkgHashHaddockHtml + , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation + , opt "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs + , opt "haddock-executables" False prettyShow pkgHashHaddockExecutables + , opt "haddock-tests" False prettyShow pkgHashHaddockTestSuites + , opt "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks + , opt "haddock-internal" False prettyShow pkgHashHaddockInternal + , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss + , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource + , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump + , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents + + ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs + where + entry key format value = Just (key ++ ": " ++ format value) + mentry key format value = fmap (\v -> key ++ ": " ++ format v) value + opt key def format value + | value == def = Nothing + | otherwise = entry key format value diff --git a/src/Distribution/Client/ParseUtils.hs b/src/Distribution/Client/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ParseUtils.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.ParseUtils +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Parsing utilities. +----------------------------------------------------------------------------- + +module Distribution.Client.ParseUtils ( + + -- * Fields and field utilities + FieldDescr(..), + liftField, + liftFields, + filterFields, + mapFieldNames, + commandOptionToField, + commandOptionsToFields, + + -- * Sections and utilities + SectionDescr(..), + liftSection, + + -- * FieldGrammar sections + FGSectionDescr(..), + + -- * Parsing and printing flat config + parseFields, + ppFields, + ppSection, + + -- * Parsing and printing config with sections and subsections + parseFieldsAndSections, + ppFieldsAndSections, + + -- ** Top level of config files + parseConfig, + showConfig, + ) + where + +import Distribution.Client.Compat.Prelude hiding (empty, get) +import Prelude () + +import Distribution.Deprecated.ParseUtils + ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo + , Field(..), liftField, readFields ) +import Distribution.Deprecated.ViewAsFieldDescr + ( viewAsFieldDescr ) + +import Distribution.Simple.Command + ( OptionField ) + +import Text.PrettyPrint ( ($+$) ) +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import qualified Text.PrettyPrint as Disp + ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) + +-- For new parser stuff +import Distribution.CabalSpecVersion (cabalSpecLatest) +import Distribution.FieldGrammar (partitionFields, parseFieldGrammar) +import Distribution.Fields.ParseResult (runParseResult) +import Distribution.Parsec.Error (showPError) +import Distribution.Parsec.Position (Position (..)) +import Distribution.Parsec.Warning (showPWarning) +import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) +import qualified Distribution.Fields as F +import qualified Distribution.FieldGrammar as FG + + +------------------------- +-- FieldDescr utilities +-- + +liftFields :: (b -> a) + -> (a -> b -> b) + -> [FieldDescr a] + -> [FieldDescr b] +liftFields get set = map (liftField get set) + + +-- | Given a collection of field descriptions, keep only a given list of them, +-- identified by name. +-- +filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a] +filterFields includeFields = filter ((`elem` includeFields) . fieldName) + +-- | Apply a name mangling function to the field names of all the field +-- descriptions. The typical use case is to apply some prefix. +-- +mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a] +mapFieldNames mangleName = + map (\descr -> descr { fieldName = mangleName (fieldName descr) }) + + +-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'. +-- +commandOptionToField :: OptionField a -> FieldDescr a +commandOptionToField = viewAsFieldDescr + +-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's. +-- +commandOptionsToFields :: [OptionField a] -> [FieldDescr a] +commandOptionsToFields = map viewAsFieldDescr + + +------------------------------------------ +-- SectionDescr definition and utilities +-- + +-- | The description of a section in a config file. It can contain both +-- fields and optionally further subsections. See also 'FieldDescr'. +-- +data SectionDescr a = forall b. SectionDescr { + sectionName :: String, + sectionFields :: [FieldDescr b], + sectionSubsections :: [SectionDescr b], + sectionGet :: a -> [(String, b)], + sectionSet :: LineNo -> String -> b -> a -> ParseResult a, + sectionEmpty :: b + } + +-- | 'FieldGrammar' section description +data FGSectionDescr g a = forall s. FGSectionDescr + { fgSectionName :: String + , fgSectionGrammar :: g s s + -- todo: add subsections? + , fgSectionGet :: a -> [(String, s)] + , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a + } + +-- | To help construction of config file descriptions in a modular way it is +-- useful to define fields and sections on local types and then hoist them +-- into the parent types when combining them in bigger descriptions. +-- +-- This is essentially a lens operation for 'SectionDescr' to help embedding +-- one inside another. +-- +liftSection :: (b -> a) + -> (a -> b -> b) + -> SectionDescr a + -> SectionDescr b +liftSection get' set' (SectionDescr name fields sections get set empty) = + let sectionGet' = get . get' + sectionSet' lineno param x y = do + x' <- set lineno param x (get' y) + return (set' x' y) + in SectionDescr name fields sections sectionGet' sectionSet' empty + + +------------------------------------- +-- Parsing and printing flat config +-- + +-- | Parse a bunch of semi-parsed 'Field's according to a set of field +-- descriptions. It accumulates the result on top of a given initial value. +-- +-- This only covers the case of flat configuration without subsections. See +-- also 'parseFieldsAndSections'. +-- +parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a +parseFields fieldDescrs = + foldM setField + where + fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] + + setField accum (F line name value) = + case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning $ "Unrecognized field " ++ name ++ " on line " ++ show line + return accum + + setField accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils +-- that also optionally print default values for empty fields as comments. +-- +ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc +ppFields fields def cur = + Disp.vcat [ ppField name (fmap getter def) (getter cur) + | FieldDescr name getter _ <- fields] + +ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc +ppField name mdef cur + | Disp.isEmpty cur = maybe Disp.empty + (\def -> Disp.text "--" <+> Disp.text name + Disp.<> Disp.colon <+> def) mdef + | otherwise = Disp.text name Disp.<> Disp.colon <+> cur + +-- | Pretty print a section. +-- +-- Since 'ppFields' does not cover subsections you can use this to add them. +-- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'. +-- +ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc +ppSection name arg fields def cur + | Disp.isEmpty fieldsDoc = Disp.empty + | otherwise = Disp.text name <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) + where + fieldsDoc = ppFields fields def cur + argDoc | arg == "" = Disp.empty + | otherwise = Disp.text arg + + +----------------------------------------- +-- Parsing and printing non-flat config +-- + +-- | Much like 'parseFields' but it also allows subsections. The permitted +-- subsections are given by a list of 'SectionDescr's. +-- +parseFieldsAndSections + :: [FieldDescr a] -- ^ field + -> [SectionDescr a] -- ^ legacy sections + -> [FGSectionDescr FG.ParsecFieldGrammar a] -- ^ FieldGrammar sections + -> a + -> [Field] -> ParseResult a +parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = + foldM setField + where + fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] + sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ] + fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ] + + setField a (F line name value) = + case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value a + Nothing -> do + warning $ "Unrecognized field '" ++ name + ++ "' on line " ++ show line + return a + + setField a (Section line name param fields) = + case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of + Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do + b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields + set line param b a + Just (Right (FGSectionDescr _ grammar _getter setter)) -> do + let fields1 = map convertField fields + (fields2, sections) = partitionFields fields1 + -- TODO: recurse into sections + for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) -> + warning $ "Unrecognized section '" ++ fromUTF8BS name' + ++ "' on line " ++ show line' + case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of + (warnings, Right b) -> do + for_ warnings $ \w -> warning $ showPWarning "???" w + setter line param b a + (warnings, Left (_, errs)) -> do + for_ warnings $ \w -> warning $ showPWarning "???" w + case errs of + err :| _errs -> fail $ showPError "???" err + Nothing -> do + warning $ "Unrecognized section '" ++ name + ++ "' on line " ++ show line + return a + +convertField :: Field -> F.Field Position +convertField (F line name str) = + F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ] + where + pos = Position line 0 +-- arguments omitted +convertField (Section line name _arg fields) = + F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields) + where + pos = Position line 0 + +-- | Much like 'ppFields' but also pretty prints any subsections. Subsection +-- are only shown if they are non-empty. +-- +-- Note that unlike 'ppFields', at present it does not support printing +-- default values. If needed, adding such support would be quite reasonable. +-- +ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc +ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val = + ppFields fieldDescrs Nothing val + $+$ + Disp.vcat ( + [ Disp.text "" $+$ sectionDoc + | SectionDescr { + sectionName, sectionGet, + sectionFields, sectionSubsections + } <- sectionDescrs + , (param, x) <- sectionGet val + , let sectionDoc = ppSectionAndSubsections + sectionName param + sectionFields sectionSubsections [] x + , not (Disp.isEmpty sectionDoc) + ] ++ + [ Disp.text "" $+$ sectionDoc + | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs + , (param, x) <- fgSectionGet val + , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x + , not (Disp.isEmpty sectionDoc) + ]) + +-- | Unlike 'ppSection' which has to be called directly, this gets used via +-- 'ppFieldsAndSections' and so does not need to be exported. +-- +ppSectionAndSubsections :: String -> String + -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc +ppSectionAndSubsections name arg fields sections fgSections cur + | Disp.isEmpty fieldsDoc = Disp.empty + | otherwise = Disp.text name <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) + where + fieldsDoc = showConfig fields sections fgSections cur + argDoc | arg == "" = Disp.empty + | otherwise = Disp.text arg + +-- | +-- +-- TODO: subsections +-- TODO: this should simply build 'PrettyField' +ppFgSection + :: String -- ^ section name + -> String -- ^ parameter + -> FG.PrettyFieldGrammar a a + -> a + -> Disp.Doc +ppFgSection secName arg grammar x + | null prettyFields = Disp.empty + | otherwise = + Disp.text secName <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) + where + prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x + + argDoc | arg == "" = Disp.empty + | otherwise = Disp.text arg + + fieldsDoc = Disp.vcat + [ Disp.text fname' <<>> Disp.colon <<>> doc + | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections + , let fname' = fromUTF8BS fname + ] + + +----------------------------------------------- +-- Top level config file parsing and printing +-- + +-- | Parse a string in the config file syntax into a value, based on a +-- description of the configuration file in terms of its fields and sections. +-- +-- It accumulates the result on top of a given initial (typically empty) value. +-- +parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a + -> BS.ByteString -> ParseResult a +parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str = + parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty + =<< readFields str + +-- | Render a value in the config file syntax, based on a description of the +-- configuration file in terms of its fields and sections. +-- +showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc +showConfig = ppFieldsAndSections + diff --git a/src/Distribution/Client/ProjectBuilding.hs b/src/Distribution/Client/ProjectBuilding.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectBuilding.hs @@ -0,0 +1,1489 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- +module Distribution.Client.ProjectBuilding ( + -- * Dry run phase + -- | What bits of the plan will we execute? The dry run does not change + -- anything but tells us what will need to be built. + rebuildTargetsDryRun, + improveInstallPlanWithUpToDatePackages, + + -- ** Build status + -- | This is the detailed status information we get from the dry run. + BuildStatusMap, + BuildStatus(..), + BuildStatusRebuild(..), + BuildReason(..), + MonitorChangedReason(..), + buildStatusToString, + + -- * Build phase + -- | Now we actually execute the plan. + rebuildTargets, + -- ** Build outcomes + -- | This is the outcome for each package of executing the plan. + -- For each package, did the build succeed or fail? + BuildOutcomes, + BuildOutcome, + BuildResult(..), + BuildFailure(..), + BuildFailureReason(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.PackageHash (renderPackageHashInputs) +import Distribution.Client.RebuildMonad +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.Store + +import Distribution.Client.Types + hiding (BuildOutcomes, BuildOutcome, + BuildResult(..), BuildFailure(..)) +import Distribution.Client.InstallPlan + ( GenericInstallPlan, GenericPlanPackage, IsUnit ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.DistDirLayout +import Distribution.Client.FileMonitor +import Distribution.Client.SetupWrapper +import Distribution.Client.JobControl +import Distribution.Client.FetchUtils +import Distribution.Client.GlobalFlags (RepoContext) +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Setup + ( filterConfigureFlags, filterHaddockArgs + , filterHaddockFlags, filterTestFlags ) +import Distribution.Client.SourceFiles +import Distribution.Client.SrcDist (allPackageSourceFiles) +import Distribution.Client.Utils + ( ProgressPhase(..), progressMessage, removeExistingFile ) + +import Distribution.Compat.Lens +import Distribution.Package +import qualified Distribution.PackageDescription as PD +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Simple.BuildPaths (haddockDirName) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Types.BuildType +import Distribution.Types.PackageDescription.Lens (componentModules) +import Distribution.Simple.Program +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Command (CommandUI) +import qualified Distribution.Simple.Register as Cabal +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), LibraryName(..) ) +import Distribution.Simple.Compiler + ( Compiler, compilerId, PackageDB(..) ) + +import Distribution.Simple.Utils +import Distribution.Version +import Distribution.Compat.Graph (IsNode(..)) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS + +import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) +import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) +import System.IO (IOMode (AppendMode), withFile) + +import Distribution.Compat.Directory (listDirectory) + + +------------------------------------------------------------------------------ +-- * Overall building strategy. +------------------------------------------------------------------------------ +-- +-- We start with an 'ElaboratedInstallPlan' that has already been improved by +-- reusing packages from the store, and pruned to include only the targets of +-- interest and their dependencies. So the remaining packages in the +-- 'InstallPlan.Configured' state are ones we either need to build or rebuild. +-- +-- First, we do a preliminary dry run phase where we work out which packages +-- we really need to (re)build, and for the ones we do need to build which +-- build phase to start at. +-- +-- We use this to improve the 'ElaboratedInstallPlan' again by changing +-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed' +-- so that the build phase will skip them. +-- +-- Then we execute the plan, that is actually build packages. The outcomes of +-- trying to build all the packages are collected and returned. +-- +-- We split things like this (dry run and execute) for a couple reasons. +-- Firstly we need to be able to do dry runs anyway, and these need to be +-- reasonably accurate in terms of letting users know what (and why) things +-- are going to be (re)built. +-- +-- Given that we need to be able to do dry runs, it would not be great if +-- we had to repeat all the same work when we do it for real. Not only is +-- it duplicate work, but it's duplicate code which is likely to get out of +-- sync. So we do things only once. We preserve info we discover in the dry +-- run phase and rely on it later when we build things for real. This also +-- somewhat simplifies the build phase. So this way the dry run can't so +-- easily drift out of sync with the real thing since we're relying on the +-- info it produces. +-- +-- An additional advantage is that it makes it easier to debug rebuild +-- errors (ie rebuilding too much or too little), since all the rebuild +-- decisions are made without making any state changes at the same time +-- (that would make it harder to reproduce the problem situation). +-- +-- Finally, we can use the dry run build status and the build outcomes to +-- give us some information on the overall status of packages in the project. +-- This includes limited information about the status of things that were +-- not actually in the subset of the plan that was used for the dry run or +-- execution phases. In particular we may know that some packages are now +-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for +-- details. + + +------------------------------------------------------------------------------ +-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? +------------------------------------------------------------------------------ + +-- Refer to ProjectBuilding.Types for details of these important types: + +-- type BuildStatusMap = ... +-- data BuildStatus = ... +-- data BuildStatusRebuild = ... +-- data BuildReason = ... + +-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. +-- +-- It gives us the 'BuildStatusMap'. This should be used with +-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of +-- the 'ElaboratedInstallPlan' with packages switched to the +-- 'InstallPlan.Installed' state when we find that they're already up to date. +-- +rebuildTargetsDryRun :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> IO BuildStatusMap +rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = + -- Do the various checks to work out the 'BuildStatus' of each package + foldMInstallPlanDepOrder dryRunPkg + where + dryRunPkg :: ElaboratedPlanPackage + -> [BuildStatus] + -> IO BuildStatus + dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = + return BuildStatusPreExisting + + dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus = + return BuildStatusInstalled + + dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do + mloc <- checkFetched (elabPkgSourceLocation pkg) + case mloc of + Nothing -> return BuildStatusDownload + + Just (LocalUnpackedPackage srcdir) -> + -- For the case of a user-managed local dir, irrespective of the + -- build style, we build from that directory and put build + -- artifacts under the shared dist directory. + dryRunLocalPkg pkg depsBuildStatus srcdir + + -- The rest cases are all tarball cases are, + -- and handled the same as each other though depending on the build style. + Just (LocalTarballPackage tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + Just (RemoteTarballPackage _ tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + Just (RepoTarballPackage _ _ tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + Just (RemoteSourceRepoPackage _repo tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + + dryRunTarballPkg :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus + dryRunTarballPkg pkg depsBuildStatus tarball = + case elabBuildStyle pkg of + BuildAndInstall -> return (BuildStatusUnpack tarball) + BuildInplaceOnly -> do + -- TODO: [nice to have] use a proper file monitor rather + -- than this dir exists test + exists <- doesDirectoryExist srcdir + if exists + then dryRunLocalPkg pkg depsBuildStatus srcdir + else return (BuildStatusUnpack tarball) + where + srcdir = distUnpackedSrcDirectory (packageId pkg) + + dryRunLocalPkg :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus + dryRunLocalPkg pkg depsBuildStatus srcdir = do + -- Go and do lots of I/O, reading caches and probing files to work out + -- if anything has changed + change <- checkPackageFileMonitorChanged + packageFileMonitor pkg srcdir depsBuildStatus + case change of + -- It did change, giving us 'BuildStatusRebuild' info on why + Left rebuild -> + return (BuildStatusRebuild srcdir rebuild) + + -- No changes, the package is up to date. Use the saved build results. + Right buildResult -> + return (BuildStatusUpToDate buildResult) + where + packageFileMonitor = + newPackageFileMonitor shared distDirLayout + (elabDistDirParams shared pkg) + + +-- | A specialised traversal over the packages in an install plan. +-- +-- The packages are visited in dependency order, starting with packages with no +-- dependencies. The result for each package is accumulated into a 'Map' and +-- returned as the final result. In addition, when visiting a package, the +-- visiting function is passed the results for all the immediate package +-- dependencies. This can be used to propagate information from dependencies. +-- +foldMInstallPlanDepOrder + :: forall m ipkg srcpkg b. + (Monad m, IsUnit ipkg, IsUnit srcpkg) + => (GenericPlanPackage ipkg srcpkg -> + [b] -> m b) + -> GenericInstallPlan ipkg srcpkg + -> m (Map UnitId b) +foldMInstallPlanDepOrder visit = + go Map.empty . InstallPlan.reverseTopologicalOrder + where + go :: Map UnitId b + -> [GenericPlanPackage ipkg srcpkg] + -> m (Map UnitId b) + go !results [] = return results + + go !results (pkg : pkgs) = do + -- we go in the right order so the results map has entries for all deps + let depresults :: [b] + depresults = + map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results + in result) + (InstallPlan.depends pkg) + result <- visit pkg depresults + let results' = Map.insert (nodeKey pkg) result results + go results' pkgs + +improveInstallPlanWithUpToDatePackages :: BuildStatusMap + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan +improveInstallPlanWithUpToDatePackages pkgsBuildStatus = + InstallPlan.installed canPackageBeImproved + where + canPackageBeImproved pkg = + case Map.lookup (installedUnitId pkg) pkgsBuildStatus of + Just BuildStatusUpToDate {} -> True + Just _ -> False + Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " + ++ prettyShow (packageId pkg) ++ " not in status map" + + +----------------------------- +-- Package change detection +-- + +-- | As part of the dry run for local unpacked packages we have to check if the +-- package config or files have changed. That is the purpose of +-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. +-- +-- When a package is (re)built, the monitor must be updated to reflect the new +-- state of the package. Because we sometimes build without reconfiguring the +-- state updates are split into two, one for package config changes and one +-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' +-- and 'updatePackageBuildFileMonitor'. +-- +data PackageFileMonitor = PackageFileMonitor { + pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), + pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, + pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) + } + +-- | This is all the components of the 'BuildResult' other than the +-- @['InstalledPackageInfo']@. +-- +-- We have to split up the 'BuildResult' components since they get produced +-- at different times (or rather, when different things change). +-- +type BuildResultMisc = (DocsResult, TestsResult) + +newPackageFileMonitor :: ElaboratedSharedConfig + -> DistDirLayout + -> DistDirParams + -> PackageFileMonitor +newPackageFileMonitor shared + DistDirLayout{distPackageCacheFile} + dparams = + PackageFileMonitor { + pkgFileMonitorConfig = + FileMonitor { + fileMonitorCacheFile = distPackageCacheFile dparams "config", + fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared, + fileMonitorCheckIfOnlyValueChanged = False + }, + + pkgFileMonitorBuild = + FileMonitor { + fileMonitorCacheFile = distPackageCacheFile dparams "build", + fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> + componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, + fileMonitorCheckIfOnlyValueChanged = True + }, + + pkgFileMonitorReg = + newFileMonitor (distPackageCacheFile dparams "registration") + } + +-- | Helper function for 'checkPackageFileMonitorChanged', +-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. +-- +-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by +-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. +-- +packageFileMonitorKeyValues :: ElaboratedConfiguredPackage + -> (ElaboratedConfiguredPackage, Set ComponentName) +packageFileMonitorKeyValues elab = + (elab_config, buildComponents) + where + -- The first part is the value used to guard (re)configuring the package. + -- That is, if this value changes then we will reconfigure. + -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of + -- information that affects the (re)configure step. But those parts that + -- do not affect the configure step need to be nulled out. Those parts are + -- the specific targets that we're going to build. + -- + elab_config = + elab { + elabBuildTargets = [], + elabTestTargets = [], + elabBenchTargets = [], + elabReplTarget = Nothing, + elabHaddockTargets = [], + elabBuildHaddocks = False + } + + -- The second part is the value used to guard the build step. So this is + -- more or less the opposite of the first part, as it's just the info about + -- what targets we're going to build. + -- + buildComponents = elabBuildTargetWholeComponents elab + +-- | Do all the checks on whether a package has changed and thus needs either +-- rebuilding or reconfiguring and rebuilding. +-- +checkPackageFileMonitorChanged :: PackageFileMonitor + -> ElaboratedConfiguredPackage + -> FilePath + -> [BuildStatus] + -> IO (Either BuildStatusRebuild BuildResult) +checkPackageFileMonitorChanged PackageFileMonitor{..} + pkg srcdir depsBuildStatus = do + --TODO: [nice to have] some debug-level message about file + --changes, like rerunIfChanged + configChanged <- checkFileMonitorChanged + pkgFileMonitorConfig srcdir pkgconfig + case configChanged of + MonitorChanged monitorReason -> + return (Left (BuildStatusConfigure monitorReason')) + where + monitorReason' = fmap (const ()) monitorReason + + MonitorUnchanged () _ + -- The configChanged here includes the identity of the dependencies, + -- so depsBuildStatus is just needed for the changes in the content + -- of dependencies. + | any buildStatusRequiresBuild depsBuildStatus -> do + regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () + let mreg = changedToMaybe regChanged + return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) + + | otherwise -> do + buildChanged <- checkFileMonitorChanged + pkgFileMonitorBuild srcdir buildComponents + regChanged <- checkFileMonitorChanged + pkgFileMonitorReg srcdir () + let mreg = changedToMaybe regChanged + case (buildChanged, regChanged) of + (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonExtraTargets prevBuildComponents + + (MonitorChanged monitorReason, _) -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonFilesChanged monitorReason' + monitorReason' = fmap (const ()) monitorReason + + (MonitorUnchanged _ _, MonitorChanged monitorReason) -> + -- this should only happen if the file is corrupt or been + -- manually deleted. We don't want to bother with another + -- phase just for this, so we'll reregister by doing a build. + return (Left (BuildStatusBuild Nothing buildReason)) + where + buildReason = BuildReasonFilesChanged monitorReason' + monitorReason' = fmap (const ()) monitorReason + + (MonitorUnchanged _ _, MonitorUnchanged _ _) + | pkgHasEphemeralBuildTargets pkg -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonEphemeralTargets + + (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> + return $ Right BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = Nothing + } + where + (docsResult, testsResult) = buildResult + where + (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + changedToMaybe (MonitorChanged _) = Nothing + changedToMaybe (MonitorUnchanged x _) = Just x + + +updatePackageConfigFileMonitor :: PackageFileMonitor + -> FilePath + -> ElaboratedConfiguredPackage + -> IO () +updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig} + srcdir pkg = + updateFileMonitor pkgFileMonitorConfig srcdir Nothing + [] pkgconfig () + where + (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg + +updatePackageBuildFileMonitor :: PackageFileMonitor + -> FilePath + -> MonitorTimestamp + -> ElaboratedConfiguredPackage + -> BuildStatusRebuild + -> [MonitorFilePath] + -> BuildResultMisc + -> IO () +updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} + srcdir timestamp pkg pkgBuildStatus + monitors buildResult = + updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) + monitors buildComponents' buildResult + where + (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + + -- If the only thing that's changed is that we're now building extra + -- components, then we can avoid later unnecessary rebuilds by saving the + -- total set of components that have been built, namely the union of the + -- existing ones plus the new ones. If files also changed this would be + -- the wrong thing to do. Note that we rely on the + -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee + -- that it's /only/ the value that changed not any files that changed. + buildComponents' = + case pkgBuildStatus of + BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) + -> buildComponents `Set.union` prevBuildComponents + _ -> buildComponents + +updatePackageRegFileMonitor :: PackageFileMonitor + -> FilePath + -> Maybe InstalledPackageInfo + -> IO () +updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} + srcdir mipkg = + updateFileMonitor pkgFileMonitorReg srcdir Nothing + [] () mipkg + +invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () +invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = + removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) + + +------------------------------------------------------------------------------ +-- * Doing it: executing an 'ElaboratedInstallPlan' +------------------------------------------------------------------------------ + +-- Refer to ProjectBuilding.Types for details of these important types: + +-- type BuildOutcomes = ... +-- type BuildOutcome = ... +-- data BuildResult = ... +-- data BuildFailure = ... +-- data BuildFailureReason = ... + +-- | Build things for real. +-- +-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. +-- +rebuildTargets :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> BuildStatusMap + -> BuildTimeSettings + -> IO BuildOutcomes +rebuildTargets verbosity + distDirLayout@DistDirLayout{..} + storeDirLayout + installPlan + sharedPackageConfig@ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb + } + pkgsBuildStatus + buildSettings@BuildTimeSettings{ + buildSettingNumJobs, + buildSettingKeepGoing + } = do + + -- Concurrency control: create the job controller and concurrency limits + -- for downloading, building and installing. + jobControl <- if isParallelBuild + then newParallelJobControl buildSettingNumJobs + else newSerialJobControl + registerLock <- newLock -- serialise registration + cacheLock <- newLock -- serialise access to setup exe cache + --TODO: [code cleanup] eliminate setup exe cache + + debug verbosity $ + "Executing install plan " + ++ if isParallelBuild + then " in parallel using " ++ show buildSettingNumJobs ++ " threads." + else " serially." + + createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory + createDirectoryIfMissingVerbose verbosity True distTempDirectory + traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + + -- Before traversing the install plan, pre-emptively find all packages that + -- will need to be downloaded and start downloading them. + asyncDownloadPackages verbosity withRepoCtx + installPlan pkgsBuildStatus $ \downloadMap -> + + -- For each package in the plan, in dependency order, but in parallel... + InstallPlan.execute jobControl keepGoing + (BuildFailure Nothing . DependentFailed . packageId) + installPlan $ \pkg -> + --TODO: review exception handling + handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ + + let uid = installedUnitId pkg + pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in + + rebuildTarget + verbosity + distDirLayout + storeDirLayout + buildSettings downloadMap + registerLock cacheLock + sharedPackageConfig + installPlan pkg + pkgBuildStatus + where + isParallelBuild = buildSettingNumJobs >= 2 + keepGoing = buildSettingKeepGoing + withRepoCtx = projectConfigWithBuilderRepoContext verbosity + buildSettings + packageDBsToUse = -- all the package dbs we may need to create + (Set.toList . Set.fromList) + [ pkgdb + | InstallPlan.Configured elab <- InstallPlan.toList installPlan + , pkgdb <- concat [ elabBuildPackageDBStack elab + , elabRegisterPackageDBStack elab + , elabSetupPackageDBStack elab ] + ] + + +-- | Create a package DB if it does not currently exist. Note that this action +-- is /not/ safe to run concurrently. +-- +createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb + -> PackageDB -> IO () +createPackageDBIfMissing verbosity compiler progdb + (SpecificPackageDB dbPath) = do + exists <- Cabal.doesPackageDBExist dbPath + unless exists $ do + createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + Cabal.createPackageDB verbosity compiler progdb False dbPath +createPackageDBIfMissing _ _ _ _ = return () + + +-- | Given all the context and resources, (re)build an individual package. +-- +rebuildTarget :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> BuildTimeSettings + -> AsyncFetchMap + -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatus + -> IO BuildResult +rebuildTarget verbosity + distDirLayout@DistDirLayout{distBuildDirectory} + storeDirLayout + buildSettings downloadMap + registerLock cacheLock + sharedPackageConfig + plan rpkg@(ReadyPackage pkg) + pkgBuildStatus + -- Technically, doing the --only-download filtering only in this function is + -- not perfect. We could also prune the plan at an earlier stage, like it's + -- done with --only-dependencies. But... + -- * the benefit would be minimal (practically just avoiding to print the + -- "requires build" parts of the plan) + -- * we currently don't have easy access to the BuildStatus of packages + -- in the pruning phase + -- * we still have to check it here to avoid performing successive phases + | buildSettingOnlyDownload buildSettings = do + case pkgBuildStatus of + BuildStatusDownload -> + void $ waitAsyncPackageDownload verbosity downloadMap pkg + _ -> return () + return $ BuildResult DocsNotTried TestsNotTried Nothing + | otherwise = + -- We rely on the 'BuildStatus' to decide which phase to start from: + case pkgBuildStatus of + BuildStatusDownload -> downloadPhase + BuildStatusUnpack tarball -> unpackTarballPhase tarball + BuildStatusRebuild srcdir status -> rebuildPhase status srcdir + + -- TODO: perhaps re-nest the types to make these impossible + BuildStatusPreExisting {} -> unexpectedState + BuildStatusInstalled {} -> unexpectedState + BuildStatusUpToDate {} -> unexpectedState + where + unexpectedState = error "rebuildTarget: unexpected package status" + + downloadPhase = do + downsrcloc <- annotateFailureNoLog DownloadFailed $ + waitAsyncPackageDownload verbosity downloadMap pkg + case downsrcloc of + DownloadedTarball tarball -> unpackTarballPhase tarball + --TODO: [nice to have] git/darcs repos etc + + + unpackTarballPhase tarball = + withTarballLocalDirectory + verbosity distDirLayout tarball + (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) + (elabBuildStyle pkg) + (elabPkgDescriptionOverride pkg) $ + + case elabBuildStyle pkg of + BuildAndInstall -> buildAndInstall + BuildInplaceOnly -> buildInplace buildStatus + where + buildStatus = BuildStatusConfigure MonitorFirstRun + + -- Note that this really is rebuild, not build. It can only happen for + -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages + -- would only start from download or unpack phases. + -- + rebuildPhase buildStatus srcdir = + assert (elabBuildStyle pkg == BuildInplaceOnly) $ + + buildInplace buildStatus srcdir builddir + where + builddir = distBuildDirectory + (elabDistDirParams sharedPackageConfig pkg) + + buildAndInstall srcdir builddir = + buildAndInstallUnpackedPackage + verbosity distDirLayout storeDirLayout + buildSettings registerLock cacheLock + sharedPackageConfig + plan rpkg + srcdir builddir' + where + builddir' = makeRelative srcdir builddir + --TODO: [nice to have] ^^ do this relative stuff better + + buildInplace buildStatus srcdir builddir = + --TODO: [nice to have] use a relative build dir rather than absolute + buildInplaceUnpackedPackage + verbosity distDirLayout + buildSettings registerLock cacheLock + sharedPackageConfig + plan rpkg + buildStatus + srcdir builddir + +-- TODO: [nice to have] do we need to use a with-style for the temp +-- files for downloading http packages, or are we going to cache them +-- persistently? + +-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the +-- packages we have to download and fork off an async action to download them. +-- We download them in dependency order so that the one's we'll need +-- first are the ones we will start downloading first. +-- +-- The body action is passed a map from those packages (identified by their +-- location) to a completion var for that package. So the body action should +-- lookup the location and use 'waitAsyncPackageDownload' to get the result. +-- +asyncDownloadPackages :: Verbosity + -> ((RepoContext -> IO a) -> IO a) + -> ElaboratedInstallPlan + -> BuildStatusMap + -> (AsyncFetchMap -> IO a) + -> IO a +asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body + | null pkgsToDownload = body Map.empty + | otherwise = withRepoCtx $ \repoctx -> + asyncFetchPackages verbosity repoctx + pkgsToDownload body + where + pkgsToDownload = + ordNub $ + [ elabPkgSourceLocation elab + | InstallPlan.Configured elab + <- InstallPlan.reverseTopologicalOrder installPlan + , let uid = installedUnitId elab + pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus + , BuildStatusDownload <- [pkgBuildStatus] + ] + + +-- | Check if a package needs downloading, and if so expect to find a download +-- in progress in the given 'AsyncFetchMap' and wait on it to finish. +-- +waitAsyncPackageDownload :: Verbosity + -> AsyncFetchMap + -> ElaboratedConfiguredPackage + -> IO DownloadedSourceLocation +waitAsyncPackageDownload verbosity downloadMap elab = do + pkgloc <- waitAsyncFetchPackage verbosity downloadMap + (elabPkgSourceLocation elab) + case downloadedSourceLocation pkgloc of + Just loc -> return loc + Nothing -> fail "waitAsyncPackageDownload: unexpected source location" + +data DownloadedSourceLocation = DownloadedTarball FilePath + --TODO: [nice to have] git/darcs repos etc + +downloadedSourceLocation :: PackageLocation FilePath + -> Maybe DownloadedSourceLocation +downloadedSourceLocation pkgloc = + case pkgloc of + RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) + RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) + _ -> Nothing + + + + +-- | Ensure that the package is unpacked in an appropriate directory, either +-- a temporary one or a persistent one under the shared dist directory. +-- +withTarballLocalDirectory + :: Verbosity + -> DistDirLayout + -> FilePath + -> PackageId + -> DistDirParams + -> BuildStyle + -> Maybe CabalFileText + -> (FilePath -> -- Source directory + FilePath -> -- Build directory + IO a) + -> IO a +withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} + tarball pkgid dparams buildstyle pkgTextOverride + buildPkg = + case buildstyle of + -- In this case we make a temp dir (e.g. tmp/src2345/), unpack + -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for + -- compatibility we put the dist dir within it + -- (i.e. tmp/src2345/foo-1.0/dist/). + -- + -- Unfortunately, a few custom Setup.hs scripts do not respect + -- the --builddir flag and always look for it at ./dist/ so + -- this way we avoid breaking those packages + BuildAndInstall -> + let tmpdir = distTempDirectory in + withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do + unpackPackageTarball verbosity tarball unpackdir + pkgid pkgTextOverride + let srcdir = unpackdir prettyShow pkgid + builddir = srcdir "dist" + buildPkg srcdir builddir + + -- In this case we make sure the tarball has been unpacked to the + -- appropriate location under the shared dist dir, and then build it + -- inplace there + BuildInplaceOnly -> do + let srcrootdir = distUnpackedSrcRootDirectory + srcdir = distUnpackedSrcDirectory pkgid + builddir = distBuildDirectory dparams + -- TODO: [nice to have] use a proper file monitor rather + -- than this dir exists test + exists <- doesDirectoryExist srcdir + unless exists $ do + createDirectoryIfMissingVerbose verbosity True srcrootdir + unpackPackageTarball verbosity tarball srcrootdir + pkgid pkgTextOverride + moveTarballShippedDistDirectory verbosity distDirLayout + srcrootdir pkgid dparams + buildPkg srcdir builddir + + +unpackPackageTarball :: Verbosity -> FilePath -> FilePath + -> PackageId -> Maybe CabalFileText + -> IO () +unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = + --TODO: [nice to have] switch to tar package and catch tar exceptions + annotateFailureNoLog UnpackFailed $ do + + -- Unpack the tarball + -- + info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." + Tar.extractTarGzFile parentdir pkgsubdir tarball + + -- Sanity check + -- + exists <- doesFileExist cabalFile + unless exists $ + die' verbosity $ + "Package .cabal file not found in the tarball: " ++ cabalFile + + -- Overwrite the .cabal with the one from the index, when appropriate + -- + case pkgTextOverride of + Nothing -> return () + Just pkgtxt -> do + info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic cabalFile pkgtxt + + where + cabalFile = parentdir pkgsubdir + prettyShow pkgname <.> "cabal" + pkgsubdir = prettyShow pkgid + pkgname = packageName pkgid + + +-- | This is a bit of a hacky workaround. A number of packages ship +-- pre-processed .hs files in a dist directory inside the tarball. We don't +-- use the standard 'dist' location so unless we move this dist dir to the +-- right place then we'll miss the shipped pre-procssed files. This hacky +-- approach to shipped pre-procssed files ought to be replaced by a proper +-- system, though we'll still need to keep this hack for older packages. +-- +moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout + -> FilePath -> PackageId -> DistDirParams + -> IO () +moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} + parentdir pkgid dparams = do + distDirExists <- doesDirectoryExist tarballDistDir + when distDirExists $ do + debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" + ++ targetDistDir ++ "'" + --TODO: [nice to have] or perhaps better to copy, and use a file monitor + renameDirectory tarballDistDir targetDistDir + where + tarballDistDir = parentdir prettyShow pkgid "dist" + targetDistDir = distBuildDirectory dparams + + +buildAndInstallUnpackedPackage :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> BuildTimeSettings -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> FilePath -> FilePath + -> IO BuildResult +buildAndInstallUnpackedPackage verbosity + distDirLayout@DistDirLayout{distTempDirectory} + storeDirLayout@StoreDirLayout { + storePackageDBStack + } + BuildTimeSettings { + buildSettingNumJobs, + buildSettingLogFile + } + registerLock cacheLock + pkgshared@ElaboratedSharedConfig { + pkgConfigPlatform = platform, + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb + } + plan rpkg@(ReadyPackage pkg) + srcdir builddir = do + + createDirectoryIfMissingVerbose verbosity True (srcdir builddir) + initLogFile + + --TODO: [code cleanup] deal consistently with talking to older + -- Setup.hs versions, much like we do for ghc, with a proper + -- options type and rendering step which will also let us + -- call directly into the lib, rather than always going via + -- the lib's command line interface, which would also allow + -- passing data like installed packages, compiler, and + -- program db for a quicker configure. + + --TODO: [required feature] docs and tests + --TODO: [required feature] sudo re-exec + + -- Configure phase + noticeProgress ProgressStarting + + annotateFailure mlogFile ConfigureFailed $ + setup' configureCommand configureFlags configureArgs + + -- Build phase + noticeProgress ProgressBuilding + + annotateFailure mlogFile BuildFailed $ + setup buildCommand buildFlags + + -- Haddock phase + whenHaddock $ do + noticeProgress ProgressHaddock + annotateFailureNoLog HaddocksFailed $ + setup haddockCommand haddockFlags + + -- Install phase + noticeProgress ProgressInstalling + annotateFailure mlogFile InstallFailed $ do + + let copyPkgFiles tmpDir = do + let tmpDirNormalised = normalise tmpDir + setup Cabal.copyCommand (copyFlags tmpDirNormalised) + -- Note that the copy command has put the files into + -- @$tmpDir/$prefix@ so we need to return this dir so + -- the store knows which dir will be the final store entry. + let prefix = normalise $ + dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + entryDir = tmpDirNormalised prefix + + -- if there weren't anything to build, it might be that directory is not created + -- the @setup Cabal.copyCommand@ above might do nothing. + -- https://github.com/haskell/cabal/issues/4130 + createDirectoryIfMissingVerbose verbosity True entryDir + + LBS.writeFile + (entryDir "cabal-hash.txt") + (renderPackageHashInputs (packageHashInputs pkgshared pkg)) + + -- Ensure that there are no files in `tmpDir`, that are + -- not in `entryDir`. While this breaks the + -- prefix-relocatable property of the libraries, it is + -- necessary on macOS to stay under the load command limit + -- of the macOS mach-o linker. See also + -- @PackageHash.hashedInstalledPackageIdVeryShort@. + -- + -- We also normalise paths to ensure that there are no + -- different representations for the same path. Like / and + -- \\ on windows under msys. + otherFiles <- filter (not . isPrefixOf entryDir) <$> + listFilesRecursive tmpDirNormalised + -- Here's where we could keep track of the installed files + -- ourselves if we wanted to by making a manifest of the + -- files in the tmp dir. + return (entryDir, otherFiles) + where + listFilesRecursive :: FilePath -> IO [FilePath] + listFilesRecursive path = do + files <- fmap (path ) <$> (listDirectory path) + allFiles <- for files $ \file -> do + isDir <- doesDirectoryExist file + if isDir + then listFilesRecursive file + else return [file] + return (concat allFiles) + + registerPkg + | not (elabRequiresRegistration pkg) = + debug verbosity $ + "registerPkg: elab does NOT require registration for " + ++ prettyShow uid + | otherwise = do + -- We register ourselves rather than via Setup.hs. We need to + -- grab and modify the InstalledPackageInfo. We decide what + -- the installed package id is, not the build system. + ipkg0 <- generateInstalledPackageInfo + let ipkg = ipkg0 { Installed.installedUnitId = uid } + assert ( elabRegisterPackageDBStack pkg + == storePackageDBStack compid) (return ()) + criticalSection registerLock $ + Cabal.registerPackage + verbosity compiler progdb + (storePackageDBStack compid) ipkg + Cabal.defaultRegisterOptions { + Cabal.registerMultiInstance = True, + Cabal.registerSuppressFilesCheck = True + } + + + -- Actual installation + void $ newStoreEntry verbosity storeDirLayout + compid uid + copyPkgFiles registerPkg + + --TODO: [nice to have] we currently rely on Setup.hs copy to do the right + -- thing. Although we do copy into an image dir and do the move into the + -- final location ourselves, perhaps we ought to do some sanity checks on + -- the image dir first. + + -- TODO: [required eventually] note that for nix-style + -- installations it is not necessary to do the + -- 'withWin32SelfUpgrade' dance, but it would be necessary for a + -- shared bin dir. + + --TODO: [required feature] docs and test phases + let docsResult = DocsNotTried + testsResult = TestsNotTried + + noticeProgress ProgressCompleted + + return BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = mlogFile + } + + where + pkgid = packageId rpkg + uid = installedUnitId rpkg + compid = compilerId compiler + + dispname = case elabPkgOrComp pkg of + ElabPackage _ -> prettyShow pkgid + ++ " (all, legacy fallback)" + ElabComponent comp -> prettyShow pkgid + ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")" + + noticeProgress phase = when isParallelBuild $ + progressMessage verbosity phase dispname + + isParallelBuild = buildSettingNumJobs >= 2 + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = flip filterConfigureFlags v $ + setupHsConfigureFlags rpkg pkgshared + verbosity builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir + + haddockCommand = Cabal.haddockCommand + haddockFlags _ = setupHsHaddockFlags pkg pkgshared + verbosity builddir + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity distTempDirectory $ \pkgConfDest -> do + let registerFlags _ = setupHsRegisterFlags + pkg pkgshared + verbosity builddir + pkgConfDest + setup Cabal.registerCommand registerFlags + + copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity + builddir destdir + + scriptOptions = setupHsScriptOptions rpkg plan pkgshared + distDirLayout srcdir builddir + isParallelBuild cacheLock + + setup :: CommandUI flags -> (Version -> flags) -> IO () + setup cmd flags = setup' cmd flags (const []) + + setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) + -> IO () + setup' cmd flags args = + withLogging $ \mLogFileHandle -> + setupWrapper + verbosity + scriptOptions + { useLoggingHandle = mLogFileHandle + , useExtraEnvOverrides = dataDirsEnvironmentForPlan + distDirLayout plan } + (Just (elabPkgDescription pkg)) + cmd flags args + + mlogFile :: Maybe FilePath + mlogFile = + case buildSettingLogFile of + Nothing -> Nothing + Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + + initLogFile = + case mlogFile of + Nothing -> return () + Just logFile -> do + createDirectoryIfMissing True (takeDirectory logFile) + exists <- doesFileExist logFile + when exists $ removeFile logFile + + withLogging action = + case mlogFile of + Nothing -> action Nothing + Just logFile -> withFile logFile AppendMode (action . Just) + + +hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool +hasValidHaddockTargets ElaboratedConfiguredPackage{..} + | not elabBuildHaddocks = False + | otherwise = any componentHasHaddocks components + where + components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets + ++ maybeToList elabReplTarget ++ elabHaddockTargets + + componentHasHaddocks :: ComponentTarget -> Bool + componentHasHaddocks (ComponentTarget name _) = + case name of + CLibName LMainLibName -> hasHaddocks + CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks + CFLibName _ -> elabHaddockForeignLibs && hasHaddocks + CExeName _ -> elabHaddockExecutables && hasHaddocks + CTestName _ -> elabHaddockTestSuites && hasHaddocks + CBenchName _ -> elabHaddockBenchmarks && hasHaddocks + where + hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) + + +buildInplaceUnpackedPackage :: Verbosity + -> DistDirLayout + -> BuildTimeSettings -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatusRebuild + -> FilePath -> FilePath + -> IO BuildResult +buildInplaceUnpackedPackage verbosity + distDirLayout@DistDirLayout { + distTempDirectory, + distPackageCacheDirectory, + distDirectory + } + BuildTimeSettings{buildSettingNumJobs} + registerLock cacheLock + pkgshared@ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb + } + plan + rpkg@(ReadyPackage pkg) + buildStatus + srcdir builddir = do + + --TODO: [code cleanup] there is duplication between the + -- distdirlayout and the builddir here builddir is not + -- enough, we also need the per-package cachedir + createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose verbosity True + (distPackageCacheDirectory dparams) + + -- Configure phase + -- + whenReConfigure $ do + annotateFailureNoLog ConfigureFailed $ + setup configureCommand configureFlags configureArgs + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor srcdir pkg + + -- Build phase + -- + let docsResult = DocsNotTried + testsResult = TestsNotTried + + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + + whenRebuild $ do + timestamp <- beginUpdateFileMonitor + annotateFailureNoLog BuildFailed $ + setup buildCommand buildFlags buildArgs + + let listSimple = + execRebuild srcdir (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity srcdir + ifNullThen m m' = do xs <- m + if null xs then m' else return xs + monitors <- case PD.buildType (elabPkgDescription pkg) of + Simple -> listSimple + -- If a Custom setup was used, AND the Cabal is recent + -- enough to have sdist --list-sources, use that to + -- determine the files that we need to track. This can + -- cause unnecessary rebuilding (for example, if README + -- is edited, we will try to rebuild) but there isn't + -- a more accurate Custom interface we can use to get + -- this info. We prefer not to use listSimple here + -- as it can miss extra source files that are considered + -- by the Custom setup. + _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17] + -- However, sometimes sdist --list-sources will fail + -- and return an empty list. In that case, fall + -- back on the (inaccurate) simple tracking. + -> listSdist `ifNullThen` listSimple + | otherwise + -> listSimple + + let dep_monitors = map monitorFileHashed + $ elabInplaceDependencyBuildCacheFiles + distDirLayout pkgshared plan pkg + updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp + pkg buildStatus + (monitors ++ dep_monitors) buildResult + + -- PURPOSELY omitted: no copy! + + whenReRegister $ annotateFailureNoLog InstallFailed $ do + -- Register locally + mipkg <- if elabRequiresRegistration pkg + then do + ipkg0 <- generateInstalledPackageInfo + -- We register ourselves rather than via Setup.hs. We need to + -- grab and modify the InstalledPackageInfo. We decide what + -- the installed package id is, not the build system. + let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } + criticalSection registerLock $ + Cabal.registerPackage verbosity compiler progdb + (elabRegisterPackageDBStack pkg) + ipkg Cabal.defaultRegisterOptions + return (Just ipkg) + + else return Nothing + + updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + + whenTest $ do + annotateFailureNoLog TestsFailed $ + setup testCommand testFlags testArgs + + whenBench $ + annotateFailureNoLog BenchFailed $ + setup benchCommand benchFlags benchArgs + + -- Repl phase + -- + whenRepl $ + annotateFailureNoLog ReplFailed $ + setupInteractive replCommand replFlags replArgs + + -- Haddock phase + whenHaddock $ + annotateFailureNoLog HaddocksFailed $ do + setup haddockCommand haddockFlags haddockArgs + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = distBuildDirectory distDirLayout dparams + "doc" "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + + return BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = Nothing + } + + where + ipkgid = installedUnitId pkg + dparams = elabDistDirParams pkgshared pkg + + isParallelBuild = buildSettingNumJobs >= 2 + + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams + + whenReConfigure action = case buildStatus of + BuildStatusConfigure _ -> action + _ -> return () + + whenRebuild action + | null (elabBuildTargets pkg) + -- NB: we have to build the test/bench suite! + , null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = return () + | otherwise = action + + whenTest action + | null (elabTestTargets pkg) = return () + | otherwise = action + + whenBench action + | null (elabBenchTargets pkg) = return () + | otherwise = action + + whenRepl action + | isNothing (elabReplTarget pkg) = return () + | otherwise = action + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + whenReRegister action + = case buildStatus of + -- We registered the package already + BuildStatusBuild (Just _) _ -> + info verbosity "whenReRegister: previously registered" + -- There is nothing to register + _ | null (elabBuildTargets pkg) -> + info verbosity "whenReRegister: nothing to register" + | otherwise -> action + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = flip filterConfigureFlags v $ + setupHsConfigureFlags rpkg pkgshared + verbosity builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = setupHsBuildFlags pkg pkgshared + verbosity builddir + buildArgs _ = setupHsBuildArgs pkg + + testCommand = Cabal.testCommand -- defaultProgramDb + testFlags v = flip filterTestFlags v $ + setupHsTestFlags pkg pkgshared + verbosity builddir + testArgs _ = setupHsTestArgs pkg + + benchCommand = Cabal.benchmarkCommand + benchFlags _ = setupHsBenchFlags pkg pkgshared + verbosity builddir + benchArgs _ = setupHsBenchArgs pkg + + replCommand = Cabal.replCommand defaultProgramDb + replFlags _ = setupHsReplFlags pkg pkgshared + verbosity builddir + replArgs _ = setupHsReplArgs pkg + + haddockCommand = Cabal.haddockCommand + haddockFlags v = flip filterHaddockFlags v $ + setupHsHaddockFlags pkg pkgshared + verbosity builddir + haddockArgs v = flip filterHaddockArgs v $ + setupHsHaddockArgs pkg + + scriptOptions = setupHsScriptOptions rpkg plan pkgshared + distDirLayout srcdir builddir + isParallelBuild cacheLock + + setupInteractive :: CommandUI flags + -> (Version -> flags) -> (Version -> [String]) -> IO () + setupInteractive cmd flags args = + setupWrapper verbosity + scriptOptions { isInteractive = True } + (Just (elabPkgDescription pkg)) + cmd flags args + + setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) + -> IO () + setup cmd flags args = + setupWrapper verbosity + scriptOptions + (Just (elabPkgDescription pkg)) + cmd flags args + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity distTempDirectory $ \pkgConfDest -> do + let registerFlags _ = setupHsRegisterFlags + pkg pkgshared + verbosity builddir + pkgConfDest + setup Cabal.registerCommand registerFlags (const []) + +withTempInstalledPackageInfoFile :: Verbosity -> FilePath + -> (FilePath -> IO ()) + -> IO InstalledPackageInfo +withTempInstalledPackageInfoFile verbosity tempdir action = + withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do + -- make absolute since @action@ will often change directory + abs_dir <- canonicalizePath dir + + let pkgConfDest = abs_dir "pkgConf" + action pkgConfDest + + readPkgConf "." pkgConfDest + where + pkgConfParseFailed :: String -> IO a + pkgConfParseFailed perror = + die' verbosity $ + "Couldn't parse the output of 'setup register --gen-pkg-config':" + ++ show perror + + readPkgConf pkgConfDir pkgConfFile = do + pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) + (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, ipkg) -> return (warns, ipkg) + + unless (null warns) $ + warn verbosity $ unlines warns + + return ipkg + + +------------------------------------------------------------------------------ +-- * Utilities +------------------------------------------------------------------------------ + +annotateFailureNoLog :: (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailureNoLog annotate action = + annotateFailure Nothing annotate action + +annotateFailure :: Maybe FilePath + -> (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailure mlogFile annotate action = + action `catches` + -- It's not just IOException and ExitCode we have to deal with, there's + -- lots, including exceptions from the hackage-security and tar packages. + -- So we take the strategy of catching everything except async exceptions. + [ +#if MIN_VERSION_base(4,7,0) + Handler $ \async -> throwIO (async :: SomeAsyncException) +#else + Handler $ \async -> throwIO (async :: AsyncException) +#endif + , Handler $ \other -> handler (other :: SomeException) + ] + where + handler :: Exception e => e -> IO a + handler = throwIO . BuildFailure mlogFile . annotate . toException diff --git a/src/Distribution/Client/ProjectBuilding/Types.hs b/src/Distribution/Client/ProjectBuilding/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectBuilding/Types.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Types for the "Distribution.Client.ProjectBuilding" +-- +-- Moved out to avoid module cycles. +-- +module Distribution.Client.ProjectBuilding.Types ( + -- * Pre-build status + BuildStatusMap, + BuildStatus(..), + buildStatusRequiresBuild, + buildStatusToString, + BuildStatusRebuild(..), + BuildReason(..), + MonitorChangedReason(..), + + -- * Build outcomes + BuildOutcomes, + BuildOutcome, + BuildResult(..), + BuildFailure(..), + BuildFailureReason(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types (DocsResult, TestsResult) +import Distribution.Client.FileMonitor (MonitorChangedReason(..)) + +import Distribution.Package (UnitId, PackageId) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.LocalBuildInfo (ComponentName) + + +------------------------------------------------------------------------------ +-- Pre-build status: result of the dry run +-- + +-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. +-- +-- This is used as the result of the dry-run of building an install plan. +-- +type BuildStatusMap = Map UnitId BuildStatus + +-- | The build status for an individual package is the state that the +-- package is in /prior/ to initiating a (re)build. +-- +-- This should not be confused with a 'BuildResult' which is the result +-- /after/ successfully building a package. +-- +-- It serves two purposes: +-- +-- * For dry-run output, it lets us explain to the user if and why a package +-- is going to be (re)built. +-- +-- * It tell us what step to start or resume building from, and carries +-- enough information for us to be able to do so. +-- +data BuildStatus = + + -- | The package is in the 'InstallPlan.PreExisting' state, so does not + -- need building. + BuildStatusPreExisting + + -- | The package is in the 'InstallPlan.Installed' state, so does not + -- need building. + | BuildStatusInstalled + + -- | The package has not been downloaded yet, so it will have to be + -- downloaded, unpacked and built. + | BuildStatusDownload + + -- | The package has not been unpacked yet, so it will have to be + -- unpacked and built. + | BuildStatusUnpack FilePath + + -- | The package exists in a local dir already, and just needs building + -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style + -- packages. + | BuildStatusRebuild FilePath BuildStatusRebuild + + -- | The package exists in a local dir already, and is fully up to date. + -- So this package can be put into the 'InstallPlan.Installed' state + -- and it does not need to be built. + | BuildStatusUpToDate BuildResult + + +-- | Which 'BuildStatus' values indicate we'll have to do some build work of +-- some sort. In particular we use this as part of checking if any of a +-- package's deps have changed. +-- +buildStatusRequiresBuild :: BuildStatus -> Bool +buildStatusRequiresBuild BuildStatusPreExisting = False +buildStatusRequiresBuild BuildStatusInstalled = False +buildStatusRequiresBuild BuildStatusUpToDate {} = False +buildStatusRequiresBuild _ = True + +-- | This is primarily here for debugging. It's not actually used anywhere. +-- +buildStatusToString :: BuildStatus -> String +buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" +buildStatusToString BuildStatusInstalled = "BuildStatusInstalled" +buildStatusToString BuildStatusDownload = "BuildStatusDownload" +buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp +buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp +buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" + + +-- | For a package that is going to be built or rebuilt, the state it's in now. +-- +-- So again, this tells us why a package needs to be rebuilt and what build +-- phases need to be run. The 'MonitorChangedReason' gives us details like +-- which file changed, which is mainly for high verbosity debug output. +-- +data BuildStatusRebuild = + + -- | The package configuration changed, so the configure and build phases + -- needs to be (re)run. + BuildStatusConfigure (MonitorChangedReason ()) + + -- | The configuration has not changed but the build phase needs to be + -- rerun. We record the reason the (re)build is needed. + -- + -- The optional registration info here tells us if we've registered the + -- package already, or if we still need to do that after building. + -- @Just Nothing@ indicates that we know that no registration is + -- necessary (e.g., executable.) + -- + | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason + +data BuildReason = + -- | The dependencies of this package have been (re)built so the build + -- phase needs to be rerun. + -- + BuildReasonDepsRebuilt + + -- | Changes in files within the package (or first run or corrupt cache) + | BuildReasonFilesChanged (MonitorChangedReason ()) + + -- | An important special case is that no files have changed but the + -- set of components the /user asked to build/ has changed. We track the + -- set of components /we have built/, which of course only grows (until + -- some other change resets it). + -- + -- The @Set 'ComponentName'@ is the set of components we have built + -- previously. When we update the monitor we take the union of the ones + -- we have built previously with the ones the user has asked for this + -- time and save those. See 'updatePackageBuildFileMonitor'. + -- + | BuildReasonExtraTargets (Set ComponentName) + + -- | Although we're not going to build any additional targets as a whole, + -- we're going to build some part of a component or run a repl or any + -- other action that does not result in additional persistent artifacts. + -- + | BuildReasonEphemeralTargets + + +------------------------------------------------------------------------------ +-- Build outcomes: result of the build +-- + +-- | A summary of the outcome for building a whole set of packages. +-- +type BuildOutcomes = Map UnitId BuildOutcome + +-- | A summary of the outcome for building a single package: either success +-- or failure. +-- +type BuildOutcome = Either BuildFailure BuildResult + +-- | Information arising from successfully building a single package. +-- +data BuildResult = BuildResult { + buildResultDocs :: DocsResult, + buildResultTests :: TestsResult, + buildResultLogFile :: Maybe FilePath + } + deriving Show + +-- | Information arising from the failure to build a single package. +-- +data BuildFailure = BuildFailure { + buildFailureLogFile :: Maybe FilePath, + buildFailureReason :: BuildFailureReason + } + deriving (Show, Typeable) + +instance Exception BuildFailure + +-- | Detail on the reason that a package failed to build. +-- +data BuildFailureReason = DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | ReplFailed SomeException + | HaddocksFailed SomeException + | TestsFailed SomeException + | BenchFailed SomeException + | InstallFailed SomeException + deriving Show diff --git a/src/Distribution/Client/ProjectConfig.hs b/src/Distribution/Client/ProjectConfig.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectConfig.hs @@ -0,0 +1,1472 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Handling project configuration. +-- +module Distribution.Client.ProjectConfig ( + + -- * Types for project config + ProjectConfig(..), + ProjectConfigBuildOnly(..), + ProjectConfigShared(..), + ProjectConfigProvenance(..), + PackageConfig(..), + MapLast(..), + MapMappend(..), + + -- * Project root + findProjectRoot, + ProjectRoot(..), + BadProjectRoot(..), + + -- * Project config files + readProjectConfig, + readGlobalConfig, + readProjectLocalFreezeConfig, + showProjectConfig, + withProjectOrGlobalConfig, + writeProjectLocalExtraConfig, + writeProjectLocalFreezeConfig, + writeProjectConfigFile, + commandLineFlagsToProjectConfig, + + -- * Packages within projects + ProjectPackageLocation(..), + BadPackageLocations(..), + BadPackageLocation(..), + BadPackageLocationMatch(..), + findProjectPackages, + fetchAndReadSourcePackages, + + -- * Resolving configuration + lookupLocalPackageConfig, + projectConfigWithBuilderRepoContext, + projectConfigWithSolverRepoContext, + SolverSettings(..), + resolveSolverSettings, + BuildTimeSettings(..), + resolveBuildTimeSettings, + + -- * Checking configuration + checkBadPerPackageCompilerPaths, + BadPerPackageCompilerPaths(..) + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.RebuildMonad +import Distribution.Client.Glob + ( isTrivialFilePathGlob ) +import Distribution.Client.VCS + ( validateSourceRepos, SourceRepoProblem(..) + , VCS(..), knownVCSs, configureVCS, syncSourceRepos ) + +import Distribution.Client.Types +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) ) +import Distribution.Client.GlobalFlags + ( RepoContext(..), withRepoContext' ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Config + ( loadConfig, getConfigFilePath ) +import Distribution.Client.HttpUtils + ( HttpTransport, configureTransport, transportCheckHttps + , downloadURI ) +import Distribution.Client.Utils.Parsec (renderParseError) + +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) + +import Distribution.Package + ( PackageName, PackageId, UnitId, packageId ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..) ) +import Distribution.System + ( Platform ) +import Distribution.Types.GenericPackageDescription + ( GenericPackageDescription ) +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescription ) +import Distribution.Fields + ( runParseResult, PError, PWarning, showPWarning) +import Distribution.Types.SourceRepo + ( RepoType(..) ) +import Distribution.Client.Types.SourceRepo + ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) +import Distribution.Simple.Compiler + ( Compiler, compilerInfo ) +import Distribution.Simple.Program + ( ConfiguredProgram(..) ) +import Distribution.Simple.Setup + ( Flag(Flag), toFlag, flagToMaybe, flagToList + , fromFlag, fromFlagOrDefault ) +import Distribution.Client.Setup + ( defaultSolver, defaultMaxBackjumps ) +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate + , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) +import Distribution.Simple.Utils + ( die', warn, notice, info, createDirectoryIfMissingVerbose, rawSystemIOWithEnv ) +import Distribution.Client.Utils + ( determineNumJobs ) +import Distribution.Utils.NubList + ( fromNubList ) +import Distribution.Verbosity + ( modifyVerbosity, verbose ) +import Distribution.Version + ( Version ) +import qualified Distribution.Deprecated.ParseUtils as OldParser + ( ParseResult(..), locatedErrorMsg, showPWarning ) +import Distribution.Client.SrcDist + ( packageDirToSdist ) + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Distribution.Client.Tar as Tar +import qualified Distribution.Client.GZipUtils as GZipUtils + +import Control.Monad.Trans (liftIO) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import qualified Data.Hashable as Hashable +import Numeric (showHex) + +import System.FilePath hiding (combine) +import System.IO + ( withBinaryFile, IOMode(ReadMode) ) +import System.Directory +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString ) + + +---------------------------------------- +-- Resolving configuration to settings +-- + +-- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific +-- 'PackageName'. This returns the configuration that applies to all local +-- packages plus any package-specific configuration for this package. +-- +lookupLocalPackageConfig + :: (Semigroup a, Monoid a) + => (PackageConfig -> a) -> ProjectConfig -> PackageName + -> a +lookupLocalPackageConfig field ProjectConfig { + projectConfigLocalPackages, + projectConfigSpecificPackage + } pkgname = + field projectConfigLocalPackages + <> maybe mempty field + (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage)) + + +-- | Use a 'RepoContext' based on the 'BuildTimeSettings'. +-- +projectConfigWithBuilderRepoContext :: Verbosity + -> BuildTimeSettings + -> (RepoContext -> IO a) -> IO a +projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} = + withRepoContext' + verbosity + buildSettingRemoteRepos + buildSettingLocalNoIndexRepos + buildSettingCacheDir + buildSettingHttpTransport + (Just buildSettingIgnoreExpiry) + buildSettingProgPathExtra + + +-- | Use a 'RepoContext', but only for the solver. The solver does not use the +-- full facilities of the 'RepoContext' so we can get away with making one +-- that doesn't have an http transport. And that avoids having to have access +-- to the 'BuildTimeSettings' +-- +projectConfigWithSolverRepoContext + :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly + -> (RepoContext -> IO a) + -> IO a +projectConfigWithSolverRepoContext verbosity + ProjectConfigShared{..} + ProjectConfigBuildOnly{..} = + withRepoContext' + verbosity + (fromNubList projectConfigRemoteRepos) + (fromNubList projectConfigLocalNoIndexRepos) + (fromFlagOrDefault + (error + "projectConfigWithSolverRepoContext: projectConfigCacheDir") + projectConfigCacheDir) + (flagToMaybe projectConfigHttpTransport) + (flagToMaybe projectConfigIgnoreExpiry) + (fromNubList projectConfigProgPathExtra) + + +-- | Resolve the project configuration, with all its optional fields, into +-- 'SolverSettings' with no optional fields (by applying defaults). +-- +resolveSolverSettings :: ProjectConfig -> SolverSettings +resolveSolverSettings ProjectConfig{ + projectConfigShared, + projectConfigLocalPackages, + projectConfigSpecificPackage + } = + SolverSettings {..} + where + --TODO: [required eventually] some of these settings need validation, e.g. + -- the flag assignments need checking. + solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos + solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos + solverSettingConstraints = projectConfigConstraints + solverSettingPreferences = projectConfigPreferences + solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages + solverSettingFlagAssignments = fmap packageConfigFlagAssignment + (getMapMappend projectConfigSpecificPackage) + solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion + solverSettingSolver = fromFlag projectConfigSolver + solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder + solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer + solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of + n | n < 0 -> Nothing + | otherwise -> Just n + solverSettingReorderGoals = fromFlag projectConfigReorderGoals + solverSettingCountConflicts = fromFlag projectConfigCountConflicts + solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts + solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet + solverSettingStrongFlags = fromFlag projectConfigStrongFlags + solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls + solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained + solverSettingIndexState = flagToMaybe projectConfigIndexState + solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos + solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals + --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs + --solverSettingReinstall = fromFlag projectConfigReinstall + --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls + --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall + --solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps + + ProjectConfigShared {..} = defaults <> projectConfigShared + + defaults = mempty { + projectConfigSolver = Flag defaultSolver, + projectConfigAllowOlder = Just (AllowOlder mempty), + projectConfigAllowNewer = Just (AllowNewer mempty), + projectConfigMaxBackjumps = Flag defaultMaxBackjumps, + projectConfigReorderGoals = Flag (ReorderGoals False), + projectConfigCountConflicts = Flag (CountConflicts True), + projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), + projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), + projectConfigStrongFlags = Flag (StrongFlags False), + projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + projectConfigOnlyConstrained = Flag OnlyConstrainedNone, + projectConfigIndependentGoals = Flag (IndependentGoals False) + --projectConfigShadowPkgs = Flag False, + --projectConfigReinstall = Flag False, + --projectConfigAvoidReinstalls = Flag False, + --projectConfigOverrideReinstall = Flag False, + --projectConfigUpgradeDeps = Flag False + } + + +-- | Resolve the project configuration, with all its optional fields, into +-- 'BuildTimeSettings' with no optional fields (by applying defaults). +-- +resolveBuildTimeSettings :: Verbosity + -> CabalDirLayout + -> ProjectConfig + -> BuildTimeSettings +resolveBuildTimeSettings verbosity + CabalDirLayout { + cabalLogsDirectory + } + ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigRemoteRepos, + projectConfigLocalNoIndexRepos, + projectConfigProgPathExtra + }, + projectConfigBuildOnly + } = + BuildTimeSettings {..} + where + buildSettingDryRun = fromFlag projectConfigDryRun + buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps + buildSettingOnlyDownload = fromFlag projectConfigOnlyDownload + buildSettingSummaryFile = fromNubList projectConfigSummaryFile + --buildSettingLogFile -- defined below, more complicated + --buildSettingLogVerbosity -- defined below, more complicated + buildSettingBuildReports = fromFlag projectConfigBuildReports + buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir + buildSettingOneShot = fromFlag projectConfigOneShot + buildSettingNumJobs = determineNumJobs projectConfigNumJobs + buildSettingKeepGoing = fromFlag projectConfigKeepGoing + buildSettingOfflineMode = fromFlag projectConfigOfflineMode + buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles + buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos + buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos + buildSettingCacheDir = fromFlag projectConfigCacheDir + buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport + buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry + buildSettingReportPlanningFailure + = fromFlag projectConfigReportPlanningFailure + buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra + + ProjectConfigBuildOnly{..} = defaults + <> projectConfigBuildOnly + + defaults = mempty { + projectConfigDryRun = toFlag False, + projectConfigOnlyDeps = toFlag False, + projectConfigOnlyDownload = toFlag False, + projectConfigBuildReports = toFlag NoReports, + projectConfigReportPlanningFailure = toFlag False, + projectConfigKeepGoing = toFlag False, + projectConfigOneShot = toFlag False, + projectConfigOfflineMode = toFlag False, + projectConfigKeepTempFiles = toFlag False, + projectConfigIgnoreExpiry = toFlag False + } + + -- The logging logic: what log file to use and what verbosity. + -- + -- If the user has specified --remote-build-reporting=detailed, use the + -- default log file location. If the --build-log option is set, use the + -- provided location. Otherwise don't use logging, unless building in + -- parallel (in which case the default location is used). + -- + buildSettingLogFile :: Maybe (Compiler -> Platform + -> PackageId -> UnitId -> FilePath) + buildSettingLogFile + | useDefaultTemplate = Just (substLogFileName defaultTemplate) + | otherwise = fmap substLogFileName givenTemplate + + defaultTemplate = toPathTemplate $ + cabalLogsDirectory + "$compiler" "$libname" <.> "log" + givenTemplate = flagToMaybe projectConfigLogFile + + useDefaultTemplate + | buildSettingBuildReports == DetailedReports = True + | isJust givenTemplate = False + | isParallelBuild = True + | otherwise = False + + isParallelBuild = buildSettingNumJobs >= 2 + + substLogFileName :: PathTemplate + -> Compiler -> Platform + -> PackageId -> UnitId -> FilePath + substLogFileName template compiler platform pkgid uid = + fromPathTemplate (substPathTemplate env template) + where + env = initialPathTemplateEnv + pkgid uid (compilerInfo compiler) platform + + -- If the user has specified --remote-build-reporting=detailed or + -- --build-log, use more verbose logging. + -- + buildSettingLogVerbosity + | overrideVerbosity = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + overrideVerbosity + | buildSettingBuildReports == DetailedReports = True + | isJust givenTemplate = True + | isParallelBuild = False + | otherwise = False + + +--------------------------------------------- +-- Reading and writing project config files +-- + +-- | Find the root of this project. +-- +-- Searches for an explicit @cabal.project@ file, in the current directory or +-- parent directories. If no project file is found then the current dir is the +-- project root (and the project will use an implicit config). +-- +findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory + -> Maybe FilePath -- ^ @cabal.project@ file name override + -> IO (Either BadProjectRoot ProjectRoot) +findProjectRoot _ (Just projectFile) + | isAbsolute projectFile = do + exists <- doesFileExist projectFile + if exists + then do projectFile' <- canonicalizePath projectFile + let projectRoot = ProjectRootExplicit (takeDirectory projectFile') + (takeFileName projectFile') + return (Right projectRoot) + else return (Left (BadProjectRootExplicitFile projectFile)) + +findProjectRoot mstartdir mprojectFile = do + startdir <- maybe getCurrentDirectory canonicalizePath mstartdir + homedir <- getHomeDirectory + probe startdir homedir + where + projectFileName = fromMaybe "cabal.project" mprojectFile + + -- Search upwards. If we get to the users home dir or the filesystem root, + -- then use the current dir + probe startdir homedir = go startdir + where + go dir | isDrive dir || dir == homedir = + case mprojectFile of + Nothing -> return (Right (ProjectRootImplicit startdir)) + Just file -> return (Left (BadProjectRootExplicitFile file)) + go dir = do + exists <- doesFileExist (dir projectFileName) + if exists + then return (Right (ProjectRootExplicit dir projectFileName)) + else go (takeDirectory dir) + +-- | Errors returned by 'findProjectRoot'. +-- +data BadProjectRoot = BadProjectRootExplicitFile FilePath +#if MIN_VERSION_base(4,8,0) + deriving (Show, Typeable) +#else + deriving (Typeable) + +instance Show BadProjectRoot where + show = renderBadProjectRoot +#endif + +instance Exception BadProjectRoot where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadProjectRoot +#endif + +renderBadProjectRoot :: BadProjectRoot -> String +renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = + "The given project file '" ++ projectFile ++ "' does not exist." + +withProjectOrGlobalConfig + :: Verbosity -- ^ verbosity + -> Flag Bool -- ^ whether to ignore local project + -> Flag FilePath -- ^ @--cabal-config@ + -> IO a -- ^ with project + -> (ProjectConfig -> IO a) -- ^ without projet + -> IO a +withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do + globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf + without globalConfig +withProjectOrGlobalConfig verbosity _ignorePrj gcf with without = + withProjectOrGlobalConfig' verbosity gcf with without + +withProjectOrGlobalConfig' + :: Verbosity + -> Flag FilePath + -> IO a + -> (ProjectConfig -> IO a) + -> IO a +withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do + globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag + + let + res' = catch with + $ \case + (BadPackageLocations prov locs) + | prov == Set.singleton Implicit + , let + isGlobErr (BadLocGlobEmptyMatch _) = True + isGlobErr _ = False + , any isGlobErr locs -> + without globalConfig + err -> throwIO err + + catch res' + $ \case + (BadProjectRootExplicitFile "") -> without globalConfig + err -> throwIO err + +-- | Read all the config relevant for a project. This includes the project +-- file if any, plus other global config. +-- +readProjectConfig :: Verbosity + -> Flag FilePath + -> DistDirLayout + -> Rebuild ProjectConfig +readProjectConfig verbosity configFileFlag distDirLayout = do + global <- readGlobalConfig verbosity configFileFlag + local <- readProjectLocalConfigOrDefault verbosity distDirLayout + freeze <- readProjectLocalFreezeConfig verbosity distDirLayout + extra <- readProjectLocalExtraConfig verbosity distDirLayout + return (global <> local <> freeze <> extra) + + +-- | Reads an explicit @cabal.project@ file in the given project root dir, +-- or returns the default project config for an implicitly defined project. +-- +readProjectLocalConfigOrDefault :: Verbosity + -> DistDirLayout + -> Rebuild ProjectConfig +readProjectLocalConfigOrDefault verbosity distDirLayout = do + usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile + if usesExplicitProjectRoot + then do + readProjectFile verbosity distDirLayout "" "project file" + else do + monitorFiles [monitorNonExistentFile projectFile] + return defaultImplicitProjectConfig + + where + projectFile = distProjectFile distDirLayout "" + + defaultImplicitProjectConfig :: ProjectConfig + defaultImplicitProjectConfig = + mempty { + -- We expect a package in the current directory. + projectPackages = [ "./*.cabal" ], + + projectConfigProvenance = Set.singleton Implicit + } + +-- | Reads a @cabal.project.local@ file in the given project root dir, +-- or returns empty. This file gets written by @cabal configure@, or in +-- principle can be edited manually or by other tools. +-- +readProjectLocalExtraConfig :: Verbosity -> DistDirLayout + -> Rebuild ProjectConfig +readProjectLocalExtraConfig verbosity distDirLayout = + readProjectFile verbosity distDirLayout "local" + "project local configuration file" + +-- | Reads a @cabal.project.freeze@ file in the given project root dir, +-- or returns empty. This file gets written by @cabal freeze@, or in +-- principle can be edited manually or by other tools. +-- +readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout + -> Rebuild ProjectConfig +readProjectLocalFreezeConfig verbosity distDirLayout = + readProjectFile verbosity distDirLayout "freeze" + "project freeze file" + +-- | Reads a named config file in the given project root dir, or returns empty. +-- +readProjectFile :: Verbosity + -> DistDirLayout + -> String + -> String + -> Rebuild ProjectConfig +readProjectFile verbosity DistDirLayout{distProjectFile} + extensionName extensionDescription = do + exists <- liftIO $ doesFileExist extensionFile + if exists + then do monitorFiles [monitorFileHashed extensionFile] + addProjectFileProvenance <$> liftIO readExtensionFile + else do monitorFiles [monitorNonExistentFile extensionFile] + return mempty + where + extensionFile = distProjectFile extensionName + + readExtensionFile = + reportParseResult verbosity extensionDescription extensionFile + . (parseProjectConfig extensionFile) + =<< BS.readFile extensionFile + + addProjectFileProvenance config = + config { + projectConfigProvenance = + Set.insert (Explicit extensionFile) (projectConfigProvenance config) + } + + +-- | Parse the 'ProjectConfig' format. +-- +-- For the moment this is implemented in terms of parsers for legacy +-- configuration types, plus a conversion. +-- +parseProjectConfig :: FilePath -> BS.ByteString -> OldParser.ParseResult ProjectConfig +parseProjectConfig source content = + convertLegacyProjectConfig <$> + (parseLegacyProjectConfig source content) + + +-- | Render the 'ProjectConfig' format. +-- +-- For the moment this is implemented in terms of a pretty printer for the +-- legacy configuration types, plus a conversion. +-- +showProjectConfig :: ProjectConfig -> String +showProjectConfig = + showLegacyProjectConfig . convertToLegacyProjectConfig + + +-- | Write a @cabal.project.local@ file in the given project root dir. +-- +writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () +writeProjectLocalExtraConfig DistDirLayout{distProjectFile} = + writeProjectConfigFile (distProjectFile "local") + + +-- | Write a @cabal.project.freeze@ file in the given project root dir. +-- +writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () +writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} = + writeProjectConfigFile (distProjectFile "freeze") + + +-- | Write in the @cabal.project@ format to the given file. +-- +writeProjectConfigFile :: FilePath -> ProjectConfig -> IO () +writeProjectConfigFile file = + writeFile file . showProjectConfig + + +-- | Read the user's @~/.cabal/config@ file. +-- +readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig +readGlobalConfig verbosity configFileFlag = do + config <- liftIO (loadConfig verbosity configFileFlag) + configFile <- liftIO (getConfigFilePath configFileFlag) + monitorFiles [monitorFileHashed configFile] + return (convertLegacyGlobalConfig config) + +reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult a -> IO a +reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do + unless (null warnings) $ + let msg = unlines (map (OldParser.showPWarning filename) warnings) + in warn verbosity msg + return x +reportParseResult verbosity filetype filename (OldParser.ParseFailed err) = + let (line, msg) = OldParser.locatedErrorMsg err + in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + + +--------------------------------------------- +-- Finding packages in the project +-- + +-- | The location of a package as part of a project. Local file paths are +-- either absolute (if the user specified it as such) or they are relative +-- to the project root. +-- +data ProjectPackageLocation = + ProjectPackageLocalCabalFile FilePath + | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file + | ProjectPackageLocalTarball FilePath + | ProjectPackageRemoteTarball URI + | ProjectPackageRemoteRepo SourceRepoList + | ProjectPackageNamed PackageVersionConstraint + deriving Show + + +-- | Exception thrown by 'findProjectPackages'. +-- +data BadPackageLocations + = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] +#if MIN_VERSION_base(4,8,0) + deriving (Show, Typeable) +#else + deriving (Typeable) + +instance Show BadPackageLocations where + show = renderBadPackageLocations +#endif + +instance Exception BadPackageLocations where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadPackageLocations +#endif +--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc + +data BadPackageLocation + = BadPackageLocationFile BadPackageLocationMatch + | BadLocGlobEmptyMatch String + | BadLocGlobBadMatches String [BadPackageLocationMatch] + | BadLocUnexpectedUriScheme String + | BadLocUnrecognisedUri String + | BadLocUnrecognised String + deriving Show + +data BadPackageLocationMatch + = BadLocUnexpectedFile String + | BadLocNonexistantFile String + | BadLocDirNoCabalFile String + | BadLocDirManyCabalFiles String + deriving Show + +renderBadPackageLocations :: BadPackageLocations -> String +renderBadPackageLocations (BadPackageLocations provenance bpls) + -- There is no provenance information, + -- render standard bad package error information. + | Set.null provenance = renderErrors renderBadPackageLocation + + -- The configuration is implicit, render bad package locations + -- using possibly specialized error messages. + | Set.singleton Implicit == provenance = + renderErrors renderImplicitBadPackageLocation + + -- The configuration contains both implicit and explicit provenance. + -- This should not occur, and a message is output to assist debugging. + | Implicit `Set.member` provenance = + "Warning: both implicit and explicit configuration is present." + ++ renderExplicit + + -- The configuration was read from one or more explicit path(s), + -- list the locations and render the bad package error information. + -- The intent is to supersede this with the relevant location information + -- per package error. + | otherwise = renderExplicit + where + renderErrors f = unlines (map f bpls) + + renderExplicit = + "When using configuration(s) from " + ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance)) + ++ ", the following errors occurred:\n" + ++ renderErrors renderBadPackageLocation + + getExplicit (Explicit path) = Just path + getExplicit Implicit = Nothing + +--TODO: [nice to have] keep track of the config file (and src loc) packages +-- were listed, to use in error messages + +-- | Render bad package location error information for the implicit +-- @cabal.project@ configuration. +-- +-- TODO: This is currently not fully realized, with only one of the implicit +-- cases handled. More cases should be added with informative help text +-- about the issues related specifically when having no project configuration +-- is present. +renderImplicitBadPackageLocation :: BadPackageLocation -> String +renderImplicitBadPackageLocation bpl = case bpl of + BadLocGlobEmptyMatch pkglocstr -> + "No cabal.project file or cabal file matching the default glob '" + ++ pkglocstr ++ "' was found.\n" + ++ "Please create a package description file .cabal " + ++ "or a cabal.project file referencing the packages you " + ++ "want to build." + _ -> renderBadPackageLocation bpl + +renderBadPackageLocation :: BadPackageLocation -> String +renderBadPackageLocation bpl = case bpl of + BadPackageLocationFile badmatch -> + renderBadPackageLocationMatch badmatch + BadLocGlobEmptyMatch pkglocstr -> + "The package location glob '" ++ pkglocstr + ++ "' does not match any files or directories." + BadLocGlobBadMatches pkglocstr failures -> + "The package location glob '" ++ pkglocstr ++ "' does not match any " + ++ "recognised forms of package. " + ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures + BadLocUnexpectedUriScheme pkglocstr -> + "The package location URI '" ++ pkglocstr ++ "' does not use a " + ++ "supported URI scheme. The supported URI schemes are http, https and " + ++ "file." + BadLocUnrecognisedUri pkglocstr -> + "The package location URI '" ++ pkglocstr ++ "' does not appear to " + ++ "be a valid absolute URI." + BadLocUnrecognised pkglocstr -> + "The package location syntax '" ++ pkglocstr ++ "' is not recognised." + +renderBadPackageLocationMatch :: BadPackageLocationMatch -> String +renderBadPackageLocationMatch bplm = case bplm of + BadLocUnexpectedFile pkglocstr -> + "The package location '" ++ pkglocstr ++ "' is not recognised. The " + ++ "supported file targets are .cabal files, .tar.gz tarballs or package " + ++ "directories (i.e. directories containing a .cabal file)." + BadLocNonexistantFile pkglocstr -> + "The package location '" ++ pkglocstr ++ "' does not exist." + BadLocDirNoCabalFile pkglocstr -> + "The package directory '" ++ pkglocstr ++ "' does not contain any " + ++ ".cabal file." + BadLocDirManyCabalFiles pkglocstr -> + "The package directory '" ++ pkglocstr ++ "' contains multiple " + ++ ".cabal files (which is not currently supported)." + +-- | Given the project config, +-- +-- Throws 'BadPackageLocations'. +-- +findProjectPackages :: DistDirLayout -> ProjectConfig + -> Rebuild [ProjectPackageLocation] +findProjectPackages DistDirLayout{distProjectRootDirectory} + ProjectConfig{..} = do + + requiredPkgs <- findPackageLocations True projectPackages + optionalPkgs <- findPackageLocations False projectPackagesOptional + let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo + namedPkgs = map ProjectPackageNamed projectPackagesNamed + + return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs]) + where + findPackageLocations required pkglocstr = do + (problems, pkglocs) <- + partitionEithers <$> traverse (findPackageLocation required) pkglocstr + unless (null problems) $ + liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems + return (concat pkglocs) + + + findPackageLocation :: Bool -> String + -> Rebuild (Either BadPackageLocation + [ProjectPackageLocation]) + findPackageLocation _required@True pkglocstr = + -- strategy: try first as a file:// or http(s):// URL. + -- then as a file glob (usually encompassing single file) + -- finally as a single file, for files that fail to parse as globs + checkIsUriPackage pkglocstr + `mplusMaybeT` checkIsFileGlobPackage pkglocstr + `mplusMaybeT` checkIsSingleFilePackage pkglocstr + >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return + + + findPackageLocation _required@False pkglocstr = do + -- just globs for optional case + res <- checkIsFileGlobPackage pkglocstr + case res of + Nothing -> return (Left (BadLocUnrecognised pkglocstr)) + Just (Left _) -> return (Right []) -- it's optional + Just (Right pkglocs) -> return (Right pkglocs) + + + checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage + :: String -> Rebuild (Maybe (Either BadPackageLocation + [ProjectPackageLocation])) + checkIsUriPackage pkglocstr = + case parseAbsoluteURI pkglocstr of + Just uri@URI { + uriScheme = scheme, + uriAuthority = Just URIAuth { uriRegName = host }, + uriPath = path, + uriQuery = query, + uriFragment = frag + } + | recognisedScheme && not (null host) -> + return (Just (Right [ProjectPackageRemoteTarball uri])) + + | scheme == "file:" && null host && null query && null frag -> + checkIsSingleFilePackage path + + | not recognisedScheme && not (null host) -> + return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) + + | recognisedScheme && null host -> + return (Just (Left (BadLocUnrecognisedUri pkglocstr))) + where + recognisedScheme = scheme == "http:" || scheme == "https:" + || scheme == "file:" + + _ -> return Nothing + + + checkIsFileGlobPackage pkglocstr = + case simpleParsec pkglocstr of + Nothing -> return Nothing + Just glob -> liftM Just $ do + matches <- matchFileGlob glob + case matches of + [] | isJust (isTrivialFilePathGlob glob) + -> return (Left (BadPackageLocationFile + (BadLocNonexistantFile pkglocstr))) + + [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) + + _ -> do + (failures, pkglocs) <- partitionEithers <$> + traverse checkFilePackageMatch matches + return $! case (failures, pkglocs) of + ([failure], []) | isJust (isTrivialFilePathGlob glob) + -> Left (BadPackageLocationFile failure) + (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) + _ -> Right pkglocs + + + checkIsSingleFilePackage pkglocstr = do + let filename = distProjectRootDirectory pkglocstr + isFile <- liftIO $ doesFileExist filename + isDir <- liftIO $ doesDirectoryExist filename + if isFile || isDir + then checkFilePackageMatch pkglocstr + >>= either (return . Just . Left . BadPackageLocationFile) + (return . Just . Right . (\x->[x])) + else return Nothing + + + checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch + ProjectPackageLocation) + checkFilePackageMatch pkglocstr = do + -- The pkglocstr may be absolute or may be relative to the project root. + -- Either way, does the right thing here. We return relative paths if + -- they were relative in the first place. + let abspath = distProjectRootDirectory pkglocstr + isFile <- liftIO $ doesFileExist abspath + isDir <- liftIO $ doesDirectoryExist abspath + parentDirExists <- case takeDirectory abspath of + [] -> return False + dir -> liftIO $ doesDirectoryExist dir + case () of + _ | isDir + -> do matches <- matchFileGlob (globStarDotCabal pkglocstr) + case matches of + [cabalFile] + -> return (Right (ProjectPackageLocalDirectory + pkglocstr cabalFile)) + [] -> return (Left (BadLocDirNoCabalFile pkglocstr)) + _ -> return (Left (BadLocDirManyCabalFiles pkglocstr)) + + | extensionIsTarGz pkglocstr + -> return (Right (ProjectPackageLocalTarball pkglocstr)) + + | takeExtension pkglocstr == ".cabal" + -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) + + | isFile + -> return (Left (BadLocUnexpectedFile pkglocstr)) + + | parentDirExists + -> return (Left (BadLocNonexistantFile pkglocstr)) + + | otherwise + -> return (Left (BadLocUnexpectedFile pkglocstr)) + + + extensionIsTarGz f = takeExtension f == ".gz" + && takeExtension (dropExtension f) == ".tar" + + +-- | A glob to find all the cabal files in a directory. +-- +-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@. +-- The directory part can be either absolute or relative. +-- +globStarDotCabal :: FilePath -> FilePathGlob +globStarDotCabal dir = + FilePathGlob + (if isAbsolute dir then FilePathRoot root else FilePathRelative) + (foldr (\d -> GlobDir [Literal d]) + (GlobFile [WildCard, Literal ".cabal"]) dirComponents) + where + (root, dirComponents) = fmap splitDirectories (splitDrive dir) + + +--TODO: [code cleanup] use sufficiently recent transformers package +mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) +mplusMaybeT ma mb = do + mx <- ma + case mx of + Nothing -> mb + Just x -> return (Just x) + + +------------------------------------------------- +-- Fetching and reading packages in the project +-- + +-- | Read the @.cabal@ files for a set of packages. For remote tarballs and +-- VCS source repos this also fetches them if needed. +-- +-- Note here is where we convert from project-root relative paths to absolute +-- paths. +-- +fetchAndReadSourcePackages + :: Verbosity + -> DistDirLayout + -> ProjectConfigShared + -> ProjectConfigBuildOnly + -> [ProjectPackageLocation] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] +fetchAndReadSourcePackages verbosity distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations = do + + pkgsLocalDirectory <- + sequenceA + [ readSourcePackageLocalDirectory verbosity dir cabalFile + | location <- pkgLocations + , (dir, cabalFile) <- projectPackageLocal location ] + + pkgsLocalTarball <- + sequenceA + [ readSourcePackageLocalTarball verbosity path + | ProjectPackageLocalTarball path <- pkgLocations ] + + pkgsRemoteTarball <- do + getTransport <- delayInitSharedResource $ + configureTransport verbosity progPathExtra + preferredHttpTransport + sequenceA + [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout + getTransport uri + | ProjectPackageRemoteTarball uri <- pkgLocations ] + + pkgsRemoteRepo <- + syncAndReadSourcePackagesRemoteRepos + verbosity distDirLayout + projectConfigShared + [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ] + + let pkgsNamed = + [ NamedPackage pkgname [PackagePropertyVersion verrange] + | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ] + + return $ concat + [ pkgsLocalDirectory + , pkgsLocalTarball + , pkgsRemoteTarball + , pkgsRemoteRepo + , pkgsNamed + ] + where + projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)] + projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)] + where dir = takeDirectory file + projectPackageLocal _ = [] + + progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared) + preferredHttpTransport = + flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly) + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'. +-- We simply read the @.cabal@ file. +-- +readSourcePackageLocalDirectory + :: Verbosity + -> FilePath -- ^ The package directory + -> FilePath -- ^ The package @.cabal@ file + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +readSourcePackageLocalDirectory verbosity dir cabalFile = do + monitorFiles [monitorFileHashed cabalFile] + root <- askRoot + let location = LocalUnpackedPackage (root dir) + liftIO $ fmap (mkSpecificSourcePackage location) + . readSourcePackageCabalFile verbosity cabalFile + =<< BS.readFile (root cabalFile) + + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find +-- the @.cabal@ file and read that. +-- +readSourcePackageLocalTarball + :: Verbosity + -> FilePath + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +readSourcePackageLocalTarball verbosity tarballFile = do + monitorFiles [monitorFile tarballFile] + root <- askRoot + let location = LocalTarballPackage (root tarballFile) + liftIO $ fmap (mkSpecificSourcePackage location) + . uncurry (readSourcePackageCabalFile verbosity) + =<< extractTarballPackageCabalFile (root tarballFile) + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir +-- and after that handle it like the local tarball case. +-- +fetchAndReadSourcePackageRemoteTarball + :: Verbosity + -> DistDirLayout + -> Rebuild HttpTransport + -> URI + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +fetchAndReadSourcePackageRemoteTarball verbosity + DistDirLayout { + distDownloadSrcDirectory + } + getTransport + tarballUri = + -- The tarball download is expensive so we use another layer of file + -- monitor to avoid it whenever possible. + rerunIfChanged verbosity monitor tarballUri $ do + + -- Download + transport <- getTransport + liftIO $ do + transportCheckHttps verbosity transport tarballUri + notice verbosity ("Downloading " ++ show tarballUri) + createDirectoryIfMissingVerbose verbosity True + distDownloadSrcDirectory + _ <- downloadURI transport verbosity tarballUri tarballFile + return () + + -- Read + monitorFiles [monitorFile tarballFile] + let location = RemoteTarballPackage tarballUri tarballFile + liftIO $ fmap (mkSpecificSourcePackage location) + . uncurry (readSourcePackageCabalFile verbosity) + =<< extractTarballPackageCabalFile tarballFile + where + tarballStem = distDownloadSrcDirectory + localFileNameForRemoteTarball tarballUri + tarballFile = tarballStem <.> "tar.gz" + + monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) + monitor = newFileMonitor (tarballStem <.> "cache") + + +-- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of +-- 'ProjectPackageRemoteRepo'. +-- +syncAndReadSourcePackagesRemoteRepos + :: Verbosity + -> DistDirLayout + -> ProjectConfigShared + -> [SourceRepoList] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] +syncAndReadSourcePackagesRemoteRepos verbosity + DistDirLayout{distDownloadSrcDirectory} + ProjectConfigShared { + projectConfigProgPathExtra + } + repos = do + + repos' <- either reportSourceRepoProblems return $ + validateSourceRepos repos + + -- All 'SourceRepo's grouped by referring to the "same" remote repo + -- instance. So same location but can differ in commit/tag/branch/subdir. + let reposByLocation :: Map (RepoType, String) + [(SourceRepoList, RepoType)] + reposByLocation = Map.fromListWith (++) + [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) + | (repo, rloc, rtype, vcs) <- repos' ] + + --TODO: pass progPathExtra on to 'configureVCS' + let _progPathExtra = fromNubList projectConfigProgPathExtra + getConfiguredVCS <- delayInitSharedResources $ \repoType -> + let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in + configureVCS verbosity {-progPathExtra-} vcs + + concat <$> sequenceA + [ rerunIfChanged verbosity monitor repoGroup' $ do + vcs' <- getConfiguredVCS repoType + syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup' + | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation + , let repoGroup' = map fst repoGroup + pathStem = distDownloadSrcDirectory + localFileNameForRemoteRepo primaryRepo + monitor :: FileMonitor + [SourceRepoList] + [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] + monitor = newFileMonitor (pathStem <.> "cache") + ] + where + syncRepoGroupAndReadSourcePackages + :: VCS ConfiguredProgram + -> FilePath + -> [SourceRepoList] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] + syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do + liftIO $ createDirectoryIfMissingVerbose verbosity False + distDownloadSrcDirectory + + -- For syncing we don't care about different 'SourceRepo' values that + -- are just different subdirs in the same repo. + syncSourceRepos verbosity vcs + [ (repo, repoPath) + | (repo, _, repoPath) <- repoGroupWithPaths ] + + -- Run post-checkout-command if it is specified + for_ repoGroupWithPaths $ \(repo, _, repoPath) -> + for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do + exitCode <- rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing + unless (exitCode /= ExitSuccess) $ exitWith exitCode + + -- But for reading we go through each 'SourceRepo' including its subdir + -- value and have to know which path each one ended up in. + sequenceA + [ readPackageFromSourceRepo repoWithSubdir repoPath + | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths + , repoWithSubdir <- NE.toList reposWithSubdir ] + where + -- So to do both things above, we pair them up here. + repoGroupWithPaths + :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] + repoGroupWithPaths = + zipWith (\(x, y) z -> (x,y,z)) + (mapGroup + [ (repo { srpSubdir = Proxy }, repo) + | repo <- foldMap (NE.toList . srpFanOut) repoGroup + ]) + repoPaths + + mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] + mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) + + -- The repos in a group are given distinct names by simple enumeration + -- foo, foo-2, foo-3 etc + repoPaths :: [FilePath] + repoPaths = pathStem + : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] + + readPackageFromSourceRepo + :: SourceRepositoryPackage Maybe + -> FilePath + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) + readPackageFromSourceRepo repo repoPath = do + let packageDir :: FilePath + packageDir = maybe repoPath (repoPath ) (srpSubdir repo) + + entries <- liftIO $ getDirectoryContents packageDir + --TODO: dcoutts 2018-06-23: wrap exceptions + case filter (\e -> takeExtension e == ".cabal") entries of + [] -> liftIO $ throwIO $ NoCabalFileFound packageDir + (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir + [cabalFileName] -> do + let cabalFilePath = packageDir cabalFileName + monitorFiles [monitorFileHashed cabalFilePath] + gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath + + -- write sdist tarball, to repoPath-pgkid + tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir + let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz" + liftIO $ LBS.writeFile tarballPath tarball + + let location = RemoteSourceRepoPackage repo tarballPath + return $ mkSpecificSourcePackage location gpd + + reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a + reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems + + renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String + renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" + + +-- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an +-- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package +-- from a given location. +-- +mkSpecificSourcePackage :: PackageLocation FilePath + -> GenericPackageDescription + -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) +mkSpecificSourcePackage location pkg = + SpecificSourcePackage SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location + , srcpkgDescrOverride = Nothing + } + + +-- | Errors reported upon failing to parse a @.cabal@ file. +-- +data CabalFileParseError = CabalFileParseError + FilePath -- ^ @.cabal@ file path + BS.ByteString -- ^ @.cabal@ file contents + (NonEmpty PError) -- ^ errors + (Maybe Version) -- ^ We might discover the spec version the package needs + [PWarning] -- ^ warnings + deriving (Typeable) + +-- | Manual instance which skips file contentes +instance Show CabalFileParseError where + showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10) + $ showString "CabalFileParseError" + . showChar ' ' . showsPrec 11 fp + . showChar ' ' . showsPrec 11 ("" :: String) + . showChar ' ' . showsPrec 11 es + . showChar ' ' . showsPrec 11 mv + . showChar ' ' . showsPrec 11 ws + +instance Exception CabalFileParseError +#if MIN_VERSION_base(4,8,0) + where + displayException = renderCabalFileParseError +#endif + +renderCabalFileParseError :: CabalFileParseError -> String +renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) = + renderParseError filePath contents errors warnings + +-- | Wrapper for the @.cabal@ file parser. It reports warnings on higher +-- verbosity levels and throws 'CabalFileParseError' on failure. +-- +readSourcePackageCabalFile :: Verbosity + -> FilePath + -> BS.ByteString + -> IO GenericPackageDescription +readSourcePackageCabalFile verbosity pkgfilename content = + case runParseResult (parseGenericPackageDescription content) of + (warnings, Right pkg) -> do + unless (null warnings) $ + info verbosity (formatWarnings warnings) + return pkg + + (warnings, Left (mspecVersion, errors)) -> + throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings + where + formatWarnings warnings = + "The package description file " ++ pkgfilename + ++ " has warnings: " + ++ unlines (map (showPWarning pkgfilename) warnings) + + +-- | When looking for a package's @.cabal@ file we can find none, or several, +-- both of which are failures. +-- +data CabalFileSearchFailure + = NoCabalFileFound FilePath + | MultipleCabalFilesFound FilePath + deriving (Show, Typeable) + +instance Exception CabalFileSearchFailure + + +-- | Find the @.cabal@ file within a tarball file and return it by value. +-- +-- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception. +-- +extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString) +extractTarballPackageCabalFile tarballFile = + withBinaryFile tarballFile ReadMode $ \hnd -> do + content <- LBS.hGetContents hnd + case extractTarballPackageCabalFilePure tarballFile content of + Left (Left e) -> throwIO e + Left (Right e) -> throwIO e + Right (fileName, fileContent) -> + (,) fileName <$> evaluate (LBS.toStrict fileContent) + + +-- | Scan through a tar file stream and collect the @.cabal@ file, or fail. +-- +extractTarballPackageCabalFilePure :: FilePath + -> LBS.ByteString + -> Either (Either Tar.FormatError + CabalFileSearchFailure) + (FilePath, LBS.ByteString) +extractTarballPackageCabalFilePure tarballFile = + check + . accumEntryMap + . Tar.filterEntries isCabalFile + . Tar.read + . GZipUtils.maybeDecompress + where + accumEntryMap = Tar.foldlEntries + (\m e -> Map.insert (Tar.entryTarPath e) e m) + Map.empty + + check (Left (e, _m)) = Left (Left e) + check (Right m) = case Map.elems m of + [] -> Left (Right $ NoCabalFileFound tarballFile) + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left (Right $ NoCabalFileFound tarballFile) + _files -> Left (Right $ MultipleCabalFilesFound tarballFile) + + isCabalFile e = case splitPath (Tar.entryPath e) of + [ _dir, file] -> takeExtension file == ".cabal" + [".", _dir, file] -> takeExtension file == ".cabal" + _ -> False + + +-- | The name to use for a local file for a remote tarball 'SourceRepo'. +-- This is deterministic based on the remote tarball URI, and is intended +-- to produce non-clashing file names for different tarballs. +-- +localFileNameForRemoteTarball :: URI -> FilePath +localFileNameForRemoteTarball uri = + mangleName uri + ++ "-" ++ showHex locationHash "" + where + mangleName = truncateString 10 . dropExtension . dropExtension + . takeFileName . dropTrailingPathSeparator . uriPath + + locationHash :: Word + locationHash = fromIntegral (Hashable.hash (uriToString id uri "")) + + +-- | The name to use for a local file or dir for a remote 'SourceRepo'. +-- This is deterministic based on the source repo identity details, and +-- intended to produce non-clashing file names for different repos. +-- +localFileNameForRemoteRepo :: SourceRepoList -> FilePath +localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} = + mangleName srpLocation ++ "-" ++ showHex locationHash "" + where + mangleName = truncateString 10 . dropExtension + . takeFileName . dropTrailingPathSeparator + + -- just the parts that make up the "identity" of the repo + locationHash :: Word + locationHash = + fromIntegral (Hashable.hash (show srpType, srpLocation)) + + +-- | Truncate a string, with a visual indication that it is truncated. +truncateString :: Int -> String -> String +truncateString n s | length s <= n = s + | otherwise = take (n-1) s ++ "_" + + +-- TODO: add something like this, here or in the project planning +-- Based on the package location, which packages will be built inplace in the +-- build tree vs placed in the store. This has various implications on what we +-- can do with the package, e.g. can we run tests, ghci etc. +-- +-- packageIsLocalToProject :: ProjectPackageLocation -> Bool + + +--------------------------------------------- +-- Checking configuration sanity +-- + +data BadPerPackageCompilerPaths + = BadPerPackageCompilerPaths [(PackageName, String)] +#if MIN_VERSION_base(4,8,0) + deriving (Show, Typeable) +#else + deriving (Typeable) + +instance Show BadPerPackageCompilerPaths where + show = renderBadPerPackageCompilerPaths +#endif + +instance Exception BadPerPackageCompilerPaths where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadPerPackageCompilerPaths +#endif +--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc + +renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String +renderBadPerPackageCompilerPaths + (BadPerPackageCompilerPaths ((pkgname, progname) : _)) = + "The path to the compiler program (or programs used by the compiler) " + ++ "cannot be specified on a per-package basis in the cabal.project file " + ++ "(i.e. setting the '" ++ progname ++ "-location' for package '" + ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so " + ++ "specify the path in a global 'program-locations' section." + --TODO: [nice to have] better format control so we can pretty-print the + -- offending part of the project file. Currently the line wrapping breaks any + -- formatting. +renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" + +-- | The project configuration is not allowed to specify program locations for +-- programs used by the compiler as these have to be the same for each set of +-- packages. +-- +-- We cannot check this until we know which programs the compiler uses, which +-- in principle is not until we've configured the compiler. +-- +-- Throws 'BadPerPackageCompilerPaths' +-- +checkBadPerPackageCompilerPaths :: [ConfiguredProgram] + -> Map PackageName PackageConfig + -> IO () +checkBadPerPackageCompilerPaths compilerPrograms packagesConfig = + case [ (pkgname, progname) + | let compProgNames = Set.fromList (map programId compilerPrograms) + , (pkgname, pkgconf) <- Map.toList packagesConfig + , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf)) + , progname `Set.member` compProgNames ] of + [] -> return () + ps -> throwIO (BadPerPackageCompilerPaths ps) diff --git a/src/Distribution/Client/ProjectConfig/Legacy.hs b/src/Distribution/Client/ProjectConfig/Legacy.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -0,0 +1,1491 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds #-} + +-- | Project configuration, implementation in terms of legacy types. +-- +module Distribution.Client.ProjectConfig.Legacy ( + + -- * Project config in terms of legacy types + LegacyProjectConfig, + parseLegacyProjectConfig, + showLegacyProjectConfig, + + -- * Conversion to and from legacy config types + commandLineFlagsToProjectConfig, + convertLegacyProjectConfig, + convertLegacyGlobalConfig, + convertToLegacyProjectConfig, + + -- * Internals, just for tests + parsePackageLocationTokenQ, + renderPackageLocationToken, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Types.Flag (parsecFlagAssignment) + +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.Types.RepoName (RepoName (..), unRepoName) +import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo) +import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..)) +import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) + +import Distribution.Client.Config + ( SavedConfig(..), remoteRepoFields, postProcessRepo ) + +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..), defaultClientInstallFlags + , clientInstallOptions ) + +import Distribution.Solver.Types.ConstraintSource + +import Distribution.FieldGrammar +import Distribution.Package +import Distribution.Types.SourceRepo (RepoType) +import Distribution.PackageDescription + ( dispFlagAssignment ) +import Distribution.Simple.Compiler + ( OptimisationLevel(..), DebugInfoLevel(..) ) +import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) +import Distribution.Simple.Setup + ( Flag(Flag), toFlag, fromFlagOrDefault + , ConfigFlags(..), configureOptions + , HaddockFlags(..), haddockOptions, defaultHaddockFlags + , TestFlags(..), testOptions', defaultTestFlags + , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags + , programDbPaths', splitArgs + ) +import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) +import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags) +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand + , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , InstallFlags(..), installOptions, defaultInstallFlags ) +import Distribution.Simple.Program + ( programName, knownPrograms ) +import Distribution.Simple.Program.Db + ( ProgramDb, defaultProgramDb ) +import Distribution.Simple.Utils + ( lowercase ) +import Distribution.Utils.NubList + ( toNubList, fromNubList, overNubList ) +import Distribution.Simple.LocalBuildInfo + ( toPathTemplate, fromPathTemplate ) + +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.ReadP + ( ReadP, (+++) ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint + ( Doc, ($+$) ) +import qualified Distribution.Deprecated.ParseUtils as ParseUtils +import Distribution.Deprecated.ParseUtils + ( ParseResult(..), PError(..), syntaxError, PWarning(..) + , commaNewLineListFieldParsec, newLineListField, parseTokenQ + , parseHaskellString, showToken + , simpleFieldParsec + ) +import Distribution.Client.ParseUtils +import Distribution.Simple.Command + ( CommandUI(commandOptions), ShowOrParseArgs(..) + , OptionField, option, reqArg' ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint ) +import Distribution.Parsec (ParsecParser) + +import qualified Data.Map as Map +import qualified Data.ByteString as BS + +import Network.URI (URI (..)) + +------------------------------------------------------------------ +-- Representing the project config file in terms of legacy types +-- + +-- | We already have parsers\/pretty-printers for almost all the fields in the +-- project config file, but they're in terms of the types used for the command +-- line flags for Setup.hs or cabal commands. We don't want to redefine them +-- all, at least not yet so for the moment we use the parsers at the old types +-- and use conversion functions. +-- +-- Ultimately if\/when this project-based approach becomes the default then we +-- can redefine the parsers directly for the new types. +-- +data LegacyProjectConfig = LegacyProjectConfig { + legacyPackages :: [String], + legacyPackagesOptional :: [String], + legacyPackagesRepo :: [SourceRepoList], + legacyPackagesNamed :: [PackageVersionConstraint], + + legacySharedConfig :: LegacySharedConfig, + legacyAllConfig :: LegacyPackageConfig, + legacyLocalConfig :: LegacyPackageConfig, + legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig + } deriving (Show, Generic) + +instance Monoid LegacyProjectConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup LegacyProjectConfig where + (<>) = gmappend + +data LegacyPackageConfig = LegacyPackageConfig { + legacyConfigureFlags :: ConfigFlags, + legacyInstallPkgFlags :: InstallFlags, + legacyHaddockFlags :: HaddockFlags, + legacyTestFlags :: TestFlags, + legacyBenchmarkFlags :: BenchmarkFlags + } deriving (Show, Generic) + +instance Monoid LegacyPackageConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup LegacyPackageConfig where + (<>) = gmappend + +data LegacySharedConfig = LegacySharedConfig { + legacyGlobalFlags :: GlobalFlags, + legacyConfigureShFlags :: ConfigFlags, + legacyConfigureExFlags :: ConfigExFlags, + legacyInstallFlags :: InstallFlags, + legacyClientInstallFlags:: ClientInstallFlags, + legacyProjectFlags :: ProjectFlags + } deriving (Show, Generic) + +instance Monoid LegacySharedConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup LegacySharedConfig where + (<>) = gmappend + + +------------------------------------------------------------------ +-- Converting from and to the legacy types +-- + +-- | Convert configuration from the @cabal configure@ or @cabal build@ command +-- line into a 'ProjectConfig' value that can combined with configuration from +-- other sources. +-- +-- At the moment this uses the legacy command line flag types. See +-- 'LegacyProjectConfig' for an explanation. +-- +commandLineFlagsToProjectConfig :: GlobalFlags + -> NixStyleFlags a + -> ClientInstallFlags + -> ProjectConfig +commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags = + mempty { + projectConfigBuildOnly = convertLegacyBuildOnlyFlags + globalFlags configFlags + installFlags clientInstallFlags + haddockFlags testFlags benchmarkFlags, + projectConfigShared = convertLegacyAllPackageFlags + globalFlags configFlags + configExFlags installFlags projectFlags, + projectConfigLocalPackages = localConfig, + projectConfigAllPackages = allConfig + } + where (localConfig, allConfig) = splitConfig + (convertLegacyPerPackageFlags + configFlags installFlags + haddockFlags testFlags benchmarkFlags) + -- split the package config (from command line arguments) into + -- those applied to all packages and those to local only. + -- + -- for now we will just copy over the ProgramPaths/Args/Extra into + -- the AllPackages. The LocalPackages do not inherit them from + -- AllPackages, and as such need to retain them. + -- + -- The general decision rule for what to put into allConfig + -- into localConfig is the following: + -- + -- - anything that is host/toolchain/env specific should be applied + -- to all packages, as packagesets have to be host/toolchain/env + -- consistent. + -- - anything else should be in the local config and could potentially + -- be lifted into all-packages vial the `package *` cabal.project + -- section. + -- + splitConfig :: PackageConfig -> (PackageConfig, PackageConfig) + splitConfig pc = (pc + , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc + , packageConfigProgramArgs = packageConfigProgramArgs pc + , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc + , packageConfigDocumentation = packageConfigDocumentation pc }) + +-- | Convert from the types currently used for the user-wide @~/.cabal/config@ +-- file into the 'ProjectConfig' type. +-- +-- Only a subset of the 'ProjectConfig' can be represented in the user-wide +-- config. In particular it does not include packages that are in the project, +-- and it also doesn't support package-specific configuration (only +-- configuration that applies to all packages). +-- +convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig +convertLegacyGlobalConfig + SavedConfig { + savedGlobalFlags = globalFlags, + savedInstallFlags = installFlags, + savedClientInstallFlags= clientInstallFlags, + savedConfigureFlags = configFlags, + savedConfigureExFlags = configExFlags, + savedUserInstallDirs = _, + savedGlobalInstallDirs = _, + savedUploadFlags = _, + savedReportFlags = _, + savedHaddockFlags = haddockFlags, + savedTestFlags = testFlags, + savedBenchmarkFlags = benchmarkFlags, + savedProjectFlags = projectFlags + } = + mempty { + projectConfigBuildOnly = configBuildOnly, + projectConfigShared = configShared, + projectConfigAllPackages = configAllPackages + } + where + --TODO: [code cleanup] eliminate use of default*Flags here and specify the + -- defaults in the various resolve functions in terms of the new types. + configExFlags' = defaultConfigExFlags <> configExFlags + installFlags' = defaultInstallFlags <> installFlags + clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags + haddockFlags' = defaultHaddockFlags <> haddockFlags + testFlags' = defaultTestFlags <> testFlags + benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags + projectFlags' = defaultProjectFlags <> projectFlags + + configAllPackages = convertLegacyPerPackageFlags + configFlags installFlags' + haddockFlags' testFlags' benchmarkFlags' + configShared = convertLegacyAllPackageFlags + globalFlags configFlags + configExFlags' installFlags' projectFlags' + configBuildOnly = convertLegacyBuildOnlyFlags + globalFlags configFlags + installFlags' clientInstallFlags' + haddockFlags' testFlags' benchmarkFlags' + + +-- | Convert the project config from the legacy types to the 'ProjectConfig' +-- and associated types. See 'LegacyProjectConfig' for an explanation of the +-- approach. +-- +convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig +convertLegacyProjectConfig + LegacyProjectConfig { + legacyPackages, + legacyPackagesOptional, + legacyPackagesRepo, + legacyPackagesNamed, + legacySharedConfig = LegacySharedConfig globalFlags configShFlags + configExFlags installSharedFlags + clientInstallFlags projectFlags, + legacyAllConfig, + legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags + haddockFlags testFlags benchmarkFlags, + legacySpecificConfig + } = + + ProjectConfig { + projectPackages = legacyPackages, + projectPackagesOptional = legacyPackagesOptional, + projectPackagesRepo = legacyPackagesRepo, + projectPackagesNamed = legacyPackagesNamed, + + projectConfigBuildOnly = configBuildOnly, + projectConfigShared = configPackagesShared, + projectConfigProvenance = mempty, + projectConfigAllPackages = configAllPackages, + projectConfigLocalPackages = configLocalPackages, + projectConfigSpecificPackage = fmap perPackage legacySpecificConfig + } + where + configAllPackages = convertLegacyPerPackageFlags g i h t b + where LegacyPackageConfig g i h t b = legacyAllConfig + configLocalPackages = convertLegacyPerPackageFlags + configFlags installPerPkgFlags haddockFlags + testFlags benchmarkFlags + configPackagesShared= convertLegacyAllPackageFlags + globalFlags (configFlags <> configShFlags) + configExFlags installSharedFlags projectFlags + configBuildOnly = convertLegacyBuildOnlyFlags + globalFlags configShFlags + installSharedFlags clientInstallFlags + haddockFlags testFlags benchmarkFlags + + perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags + perPkgHaddockFlags perPkgTestFlags + perPkgBenchmarkFlags) = + convertLegacyPerPackageFlags + perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags + perPkgTestFlags perPkgBenchmarkFlags + + +-- | Helper used by other conversion functions that returns the +-- 'ProjectConfigShared' subset of the 'ProjectConfig'. +-- +convertLegacyAllPackageFlags + :: GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> ProjectFlags + -> ProjectConfigShared +convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags = + ProjectConfigShared{..} + where + GlobalFlags { + globalConfigFile = projectConfigConfigFile, + globalRemoteRepos = projectConfigRemoteRepos, + globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, + globalActiveRepos = projectConfigActiveRepos, + globalProgPathExtra = projectConfigProgPathExtra, + globalStoreDir = projectConfigStoreDir + } = globalFlags + + ConfigFlags { + configDistPref = projectConfigDistDir, + configHcFlavor = projectConfigHcFlavor, + configHcPath = projectConfigHcPath, + configHcPkg = projectConfigHcPkg + --configProgramPathExtra = projectConfigProgPathExtra DELETE ME + --configInstallDirs = projectConfigInstallDirs, + --configUserInstall = projectConfigUserInstall, + --configPackageDBs = projectConfigPackageDBs, + } = configFlags + + ConfigExFlags { + configCabalVersion = projectConfigCabalVersion, + configExConstraints = projectConfigConstraints, + configPreferences = projectConfigPreferences, + configSolver = projectConfigSolver, + configAllowOlder = projectConfigAllowOlder, + configAllowNewer = projectConfigAllowNewer, + configWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy + } = configExFlags + + InstallFlags { + installHaddockIndex = projectConfigHaddockIndex, + --installReinstall = projectConfigReinstall, + --installAvoidReinstalls = projectConfigAvoidReinstalls, + --installOverrideReinstall = projectConfigOverrideReinstall, + installIndexState = projectConfigIndexState, + installMaxBackjumps = projectConfigMaxBackjumps, + --installUpgradeDeps = projectConfigUpgradeDeps, + installReorderGoals = projectConfigReorderGoals, + installCountConflicts = projectConfigCountConflicts, + installFineGrainedConflicts = projectConfigFineGrainedConflicts, + installMinimizeConflictSet = projectConfigMinimizeConflictSet, + installPerComponent = projectConfigPerComponent, + installIndependentGoals = projectConfigIndependentGoals, + --installShadowPkgs = projectConfigShadowPkgs, + installStrongFlags = projectConfigStrongFlags, + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, + installOnlyConstrained = projectConfigOnlyConstrained + } = installFlags + + ProjectFlags + { flagProjectFileName = projectConfigProjectFile + , flagIgnoreProject = projectConfigIgnoreProject + } = projectFlags + +-- | Helper used by other conversion functions that returns the +-- 'PackageConfig' subset of the 'ProjectConfig'. +-- +convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags + -> TestFlags -> BenchmarkFlags -> PackageConfig +convertLegacyPerPackageFlags configFlags installFlags + haddockFlags testFlags benchmarkFlags = + PackageConfig{..} + where + ConfigFlags { + configProgramPaths, + configProgramArgs, + configProgramPathExtra = packageConfigProgramPathExtra, + configVanillaLib = packageConfigVanillaLib, + configProfLib = packageConfigProfLib, + configSharedLib = packageConfigSharedLib, + configStaticLib = packageConfigStaticLib, + configDynExe = packageConfigDynExe, + configFullyStaticExe = packageConfigFullyStaticExe, + configProfExe = packageConfigProfExe, + configProf = packageConfigProf, + configProfDetail = packageConfigProfDetail, + configProfLibDetail = packageConfigProfLibDetail, + configConfigureArgs = packageConfigConfigureArgs, + configOptimization = packageConfigOptimization, + configProgPrefix = packageConfigProgPrefix, + configProgSuffix = packageConfigProgSuffix, + configGHCiLib = packageConfigGHCiLib, + configSplitSections = packageConfigSplitSections, + configSplitObjs = packageConfigSplitObjs, + configStripExes = packageConfigStripExes, + configStripLibs = packageConfigStripLibs, + configExtraLibDirs = packageConfigExtraLibDirs, + configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, + configExtraIncludeDirs = packageConfigExtraIncludeDirs, + configConfigurationsFlags = packageConfigFlagAssignment, + configTests = packageConfigTests, + configBenchmarks = packageConfigBenchmarks, + configCoverage = coverage, + configLibCoverage = libcoverage, --deprecated + configDebugInfo = packageConfigDebugInfo, + configRelocatable = packageConfigRelocatable + } = configFlags + packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths) + packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs) + + packageConfigCoverage = coverage <> libcoverage + --TODO: defer this merging to the resolve phase + + InstallFlags { + installDocumentation = packageConfigDocumentation, + installRunTests = packageConfigRunTests + } = installFlags + + HaddockFlags { + haddockHoogle = packageConfigHaddockHoogle, + haddockHtml = packageConfigHaddockHtml, + haddockHtmlLocation = packageConfigHaddockHtmlLocation, + haddockForeignLibs = packageConfigHaddockForeignLibs, + haddockForHackage = packageConfigHaddockForHackage, + haddockExecutables = packageConfigHaddockExecutables, + haddockTestSuites = packageConfigHaddockTestSuites, + haddockBenchmarks = packageConfigHaddockBenchmarks, + haddockInternal = packageConfigHaddockInternal, + haddockCss = packageConfigHaddockCss, + haddockLinkedSource = packageConfigHaddockLinkedSource, + haddockQuickJump = packageConfigHaddockQuickJump, + haddockHscolourCss = packageConfigHaddockHscolourCss, + haddockContents = packageConfigHaddockContents + } = haddockFlags + + TestFlags { + testHumanLog = packageConfigTestHumanLog, + testMachineLog = packageConfigTestMachineLog, + testShowDetails = packageConfigTestShowDetails, + testKeepTix = packageConfigTestKeepTix, + testWrapper = packageConfigTestWrapper, + testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, + testOptions = packageConfigTestTestOptions + } = testFlags + + BenchmarkFlags { + benchmarkOptions = packageConfigBenchmarkOptions + } = benchmarkFlags + + +-- | Helper used by other conversion functions that returns the +-- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'. +-- +convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags + -> InstallFlags -> ClientInstallFlags + -> HaddockFlags -> TestFlags + -> BenchmarkFlags + -> ProjectConfigBuildOnly +convertLegacyBuildOnlyFlags globalFlags configFlags + installFlags clientInstallFlags + haddockFlags _ _ = + ProjectConfigBuildOnly{..} + where + projectConfigClientInstallFlags = clientInstallFlags + GlobalFlags { + globalCacheDir = projectConfigCacheDir, + globalLogsDir = projectConfigLogsDir, + globalWorldFile = _, + globalHttpTransport = projectConfigHttpTransport, + globalIgnoreExpiry = projectConfigIgnoreExpiry + } = globalFlags + + ConfigFlags { + configVerbosity = projectConfigVerbosity + } = configFlags + + InstallFlags { + installDryRun = projectConfigDryRun, + installOnlyDownload = projectConfigOnlyDownload, + installOnly = _, + installOnlyDeps = projectConfigOnlyDeps, + installRootCmd = _, + installSummaryFile = projectConfigSummaryFile, + installLogFile = projectConfigLogFile, + installBuildReports = projectConfigBuildReports, + installReportPlanningFailure = projectConfigReportPlanningFailure, + installSymlinkBinDir = projectConfigSymlinkBinDir, + installOneShot = projectConfigOneShot, + installNumJobs = projectConfigNumJobs, + installKeepGoing = projectConfigKeepGoing, + installOfflineMode = projectConfigOfflineMode + } = installFlags + + HaddockFlags { + haddockKeepTempFiles = projectConfigKeepTempFiles --TODO: this ought to live elsewhere + } = haddockFlags + + +convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig +convertToLegacyProjectConfig + projectConfig@ProjectConfig { + projectPackages, + projectPackagesOptional, + projectPackagesRepo, + projectPackagesNamed, + projectConfigAllPackages, + projectConfigLocalPackages, + projectConfigSpecificPackage + } = + LegacyProjectConfig { + legacyPackages = projectPackages, + legacyPackagesOptional = projectPackagesOptional, + legacyPackagesRepo = projectPackagesRepo, + legacyPackagesNamed = projectPackagesNamed, + legacySharedConfig = convertToLegacySharedConfig projectConfig, + legacyAllConfig = convertToLegacyPerPackageConfig + projectConfigAllPackages, + legacyLocalConfig = convertToLegacyAllPackageConfig projectConfig + <> convertToLegacyPerPackageConfig + projectConfigLocalPackages, + legacySpecificConfig = fmap convertToLegacyPerPackageConfig + projectConfigSpecificPackage + } + +convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig +convertToLegacySharedConfig + ProjectConfig { + projectConfigBuildOnly = ProjectConfigBuildOnly {..}, + projectConfigShared = ProjectConfigShared {..}, + projectConfigAllPackages = PackageConfig { + packageConfigDocumentation + } + } = + + LegacySharedConfig + { legacyGlobalFlags = globalFlags + , legacyConfigureShFlags = configFlags + , legacyConfigureExFlags = configExFlags + , legacyInstallFlags = installFlags + , legacyClientInstallFlags = projectConfigClientInstallFlags + , legacyProjectFlags = projectFlags + } + where + globalFlags = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = projectConfigConfigFile, + globalConstraintsFile = mempty, + globalRemoteRepos = projectConfigRemoteRepos, + globalCacheDir = projectConfigCacheDir, + globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, + globalActiveRepos = projectConfigActiveRepos, + globalLogsDir = projectConfigLogsDir, + globalWorldFile = mempty, + globalIgnoreExpiry = projectConfigIgnoreExpiry, + globalHttpTransport = projectConfigHttpTransport, + globalNix = mempty, + globalStoreDir = projectConfigStoreDir, + globalProgPathExtra = projectConfigProgPathExtra + } + + configFlags = mempty { + configVerbosity = projectConfigVerbosity, + configDistPref = projectConfigDistDir + } + + configExFlags = ConfigExFlags { + configCabalVersion = projectConfigCabalVersion, + configExConstraints = projectConfigConstraints, + configPreferences = projectConfigPreferences, + configSolver = projectConfigSolver, + configAllowOlder = projectConfigAllowOlder, + configAllowNewer = projectConfigAllowNewer, + configWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy + } + + installFlags = InstallFlags { + installDocumentation = packageConfigDocumentation, + installHaddockIndex = projectConfigHaddockIndex, + installDest = Flag NoCopyDest, + installDryRun = projectConfigDryRun, + installOnlyDownload = projectConfigOnlyDownload, + installReinstall = mempty, --projectConfigReinstall, + installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls, + installOverrideReinstall = mempty, --projectConfigOverrideReinstall, + installMaxBackjumps = projectConfigMaxBackjumps, + installUpgradeDeps = mempty, --projectConfigUpgradeDeps, + installReorderGoals = projectConfigReorderGoals, + installCountConflicts = projectConfigCountConflicts, + installFineGrainedConflicts = projectConfigFineGrainedConflicts, + installMinimizeConflictSet = projectConfigMinimizeConflictSet, + installIndependentGoals = projectConfigIndependentGoals, + installShadowPkgs = mempty, --projectConfigShadowPkgs, + installStrongFlags = projectConfigStrongFlags, + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, + installOnlyConstrained = projectConfigOnlyConstrained, + installOnly = mempty, + installOnlyDeps = projectConfigOnlyDeps, + installIndexState = projectConfigIndexState, + installRootCmd = mempty, --no longer supported + installSummaryFile = projectConfigSummaryFile, + installLogFile = projectConfigLogFile, + installBuildReports = projectConfigBuildReports, + installReportPlanningFailure = projectConfigReportPlanningFailure, + installSymlinkBinDir = projectConfigSymlinkBinDir, + installPerComponent = projectConfigPerComponent, + installOneShot = projectConfigOneShot, + installNumJobs = projectConfigNumJobs, + installKeepGoing = projectConfigKeepGoing, + installRunTests = mempty, + installOfflineMode = projectConfigOfflineMode + } + + projectFlags = ProjectFlags + { flagProjectFileName = projectConfigProjectFile + , flagIgnoreProject = projectConfigIgnoreProject + } + + +convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig +convertToLegacyAllPackageConfig + ProjectConfig { + projectConfigBuildOnly = ProjectConfigBuildOnly {..}, + projectConfigShared = ProjectConfigShared {..} + } = + + LegacyPackageConfig { + legacyConfigureFlags = configFlags, + legacyInstallPkgFlags= mempty, + legacyHaddockFlags = haddockFlags, + legacyTestFlags = mempty, + legacyBenchmarkFlags = mempty + } + where + configFlags = ConfigFlags { + configArgs = mempty, + configPrograms_ = mempty, + configProgramPaths = mempty, + configProgramArgs = mempty, + configProgramPathExtra = mempty, + configHcFlavor = projectConfigHcFlavor, + configHcPath = projectConfigHcPath, + configHcPkg = projectConfigHcPkg, + configInstantiateWith = mempty, + configVanillaLib = mempty, + configProfLib = mempty, + configSharedLib = mempty, + configStaticLib = mempty, + configDynExe = mempty, + configFullyStaticExe = mempty, + configProfExe = mempty, + configProf = mempty, + configProfDetail = mempty, + configProfLibDetail = mempty, + configConfigureArgs = mempty, + configOptimization = mempty, + configProgPrefix = mempty, + configProgSuffix = mempty, + configInstallDirs = mempty, + configScratchDir = mempty, + configDistPref = mempty, + configCabalFilePath = mempty, + configVerbosity = mempty, + configUserInstall = mempty, --projectConfigUserInstall, + configPackageDBs = mempty, --projectConfigPackageDBs, + configGHCiLib = mempty, + configSplitSections = mempty, + configSplitObjs = mempty, + configStripExes = mempty, + configStripLibs = mempty, + configExtraLibDirs = mempty, + configExtraFrameworkDirs = mempty, + configConstraints = mempty, + configDependencies = mempty, + configExtraIncludeDirs = mempty, + configDeterministic = mempty, + configIPID = mempty, + configCID = mempty, + configConfigurationsFlags = mempty, + configTests = mempty, + configCoverage = mempty, --TODO: don't merge + configLibCoverage = mempty, --TODO: don't merge + configExactConfiguration = mempty, + configBenchmarks = mempty, + configFlagError = mempty, --TODO: ??? + configRelocatable = mempty, + configDebugInfo = mempty, + configUseResponseFiles = mempty, + configAllowDependingOnPrivateLibs = mempty + } + + haddockFlags = mempty { + haddockKeepTempFiles = projectConfigKeepTempFiles + } + + +convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig +convertToLegacyPerPackageConfig PackageConfig {..} = + LegacyPackageConfig { + legacyConfigureFlags = configFlags, + legacyInstallPkgFlags = installFlags, + legacyHaddockFlags = haddockFlags, + legacyTestFlags = testFlags, + legacyBenchmarkFlags = benchmarkFlags + } + where + configFlags = ConfigFlags { + configArgs = mempty, + configPrograms_ = configPrograms_ mempty, + configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths), + configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs), + configProgramPathExtra = packageConfigProgramPathExtra, + configHcFlavor = mempty, + configHcPath = mempty, + configHcPkg = mempty, + configInstantiateWith = mempty, + configVanillaLib = packageConfigVanillaLib, + configProfLib = packageConfigProfLib, + configSharedLib = packageConfigSharedLib, + configStaticLib = packageConfigStaticLib, + configDynExe = packageConfigDynExe, + configFullyStaticExe = packageConfigFullyStaticExe, + configProfExe = packageConfigProfExe, + configProf = packageConfigProf, + configProfDetail = packageConfigProfDetail, + configProfLibDetail = packageConfigProfLibDetail, + configConfigureArgs = packageConfigConfigureArgs, + configOptimization = packageConfigOptimization, + configProgPrefix = packageConfigProgPrefix, + configProgSuffix = packageConfigProgSuffix, + configInstallDirs = mempty, + configScratchDir = mempty, + configDistPref = mempty, + configCabalFilePath = mempty, + configVerbosity = mempty, + configUserInstall = mempty, + configPackageDBs = mempty, + configGHCiLib = packageConfigGHCiLib, + configSplitSections = packageConfigSplitSections, + configSplitObjs = packageConfigSplitObjs, + configStripExes = packageConfigStripExes, + configStripLibs = packageConfigStripLibs, + configExtraLibDirs = packageConfigExtraLibDirs, + configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, + configConstraints = mempty, + configDependencies = mempty, + configExtraIncludeDirs = packageConfigExtraIncludeDirs, + configIPID = mempty, + configCID = mempty, + configDeterministic = mempty, + configConfigurationsFlags = packageConfigFlagAssignment, + configTests = packageConfigTests, + configCoverage = packageConfigCoverage, --TODO: don't merge + configLibCoverage = packageConfigCoverage, --TODO: don't merge + configExactConfiguration = mempty, + configBenchmarks = packageConfigBenchmarks, + configFlagError = mempty, --TODO: ??? + configRelocatable = packageConfigRelocatable, + configDebugInfo = packageConfigDebugInfo, + configUseResponseFiles = mempty, + configAllowDependingOnPrivateLibs = mempty + } + + installFlags = mempty { + installDocumentation = packageConfigDocumentation, + installRunTests = packageConfigRunTests + } + + haddockFlags = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = mempty, + haddockHoogle = packageConfigHaddockHoogle, + haddockHtml = packageConfigHaddockHtml, + haddockHtmlLocation = packageConfigHaddockHtmlLocation, + haddockForHackage = packageConfigHaddockForHackage, + haddockForeignLibs = packageConfigHaddockForeignLibs, + haddockExecutables = packageConfigHaddockExecutables, + haddockTestSuites = packageConfigHaddockTestSuites, + haddockBenchmarks = packageConfigHaddockBenchmarks, + haddockInternal = packageConfigHaddockInternal, + haddockCss = packageConfigHaddockCss, + haddockLinkedSource = packageConfigHaddockLinkedSource, + haddockQuickJump = packageConfigHaddockQuickJump, + haddockHscolourCss = packageConfigHaddockHscolourCss, + haddockContents = packageConfigHaddockContents, + haddockDistPref = mempty, + haddockKeepTempFiles = mempty, + haddockVerbosity = mempty, + haddockCabalFilePath = mempty, + haddockArgs = mempty + } + + testFlags = TestFlags { + testDistPref = mempty, + testVerbosity = mempty, + testHumanLog = packageConfigTestHumanLog, + testMachineLog = packageConfigTestMachineLog, + testShowDetails = packageConfigTestShowDetails, + testKeepTix = packageConfigTestKeepTix, + testWrapper = packageConfigTestWrapper, + testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, + testOptions = packageConfigTestTestOptions + } + + benchmarkFlags = BenchmarkFlags { + benchmarkDistPref = mempty, + benchmarkVerbosity = mempty, + benchmarkOptions = packageConfigBenchmarkOptions + } + +------------------------------------------------ +-- Parsing and showing the project config file +-- + +parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig +parseLegacyProjectConfig source = + parseConfig (legacyProjectConfigFieldDescrs constraintSrc) + legacyPackageConfigSectionDescrs + legacyPackageConfigFGSectionDescrs + mempty + where + constraintSrc = ConstraintSourceProjectConfig source + +showLegacyProjectConfig :: LegacyProjectConfig -> String +showLegacyProjectConfig config = + Disp.render $ + showConfig (legacyProjectConfigFieldDescrs constraintSrc) + legacyPackageConfigSectionDescrs + legacyPackageConfigFGSectionDescrs + config + $+$ + Disp.text "" + where + -- Note: ConstraintSource is unused when pretty-printing. We fake + -- it here to avoid having to pass it on call-sites. It's not great + -- but requires re-work of how we annotate provenance. + constraintSrc = ConstraintSourceProjectConfig "unused" + + +legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig] +legacyProjectConfigFieldDescrs constraintSrc = + + [ newLineListField "packages" + (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ + legacyPackages + (\v flags -> flags { legacyPackages = v }) + , newLineListField "optional-packages" + (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ + legacyPackagesOptional + (\v flags -> flags { legacyPackagesOptional = v }) + , commaNewLineListFieldParsec "extra-packages" + pretty parsec + legacyPackagesNamed + (\v flags -> flags { legacyPackagesNamed = v }) + ] + + ++ map (liftField + legacySharedConfig + (\flags conf -> conf { legacySharedConfig = flags })) + (legacySharedConfigFieldDescrs constraintSrc) + + ++ map (liftField + legacyLocalConfig + (\flags conf -> conf { legacyLocalConfig = flags })) + legacyPackageConfigFieldDescrs + +-- | This is a bit tricky since it has to cover globs which have embedded @,@ +-- chars. But we don't just want to parse strictly as a glob since we want to +-- allow http urls which don't parse as globs, and possibly some +-- system-dependent file paths. So we parse fairly liberally as a token, but +-- we allow @,@ inside matched @{}@ braces. +-- +parsePackageLocationTokenQ :: ReadP r String +parsePackageLocationTokenQ = parseHaskellString + Parse.<++ parsePackageLocationToken + where + parsePackageLocationToken :: ReadP r String + parsePackageLocationToken = fmap fst (Parse.gather outerTerm) + where + outerTerm = alternateEither1 outerToken (braces innerTerm) + innerTerm = alternateEither innerToken (braces innerTerm) + outerToken = Parse.munch1 outerChar >> return () + innerToken = Parse.munch1 innerChar >> return () + outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',') + innerChar c = not (isSpace c || c == '{' || c == '}') + braces = Parse.between (Parse.char '{') (Parse.char '}') + + alternateEither, alternateEither1, + alternatePQs, alternate1PQs, alternateQsP, alternate1QsP + :: ReadP r () -> ReadP r () -> ReadP r () + + alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p + alternateEither p q = alternateEither1 p q +++ return () + alternate1PQs p q = p >> alternateQsP q p + alternatePQs p q = alternate1PQs p q +++ return () + alternate1QsP q p = Parse.many1 q >> alternatePQs p q + alternateQsP q p = alternate1QsP q p +++ return () + +renderPackageLocationToken :: String -> String +renderPackageLocationToken s | needsQuoting = show s + | otherwise = s + where + needsQuoting = not (ok 0 s) + || s == "." -- . on its own on a line has special meaning + || take 2 s == "--" -- on its own line is comment syntax + --TODO: [code cleanup] these "." and "--" escaping issues + -- ought to be dealt with systematically in ParseUtils. + ok :: Int -> String -> Bool + ok n [] = n == 0 + ok _ ('"':_) = False + ok n ('{':cs) = ok (n+1) cs + ok n ('}':cs) = ok (n-1) cs + ok n (',':cs) = (n > 0) && ok n cs + ok _ (c:_) + | isSpace c = False + ok n (_ :cs) = ok n cs + + +legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig] +legacySharedConfigFieldDescrs constraintSrc = concat + [ liftFields + legacyGlobalFlags + (\flags conf -> conf { legacyGlobalFlags = flags }) + . addFields + [ newLineListField "extra-prog-path-shared-only" + showTokenQ parseTokenQ + (fromNubList . globalProgPathExtra) + (\v conf -> conf { globalProgPathExtra = toNubList v }) + ] + . filterFields + [ "remote-repo-cache" + , "logs-dir", "store-dir", "ignore-expiry", "http-transport" + , "active-repositories" + ] + . commandOptionsToFields + $ commandOptions (globalCommand []) ParseArgs + + , liftFields + legacyConfigureShFlags + (\flags conf -> conf { legacyConfigureShFlags = flags }) + . filterFields ["verbose", "builddir" ] + . commandOptionsToFields + $ configureOptions ParseArgs + + , liftFields + legacyConfigureExFlags + (\flags conf -> conf { legacyConfigureExFlags = flags }) + . addFields + [ commaNewLineListFieldParsec "constraints" + (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec) + configExConstraints (\v conf -> conf { configExConstraints = v }) + + , commaNewLineListFieldParsec "preferences" + pretty parsec + configPreferences (\v conf -> conf { configPreferences = v }) + + , monoidFieldParsec "allow-older" + (maybe mempty pretty) (fmap Just parsec) + (fmap unAllowOlder . configAllowOlder) + (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) + + , monoidFieldParsec "allow-newer" + (maybe mempty pretty) (fmap Just parsec) + (fmap unAllowNewer . configAllowNewer) + (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) + ] + . filterFields + [ "cabal-lib-version", "solver", "write-ghc-environment-files" + -- not "constraint" or "preference", we use our own plural ones above + ] + . commandOptionsToFields + $ configureExOptions ParseArgs constraintSrc + + , liftFields + legacyInstallFlags + (\flags conf -> conf { legacyInstallFlags = flags }) + . addFields + [ newLineListField "build-summary" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + (fromNubList . installSummaryFile) + (\v conf -> conf { installSummaryFile = toNubList v }) + ] + . filterFields + [ "doc-index-file" + , "root-cmd", "symlink-bindir" + , "build-log" + , "remote-build-reporting", "report-planning-failure" + , "one-shot", "jobs", "keep-going", "offline", "per-component" + -- solver flags: + , "max-backjumps", "reorder-goals", "count-conflicts" + , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals" + , "strong-flags" , "allow-boot-library-installs" + , "reject-unconstrained-dependencies", "index-state" + ] + . commandOptionsToFields + $ installOptions ParseArgs + + , liftFields + legacyClientInstallFlags + (\flags conf -> conf { legacyClientInstallFlags = flags }) + . commandOptionsToFields + $ clientInstallOptions ParseArgs + + , liftFields + legacyProjectFlags + (\flags conf -> conf { legacyProjectFlags = flags }) + . commandOptionsToFields + $ projectFlagsOptions ParseArgs + + ] + + +legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] +legacyPackageConfigFieldDescrs = + ( liftFields + legacyConfigureFlags + (\flags conf -> conf { legacyConfigureFlags = flags }) + . addFields + [ newLineListField "extra-include-dirs" + showTokenQ parseTokenQ + configExtraIncludeDirs + (\v conf -> conf { configExtraIncludeDirs = v }) + , newLineListField "extra-lib-dirs" + showTokenQ parseTokenQ + configExtraLibDirs + (\v conf -> conf { configExtraLibDirs = v }) + , newLineListField "extra-framework-dirs" + showTokenQ parseTokenQ + configExtraFrameworkDirs + (\v conf -> conf { configExtraFrameworkDirs = v }) + , newLineListField "extra-prog-path" + showTokenQ parseTokenQ + (fromNubList . configProgramPathExtra) + (\v conf -> conf { configProgramPathExtra = toNubList v }) + , newLineListField "configure-options" + showTokenQ parseTokenQ + configConfigureArgs + (\v conf -> conf { configConfigureArgs = v }) + , simpleFieldParsec "flags" + dispFlagAssignment parsecFlagAssignment + configConfigurationsFlags + (\v conf -> conf { configConfigurationsFlags = v }) + ] + . filterFields + [ "with-compiler", "with-hc-pkg" + , "program-prefix", "program-suffix" + , "library-vanilla", "library-profiling" + , "shared", "static", "executable-dynamic", "executable-static" + , "profiling", "executable-profiling" + , "profiling-detail", "library-profiling-detail" + , "library-for-ghci", "split-objs", "split-sections" + , "executable-stripping", "library-stripping" + , "tests", "benchmarks" + , "coverage", "library-coverage" + , "relocatable" + -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs" + -- or "extra-prog-path". We use corrected ones above that parse + -- as list fields. + ] + . commandOptionsToFields + ) (configureOptions ParseArgs) + ++ + liftFields + legacyConfigureFlags + (\flags conf -> conf { legacyConfigureFlags = flags }) + [ overrideFieldCompiler + , overrideFieldOptimization + , overrideFieldDebugInfo + ] + ++ + ( liftFields + legacyInstallPkgFlags + (\flags conf -> conf { legacyInstallPkgFlags = flags }) + . filterFields + [ "documentation", "run-tests" + ] + . commandOptionsToFields + ) (installOptions ParseArgs) + ++ + ( liftFields + legacyHaddockFlags + (\flags conf -> conf { legacyHaddockFlags = flags }) + . mapFieldNames + ("haddock-"++) + . addFields + [ simpleFieldParsec "for-hackage" + -- TODO: turn this into a library function + (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty) + haddockForHackage (\v conf -> conf { haddockForHackage = v }) + ] + . filterFields + [ "hoogle", "html", "html-location" + , "foreign-libraries" + , "executables", "tests", "benchmarks", "all", "internal", "css" + , "hyperlink-source", "quickjump", "hscolour-css" + , "contents-location", "keep-temp-files" + ] + . commandOptionsToFields + ) (haddockOptions ParseArgs) + ++ + ( liftFields + legacyTestFlags + (\flags conf -> conf { legacyTestFlags = flags }) + . mapFieldNames + prefixTest + . addFields + [ newLineListField "test-options" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + testOptions + (\v conf -> conf { testOptions = v }) + ] + . filterFields + [ "log", "machine-log", "show-details", "keep-tix-files" + , "fail-when-no-test-suites", "test-wrapper" ] + . commandOptionsToFields + ) (testOptions' ParseArgs) + ++ + ( liftFields + legacyBenchmarkFlags + (\flags conf -> conf { legacyBenchmarkFlags = flags }) + . addFields + [ newLineListField "benchmark-options" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + benchmarkOptions + (\v conf -> conf { benchmarkOptions = v }) + ] + . filterFields + [] + . commandOptionsToFields + ) (benchmarkOptions' ParseArgs) + + + where + overrideFieldCompiler = + simpleFieldParsec "compiler" + (fromFlagOrDefault Disp.empty . fmap pretty) + (toFlag <$> parsec <|> pure mempty) + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + + + -- TODO: [code cleanup] The following is a hack. The "optimization" and + -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that. + -- Instead of a hand-written parser and printer, we should handle this case + -- properly in the library. + + overrideFieldOptimization = + liftField configOptimization + (\v flags -> flags { configOptimization = v }) $ + let name = "optimization" in + FieldDescr name + (\f -> case f of + Flag NoOptimisation -> Disp.text "False" + Flag NormalOptimisation -> Disp.text "True" + Flag MaximumOptimisation -> Disp.text "2" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoOptimisation) + | str == "True" -> ParseOk [] (Flag NormalOptimisation) + | str == "0" -> ParseOk [] (Flag NoOptimisation) + | str == "1" -> ParseOk [] (Flag NormalOptimisation) + | str == "2" -> ParseOk [] (Flag MaximumOptimisation) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) + | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") + + overrideFieldDebugInfo = + liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ + let name = "debug-info" in + FieldDescr name + (\f -> case f of + Flag NoDebugInfo -> Disp.text "False" + Flag MinimalDebugInfo -> Disp.text "1" + Flag NormalDebugInfo -> Disp.text "True" + Flag MaximalDebugInfo -> Disp.text "3" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) + | str == "True" -> ParseOk [] (Flag NormalDebugInfo) + | str == "0" -> ParseOk [] (Flag NoDebugInfo) + | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) + | str == "2" -> ParseOk [] (Flag NormalDebugInfo) + | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) + | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") + + prefixTest name | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name + + +legacyPackageConfigFGSectionDescrs + :: ( FieldGrammar c g, Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => [FGSectionDescr g LegacyProjectConfig] +legacyPackageConfigFGSectionDescrs = + [ packageRepoSectionDescr + ] + +legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] +legacyPackageConfigSectionDescrs = + [ packageSpecificOptionsSectionDescr + , liftSection + legacyLocalConfig + (\flags conf -> conf { legacyLocalConfig = flags }) + programOptionsSectionDescr + , liftSection + legacyLocalConfig + (\flags conf -> conf { legacyLocalConfig = flags }) + programLocationsSectionDescr + , liftSection + legacySharedConfig + (\flags conf -> conf { legacySharedConfig = flags }) $ + liftSection + legacyGlobalFlags + (\flags conf -> conf { legacyGlobalFlags = flags }) + remoteRepoSectionDescr + ] + +packageRepoSectionDescr + :: ( FieldGrammar c g, Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => FGSectionDescr g LegacyProjectConfig +packageRepoSectionDescr = FGSectionDescr + { fgSectionName = "source-repository-package" + , fgSectionGrammar = sourceRepositoryPackageGrammar + , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo + , fgSectionSet = + \lineno unused pkgrepo projconf -> do + unless (null unused) $ + syntaxError lineno "the section 'source-repository-package' takes no arguments" + return projconf { + legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo] + } + } + +-- | The definitions of all the fields that can appear in the @package pkgfoo@ +-- and @package *@ sections of the @cabal.project@-format files. +-- +packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig] +packageSpecificOptionsFieldDescrs = + legacyPackageConfigFieldDescrs + ++ programOptionsFieldDescrs + (configProgramArgs . legacyConfigureFlags) + (\args pkgconf -> pkgconf { + legacyConfigureFlags = (legacyConfigureFlags pkgconf) { + configProgramArgs = args + } + } + ) + ++ liftFields + legacyConfigureFlags + (\flags pkgconf -> pkgconf { + legacyConfigureFlags = flags + } + ) + programLocationsFieldDescrs + +-- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format +-- files. This section is per-package name. The special package @*@ applies to all +-- packages used anywhere by the project, locally or as dependencies. +-- +packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig +packageSpecificOptionsSectionDescr = + SectionDescr { + sectionName = "package", + sectionFields = packageSpecificOptionsFieldDescrs, + sectionSubsections = [], + sectionGet = \projconf -> + [ (prettyShow pkgname, pkgconf) + | (pkgname, pkgconf) <- + Map.toList . getMapMappend + . legacySpecificConfig $ projconf ] + ++ [ ("*", legacyAllConfig projconf) ], + sectionSet = + \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of + "*" -> return projconf { + legacyAllConfig = legacyAllConfig projconf <> pkgconf + } + _ -> do + pkgname <- case simpleParsec pkgnamestr of + Just pkgname -> return pkgname + Nothing -> syntaxError lineno $ + "a 'package' section requires a package name " + ++ "as an argument" + return projconf { + legacySpecificConfig = + MapMappend $ + Map.insertWith mappend pkgname pkgconf + (getMapMappend $ legacySpecificConfig projconf) + }, + sectionEmpty = mempty + } + +programOptionsFieldDescrs :: (a -> [(String, [String])]) + -> ([(String, [String])] -> a -> a) + -> [FieldDescr a] +programOptionsFieldDescrs get' set = + commandOptionsToFields + $ programDbOptions + defaultProgramDb + ParseArgs get' set + +programOptionsSectionDescr :: SectionDescr LegacyPackageConfig +programOptionsSectionDescr = + SectionDescr { + sectionName = "program-options", + sectionFields = programOptionsFieldDescrs + configProgramArgs + (\args conf -> conf { configProgramArgs = args }), + sectionSubsections = [], + sectionGet = (\x->[("", x)]) + . legacyConfigureFlags, + sectionSet = + \lineno unused confflags pkgconf -> do + unless (null unused) $ + syntaxError lineno "the section 'program-options' takes no arguments" + return pkgconf { + legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags + }, + sectionEmpty = mempty + } + +programLocationsFieldDescrs :: [FieldDescr ConfigFlags] +programLocationsFieldDescrs = + commandOptionsToFields + $ programDbPaths' + (++ "-location") + defaultProgramDb + ParseArgs + configProgramPaths + (\paths conf -> conf { configProgramPaths = paths }) + +programLocationsSectionDescr :: SectionDescr LegacyPackageConfig +programLocationsSectionDescr = + SectionDescr { + sectionName = "program-locations", + sectionFields = programLocationsFieldDescrs, + sectionSubsections = [], + sectionGet = (\x->[("", x)]) + . legacyConfigureFlags, + sectionSet = + \lineno unused confflags pkgconf -> do + unless (null unused) $ + syntaxError lineno "the section 'program-locations' takes no arguments" + return pkgconf { + legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags + }, + sectionEmpty = mempty + } + + +-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ +-- 'OptionField'. +programDbOptions + :: ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programDbOptions progDb showOrParseArgs get' set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOptions "PROG"] + ParseArgs -> map (programOptions . programName . fst) + (knownPrograms progDb) + where + programOptions prog = + option "" [prog ++ "-options"] + ("give extra options to " ++ prog) + get' set + (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) + (\progArgs -> [ joinsArgs args + | (prog', args) <- progArgs, prog==prog' ])) + + + joinsArgs = unwords . map escape + escape arg | any isSpace arg = "\"" ++ arg ++ "\"" + | otherwise = arg + + +-- The implementation is slight hack: we parse all as remote repository +-- but if the url schema is file+noindex, we switch to local. +remoteRepoSectionDescr :: SectionDescr GlobalFlags +remoteRepoSectionDescr = SectionDescr + { sectionName = "repository" + , sectionEmpty = emptyRemoteRepo (RepoName "") + , sectionFields = remoteRepoFields + , sectionSubsections = [] + , sectionGet = getS + , sectionSet = setS + } + where + getS :: GlobalFlags -> [(String, RemoteRepo)] + getS gf = + map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) + ++ + map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) + + setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags + setS lineno reponame repo0 conf = do + repo1 <- postProcessRepo lineno reponame repo0 + case repo1 of + Left repo -> return conf + { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf) + } + Right repo -> return conf + { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) + } + + localToRemote :: LocalRepo -> RemoteRepo + localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name) + { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "") + } + +------------------------------- +-- Local field utils +-- + +-- | Parser combinator for simple fields which uses the field type's +-- 'Monoid' instance for combining multiple occurrences of the field. +monoidFieldParsec + :: Monoid a => String -> (a -> Doc) -> ParsecParser a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +monoidFieldParsec name showF readF get' set = + liftField get' set' $ ParseUtils.fieldParsec name showF readF + where + set' xs b = set (get' b `mappend` xs) b + + +--TODO: [code cleanup] local redefinition that should replace the version in +-- D.ParseUtils called showFilePath. This version escapes "." and "--" which +-- otherwise are special syntax. +showTokenQ :: String -> Doc +showTokenQ "" = Disp.empty +showTokenQ x@('-':'-':_) = Disp.text (show x) +showTokenQ x@('.':[]) = Disp.text (show x) +showTokenQ x = showToken x + + +-- Handy util +addFields :: [FieldDescr a] + -> ([FieldDescr a] -> [FieldDescr a]) +addFields = (++) diff --git a/src/Distribution/Client/ProjectConfig/Types.hs b/src/Distribution/Client/ProjectConfig/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectConfig/Types.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +-- | Handling project configuration, types. +-- +module Distribution.Client.ProjectConfig.Types ( + + -- * Types for project config + ProjectConfig(..), + ProjectConfigBuildOnly(..), + ProjectConfigShared(..), + ProjectConfigProvenance(..), + PackageConfig(..), + + -- * Resolving configuration + SolverSettings(..), + BuildTimeSettings(..), + + -- * Extra useful Monoids + MapLast(..), + MapMappend(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo ) +import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) ) +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy ) +import Distribution.Client.Dependency.Types + ( PreSolver ) +import Distribution.Client.Targets + ( UserConstraint ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Types.SourceRepo (SourceRepoList) + +import Distribution.Client.IndexUtils.IndexState + ( TotalIndexState ) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) + +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..) ) + +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ConstraintSource + +import Distribution.Package + ( PackageName, PackageId, UnitId ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint ) +import Distribution.Version + ( Version ) +import Distribution.System + ( Platform ) +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Simple.Compiler + ( Compiler, CompilerFlavor + , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) +import Distribution.Simple.Setup + ( Flag, HaddockTarget(..), TestShowDetails(..) ) +import Distribution.Simple.InstallDirs + ( PathTemplate ) +import Distribution.Utils.NubList + ( NubList ) + +import qualified Data.Map as Map + +------------------------------- +-- Project config types +-- + +-- | This type corresponds directly to what can be written in the +-- @cabal.project@ file. Other sources of configuration can also be injected +-- into this type, such as the user-wide @~/.cabal/config@ file and the +-- command line of @cabal configure@ or @cabal build@. +-- +-- Since it corresponds to the external project file it is an instance of +-- 'Monoid' and all the fields can be empty. This also means there has to +-- be a step where we resolve configuration. At a minimum resolving means +-- applying defaults but it can also mean merging information from multiple +-- sources. For example for package-specific configuration the project file +-- can specify configuration that applies to all local packages, and then +-- additional configuration for a specific package. +-- +-- Future directions: multiple profiles, conditionals. If we add these +-- features then the gap between configuration as written in the config file +-- and resolved settings we actually use will become even bigger. +-- +data ProjectConfig + = ProjectConfig { + + -- | Packages in this project, including local dirs, local .cabal files + -- local and remote tarballs. When these are file globs, they must + -- match at least one package. + projectPackages :: [String], + + -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that + -- file globs are allowed to match nothing. The primary use case for + -- this is to be able to say @optional-packages: */@ to automagically + -- pick up deps that we unpack locally without erroring when + -- there aren't any. + projectPackagesOptional :: [String], + + -- | Packages in this project from remote source repositories. + projectPackagesRepo :: [SourceRepoList], + + -- | Packages in this project from hackage repositories. + projectPackagesNamed :: [PackageVersionConstraint], + + -- See respective types for an explanation of what these + -- values are about: + projectConfigBuildOnly :: ProjectConfigBuildOnly, + projectConfigShared :: ProjectConfigShared, + projectConfigProvenance :: Set ProjectConfigProvenance, + + -- | Configuration to be applied to *all* packages, + -- whether named in `cabal.project` or not. + projectConfigAllPackages :: PackageConfig, + + -- | Configuration to be applied to *local* packages; i.e., + -- any packages which are explicitly named in `cabal.project`. + projectConfigLocalPackages :: PackageConfig, + projectConfigSpecificPackage :: MapMappend PackageName PackageConfig + } + deriving (Eq, Show, Generic, Typeable) + +-- | That part of the project configuration that only affects /how/ we build +-- and not the /value/ of the things we build. This means this information +-- does not need to be tracked for changes since it does not affect the +-- outcome. +-- +data ProjectConfigBuildOnly + = ProjectConfigBuildOnly { + projectConfigVerbosity :: Flag Verbosity, + projectConfigDryRun :: Flag Bool, + projectConfigOnlyDeps :: Flag Bool, + projectConfigOnlyDownload :: Flag Bool, + projectConfigSummaryFile :: NubList PathTemplate, + projectConfigLogFile :: Flag PathTemplate, + projectConfigBuildReports :: Flag ReportLevel, + projectConfigReportPlanningFailure :: Flag Bool, + projectConfigSymlinkBinDir :: Flag FilePath, + projectConfigOneShot :: Flag Bool, + projectConfigNumJobs :: Flag (Maybe Int), + projectConfigKeepGoing :: Flag Bool, + projectConfigOfflineMode :: Flag Bool, + projectConfigKeepTempFiles :: Flag Bool, + projectConfigHttpTransport :: Flag String, + projectConfigIgnoreExpiry :: Flag Bool, + projectConfigCacheDir :: Flag FilePath, + projectConfigLogsDir :: Flag FilePath, + projectConfigClientInstallFlags :: ClientInstallFlags + } + deriving (Eq, Show, Generic) + + +-- | Project configuration that is shared between all packages in the project. +-- In particular this includes configuration that affects the solver. +-- +data ProjectConfigShared + = ProjectConfigShared { + projectConfigDistDir :: Flag FilePath, + projectConfigConfigFile :: Flag FilePath, + projectConfigProjectFile :: Flag FilePath, + projectConfigIgnoreProject :: Flag Bool, + projectConfigHcFlavor :: Flag CompilerFlavor, + projectConfigHcPath :: Flag FilePath, + projectConfigHcPkg :: Flag FilePath, + projectConfigHaddockIndex :: Flag PathTemplate, + + -- Things that only make sense for manual mode, not --local mode + -- too much control! + --projectConfigUserInstall :: Flag Bool, + --projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), + --TODO: [required eventually] decide what to do with InstallDirs + -- currently we don't allow it to be specified in the config file + --projectConfigPackageDBs :: [Maybe PackageDB], + + -- configuration used both by the solver and other phases + projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. + projectConfigLocalNoIndexRepos :: NubList LocalRepo, + projectConfigActiveRepos :: Flag ActiveRepos, + projectConfigIndexState :: Flag TotalIndexState, + projectConfigStoreDir :: Flag FilePath, + + -- solver configuration + projectConfigConstraints :: [(UserConstraint, ConstraintSource)], + projectConfigPreferences :: [PackageVersionConstraint], + projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused + projectConfigSolver :: Flag PreSolver, + projectConfigAllowOlder :: Maybe AllowOlder, + projectConfigAllowNewer :: Maybe AllowNewer, + projectConfigWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy, + projectConfigMaxBackjumps :: Flag Int, + projectConfigReorderGoals :: Flag ReorderGoals, + projectConfigCountConflicts :: Flag CountConflicts, + projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, + projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, + projectConfigStrongFlags :: Flag StrongFlags, + projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, + projectConfigOnlyConstrained :: Flag OnlyConstrained, + projectConfigPerComponent :: Flag Bool, + projectConfigIndependentGoals :: Flag IndependentGoals, + + projectConfigProgPathExtra :: NubList FilePath + + -- More things that only make sense for manual mode, not --local mode + -- too much control! + --projectConfigShadowPkgs :: Flag Bool, + --projectConfigReinstall :: Flag Bool, + --projectConfigAvoidReinstalls :: Flag Bool, + --projectConfigOverrideReinstall :: Flag Bool, + --projectConfigUpgradeDeps :: Flag Bool + } + deriving (Eq, Show, Generic) + + +-- | Specifies the provenance of project configuration, whether defaults were +-- used or if the configuration was read from an explicit file path. +data ProjectConfigProvenance + + -- | The configuration is implicit due to no explicit configuration + -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig' + -- for how implicit configuration is determined. + = Implicit + + -- | The path the project configuration was explicitly read from. + -- | The configuration was explicitly read from the specified 'FilePath'. + | Explicit FilePath + deriving (Eq, Ord, Show, Generic) + + +-- | Project configuration that is specific to each package, that is where we +-- can in principle have different values for different packages in the same +-- project. +-- +data PackageConfig + = PackageConfig { + packageConfigProgramPaths :: MapLast String FilePath, + packageConfigProgramArgs :: MapMappend String [String], + packageConfigProgramPathExtra :: NubList FilePath, + packageConfigFlagAssignment :: FlagAssignment, + packageConfigVanillaLib :: Flag Bool, + packageConfigSharedLib :: Flag Bool, + packageConfigStaticLib :: Flag Bool, + packageConfigDynExe :: Flag Bool, + packageConfigFullyStaticExe :: Flag Bool, + packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out + packageConfigProfLib :: Flag Bool, -- this duplication + packageConfigProfExe :: Flag Bool, -- and consistency + packageConfigProfDetail :: Flag ProfDetailLevel, + packageConfigProfLibDetail :: Flag ProfDetailLevel, + packageConfigConfigureArgs :: [String], + packageConfigOptimization :: Flag OptimisationLevel, + packageConfigProgPrefix :: Flag PathTemplate, + packageConfigProgSuffix :: Flag PathTemplate, + packageConfigExtraLibDirs :: [FilePath], + packageConfigExtraFrameworkDirs :: [FilePath], + packageConfigExtraIncludeDirs :: [FilePath], + packageConfigGHCiLib :: Flag Bool, + packageConfigSplitSections :: Flag Bool, + packageConfigSplitObjs :: Flag Bool, + packageConfigStripExes :: Flag Bool, + packageConfigStripLibs :: Flag Bool, + packageConfigTests :: Flag Bool, + packageConfigBenchmarks :: Flag Bool, + packageConfigCoverage :: Flag Bool, + packageConfigRelocatable :: Flag Bool, + packageConfigDebugInfo :: Flag DebugInfoLevel, + packageConfigRunTests :: Flag Bool, --TODO: [required eventually] use this + packageConfigDocumentation :: Flag Bool, --TODO: [required eventually] use this + -- Haddock options + packageConfigHaddockHoogle :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockHtml :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this + packageConfigHaddockForeignLibs :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockExecutables :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockTestSuites :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockBenchmarks :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockInternal :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this + packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this + packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this + packageConfigHaddockForHackage :: Flag HaddockTarget, + -- Test options + packageConfigTestHumanLog :: Flag PathTemplate, + packageConfigTestMachineLog :: Flag PathTemplate, + packageConfigTestShowDetails :: Flag TestShowDetails, + packageConfigTestKeepTix :: Flag Bool, + packageConfigTestWrapper :: Flag FilePath, + packageConfigTestFailWhenNoTestSuites :: Flag Bool, + packageConfigTestTestOptions :: [PathTemplate], + -- Benchmark options + packageConfigBenchmarkOptions :: [PathTemplate] + } + deriving (Eq, Show, Generic) + +instance Binary ProjectConfig +instance Binary ProjectConfigBuildOnly +instance Binary ProjectConfigShared +instance Binary ProjectConfigProvenance +instance Binary PackageConfig + +instance Structured ProjectConfig +instance Structured ProjectConfigBuildOnly +instance Structured ProjectConfigShared +instance Structured ProjectConfigProvenance +instance Structured PackageConfig + +-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes +-- the last value rather than the first value for overlapping keys. +newtype MapLast k v = MapLast { getMapLast :: Map k v } + deriving (Eq, Show, Functor, Generic, Binary, Typeable) + +instance (Structured k, Structured v) => Structured (MapLast k v) + +instance Ord k => Monoid (MapLast k v) where + mempty = MapLast Map.empty + mappend = (<>) + +instance Ord k => Semigroup (MapLast k v) where + MapLast a <> MapLast b = MapLast $ Map.union b a + -- rather than Map.union which is the normal Map monoid instance + + +-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that +-- 'mappend's values of overlapping keys rather than taking the first. +newtype MapMappend k v = MapMappend { getMapMappend :: Map k v } + deriving (Eq, Show, Functor, Generic, Binary, Typeable) + +instance (Structured k, Structured v) => Structured (MapMappend k v) + +instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where + mempty = MapMappend Map.empty + mappend = (<>) + +instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where + MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b) + -- rather than Map.union which is the normal Map monoid instance + + +instance Monoid ProjectConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfig where + (<>) = gmappend + + +instance Monoid ProjectConfigBuildOnly where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfigBuildOnly where + (<>) = gmappend + + +instance Monoid ProjectConfigShared where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfigShared where + (<>) = gmappend + + +instance Monoid PackageConfig where + mempty = gmempty + mappend = (<>) + +instance Semigroup PackageConfig where + (<>) = gmappend + +---------------------------------------- +-- Resolving configuration to settings +-- + +-- | Resolved configuration for the solver. The idea is that this is easier to +-- use than the raw configuration because in the raw configuration everything +-- is optional (monoidial). In the 'BuildTimeSettings' every field is filled +-- in, if only with the defaults. +-- +-- Use 'resolveSolverSettings' to make one from the project config (by +-- applying defaults etc). +-- +data SolverSettings + = SolverSettings { + solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. + solverSettingLocalNoIndexRepos :: [LocalRepo], + solverSettingConstraints :: [(UserConstraint, ConstraintSource)], + solverSettingPreferences :: [PackageVersionConstraint], + solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages + solverSettingFlagAssignments :: Map PackageName FlagAssignment, + solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused + solverSettingSolver :: PreSolver, + solverSettingAllowOlder :: AllowOlder, + solverSettingAllowNewer :: AllowNewer, + solverSettingMaxBackjumps :: Maybe Int, + solverSettingReorderGoals :: ReorderGoals, + solverSettingCountConflicts :: CountConflicts, + solverSettingFineGrainedConflicts :: FineGrainedConflicts, + solverSettingMinimizeConflictSet :: MinimizeConflictSet, + solverSettingStrongFlags :: StrongFlags, + solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, + solverSettingOnlyConstrained :: OnlyConstrained, + solverSettingIndexState :: Maybe TotalIndexState, + solverSettingActiveRepos :: Maybe ActiveRepos, + solverSettingIndependentGoals :: IndependentGoals + -- Things that only make sense for manual mode, not --local mode + -- too much control! + --solverSettingShadowPkgs :: Bool, + --solverSettingReinstall :: Bool, + --solverSettingAvoidReinstalls :: Bool, + --solverSettingOverrideReinstall :: Bool, + --solverSettingUpgradeDeps :: Bool + } + deriving (Eq, Show, Generic, Typeable) + +instance Binary SolverSettings +instance Structured SolverSettings + + +-- | Resolved configuration for things that affect how we build and not the +-- value of the things we build. The idea is that this is easier to use than +-- the raw configuration because in the raw configuration everything is +-- optional (monoidial). In the 'BuildTimeSettings' every field is filled in, +-- if only with the defaults. +-- +-- Use 'resolveBuildTimeSettings' to make one from the project config (by +-- applying defaults etc). +-- +data BuildTimeSettings + = BuildTimeSettings { + buildSettingDryRun :: Bool, + buildSettingOnlyDeps :: Bool, + buildSettingOnlyDownload :: Bool, + buildSettingSummaryFile :: [PathTemplate], + buildSettingLogFile :: Maybe (Compiler -> Platform + -> PackageId -> UnitId + -> FilePath), + buildSettingLogVerbosity :: Verbosity, + buildSettingBuildReports :: ReportLevel, + buildSettingReportPlanningFailure :: Bool, + buildSettingSymlinkBinDir :: [FilePath], + buildSettingOneShot :: Bool, + buildSettingNumJobs :: Int, + buildSettingKeepGoing :: Bool, + buildSettingOfflineMode :: Bool, + buildSettingKeepTempFiles :: Bool, + buildSettingRemoteRepos :: [RemoteRepo], + buildSettingLocalNoIndexRepos :: [LocalRepo], + buildSettingCacheDir :: FilePath, + buildSettingHttpTransport :: Maybe String, + buildSettingIgnoreExpiry :: Bool, + buildSettingProgPathExtra :: [FilePath] + } diff --git a/src/Distribution/Client/ProjectFlags.hs b/src/Distribution/Client/ProjectFlags.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectFlags.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Distribution.Client.ProjectFlags ( + ProjectFlags(..), + defaultProjectFlags, + projectFlagsOptions, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.ReadE (succeedReadE) +import Distribution.Simple.Command (MkOptDescr, OptionField, ShowOrParseArgs (..), boolOpt', option, reqArg) +import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg) + +data ProjectFlags = ProjectFlags + { flagProjectFileName :: Flag FilePath + -- ^ The cabal project file name; defaults to @cabal.project@. + -- The name itself denotes the cabal project file name, but it also + -- is the base of auxiliary project files, such as + -- @cabal.project.local@ and @cabal.project.freeze@ which are also + -- read and written out in some cases. If the path is not found + -- in the current working directory, we will successively probe + -- relative to parent directories until this name is found. + + , flagIgnoreProject :: Flag Bool + -- ^ Whether to ignore the local project (i.e. don't search for cabal.project) + -- The exact interpretation might be slightly different per command. + } + deriving (Show, Generic) + +defaultProjectFlags :: ProjectFlags +defaultProjectFlags = ProjectFlags + { flagProjectFileName = mempty + , flagIgnoreProject = toFlag False + -- Should we use 'Last' here? + } + +projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags] +projectFlagsOptions showOrParseArgs = + [ option [] ["project-file"] + "Set the name of the cabal.project file to search for in parent directories" + flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf }) + (reqArg "FILE" (succeedReadE Flag) flagToList) + , option ['z'] ["ignore-project"] + "Ignore local project configuration" + flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v }) + (yesNoOpt showOrParseArgs) + ] + +instance Monoid ProjectFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectFlags where + (<>) = gmappend + +yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b +yesNoOpt ShowArgs sf lf = trueArg sf lf +yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf diff --git a/src/Distribution/Client/ProjectOrchestration.hs b/src/Distribution/Client/ProjectOrchestration.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectOrchestration.hs @@ -0,0 +1,1249 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +-- | This module deals with building and incrementally rebuilding a collection +-- of packages. It is what backs the @cabal build@ and @configure@ commands, +-- as well as being a core part of @run@, @test@, @bench@ and others. +-- +-- The primary thing is in fact rebuilding (and trying to make that quick by +-- not redoing unnecessary work), so building from scratch is just a special +-- case. +-- +-- The build process and the code can be understood by breaking it down into +-- three major parts: +-- +-- * The 'ElaboratedInstallPlan' type +-- +-- * The \"what to do\" phase, where we look at the all input configuration +-- (project files, .cabal files, command line etc) and produce a detailed +-- plan of what to do -- the 'ElaboratedInstallPlan'. +-- +-- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we +-- re-execute it. +-- +-- As far as possible, the \"what to do\" phase embodies all the policy, leaving +-- the \"do it\" phase policy free. The first phase contains more of the +-- complicated logic, but it is contained in code that is either pure or just +-- has read effects (except cache updates). Then the second phase does all the +-- actions to build packages, but as far as possible it just follows the +-- instructions and avoids any logic for deciding what to do (apart from +-- recompilation avoidance in executing the plan). +-- +-- This division helps us keep the code under control, making it easier to +-- understand, test and debug. So when you are extending these modules, please +-- think about which parts of your change belong in which part. It is +-- perfectly ok to extend the description of what to do (i.e. the +-- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the +-- first phase. Also, the second phase does not have direct access to any of +-- the input configuration anyway; all the information has to flow via the +-- 'ElaboratedInstallPlan'. +-- +module Distribution.Client.ProjectOrchestration ( + -- * Discovery phase: what is in the project? + CurrentCommand(..), + establishProjectBaseContext, + establishProjectBaseContextWithRoot, + ProjectBaseContext(..), + BuildTimeSettings(..), + commandLineFlagsToProjectConfig, + + -- * Pre-build phase: decide what to do. + withInstallPlan, + runProjectPreBuildPhase, + ProjectBuildContext(..), + + -- ** Selecting what targets we mean + readTargetSelectors, + reportTargetSelectorProblems, + resolveTargets, + TargetsMap, + TargetSelector(..), + TargetImplicitCwd(..), + PackageId, + AvailableTarget(..), + AvailableTargetStatus(..), + TargetRequested(..), + ComponentName(..), + ComponentKind(..), + ComponentTarget(..), + SubComponentTarget(..), + selectComponentTargetBasic, + distinctTargetComponents, + -- ** Utils for selecting targets + filterTargetsKind, + filterTargetsKindWith, + selectBuildableTargets, + selectBuildableTargetsWith, + selectBuildableTargets', + selectBuildableTargetsWith', + forgetTargetsDetail, + + -- ** Adjusting the plan + pruneInstallPlanToTargets, + TargetAction(..), + pruneInstallPlanToDependencies, + CannotPruneDependencies(..), + printPlan, + + -- * Build phase: now do it. + runProjectBuildPhase, + + -- * Post build actions + runProjectPostBuildPhase, + dieOnBuildFailures, + + -- * Dummy projects + establishDummyProjectBaseContext, + establishDummyDistDirLayout, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Directory + ( makeAbsolute ) + +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanning + hiding ( pruneInstallPlanToTargets ) +import qualified Distribution.Client.ProjectPlanning as ProjectPlanning + ( pruneInstallPlanToTargets ) +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding +import Distribution.Client.ProjectPlanOutput +import Distribution.Client.RebuildMonad ( runRebuild ) + +import Distribution.Client.TargetProblem + ( TargetProblem (..) ) +import Distribution.Client.Types + ( GenericReadyPackage(..), UnresolvedSourcePackage + , PackageSpecifier(..) + , SourcePackageDb(..) + , WriteGhcEnvironmentFilesPolicy(..) ) +import Distribution.Solver.Types.PackageIndex + ( lookupPackageName ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.TargetSelector + ( TargetSelector(..), TargetImplicitCwd(..) + , ComponentKind(..), componentKind + , readTargetSelectors, reportTargetSelectorProblems ) +import Distribution.Client.DistDirLayout +import Distribution.Client.Config (getCabalDir) +import Distribution.Client.Setup hiding (packageName) +import Distribution.Compiler + ( CompilerFlavor(GHC) ) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, packageNameToUnqualComponentName ) + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Package +import Distribution.Types.Flag + ( FlagAssignment, showFlagAssignment, diffFlagAssignment ) +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), pkgComponents ) +import Distribution.Simple.Flag + ( fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.Setup as Setup +import Distribution.Simple.Command (commandShowOptions) +import Distribution.Simple.Configure (computeEffectiveProfiling) + +import Distribution.Simple.Utils + ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose ) +import Distribution.Verbosity +import Distribution.Version + ( mkVersion ) +import Distribution.Simple.Compiler + ( compilerCompatVersion, showCompilerId + , OptimisationLevel(..)) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Exception (assert) +#ifdef MIN_VERSION_unix +import System.Posix.Signals (sigKILL, sigSEGV) +#endif + + +-- | Tracks what command is being executed, because we need to hide this somewhere +-- for cases that need special handling (usually for error reporting). +data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand + deriving (Show, Eq) + +-- | This holds the context of a project prior to solving: the content of the +-- @cabal.project@ and all the local package @.cabal@ files. +-- +data ProjectBaseContext = ProjectBaseContext { + distDirLayout :: DistDirLayout, + cabalDirLayout :: CabalDirLayout, + projectConfig :: ProjectConfig, + localPackages :: [PackageSpecifier UnresolvedSourcePackage], + buildSettings :: BuildTimeSettings, + currentCommand :: CurrentCommand + } + +establishProjectBaseContext + :: Verbosity + -> ProjectConfig + -> CurrentCommand + -> IO ProjectBaseContext +establishProjectBaseContext verbosity cliConfig currentCommand = do + projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile + establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand + where + mprojectFile = Setup.flagToMaybe projectConfigProjectFile + ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig + +-- | Like 'establishProjectBaseContext' but doesn't search for project root. +establishProjectBaseContextWithRoot + :: Verbosity + -> ProjectConfig + -> ProjectRoot + -> CurrentCommand + -> IO ProjectBaseContext +establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do + cabalDir <- getCabalDir + + let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory + + (projectConfig, localPackages) <- + rebuildProjectConfig verbosity + distDirLayout + cliConfig + + let ProjectConfigBuildOnly { + projectConfigLogsDir + } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + + mlogsDir = Setup.flagToMaybe projectConfigLogsDir + mstoreDir <- sequenceA $ makeAbsolute + <$> Setup.flagToMaybe projectConfigStoreDir + let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + -- https://github.com/haskell/cabal/issues/6013 + when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $ + warn verbosity "There are no packages or optional-packages in the project" + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings, + currentCommand + } + where + mdistDirectory = Setup.flagToMaybe projectConfigDistDir + ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig + + +-- | This holds the context between the pre-build, build and post-build phases. +-- +data ProjectBuildContext = ProjectBuildContext { + -- | This is the improved plan, before we select a plan subset based on + -- the build targets, and before we do the dry-run. So this contains + -- all packages in the project. + elaboratedPlanOriginal :: ElaboratedInstallPlan, + + -- | This is the 'elaboratedPlanOriginal' after we select a plan subset + -- and do the dry-run phase to find out what is up-to or out-of date. + -- This is the plan that will be executed during the build phase. So + -- this contains only a subset of packages in the project. + elaboratedPlanToExecute:: ElaboratedInstallPlan, + + -- | The part of the install plan that's shared between all packages in + -- the plan. This does not change between the two plan variants above, + -- so there is just the one copy. + elaboratedShared :: ElaboratedSharedConfig, + + -- | The result of the dry-run phase. This tells us about each member of + -- the 'elaboratedPlanToExecute'. + pkgsBuildStatus :: BuildStatusMap, + + -- | The targets selected by @selectPlanSubset@. This is useful eg. in + -- CmdRun, where we need a valid target to execute. + targetsMap :: TargetsMap + } + + +-- | Pre-build phase: decide what to do. +-- +withInstallPlan + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a) + -> IO a +withInstallPlan + verbosity + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } + action = do + -- Take the project configuration and make a plan for how to build + -- everything in the project. This is independent of any specific targets + -- the user has asked for. + -- + (elaboratedPlan, _, elaboratedShared, _, _) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + action elaboratedPlan elaboratedShared + +runProjectPreBuildPhase + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) + -> IO ProjectBuildContext +runProjectPreBuildPhase + verbosity + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } + selectPlanSubset = do + -- Take the project configuration and make a plan for how to build + -- everything in the project. This is independent of any specific targets + -- the user has asked for. + -- + (elaboratedPlan, _, elaboratedShared, _, _) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + + -- The plan for what to do is represented by an 'ElaboratedInstallPlan' + + -- Now given the specific targets the user has asked for, decide + -- which bits of the plan we will want to execute. + -- + (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan + + -- Check which packages need rebuilding. + -- This also gives us more accurate reasons for the --dry-run output. + -- + pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared + elaboratedPlan' + + -- Improve the plan by marking up-to-date packages as installed. + -- + let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages + pkgsBuildStatus elaboratedPlan' + debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') + + return ProjectBuildContext { + elaboratedPlanOriginal = elaboratedPlan, + elaboratedPlanToExecute = elaboratedPlan'', + elaboratedShared, + pkgsBuildStatus, + targetsMap = targets + } + + +-- | Build phase: now do it. +-- +-- Execute all or parts of the description of what to do to build or +-- rebuild the various packages needed. +-- +runProjectBuildPhase :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> IO BuildOutcomes +runProjectBuildPhase _ ProjectBaseContext{buildSettings} _ + | buildSettingDryRun buildSettings + = return Map.empty + +runProjectBuildPhase verbosity + ProjectBaseContext{..} ProjectBuildContext {..} = + fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $ + rebuildTargets verbosity + distDirLayout + (cabalStoreDirLayout cabalDirLayout) + elaboratedPlanToExecute + elaboratedShared + pkgsBuildStatus + buildSettings + where + previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes + previousBuildOutcomes = + Map.mapMaybe $ \status -> case status of + BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess) + --TODO: [nice to have] record build failures persistently + _ -> Nothing + +-- | Post-build phase: various administrative tasks +-- +-- Update bits of state based on the build outcomes and report any failures. +-- +runProjectPostBuildPhase :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> BuildOutcomes + -> IO () +runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ + | buildSettingDryRun buildSettings + = return () + +runProjectPostBuildPhase verbosity + ProjectBaseContext {..} ProjectBuildContext {..} + buildOutcomes = do + -- Update other build artefacts + -- TODO: currently none, but could include: + -- - bin symlinks/wrappers + -- - haddock/hoogle/ctags indexes + -- - delete stale lib registrations + -- - delete stale package dirs + + postBuildStatus <- updatePostBuildProjectStatus + verbosity + distDirLayout + elaboratedPlanOriginal + pkgsBuildStatus + buildOutcomes + + -- Write the .ghc.environment file (if allowed by the env file write policy). + let writeGhcEnvFilesPolicy = + projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared + $ projectConfig + + shouldWriteGhcEnvironment = + case fromFlagOrDefault NeverWriteGhcEnvironmentFiles + writeGhcEnvFilesPolicy + of + AlwaysWriteGhcEnvironmentFiles -> True + NeverWriteGhcEnvironmentFiles -> False + WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> + let compiler = pkgConfigCompiler elaboratedShared + ghcCompatVersion = compilerCompatVersion GHC compiler + in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion + + when shouldWriteGhcEnvironment $ + void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) + elaboratedPlanOriginal + elaboratedShared + postBuildStatus + + -- Finally if there were any build failures then report them and throw + -- an exception to terminate the program + dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes + + -- Note that it is a deliberate design choice that the 'buildTargets' is + -- not passed to phase 1, and the various bits of input config is not + -- passed to phase 2. + -- + -- We make the install plan without looking at the particular targets the + -- user asks us to build. The set of available things we can build is + -- discovered from the env and config and is used to make the install plan. + -- The targets just tell us which parts of the install plan to execute. + -- + -- Conversely, executing the plan does not directly depend on any of the + -- input config. The bits that are needed (or better, the decisions based + -- on it) all go into the install plan. + + -- Notionally, the 'BuildFlags' should be things that do not affect what + -- we build, just how we do it. These ones of course do + + +------------------------------------------------------------------------------ +-- Taking targets into account, selecting what to build +-- + +-- | The set of components to build, represented as a mapping from 'UnitId's +-- to the 'ComponentTarget's within the unit that will be selected +-- (e.g. selected to build, test or repl). +-- +-- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that +-- matched this target. Typically this is exactly one, but in general it is +-- possible to for different selectors to match the same target. This extra +-- information is primarily to help make helpful error messages. +-- +type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])] + +-- | Given a set of 'TargetSelector's, resolve which 'UnitId's and +-- 'ComponentTarget's they ought to refer to. +-- +-- The idea is that every user target identifies one or more roots in the +-- 'ElaboratedInstallPlan', which we will use to determine the closure +-- of what packages need to be built, dropping everything from the plan +-- that is unnecessary. This closure and pruning is done by +-- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms +-- of 'UnitId's and the 'ComponentTarget's within those. +-- +-- This means we first need to translate the 'TargetSelector's into the +-- 'UnitId's and 'ComponentTarget's. This translation has to be different for +-- the different command line commands, like @build@, @repl@ etc. For example +-- the command @build pkgfoo@ could select a different set of components in +-- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and +-- all executables, whereas @repl@ would select the library or a single +-- executable. Furthermore, both of these examples could fail, and fail in +-- different ways and each needs to be able to produce helpful error messages. +-- +-- So 'resolveTargets' takes two helpers: one to select the targets to be used +-- by user targets that refer to a whole package ('TargetPackage'), and +-- another to check user targets that refer to a component (or a module or +-- file within a component). These helpers can fail, and use their own error +-- type. Both helpers get given the 'AvailableTarget' info about the +-- component(s). +-- +-- While commands vary quite a bit in their behaviour about which components to +-- select for a whole-package target, most commands have the same behaviour for +-- checking a user target that refers to a specific component. To help with +-- this commands can use 'selectComponentTargetBasic', either directly or as +-- a basis for their own @selectComponentTarget@ implementation. +-- +resolveTargets :: forall err. + (forall k. TargetSelector + -> [AvailableTarget k] + -> Either (TargetProblem err) [k]) + -> (forall k. SubComponentTarget + -> AvailableTarget k + -> Either (TargetProblem err) k ) + -> ElaboratedInstallPlan + -> Maybe (SourcePackageDb) + -> [TargetSelector] + -> Either [TargetProblem err] TargetsMap +resolveTargets selectPackageTargets selectComponentTarget + installPlan mPkgDb = + fmap mkTargetsMap + . either (Left . toList) Right + . checkErrors + . map (\ts -> (,) ts <$> checkTarget ts) + where + mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])] + -> TargetsMap + mkTargetsMap targets = + Map.map nubComponentTargets + $ Map.fromListWith (++) + [ (uid, [(ct, ts)]) + | (ts, cts) <- targets + , (uid, ct) <- cts ] + + AvailableTargetIndexes{..} = availableTargetIndexes installPlan + + checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)] + + -- We can ask to build any whole package, project-local or a dependency + checkTarget bt@(TargetPackage _ [pkgid] mkfilter) + | Just ats <- fmap (maybe id filterTargetsKind mkfilter) + $ Map.lookup pkgid availableTargetsByPackageId + = fmap (componentTargets WholeComponent) + $ selectPackageTargets bt ats + + | otherwise + = Left (TargetProblemNoSuchPackage pkgid) + + checkTarget (TargetPackage _ pkgids _) + = error ("TODO: add support for multiple packages in a directory. Got\n" + ++ unlines (map prettyShow pkgids)) + -- For the moment this error cannot happen here, because it gets + -- detected when the package config is being constructed. This case + -- will need handling properly when we do add support. + -- + -- TODO: how should this use case play together with the + -- '--cabal-file' option of 'configure' which allows using multiple + -- .cabal files for a single package? + + checkTarget bt@(TargetAllPackages mkfilter) = + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + . maybe id filterTargetsKind mkfilter + . filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackageId) + + checkTarget (TargetComponent pkgid cname subtarget) + | Just ats <- Map.lookup (pkgid, cname) + availableTargetsByPackageIdAndComponentName + = fmap (componentTargets subtarget) + $ selectComponentTargets subtarget ats + + | Map.member pkgid availableTargetsByPackageId + = Left (TargetProblemNoSuchComponent pkgid cname) + + | otherwise + = Left (TargetProblemNoSuchPackage pkgid) + + checkTarget (TargetComponentUnknown pkgname ecname subtarget) + | Just ats <- case ecname of + Left ucname -> + Map.lookup (pkgname, ucname) + availableTargetsByPackageNameAndUnqualComponentName + Right cname -> + Map.lookup (pkgname, cname) + availableTargetsByPackageNameAndComponentName + = fmap (componentTargets subtarget) + $ selectComponentTargets subtarget ats + + | Map.member pkgname availableTargetsByPackageName + = Left (TargetProblemUnknownComponent pkgname ecname) + + | otherwise + = Left (TargetNotInProject pkgname) + + checkTarget bt@(TargetPackageNamed pkgname mkfilter) + | Just ats <- fmap (maybe id filterTargetsKind mkfilter) + $ Map.lookup pkgname availableTargetsByPackageName + = fmap (componentTargets WholeComponent) + . selectPackageTargets bt + $ ats + + | Just SourcePackageDb{ packageIndex } <- mPkgDb + , let pkg = lookupPackageName packageIndex pkgname + , not (null pkg) + = Left (TargetAvailableInIndex pkgname) + + | otherwise + = Left (TargetNotInProject pkgname) + + componentTargets :: SubComponentTarget + -> [(b, ComponentName)] + -> [(b, ComponentTarget)] + componentTargets subtarget = + map (fmap (\cname -> ComponentTarget cname subtarget)) + + selectComponentTargets :: SubComponentTarget + -> [AvailableTarget k] + -> Either (TargetProblem err) [k] + selectComponentTargets subtarget = + either (Left . NE.head) Right + . checkErrors + . map (selectComponentTarget subtarget) + + checkErrors :: [Either e a] -> Either (NonEmpty e) [a] + checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') }) + . partitionEithers + + +data AvailableTargetIndexes = AvailableTargetIndexes { + availableTargetsByPackageIdAndComponentName + :: AvailableTargetsMap (PackageId, ComponentName), + + availableTargetsByPackageId + :: AvailableTargetsMap PackageId, + + availableTargetsByPackageName + :: AvailableTargetsMap PackageName, + + availableTargetsByPackageNameAndComponentName + :: AvailableTargetsMap (PackageName, ComponentName), + + availableTargetsByPackageNameAndUnqualComponentName + :: AvailableTargetsMap (PackageName, UnqualComponentName) + } +type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] + +-- We define a bunch of indexes to help 'resolveTargets' with resolving +-- 'TargetSelector's to specific 'UnitId's. +-- +-- They are all derived from the 'availableTargets' index. +-- The 'availableTargetsByPackageIdAndComponentName' is just that main index, +-- while the others are derived by re-grouping on the index key. +-- +-- They are all constructed lazily because they are not necessarily all used. +-- +availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes +availableTargetIndexes installPlan = AvailableTargetIndexes{..} + where + availableTargetsByPackageIdAndComponentName = + availableTargets installPlan + + availableTargetsByPackageId = + Map.mapKeysWith + (++) (\(pkgid, _cname) -> pkgid) + availableTargetsByPackageIdAndComponentName + `Map.union` availableTargetsEmptyPackages + + availableTargetsByPackageName = + Map.mapKeysWith + (++) packageName + availableTargetsByPackageId + + availableTargetsByPackageNameAndComponentName = + Map.mapKeysWith + (++) (\(pkgid, cname) -> (packageName pkgid, cname)) + availableTargetsByPackageIdAndComponentName + + availableTargetsByPackageNameAndUnqualComponentName = + Map.mapKeysWith + (++) (\(pkgid, cname) -> let pname = packageName pkgid + cname' = unqualComponentName pname cname + in (pname, cname')) + availableTargetsByPackageIdAndComponentName + where + unqualComponentName :: + PackageName -> ComponentName -> UnqualComponentName + unqualComponentName pkgname = + fromMaybe (packageNameToUnqualComponentName pkgname) + . componentNameString + + -- Add in all the empty packages. These do not appear in the + -- availableTargetsByComponent map, since that only contains + -- components, so packages with no components are invisible from + -- that perspective. The empty packages need to be there for + -- proper error reporting, so users can select the empty package + -- and then we can report that it is empty, otherwise we falsely + -- report there is no such package at all. + availableTargetsEmptyPackages = + Map.fromList + [ (packageId pkg, []) + | InstallPlan.Configured pkg <- InstallPlan.toList installPlan + , case elabPkgOrComp pkg of + ElabComponent _ -> False + ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) + ] + + --TODO: [research required] what if the solution has multiple + -- versions of this package? + -- e.g. due to setup deps or due to multiple independent sets + -- of packages being built (e.g. ghc + ghcjs in a project) + +filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKind ckind = filterTargetsKindWith (== ckind) + +filterTargetsKindWith :: (ComponentKind -> Bool) + -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKindWith p ts = + [ t | t@(AvailableTarget _ cname _ _) <- ts + , p (componentKind cname) ] + +selectBuildableTargets :: [AvailableTarget k] -> [k] +selectBuildableTargets ts = + [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] + +selectBuildableTargetsWith :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> [k] +selectBuildableTargetsWith p ts = + [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] + +selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargets' ts = + (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] + [ forgetTargetDetail t + | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ] + +selectBuildableTargetsWith' :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargetsWith' p ts = + (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] + [ forgetTargetDetail t + | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ] + + +forgetTargetDetail :: AvailableTarget k -> AvailableTarget () +forgetTargetDetail = fmap (const ()) + +forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()] +forgetTargetsDetail = map forgetTargetDetail + +-- | A basic @selectComponentTarget@ implementation to use or pass to +-- 'resolveTargets', that does the basic checks that the component is +-- buildable and isn't a test suite or benchmark that is disabled. This +-- can also be used to do these basic checks as part of a custom impl that +-- +selectComponentTargetBasic :: SubComponentTarget + -> AvailableTarget k + -> Either (TargetProblem a) k +selectComponentTargetBasic subtarget + AvailableTarget { + availableTargetPackageId = pkgid, + availableTargetComponentName = cname, + availableTargetStatus + } = + case availableTargetStatus of + TargetDisabledByUser -> + Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) + + TargetDisabledBySolver -> + Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget) + + TargetNotLocal -> + Left (TargetComponentNotProjectLocal pkgid cname subtarget) + + TargetNotBuildable -> + Left (TargetComponentNotBuildable pkgid cname subtarget) + + TargetBuildable targetKey _ -> + Right targetKey + +-- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts +-- for the extra unneeded info in the 'TargetsMap'. +-- +pruneInstallPlanToTargets :: TargetAction -> TargetsMap + -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = + assert (Map.size targetsMap > 0) $ + ProjectPlanning.pruneInstallPlanToTargets + targetActionType + (Map.map (map fst) targetsMap) + elaboratedPlan + +-- | Utility used by repl and run to check if the targets spans multiple +-- components, since those commands do not support multiple components. +-- +distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) +distinctTargetComponents targetsMap = + Set.fromList [ (uid, cname) + | (uid, cts) <- Map.toList targetsMap + , (ComponentTarget cname _, _) <- cts ] + + +------------------------------------------------------------------------------ +-- Displaying what we plan to do +-- + +-- | Print a user-oriented presentation of the install plan, indicating what +-- will be built. +-- +printPlan :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> IO () +printPlan verbosity + ProjectBaseContext { + buildSettings = BuildTimeSettings{buildSettingDryRun}, + projectConfig = ProjectConfig { + projectConfigLocalPackages = + PackageConfig {packageConfigOptimization} + } + } + ProjectBuildContext { + elaboratedPlanToExecute = elaboratedPlan, + elaboratedShared, + pkgsBuildStatus + } + + | null pkgs + = notice verbosity "Up to date" + + | otherwise + = noticeNoWrap verbosity $ unlines $ + (showBuildProfile ++ "In order, the following " + ++ wouldWill ++ " be built" + ++ ifNormal " (use -v for more details)" ++ ":") + : map showPkgAndReason pkgs + + where + pkgs = InstallPlan.executionOrder elaboratedPlan + + ifVerbose s | verbosity >= verbose = s + | otherwise = "" + + ifNormal s | verbosity >= verbose = "" + | otherwise = s + + wouldWill | buildSettingDryRun = "would" + | otherwise = "will" + + showPkgAndReason :: ElaboratedReadyPackage -> String + showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $ + [ " -" + , if verbosity >= deafening + then prettyShow (installedUnitId elab) + else prettyShow (packageId elab) + , case elabPkgOrComp elab of + ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) + ElabComponent comp -> + "(" ++ showComp elab comp ++ ")" + , showFlagAssignment (nonDefaultFlags elab) + , showConfigureFlags elab + , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab + in "(" ++ showBuildStatus buildStatus ++ ")" + ] + + showComp elab comp = + maybe "custom" prettyShow (compComponentName comp) ++ + if Map.null (elabInstantiatedWith elab) + then "" + else " with " ++ + intercalate ", " + -- TODO: Abbreviate the UnitIds + [ prettyShow k ++ "=" ++ prettyShow v + | (k,v) <- Map.toList (elabInstantiatedWith elab) ] + + nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment + nonDefaultFlags elab = + elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab + + showTargets elab + | null (elabBuildTargets elab) = "" + | otherwise + = "(" + ++ intercalate ", " [ showComponentTarget (packageId elab) t + | t <- elabBuildTargets elab ] + ++ ")" + + showConfigureFlags elab = + let fullConfigureFlags + = setupHsConfigureFlags + (ReadyPackage elab) + elaboratedShared + verbosity + "$builddir" + -- | Given a default value @x@ for a flag, nub @Flag x@ + -- into @NoFlag@. This gives us a tidier command line + -- rendering. + nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a + nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag + nubFlag _ f = f + + (tryLibProfiling, tryExeProfiling) = + computeEffectiveProfiling fullConfigureFlags + + partialConfigureFlags + = mempty { + configProf = + nubFlag False (configProf fullConfigureFlags), + configProfExe = + nubFlag tryExeProfiling (configProfExe fullConfigureFlags), + configProfLib = + nubFlag tryLibProfiling (configProfLib fullConfigureFlags) + -- Maybe there are more we can add + } + -- Not necessary to "escape" it, it's just for user output + in unwords . ("":) $ + commandShowOptions + (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) + partialConfigureFlags + + showBuildStatus status = case status of + BuildStatusPreExisting -> "existing package" + BuildStatusInstalled -> "already installed" + BuildStatusDownload {} -> "requires download & build" + BuildStatusUnpack {} -> "requires build" + BuildStatusRebuild _ rebuild -> case rebuild of + BuildStatusConfigure + (MonitoredValueChanged _) -> "configuration changed" + BuildStatusConfigure mreason -> showMonitorChangedReason mreason + BuildStatusBuild _ buildreason -> case buildreason of + BuildReasonDepsRebuilt -> "dependency rebuilt" + BuildReasonFilesChanged + mreason -> showMonitorChangedReason mreason + BuildReasonExtraTargets _ -> "additional components to build" + BuildReasonEphemeralTargets -> "ephemeral targets" + BuildStatusUpToDate {} -> "up to date" -- doesn't happen + + showMonitorChangedReason (MonitoredFileChanged file) = + "file " ++ file ++ " changed" + showMonitorChangedReason (MonitoredValueChanged _) = "value changed" + showMonitorChangedReason MonitorFirstRun = "first run" + showMonitorChangedReason MonitorCorruptCache = + "cannot read state cache" + + showBuildProfile = "Build profile: " ++ unwords [ + "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, + "-O" ++ (case packageConfigOptimization of + Setup.Flag NoOptimisation -> "0" + Setup.Flag NormalOptimisation -> "1" + Setup.Flag MaximumOptimisation -> "2" + Setup.NoFlag -> "1")] + ++ "\n" + +-- | If there are build failures then report them and throw an exception. +-- +dieOnBuildFailures :: Verbosity -> CurrentCommand + -> ElaboratedInstallPlan -> BuildOutcomes -> IO () +dieOnBuildFailures verbosity currentCommand plan buildOutcomes + | null failures = return () + + | isSimpleCase = exitFailure + + | otherwise = do + -- For failures where we have a build log, print the log plus a header + sequence_ + [ do notice verbosity $ + '\n' : renderFailureDetail False pkg reason + ++ "\nBuild log ( " ++ logfile ++ " ):" + readFile logfile >>= noticeNoWrap verbosity + | (pkg, ShowBuildSummaryAndLog reason logfile) + <- failuresClassification + ] + + -- For all failures, print either a short summary (if we showed the + -- build log) or all details + dieIfNotHaddockFailure verbosity $ unlines + [ case failureClassification of + ShowBuildSummaryAndLog reason _ + | verbosity > normal + -> renderFailureDetail mentionDepOf pkg reason + + | otherwise + -> renderFailureSummary mentionDepOf pkg reason + ++ ". See the build log above for details." + + ShowBuildSummaryOnly reason -> + renderFailureDetail mentionDepOf pkg reason + + | let mentionDepOf = verbosity <= normal + , (pkg, failureClassification) <- failuresClassification ] + where + failures = [ (pkgid, failure) + | (pkgid, Left failure) <- Map.toList buildOutcomes ] + + failuresClassification = + [ (pkg, classifyBuildFailure failure) + | (pkgid, failure) <- failures + , case buildFailureReason failure of + DependentFailed {} -> verbosity > normal + _ -> True + , InstallPlan.Configured pkg <- + maybeToList (InstallPlan.lookup plan pkgid) + ] + + dieIfNotHaddockFailure + | currentCommand == HaddockCommand = die' + | all isHaddockFailure failuresClassification = warn + | otherwise = die' + where + isHaddockFailure + (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True + isHaddockFailure + (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True + isHaddockFailure + _ = False + + + classifyBuildFailure :: BuildFailure -> BuildFailurePresentation + classifyBuildFailure BuildFailure { + buildFailureReason = reason, + buildFailureLogFile = mlogfile + } = + maybe (ShowBuildSummaryOnly reason) + (ShowBuildSummaryAndLog reason) $ do + logfile <- mlogfile + e <- buildFailureException reason + ExitFailure 1 <- fromException e + return logfile + + -- Special case: we don't want to report anything complicated in the case + -- of just doing build on the current package, since it's clear from + -- context which package failed. + -- + -- We generalise this rule as follows: + -- - if only one failure occurs, and it is in a single root + -- package (i.e. a package with nothing else depending on it) + -- - and that failure is of a kind that always reports enough + -- detail itself (e.g. ghc reporting errors on stdout) + -- - then we do not report additional error detail or context. + -- + isSimpleCase + | [(pkgid, failure)] <- failures + , [pkg] <- rootpkgs + , installedUnitId pkg == pkgid + , isFailureSelfExplanatory (buildFailureReason failure) + , currentCommand /= InstallCommand + = True + | otherwise + = False + + -- NB: if the Setup script segfaulted or was interrupted, + -- we should give more detailed information. So only + -- assume that exit code 1 is "pedestrian failure." + isFailureSelfExplanatory (BuildFailed e) + | Just (ExitFailure 1) <- fromException e = True + + isFailureSelfExplanatory (ConfigureFailed e) + | Just (ExitFailure 1) <- fromException e = True + + isFailureSelfExplanatory _ = False + + rootpkgs = + [ pkg + | InstallPlan.Configured pkg <- InstallPlan.toList plan + , hasNoDependents pkg ] + + ultimateDeps pkgid = + filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) + (InstallPlan.reverseDependencyClosure plan [pkgid]) + + hasNoDependents :: HasUnitId pkg => pkg -> Bool + hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId + + renderFailureDetail mentionDepOf pkg reason = + renderFailureSummary mentionDepOf pkg reason ++ "." + ++ renderFailureExtraDetail reason + ++ maybe "" showException (buildFailureException reason) + + renderFailureSummary mentionDepOf pkg reason = + case reason of + DownloadFailed _ -> "Failed to download " ++ pkgstr + UnpackFailed _ -> "Failed to unpack " ++ pkgstr + ConfigureFailed _ -> "Failed to build " ++ pkgstr + BuildFailed _ -> "Failed to build " ++ pkgstr + ReplFailed _ -> "repl failed for " ++ pkgstr + HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr + TestsFailed _ -> "Tests failed for " ++ pkgstr + BenchFailed _ -> "Benchmarks failed for " ++ pkgstr + InstallFailed _ -> "Failed to build " ++ pkgstr + DependentFailed depid + -> "Failed to build " ++ prettyShow (packageId pkg) + ++ " because it depends on " ++ prettyShow depid + ++ " which itself failed to build" + where + pkgstr = elabConfiguredName verbosity pkg + ++ if mentionDepOf + then renderDependencyOf (installedUnitId pkg) + else "" + + renderFailureExtraDetail (ConfigureFailed _) = + " The failure occurred during the configure step." + renderFailureExtraDetail (InstallFailed _) = + " The failure occurred during the final install step." + renderFailureExtraDetail _ = + "" + + renderDependencyOf pkgid = + case ultimateDeps pkgid of + [] -> "" + (p1:[]) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" + (p1:p2:[]) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 + ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" + (p1:p2:_) -> + " (which is required by " ++ elabPlanPackageName verbosity p1 + ++ ", " ++ elabPlanPackageName verbosity p2 + ++ " and others)" + + showException e = case fromException e of + Just (ExitFailure 1) -> "" + +#ifdef MIN_VERSION_unix + -- Note [Positive "signal" exit code] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- What's the business with the test for negative and positive + -- signal values? The API for process specifies that if the + -- process died due to a signal, it returns a *negative* exit + -- code. So that's the negative test. + -- + -- What about the positive test? Well, when we find out that + -- a process died due to a signal, we ourselves exit with that + -- exit code. However, we don't "kill ourselves" with the + -- signal; we just exit with the same code as the signal: thus + -- the caller sees a *positive* exit code. So that's what + -- happens when we get a positive exit code. + Just (ExitFailure n) + | -n == fromIntegral sigSEGV -> + " The build process segfaulted (i.e. SIGSEGV)." + + | n == fromIntegral sigSEGV -> + " The build process terminated with exit code " ++ show n + ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." + + | -n == fromIntegral sigKILL -> + " The build process was killed (i.e. SIGKILL). " ++ explanation + + | n == fromIntegral sigKILL -> + " The build process terminated with exit code " ++ show n + ++ " which may be because some part of it was killed " + ++ "(i.e. SIGKILL). " ++ explanation + where + explanation = + "The typical reason for this is that there is not " + ++ "enough memory available (e.g. the OS killed a process " + ++ "using lots of memory)." +#endif + Just (ExitFailure n) -> + " The build process terminated with exit code " ++ show n + + _ -> " The exception was:\n " +#if MIN_VERSION_base(4,8,0) + ++ displayException e +#else + ++ show e +#endif + + buildFailureException reason = + case reason of + DownloadFailed e -> Just e + UnpackFailed e -> Just e + ConfigureFailed e -> Just e + BuildFailed e -> Just e + ReplFailed e -> Just e + HaddocksFailed e -> Just e + TestsFailed e -> Just e + BenchFailed e -> Just e + InstallFailed e -> Just e + DependentFailed _ -> Nothing + +data BuildFailurePresentation = + ShowBuildSummaryOnly BuildFailureReason + | ShowBuildSummaryAndLog BuildFailureReason FilePath + +------------------------------------------------------------------------------- +-- Dummy projects +------------------------------------------------------------------------------- + +-- | Create a dummy project context, without a .cabal or a .cabal.project file +-- (a place where to put a temporary dist directory is still needed) +establishDummyProjectBaseContext + :: Verbosity + -> ProjectConfig + -> DistDirLayout + -- ^ Where to put the dist directory + -> [PackageSpecifier UnresolvedSourcePackage] + -- ^ The packages to be included in the project + -> CurrentCommand + -> IO ProjectBaseContext +establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do + cabalDir <- getCabalDir + + globalConfig <- runRebuild "" + $ readGlobalConfig verbosity + $ projectConfigConfigFile + $ projectConfigShared cliConfig + let projectConfig = globalConfig <> cliConfig + + let ProjectConfigBuildOnly { + projectConfigLogsDir + } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings, + currentCommand + } + +establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout +establishDummyDistDirLayout verbosity cliConfig tmpDir = do + let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory + + -- Create the dist directories + createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout + createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout + + return distDirLayout + where + mdistDirectory = flagToMaybe + $ projectConfigDistDir + $ projectConfigShared cliConfig + projectRoot = ProjectRootImplicit tmpDir diff --git a/src/Distribution/Client/ProjectPlanOutput.hs b/src/Distribution/Client/ProjectPlanOutput.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectPlanOutput.hs @@ -0,0 +1,939 @@ +{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns, + DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, + ScopedTypeVariables #-} + +module Distribution.Client.ProjectPlanOutput ( + -- * Plan output + writePlanExternalRepresentation, + + -- * Project status + -- | Several outputs rely on having a general overview of + PostBuildProjectStatus(..), + updatePostBuildProjectStatus, + createPackageEnvironment, + writePlanGhcEnvironment, + argsEquivalentOfGhcEnvironmentFile, + ) where + +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.DistDirLayout +import Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..)) +import Distribution.Client.Types.PackageLocation (PackageLocation(..)) +import Distribution.Client.Types.ConfiguredId (confInstId) +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) +import Distribution.Client.HashValue (showHashValue, hashValue) +import Distribution.Client.Utils (cabalInstallVersion) + +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.Utils.Json as J +import qualified Distribution.Simple.InstallDirs as InstallDirs + +import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps + +import Distribution.Package +import Distribution.System +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.PackageDescription as PD +import Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) +import Distribution.Simple.Compiler + ( PackageDBStack, PackageDB(..) + , compilerVersion, compilerFlavor, showCompilerId + , compilerId, CompilerId(..), Compiler ) +import Distribution.Simple.GHC + ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) + , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile + , writeGhcEnvironmentFile ) +import Distribution.Simple.BuildPaths + ( dllExtension, exeExtension ) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (Graph, Node) +import qualified Distribution.Compat.Binary as Binary +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Prelude () +import Distribution.Client.Compat.Prelude + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Builder as BB + +import System.FilePath +import System.IO + +import Distribution.Simple.Program.GHC (packageDbArgsDb) + +----------------------------------------------------------------------------- +-- Writing plan.json files +-- + +-- | Write out a representation of the elaborated install plan. +-- +-- This is for the benefit of debugging and external tools like editors. +-- +writePlanExternalRepresentation :: DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> IO () +writePlanExternalRepresentation distDirLayout elaboratedInstallPlan + elaboratedSharedConfig = + writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $ + BB.toLazyByteString + . J.encodeToBuilder + $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig + +-- | Renders a subset of the elaborated install plan in a semi-stable JSON +-- format. +-- +encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value +encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = + --TODO: [nice to have] include all of the sharedPackageConfig and all of + -- the parts of the elaboratedInstallPlan + J.object [ "cabal-version" J..= jdisplay cabalInstallVersion + , "cabal-lib-version" J..= jdisplay cabalVersion + , "compiler-id" J..= (J.String . showCompilerId . pkgConfigCompiler) + elaboratedSharedConfig + , "os" J..= jdisplay os + , "arch" J..= jdisplay arch + , "install-plan" J..= installPlanToJ elaboratedInstallPlan + ] + where + plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig + + installPlanToJ :: ElaboratedInstallPlan -> [J.Value] + installPlanToJ = map planPackageToJ . InstallPlan.toList + + planPackageToJ :: ElaboratedPlanPackage -> J.Value + planPackageToJ pkg = + case pkg of + InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi + InstallPlan.Configured elab -> elaboratedPackageToJ False elab + InstallPlan.Installed elab -> elaboratedPackageToJ True elab + -- Note that the plan.json currently only uses the elaborated plan, + -- not the improved plan. So we will not get the Installed state for + -- that case, but the code supports it in case we want to use this + -- later in some use case where we want the status of the build. + + installedPackageInfoToJ :: InstalledPackageInfo -> J.Value + installedPackageInfoToJ ipi = + -- Pre-existing packages lack configuration information such as their flag + -- settings or non-lib components. We only get pre-existing packages for + -- the global/core packages however, so this isn't generally a problem. + -- So these packages are never local to the project. + -- + J.object + [ "type" J..= J.String "pre-existing" + , "id" J..= (jdisplay . installedUnitId) ipi + , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi + , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi + , "depends" J..= map jdisplay (installedDepends ipi) + ] + + elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value + elaboratedPackageToJ isInstalled elab = + J.object $ + [ "type" J..= J.String (if isInstalled then "installed" + else "configured") + , "id" J..= (jdisplay . installedUnitId) elab + , "pkg-name" J..= (jdisplay . pkgName . packageId) elab + , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab + , "flags" J..= J.object [ PD.unFlagName fn J..= v + | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] + , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) + , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) + ] ++ + [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) + | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++ + [ "pkg-src-sha256" J..= J.String (showHashValue hash) + | Just hash <- [elabPkgSourceHash elab] ] ++ + (case elabBuildStyle elab of + BuildInplaceOnly -> + ["dist-dir" J..= J.String dist_dir] + BuildAndInstall -> + -- TODO: install dirs? + [] + ) ++ + case elabPkgOrComp elab of + ElabPackage pkg -> + let components = J.object $ + [ comp2str c J..= (J.object $ + [ "depends" J..= map (jdisplay . confInstId) ldeps + , "exe-depends" J..= map (jdisplay . confInstId) edeps + ] ++ + bin_file c) + | (c,(ldeps,edeps)) + <- ComponentDeps.toList $ + ComponentDeps.zip (pkgLibDependencies pkg) + (pkgExeDependencies pkg) ] + in ["components" J..= components] + ElabComponent comp -> + ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) + ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) + ,"component-name" J..= J.String (comp2str (compSolverName comp)) + ] ++ + bin_file (compSolverName comp) + where + packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value + packageLocationToJ pkgloc = + case pkgloc of + LocalUnpackedPackage local -> + J.object [ "type" J..= J.String "local" + , "path" J..= J.String local + ] + LocalTarballPackage local -> + J.object [ "type" J..= J.String "local-tar" + , "path" J..= J.String local + ] + RemoteTarballPackage uri _ -> + J.object [ "type" J..= J.String "remote-tar" + , "uri" J..= J.String (show uri) + ] + RepoTarballPackage repo _ _ -> + J.object [ "type" J..= J.String "repo-tar" + , "repo" J..= repoToJ repo + ] + RemoteSourceRepoPackage srcRepo _ -> + J.object [ "type" J..= J.String "source-repo" + , "source-repo" J..= sourceRepoToJ srcRepo + ] + + repoToJ :: Repo -> J.Value + repoToJ repo = + case repo of + RepoLocalNoIndex{..} -> + J.object [ "type" J..= J.String "local-repo-no-index" + , "path" J..= J.String repoLocalDir + ] + RepoRemote{..} -> + J.object [ "type" J..= J.String "remote-repo" + , "uri" J..= J.String (show (remoteRepoURI repoRemote)) + ] + RepoSecure{..} -> + J.object [ "type" J..= J.String "secure-repo" + , "uri" J..= J.String (show (remoteRepoURI repoRemote)) + ] + + sourceRepoToJ :: SourceRepoMaybe -> J.Value + sourceRepoToJ SourceRepositoryPackage{..} = + J.object $ filter ((/= J.Null) . snd) $ + [ "type" J..= jdisplay srpType + , "location" J..= J.String srpLocation + , "branch" J..= fmap J.String srpBranch + , "tag" J..= fmap J.String srpTag + , "subdir" J..= fmap J.String srpSubdir + ] + + dist_dir = distBuildDirectory distDirLayout + (elabDistDirParams elaboratedSharedConfig elab) + + bin_file c = case c of + ComponentDeps.ComponentExe s -> bin_file' s + ComponentDeps.ComponentTest s -> bin_file' s + ComponentDeps.ComponentBench s -> bin_file' s + ComponentDeps.ComponentFLib s -> flib_file' s + _ -> [] + bin_file' s = + ["bin-file" J..= J.String bin] + where + bin = if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat + else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + + flib_file' s = + ["bin-file" J..= J.String bin] + where + bin = if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat + else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + + comp2str :: ComponentDeps.Component -> String + comp2str = prettyShow + + style2str :: Bool -> BuildStyle -> String + style2str True _ = "local" + style2str False BuildInplaceOnly = "inplace" + style2str False BuildAndInstall = "global" + + jdisplay :: Pretty a => a -> J.Value + jdisplay = J.String . prettyShow + + +----------------------------------------------------------------------------- +-- Project status +-- + +-- So, what is the status of a project after a build? That is, how do the +-- inputs (package source files etc) compare to the output artefacts (build +-- libs, exes etc)? Do the outputs reflect the current values of the inputs +-- or are outputs out of date or invalid? +-- +-- First of all, what do we mean by out-of-date and what do we mean by +-- invalid? We think of the build system as a morally pure function that +-- computes the output artefacts given input values. We say an output artefact +-- is out of date when its value is not the value that would be computed by a +-- build given the current values of the inputs. An output artefact can be +-- out-of-date but still be perfectly usable; it simply correspond to a +-- previous state of the inputs. +-- +-- On the other hand there are cases where output artefacts cannot safely be +-- used. For example libraries and dynamically linked executables cannot be +-- used when the libs they depend on change without them being recompiled +-- themselves. Whether an artefact is still usable depends on what it is, e.g. +-- dynamically linked vs statically linked and on how it gets updated (e.g. +-- only atomically on success or if failure can leave invalid states). We need +-- a definition (or two) that is independent of the kind of artefact and can +-- be computed just in terms of changes in package graphs, but are still +-- useful for determining when particular kinds of artefacts are invalid. +-- +-- Note that when we talk about packages in this context we just mean nodes +-- in the elaborated install plan, which can be components or packages. +-- +-- There's obviously a close connection between packages being out of date and +-- their output artefacts being unusable: most of the time if a package +-- remains out of date at the end of a build then some of its output artefacts +-- will be unusable. That is true most of the time because a build will have +-- attempted to build one of the out-of-date package's dependencies. If the +-- build of the dependency succeeded then it changed output artefacts (like +-- libs) and if it failed then it may have failed after already changing +-- things (think failure after updating some but not all .hi files). +-- +-- There are a few reasons we may end up with still-usable output artefacts +-- for a package even when it remains out of date at the end of a build. +-- Firstly if executing a plan fails then packages can be skipped, and thus we +-- may have packages where all their dependencies were skipped. Secondly we +-- have artefacts like statically linked executables which are not affected by +-- libs they depend on being recompiled. Furthermore, packages can be out of +-- date due to changes in build tools or Setup.hs scripts they depend on, but +-- again libraries or executables in those out-of-date packages remain usable. +-- +-- So we have two useful definitions of invalid. Both are useful, for +-- different purposes, so we will compute both. The first corresponds to the +-- invalid libraries and dynamic executables. We say a package is invalid by +-- changed deps if any of the packages it depends on (via library dep edges) +-- were rebuilt (successfully or unsuccessfully). The second definition +-- corresponds to invalid static executables. We say a package is invalid by +-- a failed build simply if the package was built but unsuccessfully. +-- +-- So how do we find out what packages are out of date or invalid? +-- +-- Obviously we know something for all the packages that were part of the plan +-- that was executed, but that is just a subset since we prune the plan down +-- to the targets and their dependencies. +-- +-- Recall the steps we go though: +-- +-- + starting with the initial improved plan (this is the full project); +-- +-- + prune the plan to the user's build targets; +-- +-- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap +-- covering the pruned subset of the original plan; +-- +-- + execute the plan giving us BuildOutcomes which tell us success/failure +-- for each package. +-- +-- So given that the BuildStatusMap and BuildOutcomes do not cover everything +-- in the original plan, what can they tell us about the original plan? +-- +-- The BuildStatusMap tells us directly that some packages are up to date and +-- others out of date (but only for the pruned subset). But we know that +-- everything that is a reverse dependency of an out-of-date package is itself +-- out-of-date (whether or not it is in the pruned subset). Of course after +-- a build the BuildOutcomes may tell us that some of those out-of-date +-- packages are now up to date (ie a successful build outcome). +-- +-- The difference is packages that are reverse dependencies of out-of-date +-- packages but are not brought up-to-date by the build (i.e. did not have +-- successful outcomes, either because they failed or were not in the pruned +-- subset to be built). We also know which packages were rebuilt, so we can +-- use this to find the now-invalid packages. +-- +-- Note that there are still packages for which we cannot discover full status +-- information. There may be packages outside of the pruned plan that do not +-- depend on packages within the pruned plan that were discovered to be +-- out-of-date. For these packages we do not know if their build artefacts +-- are out-of-date or not. We do know however that they are not invalid, as +-- that's not possible given our definition of invalid. Intuitively it is +-- because we have not disturbed anything that these packages depend on, e.g. +-- we've not rebuilt any libs they depend on. Recall that our widest +-- definition of invalid was only concerned about dependencies on libraries +-- (to cover problems like shared libs or GHC seeing inconsistent .hi files). +-- +-- So our algorithm for out-of-date packages is relatively simple: take the +-- reverse dependency closure in the original improved plan (pre-pruning) of +-- the out-of-date packages (as determined by the BuildStatusMap from the dry +-- run). That gives a set of packages that were definitely out of date after +-- the dry run. Now we remove from this set the packages that the +-- BuildOutcomes tells us are now up-to-date after the build. The remaining +-- set is the out-of-date packages. +-- +-- As for packages that are invalid by changed deps, we start with the plan +-- dependency graph but keep only those edges that point to libraries (so +-- ignoring deps on exes and setup scripts). We take the packages for which a +-- build was attempted (successfully or unsuccessfully, but not counting +-- knock-on failures) and take the reverse dependency closure. We delete from +-- this set all the packages that were built successfully. Note that we do not +-- need to intersect with the out-of-date packages since this follows +-- automatically: all rev deps of packages we attempted to build must have +-- been out of date at the start of the build, and if they were not built +-- successfully then they're still out of date -- meeting our definition of +-- invalid. + + +type PackageIdSet = Set UnitId +type PackagesUpToDate = PackageIdSet + +data PostBuildProjectStatus = PostBuildProjectStatus { + + -- | Packages that are known to be up to date. These were found to be + -- up to date before the build, or they have a successful build outcome + -- afterwards. + -- + -- This does not include any packages outside of the subset of the plan + -- that was executed because we did not check those and so don't know + -- for sure that they're still up to date. + -- + packagesDefinitelyUpToDate :: PackageIdSet, + + -- | Packages that are probably still up to date (and at least not + -- known to be out of date, and certainly not invalid). This includes + -- 'packagesDefinitelyUpToDate' plus packages that were up to date + -- previously and are outside of the subset of the plan that was + -- executed. It excludes 'packagesOutOfDate'. + -- + packagesProbablyUpToDate :: PackageIdSet, + + -- | Packages that are known to be out of date. These are packages + -- that were determined to be out of date before the build, and they + -- do not have a successful build outcome afterwards. + -- + -- Note that this can sometimes include packages outside of the subset + -- of the plan that was executed. For example suppose package A and B + -- depend on C, and A is the target so only A and C are in the subset + -- to be built. Now suppose C is found to have changed, then both A + -- and B are out-of-date before the build and since B is outside the + -- subset to be built then it will remain out of date. + -- + -- Note also that this is /not/ the inverse of + -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. + -- There are packages where we have no information (ones that were not + -- in the subset of the plan that was executed). + -- + packagesOutOfDate :: PackageIdSet, + + -- | Packages that depend on libraries that have changed during the + -- build (either build success or failure). + -- + -- This corresponds to the fact that libraries and dynamic executables + -- are invalid once any of the libs they depend on change. + -- + -- This does include packages that themselves failed (i.e. it is a + -- superset of 'packagesInvalidByFailedBuild'). It does not include + -- changes in dependencies on executables (i.e. build tools). + -- + packagesInvalidByChangedLibDeps :: PackageIdSet, + + -- | Packages that themselves failed during the build (i.e. them + -- directly not a dep). + -- + -- This corresponds to the fact that static executables are invalid + -- in unlucky circumstances such as linking failing half way though, + -- or data file generation failing. + -- + -- This is a subset of 'packagesInvalidByChangedLibDeps'. + -- + packagesInvalidByFailedBuild :: PackageIdSet, + + -- | A subset of the plan graph, including only dependency-on-library + -- edges. That is, dependencies /on/ libraries, not dependencies /of/ + -- libraries. This tells us all the libraries that packages link to. + -- + -- This is here as a convenience, as strictly speaking it's not status + -- as it's just a function of the original 'ElaboratedInstallPlan'. + -- + packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage), + + -- | As a convenience for 'Set.intersection' with any of the other + -- 'PackageIdSet's to select only packages that are part of the + -- project locally (i.e. with a local source dir). + -- + packagesBuildLocal :: PackageIdSet, + + -- | As a convenience for 'Set.intersection' with any of the other + -- 'PackageIdSet's to select only packages that are being built + -- in-place within the project (i.e. not destined for the store). + -- + packagesBuildInplace :: PackageIdSet, + + -- | As a convenience for 'Set.intersection' or 'Set.difference' with + -- any of the other 'PackageIdSet's to select only packages that were + -- pre-installed or already in the store prior to the build. + -- + packagesAlreadyInStore :: PackageIdSet + } + +-- | Work out which packages are out of date or invalid after a build. +-- +postBuildProjectStatus :: ElaboratedInstallPlan + -> PackagesUpToDate + -> BuildStatusMap + -> BuildOutcomes + -> PostBuildProjectStatus +postBuildProjectStatus plan previousPackagesUpToDate + pkgBuildStatus buildOutcomes = + PostBuildProjectStatus { + packagesDefinitelyUpToDate, + packagesProbablyUpToDate, + packagesOutOfDate, + packagesInvalidByChangedLibDeps, + packagesInvalidByFailedBuild, + -- convenience stuff + packagesLibDepGraph, + packagesBuildLocal, + packagesBuildInplace, + packagesAlreadyInStore + } + where + packagesDefinitelyUpToDate = + packagesUpToDatePreBuild + `Set.union` + packagesSuccessfulPostBuild + + packagesProbablyUpToDate = + packagesDefinitelyUpToDate + `Set.union` + (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) + + packagesOutOfDate = + packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild + + packagesInvalidByChangedLibDeps = + packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild + + packagesInvalidByFailedBuild = + packagesFailurePostBuild + + -- Note: if any of the intermediate values below turn out to be useful in + -- their own right then we can simply promote them to the result record + + -- The previous set of up-to-date packages will contain bogus package ids + -- when the solver plan or config contributing to the hash changes. + -- So keep only the ones where the package id (i.e. hash) is the same. + previousPackagesUpToDate' = + Set.intersection + previousPackagesUpToDate + (InstallPlan.keysSet plan) + + packagesUpToDatePreBuild = + Set.filter + (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) + -- For packages not in the plan subset we did the dry-run on we don't + -- know anything about their status, so not known to be /up to date/. + (InstallPlan.keysSet plan) + + packagesOutOfDatePreBuild = + Set.fromList . map installedUnitId $ + InstallPlan.reverseDependencyClosure plan + [ ipkgid + | pkg <- InstallPlan.toList plan + , let ipkgid = installedUnitId pkg + , lookupBuildStatusRequiresBuild False ipkgid + -- For packages not in the plan subset we did the dry-run on we don't + -- know anything about their status, so not known to be /out of date/. + ] + + packagesSuccessfulPostBuild = + Set.fromList + [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ] + + -- direct failures, not failures due to deps + packagesFailurePostBuild = + Set.fromList + [ ikgid + | (ikgid, Left failure) <- Map.toList buildOutcomes + , case buildFailureReason failure of + DependentFailed _ -> False + _ -> True + ] + + -- Packages that have a library dependency on a package for which a build + -- was attempted + packagesDepOnChangedLib = + Set.fromList . map Graph.nodeKey $ + fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ + Graph.revClosure packagesLibDepGraph + ( Map.keys + . Map.filter (uncurry buildAttempted) + $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes + ) + + -- The plan graph but only counting dependency-on-library edges + packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph = + Graph.fromDistinctList + [ Graph.N pkg (installedUnitId pkg) libdeps + | pkg <- InstallPlan.toList plan + , let libdeps = case pkg of + InstallPlan.PreExisting ipkg -> installedDepends ipkg + InstallPlan.Configured srcpkg -> elabLibDeps srcpkg + InstallPlan.Installed srcpkg -> elabLibDeps srcpkg + ] + elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies + + -- Was a build was attempted for this package? + -- If it doesn't have both a build status and outcome then the answer is no. + buildAttempted :: BuildStatus -> BuildOutcome -> Bool + -- And not if it didn't need rebuilding in the first place. + buildAttempted buildStatus _buildOutcome + | not (buildStatusRequiresBuild buildStatus) + = False + + -- And not if it was skipped due to a dep failing first. + buildAttempted _ (Left BuildFailure {buildFailureReason}) + | DependentFailed _ <- buildFailureReason + = False + + -- Otherwise, succeeded or failed, yes the build was tried. + buildAttempted _ (Left BuildFailure {}) = True + buildAttempted _ (Right _) = True + + lookupBuildStatusRequiresBuild def ipkgid = + case Map.lookup ipkgid pkgBuildStatus of + Nothing -> def -- Not in the plan subset we did the dry-run on + Just buildStatus -> buildStatusRequiresBuild buildStatus + + packagesBuildLocal = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> False + InstallPlan.Installed _ -> False + InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg + + packagesBuildInplace = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> False + InstallPlan.Installed _ -> False + InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg + == BuildInplaceOnly + + packagesAlreadyInStore = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> True + InstallPlan.Installed _ -> True + InstallPlan.Configured _ -> False + + selectPlanPackageIdSet p = Map.keysSet + . Map.filter p + $ InstallPlan.toMap plan + + + +updatePostBuildProjectStatus :: Verbosity + -> DistDirLayout + -> ElaboratedInstallPlan + -> BuildStatusMap + -> BuildOutcomes + -> IO PostBuildProjectStatus +updatePostBuildProjectStatus verbosity distDirLayout + elaboratedInstallPlan + pkgsBuildStatus buildOutcomes = do + + -- Read the previous up-to-date set, update it and write it back + previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout + let currentBuildStatus@PostBuildProjectStatus{..} + = postBuildProjectStatus + elaboratedInstallPlan + previousUpToDate + pkgsBuildStatus + buildOutcomes + let currentUpToDate = packagesProbablyUpToDate + writePackagesUpToDateCacheFile distDirLayout currentUpToDate + + -- Report various possibly interesting things + -- We additionally intersect with the packagesBuildInplace so that + -- we don't show huge numbers of boring packages from the store. + debugNoWrap verbosity $ + "packages definitely up to date: " + ++ displayPackageIdSet (packagesDefinitelyUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages previously probably up to date: " + ++ displayPackageIdSet (previousUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages now probably up to date: " + ++ displayPackageIdSet (packagesProbablyUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages newly up to date: " + ++ displayPackageIdSet (packagesDefinitelyUpToDate + `Set.difference` previousUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages out to date: " + ++ displayPackageIdSet (packagesOutOfDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages invalid due to dep change: " + ++ displayPackageIdSet packagesInvalidByChangedLibDeps + + debugNoWrap verbosity $ + "packages invalid due to build failure: " + ++ displayPackageIdSet packagesInvalidByFailedBuild + + return currentBuildStatus + where + displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList + +-- | Helper for reading the cache file. +-- +-- This determines the type and format of the binary cache file. +-- +readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate +readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = + handleDoesNotExist Set.empty $ + handleDecodeFailure $ + withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> + Binary.decodeOrFailIO =<< BS.hGetContents hnd + where + handleDecodeFailure = fmap (either (const Set.empty) id) + +-- | Helper for writing the package up-to-date cache file. +-- +-- This determines the type and format of the binary cache file. +-- +writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () +writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = + writeFileAtomic (distProjectCacheFile "up-to-date") $ + Binary.encode upToDate + +-- | Prepare a package environment that includes all the library dependencies +-- for a plan. +-- +-- When running cabal new-exec, we want to set things up so that the compiler +-- can find all the right packages (and nothing else). This function is +-- intended to do that work. It takes a location where it can write files +-- temporarily, in case the compiler wants to learn this information via the +-- filesystem, and returns any environment variable overrides the compiler +-- needs. +createPackageEnvironment :: Verbosity + -> FilePath + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO [(String, Maybe String)] +createPackageEnvironment verbosity + path + elaboratedPlan + elaboratedShared + buildStatus + | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC + = do + envFileM <- writePlanGhcEnvironment + path + elaboratedPlan + elaboratedShared + buildStatus + case envFileM of + Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] + Nothing -> do + warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" + return [] + | otherwise + = do + warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" + return [] + +-- Writing .ghc.environment files +-- + +writePlanGhcEnvironment :: FilePath + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO (Maybe FilePath) +writePlanGhcEnvironment path + elaboratedInstallPlan + ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigPlatform = platform + } + postBuildStatus + | compilerFlavor compiler == GHC + , supportsPkgEnvFiles (getImplInfo compiler) + --TODO: check ghcjs compat + = fmap Just $ writeGhcEnvironmentFile + path + platform (compilerVersion compiler) + (renderGhcEnvironmentFile path + elaboratedInstallPlan + postBuildStatus) + --TODO: [required eventually] support for writing user-wide package + -- environments, e.g. like a global project, but we would not put the + -- env file in the home dir, rather it lives under ~/.ghc/ + +writePlanGhcEnvironment _ _ _ _ = return Nothing + +renderGhcEnvironmentFile :: FilePath + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [GhcEnvironmentFileEntry] +renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan + postBuildStatus = + headerComment + : simpleGhcEnvironmentFile packageDBs unitIds + where + headerComment = + GhcEnvFileComment + $ "This is a GHC environment file written by cabal. This means you can\n" + ++ "run ghc or ghci and get the environment of the project as a whole.\n" + ++ "But you still need to use cabal repl $target to get the environment\n" + ++ "of specific components (libs, exes, tests etc) because each one can\n" + ++ "have its own source dirs, cpp flags etc.\n\n" + unitIds = selectGhcEnvironmentFileLibraries postBuildStatus + packageDBs = relativePackageDBPaths projectRootDir $ + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan + + +argsEquivalentOfGhcEnvironmentFile + :: Compiler + -> DistDirLayout + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [String] +argsEquivalentOfGhcEnvironmentFile compiler = + case compilerId compiler + of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId _ _ -> error "Only GHC and GHCJS are supported" + +-- TODO remove this when we drop support for non-.ghc.env ghc +argsEquivalentOfGhcEnvironmentFileGhc + :: DistDirLayout + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [String] +argsEquivalentOfGhcEnvironmentFileGhc + distDirLayout + elaboratedInstallPlan + postBuildStatus = + clearPackageDbStackFlag + ++ packageDbArgsDb packageDBs + ++ foldMap packageIdFlag packageIds + where + projectRootDir = distProjectRootDirectory distDirLayout + packageIds = selectGhcEnvironmentFileLibraries postBuildStatus + packageDBs = relativePackageDBPaths projectRootDir $ + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan + -- TODO use proper flags? but packageDbArgsDb is private + clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] + packageIdFlag uid = ["-package-id", prettyShow uid] + + +-- We're producing an environment for users to use in ghci, so of course +-- that means libraries only (can't put exes into the ghc package env!). +-- The library environment should be /consistent/ with the environment +-- that each of the packages in the project use (ie same lib versions). +-- So that means all the normal library dependencies of all the things +-- in the project (including deps of exes that are local to the project). +-- We do not however want to include the dependencies of Setup.hs scripts, +-- since these are generally uninteresting but also they need not in +-- general be consistent with the library versions that packages local to +-- the project use (recall that Setup.hs script's deps can be picked +-- independently of other packages in the project). +-- +-- So, our strategy is as follows: +-- +-- produce a dependency graph of all the packages in the install plan, +-- but only consider normal library deps as edges in the graph. Thus we +-- exclude the dependencies on Setup.hs scripts (in the case of +-- per-component granularity) or of Setup.hs scripts (in the case of +-- per-package granularity). Then take a dependency closure, using as +-- roots all the packages/components local to the project. This will +-- exclude Setup scripts and their dependencies. +-- +-- Note: this algorithm will have to be adapted if/when the install plan +-- is extended to cover multiple compilers at once, and may also have to +-- change if we start to treat unshared deps of test suites in a similar +-- way to how we treat Setup.hs script deps (ie being able to pick them +-- independently). +-- +-- Since we had to use all the local packages, including exes, (as roots +-- to find the libs) then those exes still end up in our list so we have +-- to filter them out at the end. +-- +selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] +selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = + case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of + Nothing -> error "renderGhcEnvironmentFile: broken dep closure" + Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes + , hasUpToDateLib pkg ] + where + hasUpToDateLib planpkg = case planpkg of + -- A pre-existing global lib + InstallPlan.PreExisting _ -> True + + -- A package in the store. Check it's a lib. + InstallPlan.Installed pkg -> elabRequiresRegistration pkg + + -- A package we were installing this time, either destined for the store + -- or just locally. Check it's a lib and that it is probably up to date. + InstallPlan.Configured pkg -> + elabRequiresRegistration pkg + && installedUnitId pkg `Set.member` packagesProbablyUpToDate + + +selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack +selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = + -- If we have any inplace packages then their package db stack is the + -- one we should use since it'll include the store + the local db but + -- it's certainly possible to have no local inplace packages + -- e.g. just "extra" packages coming from the store. + case (inplacePackages, sourcePackages) of + ([], pkgs) -> checkSamePackageDBs pkgs + (pkgs, _) -> checkSamePackageDBs pkgs + where + checkSamePackageDBs pkgs = + case ordNub (map elabBuildPackageDBStack pkgs) of + [packageDbs] -> packageDbs + [] -> [] + _ -> error $ "renderGhcEnvironmentFile: packages with " + ++ "different package db stacks" + -- This should not happen at the moment but will happen as soon + -- as we support projects where we build packages with different + -- compilers, at which point we have to consider how to adapt + -- this feature, e.g. write out multiple env files, one for each + -- compiler / project profile. + + inplacePackages = + [ srcpkg + | srcpkg <- sourcePackages + , elabBuildStyle srcpkg == BuildInplaceOnly ] + sourcePackages = + [ srcpkg + | pkg <- InstallPlan.toList elaboratedInstallPlan + , srcpkg <- maybeToList $ case pkg of + InstallPlan.Configured srcpkg -> Just srcpkg + InstallPlan.Installed srcpkg -> Just srcpkg + InstallPlan.PreExisting _ -> Nothing + ] + +relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack +relativePackageDBPaths relroot = map (relativePackageDBPath relroot) + +relativePackageDBPath :: FilePath -> PackageDB -> PackageDB +relativePackageDBPath relroot pkgdb = + case pkgdb of + GlobalPackageDB -> GlobalPackageDB + UserPackageDB -> UserPackageDB + SpecificPackageDB path -> SpecificPackageDB relpath + where relpath = makeRelative relroot path diff --git a/src/Distribution/Client/ProjectPlanning.hs b/src/Distribution/Client/ProjectPlanning.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectPlanning.hs @@ -0,0 +1,3881 @@ +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} + +-- | Planning how to build everything in a project. +-- +module Distribution.Client.ProjectPlanning ( + -- * elaborated install plan types + ElaboratedInstallPlan, + ElaboratedConfiguredPackage(..), + ElaboratedPlanPackage, + ElaboratedSharedConfig(..), + ElaboratedReadyPackage, + BuildStyle(..), + CabalFileText, + + -- * Producing the elaborated install plan + rebuildProjectConfig, + rebuildInstallPlan, + + -- * Build targets + availableTargets, + AvailableTarget(..), + AvailableTargetStatus(..), + TargetRequested(..), + ComponentTarget(..), + SubComponentTarget(..), + showComponentTarget, + nubComponentTargets, + + -- * Selecting a plan subset + pruneInstallPlanToTargets, + TargetAction(..), + pruneInstallPlanToDependencies, + CannotPruneDependencies(..), + + -- * Utils required for building + pkgHasEphemeralBuildTargets, + elabBuildTargetWholeComponents, + + -- * Setup.hs CLI flags for building + setupHsScriptOptions, + setupHsConfigureFlags, + setupHsConfigureArgs, + setupHsBuildFlags, + setupHsBuildArgs, + setupHsReplFlags, + setupHsReplArgs, + setupHsTestFlags, + setupHsTestArgs, + setupHsBenchFlags, + setupHsBenchArgs, + setupHsCopyFlags, + setupHsRegisterFlags, + setupHsHaddockFlags, + setupHsHaddockArgs, + + packageHashInputs, + + -- * Path construction + binDirectoryFor, + binDirectories, + storePackageInstallDirs, + storePackageInstallDirs' + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.HashValue +import Distribution.Client.ProjectPlanning.Types as Ty +import Distribution.Client.PackageHash +import Distribution.Client.RebuildMonad +import Distribution.Client.Store +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanOutput + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import qualified Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.Init (incVersion) +import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.DistDirLayout +import Distribution.Client.SetupWrapper +import Distribution.Client.JobControl +import Distribution.Client.FetchUtils +import Distribution.Client.Config +import qualified Hackage.Security.Client as Sec +import Distribution.Client.Setup hiding (packageName, cabalVersion) +import Distribution.Utils.NubList +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings + +import Distribution.CabalSpecVersion +import Distribution.ModuleName +import Distribution.Package +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName +import Distribution.Types.GivenComponent + (GivenComponent(..)) +import Distribution.Types.PackageVersionConstraint +import Distribution.Types.PkgconfigDependency +import Distribution.Types.UnqualComponentName +import Distribution.System +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.PackageDescription as PD +import qualified Distribution.PackageDescription.Configuration as PD +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Compiler +import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate +import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Setup + (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault) +import qualified Distribution.Simple.Configure as Cabal +import qualified Distribution.Simple.LocalBuildInfo as Cabal +import Distribution.Simple.LocalBuildInfo + ( Component(..), pkgComponents, componentBuildInfo + , componentName ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.InstalledPackageInfo as IPI + +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.FullUnitId +import Distribution.Backpack +import Distribution.Types.ComponentInclude + +import Distribution.Simple.Utils +import Distribution.Version + +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph(IsNode(..)) + +import Data.Foldable (fold) +import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma) +import qualified Text.PrettyPrint as Disp +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad.State as State +import Control.Exception (assert) +import Data.List (groupBy) +import qualified Data.List.NonEmpty as NE +import System.FilePath + +------------------------------------------------------------------------------ +-- * Elaborated install plan +------------------------------------------------------------------------------ + +-- "Elaborated" -- worked out with great care and nicety of detail; +-- executed with great minuteness: elaborate preparations; +-- elaborate care. +-- +-- So here's the idea: +-- +-- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc +-- all passed in as separate args and which are then further selected, +-- transformed etc during the execution of the build. Instead we construct +-- an elaborated install plan that includes everything we will need, and then +-- during the execution of the plan we do as little transformation of this +-- info as possible. +-- +-- So we're trying to split the work into two phases: construction of the +-- elaborated install plan (which as far as possible should be pure) and +-- then simple execution of that plan without any smarts, just doing what the +-- plan says to do. +-- +-- So that means we need a representation of this fully elaborated install +-- plan. The representation consists of two parts: +-- +-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a +-- representation of source packages that includes a lot more detail about +-- that package's individual configuration +-- +-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for +-- every package in a plan. Rather than duplicate that info every entry in +-- the 'GenericInstallPlan' we keep that separately. +-- +-- The division between the shared and per-package config is /not set in stone +-- for all time/. For example if we wanted to generalise the install plan to +-- describe a situation where we want to build some packages with GHC and some +-- with GHCJS then the platform and compiler would no longer be shared between +-- all packages but would have to be per-package (probably with some sanity +-- condition on the graph structure). +-- + +-- Refer to ProjectPlanning.Types for details of these important types: + +-- type ElaboratedInstallPlan = ... +-- type ElaboratedPlanPackage = ... +-- data ElaboratedSharedConfig = ... +-- data ElaboratedConfiguredPackage = ... +-- data BuildStyle = + + +-- | Check that an 'ElaboratedConfiguredPackage' actually makes +-- sense under some 'ElaboratedSharedConfig'. +sanityCheckElaboratedConfiguredPackage + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> a + -> a +sanityCheckElaboratedConfiguredPackage sharedConfig + elab@ElaboratedConfiguredPackage{..} = + (case elabPkgOrComp of + ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg + ElabComponent comp -> sanityCheckElaboratedComponent elab comp) + + -- either a package is being built inplace, or the + -- 'installedPackageId' we assigned is consistent with + -- the 'hashedInstalledPackageId' we would compute from + -- the elaborated configured package + . assert (elabBuildStyle == BuildInplaceOnly || + elabComponentId == hashedInstalledPackageId + (packageHashInputs sharedConfig elab)) + + -- the stanzas explicitly disabled should not be available + . assert (optStanzaSetNull $ + optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable) + + -- either a package is built inplace, or we are not attempting to + -- build any test suites or benchmarks (we never build these + -- for remote packages!) + . assert (elabBuildStyle == BuildInplaceOnly || + optStanzaSetNull elabStanzasAvailable) + +sanityCheckElaboratedComponent + :: ElaboratedConfiguredPackage + -> ElaboratedComponent + -> a + -> a +sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} + ElaboratedComponent{..} = + + -- Should not be building bench or test if not inplace. + assert (elabBuildStyle == BuildInplaceOnly || + case compComponentName of + Nothing -> True + Just (CLibName _) -> True + Just (CExeName _) -> True + -- This is interesting: there's no way to declare a dependency + -- on a foreign library at the moment, but you may still want + -- to install these to the store + Just (CFLibName _) -> True + Just (CBenchName _) -> False + Just (CTestName _) -> False) + + +sanityCheckElaboratedPackage + :: ElaboratedConfiguredPackage + -> ElaboratedPackage + -> a + -> a +sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} + ElaboratedPackage{..} = + -- we should only have enabled stanzas that actually can be built + -- (according to the solver) + assert (pkgStanzasEnabled `optStanzaSetIsSubset` elabStanzasAvailable) + + -- the stanzas that the user explicitly requested should be + -- enabled (by the previous test, they are also available) + . assert (optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + `optStanzaSetIsSubset` pkgStanzasEnabled) + +------------------------------------------------------------------------------ +-- * Deciding what to do: making an 'ElaboratedInstallPlan' +------------------------------------------------------------------------------ + +-- | Return the up-to-date project config and information about the local +-- packages within the project. +-- +rebuildProjectConfig :: Verbosity + -> DistDirLayout + -> ProjectConfig + -> IO ( ProjectConfig + , [PackageSpecifier UnresolvedSourcePackage] ) +rebuildProjectConfig verbosity + distDirLayout@DistDirLayout { + distProjectRootDirectory, + distDirectory, + distProjectCacheFile, + distProjectCacheDirectory, + distProjectFile + } + cliConfig = do + + fileMonitorProjectConfigKey <- do + configPath <- getConfigFilePath projectConfigConfigFile + return (configPath, distProjectFile "") + + (projectConfig, localPackages) <- + runRebuild distProjectRootDirectory + $ rerunIfChanged verbosity + fileMonitorProjectConfig + fileMonitorProjectConfigKey + $ do + liftIO $ info verbosity "Project settings changed, reconfiguring..." + projectConfig <- phaseReadProjectConfig + localPackages <- phaseReadLocalPackages projectConfig + return (projectConfig, localPackages) + + info verbosity + $ unlines + $ ("this build was affected by the following (project) config files:" :) + $ [ "- " ++ path + | Explicit path <- Set.toList $ projectConfigProvenance projectConfig + ] + + return (projectConfig <> cliConfig, localPackages) + + where + + ProjectConfigShared { projectConfigConfigFile } = + projectConfigShared cliConfig + + fileMonitorProjectConfig = + newFileMonitor (distProjectCacheFile "config") :: FileMonitor + (FilePath, FilePath) + (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage]) + + -- Read the cabal.project (or implicit config) and combine it with + -- arguments from the command line + -- + phaseReadProjectConfig :: Rebuild ProjectConfig + phaseReadProjectConfig = do + readProjectConfig verbosity projectConfigConfigFile distDirLayout + + -- Look for all the cabal packages in the project + -- some of which may be local src dirs, tarballs etc + -- + phaseReadLocalPackages :: ProjectConfig + -> Rebuild [PackageSpecifier UnresolvedSourcePackage] + phaseReadLocalPackages projectConfig@ProjectConfig { + projectConfigShared, + projectConfigBuildOnly + } = do + pkgLocations <- findProjectPackages distDirLayout projectConfig + + -- Create folder only if findProjectPackages did not throw a + -- BadPackageLocations exception. + liftIO $ do + createDirectoryIfMissingVerbose verbosity True distDirectory + createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + + fetchAndReadSourcePackages verbosity distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations + + +-- | Return an up-to-date elaborated install plan. +-- +-- Two variants of the install plan are returned: with and without packages +-- from the store. That is, the \"improved\" plan where source packages are +-- replaced by pre-existing installed packages from the store (when their ids +-- match), and also the original elaborated plan which uses primarily source +-- packages. + +-- The improved plan is what we use for building, but the original elaborated +-- plan is useful for reporting and configuration. For example the @freeze@ +-- command needs the source package info to know about flag choices and +-- dependencies of executables and setup scripts. +-- +rebuildInstallPlan :: Verbosity + -> DistDirLayout -> CabalDirLayout + -> ProjectConfig + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO ( ElaboratedInstallPlan -- with store packages + , ElaboratedInstallPlan -- with source packages + , ElaboratedSharedConfig + , IndexUtils.TotalIndexState + , IndexUtils.ActiveRepos + ) + -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ +rebuildInstallPlan verbosity + distDirLayout@DistDirLayout { + distProjectRootDirectory, + distProjectCacheFile + } + CabalDirLayout { + cabalStoreDirLayout + } = \projectConfig localPackages -> + runRebuild distProjectRootDirectory $ do + progsearchpath <- liftIO $ getSystemSearchPath + let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } + + -- The overall improved plan is cached + rerunIfChanged verbosity fileMonitorImprovedPlan + -- react to changes in the project config, + -- the package .cabal files and the path + (projectConfigMonitored, localPackages, progsearchpath) $ do + + -- And so is the elaborated plan that the improved plan based on + (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <- + rerunIfChanged verbosity fileMonitorElaboratedPlan + (projectConfigMonitored, localPackages, + progsearchpath) $ do + + compilerEtc <- phaseConfigureCompiler projectConfig + _ <- phaseConfigurePrograms projectConfig compilerEtc + (solverPlan, pkgConfigDB, totalIndexState, activeRepos) + <- phaseRunSolver projectConfig + compilerEtc + localPackages + (elaboratedPlan, + elaboratedShared) <- phaseElaboratePlan projectConfig + compilerEtc pkgConfigDB + solverPlan + localPackages + + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared + return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + + -- The improved plan changes each time we install something, whereas + -- the underlying elaborated plan only changes when input config + -- changes, so it's worth caching them separately. + improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared + + return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + + where + fileMonitorCompiler = newFileMonitorInCacheDir "compiler" + fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" + fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" + fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" + fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" + + newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b + newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile + + + -- Configure the compiler we're using. + -- + -- This is moderately expensive and doesn't change that often so we cache + -- it independently. + -- + phaseConfigureCompiler :: ProjectConfig + -> Rebuild (Compiler, Platform, ProgramDb) + phaseConfigureCompiler ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigHcFlavor, + projectConfigHcPath, + projectConfigHcPkg + }, + projectConfigLocalPackages = PackageConfig { + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra + } + } = do + progsearchpath <- liftIO $ getSystemSearchPath + rerunIfChanged verbosity fileMonitorCompiler + (hcFlavor, hcPath, hcPkg, progsearchpath, + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra) $ do + + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + result@(_, _, progdb') <- liftIO $ + Cabal.configCompilerEx + hcFlavor hcPath hcPkg + progdb verbosity + + -- Note that we added the user-supplied program locations and args + -- for /all/ programs, not just those for the compiler prog and + -- compiler-related utils. In principle we don't know which programs + -- the compiler will configure (and it does vary between compilers). + -- We do know however that the compiler will only configure the + -- programs it cares about, and those are the ones we monitor here. + monitorFiles (programsMonitorFiles progdb') + + return result + where + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + progdb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) + . modifyProgramSearchPath + (++ [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra ]) + $ defaultProgramDb + + + -- Configuring other programs. + -- + -- Having configred the compiler, now we configure all the remaining + -- programs. This is to check we can find them, and to monitor them for + -- changes. + -- + -- TODO: [required eventually] we don't actually do this yet. + -- + -- We rely on the fact that the previous phase added the program config for + -- all local packages, but that all the programs configured so far are the + -- compiler program or related util programs. + -- + phaseConfigurePrograms :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> Rebuild () + phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do + -- Users are allowed to specify program locations independently for + -- each package (e.g. to use a particular version of a pre-processor + -- for some packages). However they cannot do this for the compiler + -- itself as that's just not going to work. So we check for this. + liftIO $ checkBadPerPackageCompilerPaths + (configuredPrograms compilerprogdb) + (getMapMappend (projectConfigSpecificPackage projectConfig)) + + --TODO: [required eventually] find/configure other programs that the + -- user specifies. + + --TODO: [required eventually] find/configure all build-tools + -- but note that some of them may be built as part of the plan. + + + -- Run the solver to get the initial install plan. + -- This is expensive so we cache it independently. + -- + phaseRunSolver + :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> [PackageSpecifier UnresolvedSourcePackage] + -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) + phaseRunSolver projectConfig@ProjectConfig { + projectConfigShared, + projectConfigBuildOnly + } + (compiler, platform, progdb) + localPackages = + rerunIfChanged verbosity fileMonitorSolverPlan + (solverSettings, + localPackages, localPackagesEnabledStanzas, + compiler, platform, programDbSignature progdb) $ do + + installedPkgIndex <- getInstalledPackages verbosity + compiler progdb platform + corePackageDbs + (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx + (solverSettingIndexState solverSettings) + (solverSettingActiveRepos solverSettings) + pkgConfigDB <- getPkgConfigDb verbosity progdb + + --TODO: [code cleanup] it'd be better if the Compiler contained the + -- ConfiguredPrograms that it needs, rather than relying on the progdb + -- since we don't need to depend on all the programs here, just the + -- ones relevant for the compiler. + + liftIO $ do + solver <- chooseSolver verbosity + (solverSettingSolver solverSettings) + (compilerInfo compiler) + + notice verbosity "Resolving dependencies..." + plan <- foldProgress logMsg (die' verbosity) return $ + planPackages verbosity compiler platform solver solverSettings + installedPkgIndex sourcePkgDb pkgConfigDB + localPackages localPackagesEnabledStanzas + return (plan, pkgConfigDB, tis, ar) + where + corePackageDbs = [GlobalPackageDB] + withRepoCtx = projectConfigWithSolverRepoContext verbosity + projectConfigShared + projectConfigBuildOnly + solverSettings = resolveSolverSettings projectConfig + logMsg message rest = debugNoWrap verbosity message >> rest + + localPackagesEnabledStanzas = + Map.fromList + [ (pkgname, stanzas) + | pkg <- localPackages + -- TODO: misnormer: we should separate + -- builtin/global/inplace/local packages + -- and packages explicitly mentioned in the project + -- + , let pkgname = pkgSpecifierTarget pkg + testsEnabled = lookupLocalPackageConfig + packageConfigTests + projectConfig pkgname + benchmarksEnabled = lookupLocalPackageConfig + packageConfigBenchmarks + projectConfig pkgname + isLocal = isJust (shouldBeLocal pkg) + stanzas + | isLocal = Map.fromList $ + [ (TestStanzas, enabled) + | enabled <- flagToList testsEnabled ] ++ + [ (BenchStanzas , enabled) + | enabled <- flagToList benchmarksEnabled ] + | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ] + ] + + -- Elaborate the solver's install plan to get a fully detailed plan. This + -- version of the plan has the final nix-style hashed ids. + -- + phaseElaboratePlan :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> PkgConfigDb + -> SolverInstallPlan + -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> Rebuild ( ElaboratedInstallPlan + , ElaboratedSharedConfig ) + phaseElaboratePlan ProjectConfig { + projectConfigShared, + projectConfigAllPackages, + projectConfigLocalPackages, + projectConfigSpecificPackage, + projectConfigBuildOnly + } + (compiler, platform, progdb) pkgConfigDB + solverPlan localPackages = do + + liftIO $ debug verbosity "Elaborating the install plan..." + + sourcePackageHashes <- + rerunIfChanged verbosity fileMonitorSourceHashes + (packageLocationsSignature solverPlan) $ + getPackageSourceHashes verbosity withRepoCtx solverPlan + + defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + (elaboratedPlan, elaboratedShared) + <- liftIO . runLogProgress verbosity $ + elaborateInstallPlan + verbosity + platform compiler progdb pkgConfigDB + distDirLayout + cabalStoreDirLayout + solverPlan + localPackages + sourcePackageHashes + defaultInstallDirs + projectConfigShared + projectConfigAllPackages + projectConfigLocalPackages + (getMapMappend projectConfigSpecificPackage) + let instantiatedPlan + = instantiateInstallPlan + cabalStoreDirLayout + defaultInstallDirs + elaboratedShared + elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + return (instantiatedPlan, elaboratedShared) + where + withRepoCtx = projectConfigWithSolverRepoContext verbosity + projectConfigShared + projectConfigBuildOnly + + -- Update the files we maintain that reflect our current build environment. + -- In particular we maintain a JSON representation of the elaborated + -- install plan (but not the improved plan since that reflects the state + -- of the build rather than just the input environment). + -- + phaseMaintainPlanOutputs :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild () + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do + debug verbosity "Updating plan.json" + writePlanExternalRepresentation + distDirLayout + elaboratedPlan + elaboratedShared + + + -- Improve the elaborated install plan. The elaborated plan consists + -- mostly of source packages (with full nix-style hashed ids). Where + -- corresponding installed packages already exist in the store, replace + -- them in the plan. + -- + -- Note that we do monitor the store's package db here, so we will redo + -- this improvement phase when the db changes -- including as a result of + -- executing a plan and installing things. + -- + phaseImprovePlan :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild ElaboratedInstallPlan + phaseImprovePlan elaboratedPlan elaboratedShared = do + + liftIO $ debug verbosity "Improving the install plan..." + storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid + let improvedPlan = improveInstallPlanWithInstalledPackages + storePkgIdSet + elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) + -- TODO: [nice to have] having checked which packages from the store + -- we're using, it may be sensible to sanity check those packages + -- by loading up the compiler package db and checking everything + -- matches up as expected, e.g. no dangling deps, files deleted. + return improvedPlan + where + compid = compilerId (pkgConfigCompiler elaboratedShared) + + +programsMonitorFiles :: ProgramDb -> [MonitorFilePath] +programsMonitorFiles progdb = + [ monitor + | prog <- configuredPrograms progdb + , monitor <- monitorFileSearchPath (programMonitorFiles prog) + (programPath prog) + ] + +-- | Select the bits of a 'ProgramDb' to monitor for value changes. +-- Use 'programsMonitorFiles' for the files to monitor. +-- +programDbSignature :: ProgramDb -> [ConfiguredProgram] +programDbSignature progdb = + [ prog { programMonitorFiles = [] + , programOverrideEnv = filter ((/="PATH") . fst) + (programOverrideEnv prog) } + | prog <- configuredPrograms progdb ] + +getInstalledPackages :: Verbosity + -> Compiler -> ProgramDb -> Platform + -> PackageDBStack + -> Rebuild InstalledPackageIndex +getInstalledPackages verbosity compiler progdb platform packagedbs = do + monitorFiles . map monitorFileOrDirectory + =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles + verbosity compiler + packagedbs progdb platform) + liftIO $ IndexUtils.getInstalledPackages + verbosity compiler + packagedbs progdb + +{- +--TODO: [nice to have] use this but for sanity / consistency checking +getPackageDBContents :: Verbosity + -> Compiler -> ProgramDb -> Platform + -> PackageDB + -> Rebuild InstalledPackageIndex +getPackageDBContents verbosity compiler progdb platform packagedb = do + monitorFiles . map monitorFileOrDirectory + =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles + verbosity compiler + [packagedb] progdb platform) + liftIO $ do + createPackageDBIfMissing verbosity compiler progdb packagedb + Cabal.getPackageDBContents verbosity compiler + packagedb progdb +-} + +getSourcePackages + :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> Maybe IndexUtils.TotalIndexState + -> Maybe IndexUtils.ActiveRepos + -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) +getSourcePackages verbosity withRepoCtx idxState activeRepos = do + (sourcePkgDbWithTIS, repos) <- + liftIO $ + withRepoCtx $ \repoctx -> do + sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos + return (sourcePkgDbWithTIS, repoContextRepos repoctx) + + traverse_ needIfExists + . IndexUtils.getSourcePackagesMonitorFiles + $ repos + return sourcePkgDbWithTIS + + +getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb +getPkgConfigDb verbosity progdb = do + dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb + -- Just monitor the dirs so we'll notice new .pc files. + -- Alternatively we could monitor all the .pc files too. + traverse_ monitorDirectoryStatus dirs + liftIO $ readPkgConfigDb verbosity progdb + + +-- | Select the config values to monitor for changes package source hashes. +packageLocationsSignature :: SolverInstallPlan + -> [(PackageId, PackageLocation (Maybe FilePath))] +packageLocationsSignature solverPlan = + [ (packageId pkg, srcpkgSource pkg) + | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) + <- SolverInstallPlan.toList solverPlan + ] + + +-- | Get the 'HashValue' for all the source packages where we use hashes, +-- and download any packages required to do so. +-- +-- Note that we don't get hashes for local unpacked packages. +-- +getPackageSourceHashes :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> SolverInstallPlan + -> Rebuild (Map PackageId PackageSourceHash) +getPackageSourceHashes verbosity withRepoCtx solverPlan = do + + -- Determine if and where to get the package's source hash from. + -- + let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] + allPkgLocations = + [ (packageId pkg, srcpkgSource pkg) + | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) + <- SolverInstallPlan.toList solverPlan ] + + -- Tarballs that were local in the first place. + -- We'll hash these tarball files directly. + localTarballPkgs :: [(PackageId, FilePath)] + localTarballPkgs = + [ (pkgid, tarball) + | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] + + -- Tarballs from remote URLs. We must have downloaded these already + -- (since we extracted the .cabal file earlier) + remoteTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] + + -- tarballs from source-repository-package stanzas + sourceRepoTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] + + -- Tarballs from repositories, either where the repository provides + -- hashes as part of the repo metadata, or where we will have to + -- download and hash the tarball. + repoTarballPkgsWithMetadata :: [(PackageId, Repo)] + repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] + (repoTarballPkgsWithMetadata, + repoTarballPkgsWithoutMetadata) = + partitionEithers + [ case repo of + RepoSecure{} -> Left (pkgid, repo) + _ -> Right (pkgid, repo) + | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] + + -- For tarballs from repos that do not have hashes available we now have + -- to check if the packages were downloaded already. + -- + (repoTarballPkgsToDownload, + repoTarballPkgsDownloaded) + <- fmap partitionEithers $ + liftIO $ sequence + [ do mtarball <- checkRepoTarballFetched repo pkgid + case mtarball of + Nothing -> return (Left (pkgid, repo)) + Just tarball -> return (Right (pkgid, tarball)) + | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] + + (hashesFromRepoMetadata, + repoTarballPkgsNewlyDownloaded) <- + -- Avoid having to initialise the repository (ie 'withRepoCtx') if we + -- don't have to. (The main cost is configuring the http client.) + if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata + then return (Map.empty, []) + else liftIO $ withRepoCtx $ \repoctx -> do + + -- For tarballs from repos that do have hashes available as part of the + -- repo metadata we now load up the index for each repo and retrieve + -- the hashes for the packages + -- + hashesFromRepoMetadata <- + Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions + fmap (Map.fromList . concat) $ + sequence + -- Reading the repo index is expensive so we group the packages by repo + [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> + Sec.withIndex secureRepo $ \repoIndex -> + sequence + [ do hash <- Sec.trusted <$> -- strip off Trusted tag + Sec.indexLookupHash repoIndex pkgid + -- Note that hackage-security currently uses SHA256 + -- but this API could in principle give us some other + -- choice in future. + return (pkgid, hashFromTUF hash) + | pkgid <- pkgids ] + | (repo, pkgids) <- + map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp))) + . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) + . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) + $ repoTarballPkgsWithMetadata + ] + + -- For tarballs from repos that do not have hashes available, download + -- the ones we previously determined we need. + -- + repoTarballPkgsNewlyDownloaded <- + sequence + [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid + return (pkgid, tarball) + | (pkgid, repo) <- repoTarballPkgsToDownload ] + + return (hashesFromRepoMetadata, + repoTarballPkgsNewlyDownloaded) + + -- Hash tarball files for packages where we have to do that. This includes + -- tarballs that were local in the first place, plus tarballs from repos, + -- either previously cached or freshly downloaded. + -- + let allTarballFilePkgs :: [(PackageId, FilePath)] + allTarballFilePkgs = localTarballPkgs + ++ remoteTarballPkgs + ++ sourceRepoTarballPkgs + ++ repoTarballPkgsDownloaded + ++ repoTarballPkgsNewlyDownloaded + hashesFromTarballFiles <- liftIO $ + fmap Map.fromList $ + sequence + [ do srchash <- readFileHashValue tarball + return (pkgid, srchash) + | (pkgid, tarball) <- allTarballFilePkgs + ] + monitorFiles [ monitorFile tarball + | (_pkgid, tarball) <- allTarballFilePkgs ] + + -- Return the combination + return $! hashesFromRepoMetadata + <> hashesFromTarballFiles + + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +planPackages :: Verbosity + -> Compiler + -> Platform + -> Solver -> SolverSettings + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> Map PackageName (Map OptionalStanza Bool) + -> Progress String String SolverInstallPlan +planPackages verbosity comp platform solver SolverSettings{..} + installedPkgIndex sourcePkgDb pkgConfigDB + localPackages pkgStanzasEnable = + + resolveDependencies + platform (compilerInfo comp) + pkgConfigDB solver + resolverParams + + where + + --TODO: [nice to have] disable multiple instances restriction in + -- the solver, but then make sure we can cope with that in the + -- output. + resolverParams = + + setMaxBackjumps solverSettingMaxBackjumps + + . setIndependentGoals solverSettingIndependentGoals + + . setReorderGoals solverSettingReorderGoals + + . setCountConflicts solverSettingCountConflicts + + . setFineGrainedConflicts solverSettingFineGrainedConflicts + + . setMinimizeConflictSet solverSettingMinimizeConflictSet + + --TODO: [required eventually] should only be configurable for + --custom installs + -- . setAvoidReinstalls solverSettingAvoidReinstalls + + --TODO: [required eventually] should only be configurable for + --custom installs + -- . setShadowPkgs solverSettingShadowPkgs + + . setStrongFlags solverSettingStrongFlags + + . setAllowBootLibInstalls solverSettingAllowBootLibInstalls + + . setOnlyConstrained solverSettingOnlyConstrained + + . setSolverVerbosity verbosity + + --TODO: [required eventually] decide if we need to prefer + -- installed for global packages, or prefer latest even for + -- global packages. Perhaps should be configurable but with a + -- different name than "upgrade-dependencies". + . setPreferenceDefault PreferLatestForSelected + {-(if solverSettingUpgradeDeps + then PreferAllLatest + else PreferLatestForSelected)-} + + . removeLowerBounds solverSettingAllowOlder + . removeUpperBounds solverSettingAllowNewer + + . addDefaultSetupDependencies (defaultSetupDeps comp platform + . PD.packageDescription + . srcpkgDescription) + + . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint + . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- solverSettingPreferences ] + + . addConstraints + -- version constraints from the config file or command line + [ LabeledPackageConstraint (userToPackageConstraint pc) src + | (pc, src) <- solverSettingConstraints ] + + . addPreferences + -- enable stanza preference where the user did not specify + [ PackageStanzasPreference pkgname stanzas + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = [ stanza | stanza <- [minBound..maxBound] + , Map.lookup stanza stanzaM == Nothing ] + , not (null stanzas) + ] + + . addConstraints + -- enable stanza constraints where the user asked to enable + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyStanzas stanzas)) + ConstraintSourceConfigFlagOrTarget + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = [ stanza | stanza <- [minBound..maxBound] + , Map.lookup stanza stanzaM == Just True ] + , not (null stanzas) + ] + + . addConstraints + --TODO: [nice to have] should have checked at some point that the + -- package in question actually has these flags. + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyFlags flags)) + ConstraintSourceConfigFlagOrTarget + | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] + + . addConstraints + --TODO: [nice to have] we have user-supplied flags for unspecified + -- local packages (as well as specific per-package flags). For the + -- former we just apply all these flags to all local targets which + -- is silly. We should check if the flags are appropriate. + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyFlags flags)) + ConstraintSourceConfigFlagOrTarget + | let flags = solverSettingFlagAssignment + , not (PD.nullFlagAssignment flags) + , pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg ] + + $ stdResolverParams + + stdResolverParams = + -- Note: we don't use the standardInstallPolicy here, since that uses + -- its own addDefaultSetupDependencies that is not appropriate for us. + basicInstallPolicy + installedPkgIndex sourcePkgDb + localPackages + + -- While we can talk to older Cabal versions (we need to be able to + -- do so for custom Setup scripts that require older Cabal lib + -- versions), we have problems talking to some older versions that + -- don't support certain features. + -- + -- For example, Cabal-1.16 and older do not know about build targets. + -- Even worse, 1.18 and older only supported the --constraint flag + -- with source package ids, not --dependency with installed package + -- ids. That is bad because we cannot reliably select the right + -- dependencies in the presence of multiple instances (i.e. the + -- store). See issue #3932. So we require Cabal 1.20 as a minimum. + -- + -- Moreover, lib:Cabal generally only supports the interface of + -- current and past compilers; in fact recent lib:Cabal versions + -- will warn when they encounter a too new or unknown GHC compiler + -- version (c.f. #415). To avoid running into unsupported + -- configurations we encode the compatibility matrix as lower + -- bounds on lib:Cabal here (effectively corresponding to the + -- respective major Cabal version bundled with the respective GHC + -- release). + -- + -- GHC 9.0 needs Cabal >= 3.4 + -- GHC 8.10 needs Cabal >= 3.2 + -- GHC 8.8 needs Cabal >= 3.0 + -- GHC 8.6 needs Cabal >= 2.4 + -- GHC 8.4 needs Cabal >= 2.2 + -- GHC 8.2 needs Cabal >= 2.0 + -- GHC 8.0 needs Cabal >= 1.24 + -- GHC 7.10 needs Cabal >= 1.22 + -- + -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is + -- the absolute lower bound) + -- + -- TODO: long-term, this compatibility matrix should be + -- stored as a field inside 'Distribution.Compiler.Compiler' + setupMinCabalVersionConstraint + | isGHC, compVer >= mkVersion [9,0] = mkVersion [3,4] + | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2] + | isGHC, compVer >= mkVersion [8,8] = mkVersion [3,0] + | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,4] + | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2] + | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] + | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24] + | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22] + | otherwise = mkVersion [1,20] + where + isGHC = compFlav `elem` [GHC,GHCJS] + compFlav = compilerFlavor comp + compVer = compilerVersion comp + + -- As we can't predict the future, we also place a global upper + -- bound on the lib:Cabal version we know how to interact with: + -- + -- The upper bound is computed by incrementing the current major + -- version twice in order to allow for the current version, as + -- well as the next adjacent major version (one of which will not + -- be released, as only "even major" versions of Cabal are + -- released to Hackage or bundled with proper GHC releases). + -- + -- For instance, if the current version of cabal-install is an odd + -- development version, e.g. Cabal-2.1.0.0, then we impose an + -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a + -- stable/release even version, e.g. Cabal-2.2.1.0, the upper + -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility + -- when dealing with development snapshots of Cabal and cabal-install. + -- + setupMaxCabalVersionConstraint = + alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion + +------------------------------------------------------------------------------ +-- * Install plan post-processing +------------------------------------------------------------------------------ + +-- This phase goes from the InstallPlan we get from the solver and has to +-- make an elaborated install plan. +-- +-- We go in two steps: +-- +-- 1. elaborate all the source packages that the solver has chosen. +-- 2. swap source packages for pre-existing installed packages wherever +-- possible. +-- +-- We do it in this order, elaborating and then replacing, because the easiest +-- way to calculate the installed package ids used for the replacement step is +-- from the elaborated configuration for each package. + + + + +------------------------------------------------------------------------------ +-- * Install plan elaboration +------------------------------------------------------------------------------ + +-- Note [SolverId to ConfiguredId] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Dependency solving is a per package affair, so after we're done, we +-- end up with 'SolverInstallPlan' that records in 'solverPkgLibDeps' +-- and 'solverPkgExeDeps' what packages provide the libraries and executables +-- needed by each component of the package (phew!) For example, if I have +-- +-- library +-- build-depends: lib +-- build-tool-depends: pkg:exe1 +-- build-tools: alex +-- +-- After dependency solving, I find out that this library component has +-- library dependencies on lib-0.2, and executable dependencies on pkg-0.1 +-- and alex-0.3 (other components of the package may have different +-- dependencies). Note that I've "lost" the knowledge that I depend +-- *specifically* on the exe1 executable from pkg. +-- +-- So, we have a this graph of packages, and we need to transform it into +-- a graph of components which we are actually going to build. In particular: +-- +-- NODE changes from PACKAGE (SolverPackage) to COMPONENTS (ElaboratedConfiguredPackage) +-- EDGE changes from PACKAGE DEP (SolverId) to COMPONENT DEPS (ConfiguredId) +-- +-- In both cases, what was previously a single node/edge may turn into multiple +-- nodes/edges. Multiple components, because there may be multiple components +-- in a package; multiple component deps, because we may depend upon multiple +-- executables from the same package (and maybe, some day, multiple libraries +-- from the same package.) +-- +-- Let's talk about how to do this transformation. Naively, we might consider +-- just processing each package, converting it into (zero or) one or more +-- components. But we also have to update the edges; this leads to +-- two complications: +-- +-- 1. We don't know what the ConfiguredId of a component is until +-- we've configured it, but we cannot configure a component unless +-- we know the ConfiguredId of all its dependencies. Thus, we must +-- process the 'SolverInstallPlan' in topological order. +-- +-- 2. When we process a package, we know the SolverIds of its +-- dependencies, but we have to do some work to turn these into +-- ConfiguredIds. For example, in the case of build-tool-depends, the +-- SolverId isn't enough to uniquely determine the ConfiguredId we should +-- elaborate to: we have to look at the executable name attached to +-- the package name in the package description to figure it out. +-- At the same time, we NEED to use the SolverId, because there might +-- be multiple versions of the same package in the build plan +-- (due to setup dependencies); we can't just look up the package name +-- from the package description. +-- +-- We can adopt the following strategy: +-- +-- * When a package is transformed into components, record +-- a mapping from SolverId to ALL of the components +-- which were elaborated. +-- +-- * When we look up an edge, we use our knowledge of the +-- component name to *filter* the list of components into +-- the ones we actually wanted to refer to. +-- +-- By the way, we can tell that SolverInstallPlan is not the "right" type +-- because a SolverId cannot adequately represent all possible dependency +-- solver states: we may need to record foo-0.1 multiple times in +-- the solver install plan with different dependencies. This imprecision in the +-- type currently doesn't cause any problems because the dependency solver +-- continues to enforce the single instance restriction regardless of compiler +-- version. The right way to solve this is to come up with something very much +-- like a 'ConfiguredId', in that it incorporates the version choices of its +-- dependencies, but less fine grained. + + +-- | Produce an elaborated install plan using the policy for local builds with +-- a nix-style shared store. +-- +-- In theory should be able to make an elaborated install plan with a policy +-- matching that of the classic @cabal install --user@ or @--global@ +-- +elaborateInstallPlan + :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb + -> DistDirLayout + -> StoreDirLayout + -> SolverInstallPlan + -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> Map PackageId PackageSourceHash + -> InstallDirs.InstallDirTemplates + -> ProjectConfigShared + -> PackageConfig + -> PackageConfig + -> Map PackageName PackageConfig + -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) +elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB + distDirLayout@DistDirLayout{..} + storeDirLayout@StoreDirLayout{storePackageDBStack} + solverPlan localPackages + sourcePackageHashes + defaultInstallDirs + sharedPackageConfig + allPackagesConfig + localPackagesConfig + perPackageConfig = do + x <- elaboratedInstallPlan + return (x, elaboratedSharedConfig) + where + elaboratedSharedConfig = + ElaboratedSharedConfig { + pkgConfigPlatform = platform, + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = compilerprogdb, + pkgConfigReplOptions = [] + } + + preexistingInstantiatedPkgs = + Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) + where + f (SolverInstallPlan.PreExisting inst) + | let ipkg = instSolverPkgIPI inst + , not (IPI.indefinite ipkg) + = Just (IPI.installedUnitId ipkg, + (FullUnitId (IPI.installedComponentId ipkg) + (Map.fromList (IPI.instantiatedWith ipkg)))) + f _ = Nothing + + elaboratedInstallPlan = + flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> + case planpkg of + SolverInstallPlan.PreExisting pkg -> + return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + + SolverInstallPlan.Configured pkg -> + let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" + | otherwise = Disp.empty + in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+> + quotes (pretty (packageId pkg))) $ + map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg + + -- NB: We don't INSTANTIATE packages at this point. That's + -- a post-pass. This makes it simpler to compute dependencies. + elaborateSolverToComponents + :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> LogProgress [ElaboratedConfiguredPackage] + elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) + = case mkComponentsGraph (elabEnabledSpec elab0) pd of + Right g -> do + let src_comps = componentsGraphToList g + infoProgress $ hang (text "Component graph for" <+> pretty pkgid <<>> colon) + 4 (dispComponentsWithDeps src_comps) + (_, comps) <- mapAccumM buildComponent + (Map.empty, Map.empty, Map.empty) + (map fst src_comps) + let not_per_component_reasons = why_not_per_component src_comps + if null not_per_component_reasons + then return comps + else do checkPerPackageOk comps not_per_component_reasons + return [elaborateSolverToPackage spkg g $ + comps ++ maybeToList setupComponent] + Left cns -> + dieProgress $ + hang (text "Dependency cycle between the following components:") 4 + (vcat (map (text . componentNameStanza) cns)) + where + -- You are eligible to per-component build if this list is empty + why_not_per_component g + = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage + where + cuz reason = [text reason] + -- We have to disable per-component for now with + -- Configure-type scripts in order to prevent parallel + -- invocation of the same `./configure` script. + -- See https://github.com/haskell/cabal/issues/4548 + -- + -- Moreoever, at this point in time, only non-Custom setup scripts + -- are supported. Implementing per-component builds with + -- Custom would require us to create a new 'ElabSetup' + -- type, and teach all of the code paths how to handle it. + -- Once you've implemented this, swap it for the code below. + cuz_buildtype = + case PD.buildType (elabPkgDescription elab0) of + PD.Configure -> cuz "build-type is Configure" + PD.Custom -> cuz "build-type is Custom" + _ -> [] + -- cabal-format versions prior to 1.8 have different build-depends semantics + -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 + -- see, https://github.com/haskell/cabal/issues/4121 + cuz_spec + | PD.specVersion pd >= CabalSpecV1_8 = [] + | otherwise = cuz "cabal-version is less than 1.8" + -- In the odd corner case that a package has no components at all + -- then keep it as a whole package, since otherwise it turns into + -- 0 component graph nodes and effectively vanishes. We want to + -- keep it around at least for error reporting purposes. + cuz_length + | length g > 0 = [] + | otherwise = cuz "there are no buildable components" + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) + = [] + | otherwise = cuz "you passed --disable-per-component" + -- Enabling program coverage introduces odd runtime dependencies + -- between components. + cuz_coverage + | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) + = cuz "program coverage is enabled" + | otherwise = [] + + -- | Sometimes a package may make use of features which are only + -- supported in per-package mode. If this is the case, we should + -- give an error when this occurs. + checkPerPackageOk comps reasons = do + let is_sublib (CLibName (LSubLibName _)) = True + is_sublib _ = False + when (any (matchElabPkg is_sublib) comps) $ + dieProgress $ + text "Internal libraries only supported with per-component builds." $$ + text "Per-component builds were disabled because" <+> + fsep (punctuate comma reasons) + -- TODO: Maybe exclude Backpack too + + elab0 = elaborateSolverToCommon spkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + -- TODO: This is just a skeleton to get elaborateSolverToPackage + -- working correctly + -- TODO: When we actually support building these components, we + -- have to add dependencies on this from all other components + setupComponent :: Maybe ElaboratedConfiguredPackage + setupComponent + | PD.buildType (elabPkgDescription elab0) == PD.Custom + = Just elab0 { + elabModuleShape = emptyModuleShape, + elabUnitId = notImpl "elabUnitId", + elabComponentId = notImpl "elabComponentId", + elabLinkedInstantiatedWith = Map.empty, + elabInstallDirs = notImpl "elabInstallDirs", + elabPkgOrComp = ElabComponent (ElaboratedComponent {..}) + } + | otherwise + = Nothing + where + compSolverName = CD.ComponentSetup + compComponentName = Nothing + dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 + compLibDependencies + = map configuredId dep_pkgs + compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + compOrderLibDependencies = notImpl "compOrderLibDependencies" + -- Not supported: + compExeDependencies = [] + compExeDependencyPaths = [] + compPkgConfigDependencies = [] + + notImpl f = + error $ "Distribution.Client.ProjectPlanning.setupComponent: " ++ + f ++ " not implemented yet" + + + buildComponent + :: (ConfiguredComponentMap, + LinkedComponentMap, + Map ComponentId FilePath) + -> Cabal.Component + -> LogProgress + ((ConfiguredComponentMap, + LinkedComponentMap, + Map ComponentId FilePath), + ElaboratedConfiguredPackage) + buildComponent (cc_map, lc_map, exe_map) comp = + addProgressCtx (text "In the stanza" <+> + quotes (text (componentNameStanza cname))) $ do + + -- 1. Configure the component, but with a place holder ComponentId. + cc0 <- toConfiguredComponent + pd + (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") + (Map.unionWith Map.union external_lib_cc_map cc_map) + (Map.unionWith Map.union external_exe_cc_map cc_map) + comp + + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub (map (annotatedIdToConfiguredId . ci_ann_id) + (cc_includes cc0)) + compExeDependencies = + map annotatedIdToConfiguredId + (cc_exe_deps cc0) + compExeDependencyPaths = + [ (annotatedIdToConfiguredId aid', path) + | aid' <- cc_exe_deps cc0 + , Just paths <- [Map.lookup (ann_id aid') exe_map1] + , path <- paths ] + elab_comp = ElaboratedComponent {..} + + -- 3. Construct a preliminary ElaboratedConfiguredPackage, + -- and use this to compute the component ID. Fix up cc_id + -- correctly. + let elab1 = elab0 { + elabPkgOrComp = ElabComponent $ elab_comp + } + cid = case elabBuildStyle elab0 of + BuildInplaceOnly -> + mkComponentId $ + prettyShow pkgid ++ "-inplace" ++ + (case Cabal.componentNameString cname of + Nothing -> "" + Just s -> "-" ++ prettyShow s) + BuildAndInstall -> + hashedInstalledPackageId + (packageHashInputs + elaboratedSharedConfig + elab1) -- knot tied + cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) } + infoProgress $ dispConfiguredComponent cc + + -- 4. Perform mix-in linking + let lookup_uid def_uid = + case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of + Just full -> full + Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) + lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) + (Map.union external_lc_map lc_map) cc + infoProgress $ dispLinkedComponent lc + -- NB: elab is setup to be the correct form for an + -- indefinite library, or a definite library with no holes. + -- We will modify it in 'instantiateInstallPlan' to handle + -- instantiated packages. + + -- 5. Construct the final ElaboratedConfiguredPackage + let + elab2 = elab1 { + elabModuleShape = lc_shape lc, + elabUnitId = abstractUnitId (lc_uid lc), + elabComponentId = lc_cid lc, + elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), + elabPkgOrComp = ElabComponent $ elab_comp { + compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)), + compOrderLibDependencies = + ordNub (map (abstractUnitId . ci_id) + (lc_includes lc ++ lc_sig_includes lc)) + } + } + elab = elab2 { + elabInstallDirs = computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab2 + } + + -- 6. Construct the updated local maps + let cc_map' = extendConfiguredComponentMap cc cc_map + lc_map' = extendLinkedComponentMap lc lc_map + exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + + return ((cc_map', lc_map', exe_map'), elab) + where + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" + + cname = Cabal.componentName comp + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname + + -- NB: compLinkedLibDependencies and + -- compOrderLibDependencies are defined when we define + -- 'elab'. + external_lib_dep_sids = CD.select (== compSolverName) deps0 + external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 + + external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids + + -- Combine library and build-tool dependencies, for backwards + -- compatibility (See issue #5412 and the documentation for + -- InstallPlan.fromSolverInstallPlan), but prefer the versions + -- specified as build-tools. + external_exe_dep_pkgs = + concatMap mapDep $ + ordNubBy (pkgName . packageId) $ + external_exe_dep_sids ++ external_lib_dep_sids + + external_exe_map = Map.fromList $ + [ (getComponentId pkg, paths) + | pkg <- external_exe_dep_pkgs + , let paths = planPackageExePaths pkg ] + exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map + + external_lib_cc_map = Map.fromListWith Map.union + $ map mkCCMapping external_lib_dep_pkgs + external_exe_cc_map = Map.fromListWith Map.union + $ map mkCCMapping external_exe_dep_pkgs + external_lc_map = + Map.fromList $ map mkShapeMapping $ + external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids + + compPkgConfigDependencies = + [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " + ++ prettyShow pn ++ " from " + ++ prettyShow (elabPkgSourceId elab0)) + (pkgConfigDbPkgVersion pkgConfigDB pn)) + | PkgconfigDependency pn _ <- PD.pkgconfigDepends + (Cabal.componentBuildInfo comp) ] + + inplace_bin_dir elab = + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab $ + case Cabal.componentNameString cname of + Just n -> prettyShow n + Nothing -> "" + + + -- | Given a 'SolverId' referencing a dependency on a library, return + -- the 'ElaboratedPlanPackage' corresponding to the library. This + -- returns at most one result. + elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [ElaboratedPlanPackage] + elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep + + -- | Given an 'ElaboratedPlanPackage', return the paths to where the + -- executables that this package represents would be installed. + -- The only case where multiple paths can be returned is the inplace + -- monolithic package one, since there can be multiple exes and each one + -- has its own directory. + planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] + planPackageExePaths = + -- Pre-existing executables are assumed to be in PATH + -- already. In fact, this should be impossible. + InstallPlan.foldPlanPackage (const []) $ \elab -> + let + executables :: [FilePath] + executables = + case elabPkgOrComp elab of + -- Monolithic mode: all exes of the package + ElabPackage _ -> unUnqualComponentName . PD.exeName + <$> PD.executables (elabPkgDescription elab) + -- Per-component mode: just the selected exe + ElabComponent comp -> + case fmap Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> [prettyShow n] + _ -> [""] + in + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab + <$> executables + + elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc + -> ComponentsGraph + -> [ElaboratedConfiguredPackage] + -> ElaboratedConfiguredPackage + elaborateSolverToPackage + pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride) + _flags _stanzas _deps0 _exe_deps0) + compGraph comps = + -- Knot tying: the final elab includes the + -- pkgInstalledId, which is calculated by hashing many + -- of the other fields of the elaboratedPackage. + elab + where + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg + elab1 = elab0 { + elabUnitId = newSimpleUnitId pkgInstalledId, + elabComponentId = pkgInstalledId, + elabLinkedInstantiatedWith = Map.empty, + elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, + elabModuleShape = modShape + } + elab = elab1 { + elabInstallDirs = + computeInstallDirs storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab1 + } + + modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of + Nothing -> emptyModuleShape + Just e -> Ty.elabModuleShape e + + pkgInstalledId + | shouldBuildInplaceOnly pkg + = mkComponentId (prettyShow pkgid ++ "-inplace") + + | otherwise + = assert (isJust elabPkgSourceHash) $ + hashedInstalledPackageId + (packageHashInputs + elaboratedSharedConfig + elab) -- recursive use of elab + + | otherwise + = error $ "elaborateInstallPlan: non-inplace package " + ++ " is missing a source hash: " ++ prettyShow pkgid + + -- Need to filter out internal dependencies, because they don't + -- correspond to anything real anymore. + isExt confid = confSrcId confid /= pkgid + filterExt = filter isExt + filterExt' = filter (isExt . fst) + + pkgLibDependencies + = buildComponentDeps (filterExt . compLibDependencies) + pkgExeDependencies + = buildComponentDeps (filterExt . compExeDependencies) + pkgExeDependencyPaths + = buildComponentDeps (filterExt' . compExeDependencyPaths) + -- TODO: Why is this flat? + pkgPkgConfigDependencies + = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + + pkgDependsOnSelfLib + = CD.fromList [ (CD.componentNameToComponent cn, [()]) + | Graph.N _ cn _ <- fromMaybe [] mb_closure ] + where + mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ] + -- NB: the sublib case should not occur, because sub-libraries + -- are not supported without per-component builds + is_lib (CLibName _) = True + is_lib _ = False + + buildComponentDeps f + = CD.fromList [ (compSolverName comp, f comp) + | ElaboratedConfiguredPackage{ + elabPkgOrComp = ElabComponent comp + } <- comps + ] + + -- NB: This is not the final setting of 'pkgStanzasEnabled'. + -- See [Sticky enabled testsuites]; we may enable some extra + -- stanzas opportunistically when it is cheap to do so. + -- + -- However, we start off by enabling everything that was + -- requested, so that we can maintain an invariant that + -- pkgStanzasEnabled is a superset of elabStanzasRequested + pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + + elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc + -> ElaboratedConfiguredPackage + elaborateSolverToCommon + pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) + flags stanzas deps0 _exe_deps0) = + elaboratedPackage + where + elaboratedPackage = ElaboratedConfiguredPackage {..} + + -- These get filled in later + elabUnitId = error "elaborateSolverToCommon: elabUnitId" + elabComponentId = error "elaborateSolverToCommon: elabComponentId" + elabInstantiatedWith = Map.empty + elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" + elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" + elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" + elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" + + elabIsCanonical = True + elabPkgSourceId = pkgid + elabPkgDescription = case PD.finalizePD + flags elabEnabledSpec (const True) + platform (compilerInfo compiler) + [] gdesc of + Right (desc, _) -> desc + Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabFlagAssignment = flags + elabFlagDefaults = PD.mkFlagAssignment + [ (Cabal.flagName flag, Cabal.flagDefault flag) + | flag <- PD.genPackageFlags gdesc ] + + elabEnabledSpec = enableStanzas stanzas + elabStanzasAvailable = stanzas + + elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) + elabStanzasRequested = optStanzaTabulate $ \o -> case o of + -- NB: even if a package stanza is requested, if the package + -- doesn't actually have any of that stanza we omit it from + -- the request, to ensure that we don't decide that this + -- package needs to be rebuilt. (It needs to be done here, + -- because the ElaboratedConfiguredPackage is where we test + -- whether or not there have been changes.) + TestStanzas -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ] + BenchStanzas -> listToMaybe [ v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription ] + where + tests, benchmarks :: Maybe Bool + tests = perPkgOptionMaybe pkgid packageConfigTests + benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + + -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' + -- and 'pruneInstallPlanPass2'. We can't populate it here + -- because whether or not tests/benchmarks should be enabled + -- is heuristically calculated based on whether or not the + -- dependencies of the test suite have already been installed, + -- but this function doesn't know what is installed (since + -- we haven't improved the plan yet), so we do it in another pass. + -- Check the comments of those functions for more details. + elabConfigureTargets = [] + elabBuildTargets = [] + elabTestTargets = [] + elabBenchTargets = [] + elabReplTarget = Nothing + elabHaddockTargets = [] + + elabBuildHaddocks = + perPkgOptionFlag pkgid False packageConfigDocumentation + + elabPkgSourceLocation = srcloc + elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabLocalToProject = isLocalToProject pkg + elabBuildStyle = if shouldBuildInplaceOnly pkg + then BuildInplaceOnly else BuildAndInstall + elabBuildPackageDBStack = buildAndRegisterDbs + elabRegisterPackageDBStack = buildAndRegisterDbs + + elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + elabSetupScriptCliVersion = + packageSetupScriptSpecVersion + elabSetupScriptStyle elabPkgDescription libDepGraph deps0 + elabSetupPackageDBStack = buildAndRegisterDbs + + elabInplaceBuildPackageDBStack = inplacePackageDbs + elabInplaceRegisterPackageDBStack = inplacePackageDbs + elabInplaceSetupPackageDBStack = inplacePackageDbs + + buildAndRegisterDbs + | shouldBuildInplaceOnly pkg = inplacePackageDbs + | otherwise = storePackageDbs + + elabPkgDescriptionOverride = descOverride + + elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively + elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib + elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe + elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe + elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still + + elabProfExe = perPkgOptionFlag pkgid False packageConfigProf + elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + + (elabProfExeDetail, + elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault + packageConfigProfDetail + packageConfigProfLibDetail + elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage + + elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization + elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs + elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections + elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs + elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes + elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo + + -- Combine the configured compiler prog settings with the user-supplied + -- config. For the compiler progs any user-supplied config was taken + -- into account earlier when configuring the compiler so its ok that + -- our configured settings for the compiler override the user-supplied + -- config here. + elabProgramPaths = Map.fromList + [ (programId prog, programPath prog) + | prog <- configuredPrograms compilerprogdb ] + <> perPkgOptionMapLast pkgid packageConfigProgramPaths + elabProgramArgs = Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms compilerprogdb + , let args = programOverrideArgs prog + , not (null args) + ] + <> perPkgOptionMapMappend pkgid packageConfigProgramArgs + elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs + elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs + elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix + elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix + + + elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle + elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml + elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation + elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs + elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage + elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss + elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource + elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump + elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents + + elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog + elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog + elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails + elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix + elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper + elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites + elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions + + elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions + + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a + perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] + + perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) + perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) + perPkgOptionList pkgid f = lookupPerPkgOption pkgid f + perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) + perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) + perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) + + perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) + where + exe = fromFlagOrDefault def bothflag + lib = fromFlagOrDefault def (bothflag <> libflag) + + bothflag = lookupPerPkgOption pkgid fboth + libflag = lookupPerPkgOption pkgid flib + + lookupPerPkgOption :: (Package pkg, Monoid m) + => pkg -> (PackageConfig -> m) -> m + lookupPerPkgOption pkg f = + -- This is where we merge the options from the project config that + -- apply to all packages, all project local packages, and to specific + -- named packages + global `mappend` local `mappend` perpkg + where + global = f allPackagesConfig + local | isLocalToProject pkg + = f localPackagesConfig + | otherwise + = mempty + perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) + + inplacePackageDbs = storePackageDbs + ++ [ distPackageDB (compilerId compiler) ] + + storePackageDbs = storePackageDBStack (compilerId compiler) + + -- For this local build policy, every package that lives in a local source + -- dir (as opposed to a tarball), or depends on such a package, will be + -- built inplace into a shared dist dir. Tarball packages that depend on + -- source dir packages will also get unpacked locally. + shouldBuildInplaceOnly :: SolverPackage loc -> Bool + shouldBuildInplaceOnly pkg = Set.member (packageId pkg) + pkgsToBuildInplaceOnly + + pkgsToBuildInplaceOnly :: Set PackageId + pkgsToBuildInplaceOnly = + Set.fromList + $ map packageId + $ SolverInstallPlan.reverseDependencyClosure + solverPlan + (map PlannedId (Set.toList pkgsLocalToProject)) + + isLocalToProject :: Package pkg => pkg -> Bool + isLocalToProject pkg = Set.member (packageId pkg) + pkgsLocalToProject + + pkgsLocalToProject :: Set PackageId + pkgsLocalToProject = + Set.fromList (catMaybes (map shouldBeLocal localPackages)) + --TODO: localPackages is a misnomer, it's all project packages + -- here is where we decide which ones will be local! + + pkgsUseSharedLibrary :: Set PackageId + pkgsUseSharedLibrary = + packagesWithLibDepsDownwardClosedProperty needsSharedLib + where + needsSharedLib pkg = + fromMaybe compilerShouldUseSharedLibByDefault + (liftM2 (||) pkgSharedLib pkgDynExe) + where + pkgid = packageId pkg + pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib + pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + + --TODO: [code cleanup] move this into the Cabal lib. It's currently open + -- coded in Distribution.Simple.Configure, but should be made a proper + -- function of the Compiler or CompilerInfo. + compilerShouldUseSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.isDynamic compiler + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + pkgsUseProfilingLibrary :: Set PackageId + pkgsUseProfilingLibrary = + packagesWithLibDepsDownwardClosedProperty needsProfilingLib + where + needsProfilingLib pkg = + fromFlagOrDefault False (profBothFlag <> profLibFlag) + where + pkgid = packageId pkg + profBothFlag = lookupPerPkgOption pkgid packageConfigProf + profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe + + libDepGraph = Graph.fromDistinctList $ + map NonSetupLibDepSolverPlanPackage + (SolverInstallPlan.toList solverPlan) + + packagesWithLibDepsDownwardClosedProperty property = + Set.fromList + . map packageId + . fromMaybe [] + $ Graph.closure + libDepGraph + [ Graph.nodeKey pkg + | pkg <- SolverInstallPlan.toList solverPlan + , property pkg ] -- just the packages that satisfy the property + --TODO: [nice to have] this does not check the config consistency, + -- e.g. a package explicitly turning off profiling, but something + -- depending on it that needs profiling. This really needs a separate + -- package config validation/resolution pass. + + --TODO: [nice to have] config consistency checking: + -- + profiling libs & exes, exe needs lib, recursive + -- + shared libs & exes, exe needs lib, recursive + -- + vanilla libs & exes, exe needs lib, recursive + -- + ghci or shared lib needed by TH, recursive, ghc version dependent + +-- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping + +shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId +shouldBeLocal NamedPackage{} = Nothing +shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of + LocalUnpackedPackage _ -> Just (packageId pkg) + _ -> Nothing + +-- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. +matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool +matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) + +-- | Get the appropriate 'ComponentName' which identifies an installed +-- component. +ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName +ipiComponentName = CLibName . IPI.sourceLibName + +-- | Given a 'ElaboratedConfiguredPackage', report if it matches a +-- 'ComponentName'. +matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool +matchElabPkg p elab = + case elabPkgOrComp elab of + ElabComponent comp -> maybe False p (compComponentName comp) + ElabPackage _ -> + -- So, what should we do here? One possibility is to + -- unconditionally return 'True', because whatever it is + -- that we're looking for, it better be in this package. + -- But this is a bit dodgy if the package doesn't actually + -- have, e.g., a library. Fortunately, it's not possible + -- for the build of the library/executables to be toggled + -- by 'pkgStanzasEnabled', so the only thing we have to + -- test is if the component in question is *buildable.* + any (p . componentName) + (Cabal.pkgBuildableComponents (elabPkgDescription elab)) + +-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' +-- and 'ComponentName' to the 'ComponentId' that should be used +-- in this case. +mkCCMapping :: ElaboratedPlanPackage + -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) +mkCCMapping = + InstallPlan.foldPlanPackage + (\ipkg -> (packageName ipkg, + Map.singleton (ipiComponentName ipkg) + -- TODO: libify + (AnnotatedId { + ann_id = IPI.installedComponentId ipkg, + ann_pid = packageId ipkg, + ann_cname = IPI.sourceComponentName ipkg + }))) + $ \elab -> + let mk_aid cn = AnnotatedId { + ann_id = elabComponentId elab, + ann_pid = packageId elab, + ann_cname = cn + } + in (packageName elab, + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Nothing -> Map.empty + Just n -> Map.singleton n (mk_aid n) + ElabPackage _ -> + Map.fromList $ + map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) + (Cabal.pkgBuildableComponents (elabPkgDescription elab))) + +-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' +-- to the shape of this package, as per mix-in linking. +mkShapeMapping :: ElaboratedPlanPackage + -> (ComponentId, (OpenUnitId, ModuleShape)) +mkShapeMapping dpkg = + (getComponentId dpkg, (indef_uid, shape)) + where + (dcid, shape) = + InstallPlan.foldPlanPackage + -- Uses Monad (->) + (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) + (liftM2 (,) elabComponentId elabModuleShape) + dpkg + indef_uid = + IndefFullUnitId dcid + (Map.fromList [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires shape)]) + +-- | Get the bin\/ directories that a package's executables should reside in. +-- +-- The result may be empty if the package does not build any executables. +-- +-- The result may have several entries if this is an inplace build of a package +-- with multiple executables. +binDirectories + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> [FilePath] +binDirectories layout config package = case elabBuildStyle package of + -- quick sanity check: no sense returning a bin directory if we're not going + -- to put any executables in it, that will just clog up the PATH + _ | noExecutables -> [] + BuildAndInstall -> [installedBinDirectory package] + BuildInplaceOnly -> map (root) $ case elabPkgOrComp package of + ElabComponent comp -> case compSolverName comp of + CD.ComponentExe n -> [prettyShow n] + _ -> [] + ElabPackage _ -> map (prettyShow . PD.exeName) + . PD.executables + . elabPkgDescription + $ package + where + noExecutables = null . PD.executables . elabPkgDescription $ package + root = distBuildDirectory layout (elabDistDirParams config package) + "build" + +-- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the +-- dependency graph considers only dependencies on libraries which are +-- NOT from setup dependencies. Used to compute the set +-- of packages needed for profiling and dynamic libraries. +newtype NonSetupLibDepSolverPlanPackage + = NonSetupLibDepSolverPlanPackage + { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } + +instance Package NonSetupLibDepSolverPlanPackage where + packageId = packageId . unNonSetupLibDepSolverPlanPackage + +instance IsNode NonSetupLibDepSolverPlanPackage where + type Key NonSetupLibDepSolverPlanPackage = SolverId + nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage + nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) + = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) + +type InstS = Map UnitId ElaboratedPlanPackage +type InstM a = State InstS a + +getComponentId :: ElaboratedPlanPackage + -> ComponentId +getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg +getComponentId (InstallPlan.Configured elab) = elabComponentId elab +getComponentId (InstallPlan.Installed elab) = elabComponentId elab + +extractElabBuildStyle :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage + -> BuildStyle +extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab +extractElabBuildStyle _ = BuildAndInstall + +-- instantiateInstallPlan is responsible for filling out an InstallPlan +-- with all of the extra Configured packages that would be generated by +-- recursively instantiating the dependencies of packages. +-- +-- Suppose we are compiling the following packages: +-- +-- unit f where +-- signature H +-- +-- unit g where +-- dependency f[H=containers:Data.Map] +-- +-- At entry, we have an InstallPlan with a single plan package per +-- actual source package, e.g., only (indefinite!) f and g. The job of +-- instantiation is to turn this into three plan packages: each of the +-- packages as before, but also a new, definite package f[H=containers:Data.Map] +-- +-- How do we do this? The general strategy is to iterate over every +-- package in the existing plan and recursively create new entries for +-- each of its dependencies which is an instantiated package (e.g., +-- f[H=p:G]). This process must be recursive, as f itself may depend on +-- OTHER packages which it instantiated using its hole H. +-- +-- Some subtleties: +-- +-- * We have to keep track of whether or not we are instantiating with +-- inplace packages, because instantiating a non-inplace package with +-- an inplace packages makes it inplace (since it depends on +-- something in the inplace store)! The rule is that if any of the +-- modules in an instantiation are inplace, then the instantiated +-- unit itself must be inplace. There is then a bunch of faffing +-- about to keep track of BuildStyle. +-- +-- * ElaboratedConfiguredPackage was never really designed for post +-- facto instantiation, so some of the steps for generating new +-- instantiations are a little fraught. For example, the act of +-- flipping a package to be inplace involves faffing about with four +-- fields, because these fields are precomputed. A good refactor +-- would be to reduce the amount of precomputation to simplify the +-- algorithm here. +-- +-- * We use the state monad to cache already instantiated modules, so +-- we don't instantiate the same thing multiple times. +-- +instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan +instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = + InstallPlan.new (IndependentGoals False) + (Graph.fromDistinctList (Map.elems ready_map)) + where + pkgs = InstallPlan.toList plan + + cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] + + instantiateUnitId :: ComponentId -> Map ModuleName (Module, BuildStyle) + -> InstM (DefUnitId, BuildStyle) + instantiateUnitId cid insts = state $ \s -> + case Map.lookup uid s of + Nothing -> + -- Knot tied + -- TODO: I don't think the knot tying actually does + -- anything useful + let (r, s') = runState (instantiateComponent uid cid insts) + (Map.insert uid r s) + in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') + Just r -> ((def_uid, extractElabBuildStyle r), s) + where + def_uid = mkDefUnitId cid (fmap fst insts) + uid = unDefUnitId def_uid + + -- No need to InplaceT; the inplace-ness is properly computed for + -- the ElaboratedPlanPackage, so that will implicitly pass it on + instantiateComponent + :: UnitId -> ComponentId -> Map ModuleName (Module, BuildStyle) + -> InstM ElaboratedPlanPackage + instantiateComponent uid cid insts + | Just planpkg <- Map.lookup cid cmap + = case planpkg of + InstallPlan.Configured (elab0@ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp }) -> do + deps <- + traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) + let build_style = fold (fmap snd insts) + let getDep (Module dep_uid _) = [dep_uid] + elab1 = fixupBuildStyle build_style $ elab0 { + elabUnitId = uid, + elabComponentId = cid, + elabInstantiatedWith = fmap fst insts, + elabIsCanonical = Map.null (fmap fst insts), + elabPkgOrComp = ElabComponent comp { + compOrderLibDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) ++ + ordNub (map unDefUnitId + (deps ++ concatMap (getDep . fst) (Map.elems insts))) + } + } + elab = elab1 { + elabInstallDirs = computeInstallDirs storeDirLayout + defaultInstallDirs + elaboratedShared + elab1 + } + return $ InstallPlan.Configured elab + _ -> return planpkg + | otherwise = error ("instantiateComponent: " ++ prettyShow cid) + + substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle) + substUnitId _ (DefiniteUnitId uid) = + -- This COULD actually, secretly, be an inplace package, but in + -- that case it doesn't matter as it's already been recorded + -- in the package that depends on this + return (uid, BuildAndInstall) + substUnitId subst (IndefFullUnitId cid insts) = do + insts' <- substSubst subst insts + instantiateUnitId cid insts' + + -- NB: NOT composition + substSubst :: Map ModuleName (Module, BuildStyle) + -> Map ModuleName OpenModule + -> InstM (Map ModuleName (Module, BuildStyle)) + substSubst subst insts = traverse (substModule subst) insts + + substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle) + substModule subst (OpenModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (OpenModule uid mod_name) = do + (uid', build_style) <- substUnitId subst uid + return (Module uid' mod_name, build_style) + + indefiniteUnitId :: ComponentId -> InstM UnitId + indefiniteUnitId cid = do + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + state $ \s -> (uid, Map.insert uid r s) + + indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage + indefiniteComponent _uid cid + -- Only need Configured; this phase happens before improvement, so + -- there shouldn't be any Installed packages here. + | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap + , ElabComponent elab_comp <- elabPkgOrComp epkg + = do -- We need to do a little more processing of the includes: some + -- of them are fully definite even without substitution. We + -- want to build those too; see #5634. + -- + -- This code mimics similar code in Distribution.Backpack.ReadyComponent; + -- however, unlike the conversion from LinkedComponent to + -- ReadyComponent, this transformation is done *without* + -- changing the type in question; and what we are simply + -- doing is enforcing tighter invariants on the data + -- structure in question. The new invariant is that there + -- is no IndefFullUnitId in compLinkedLibDependencies that actually + -- has no holes. We couldn't specify this invariant when + -- we initially created the ElaboratedPlanPackage because + -- we have no way of actually reifying the UnitId into a + -- DefiniteUnitId (that's what substUnitId does!) + new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> + if Set.null (openUnitIdFreeHoles uid) + then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid) + else return uid + -- NB: no fixupBuildStyle needed here, as if the indefinite + -- component depends on any inplace packages, it itself must + -- be indefinite! There is no substitution here, we can't + -- post facto add inplace deps + return . InstallPlan.Configured $ epkg { + elabPkgOrComp = ElabComponent elab_comp { + compLinkedLibDependencies = new_deps, + -- I think this is right: any new definite unit ids we + -- minted in the phase above need to be built before us. + -- Add 'em in. This doesn't remove any old dependencies + -- on the indefinite package; they're harmless. + compOrderLibDependencies = + ordNub $ compOrderLibDependencies elab_comp ++ + [unDefUnitId d | DefiniteUnitId d <- new_deps] + } + } + | Just planpkg <- Map.lookup cid cmap + = return planpkg + | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) + + fixupBuildStyle BuildAndInstall elab = elab + fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly }) = elab + fixupBuildStyle BuildInplaceOnly elab = elab { + elabBuildStyle = BuildInplaceOnly, + elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab, + elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab, + elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab + } + + ready_map = execState work Map.empty + + work = for_ pkgs $ \pkg -> + case pkg of + InstallPlan.Configured elab + | not (Map.null (elabLinkedInstantiatedWith elab)) + -> indefiniteUnitId (elabComponentId elab) + >> return () + _ -> instantiateUnitId (getComponentId pkg) Map.empty + >> return () + +--------------------------- +-- Build targets +-- + +-- Refer to ProjectPlanning.Types for details of these important types: + +-- data ComponentTarget = ... +-- data SubComponentTarget = ... + +-- One step in the build system is to translate higher level intentions like +-- "build this package", "test that package", or "repl that component" into +-- a more detailed specification of exactly which components to build (or other +-- actions like repl or build docs). This translation is somewhat different for +-- different commands. For example "test" for a package will build a different +-- set of components than "build". In addition, the translation of these +-- intentions can fail. For example "run" for a package is only unambiguous +-- when the package has a single executable. +-- +-- So we need a little bit of infrastructure to make it easy for the command +-- implementations to select what component targets are meant when a user asks +-- to do something with a package or component. To do this (and to be able to +-- produce good error messages for mistakes and when targets are not available) +-- we need to gather and summarise accurate information about all the possible +-- targets, both available and unavailable. Then a command implementation can +-- decide which of the available component targets should be selected. + +-- | An available target represents a component within a package that a user +-- command could plausibly refer to. In this sense, all the components defined +-- within the package are things the user could refer to, whether or not it +-- would actually be possible to build that component. +-- +-- In particular the available target contains an 'AvailableTargetStatus' which +-- informs us about whether it's actually possible to select this component to +-- be built, and if not why not. This detail makes it possible for command +-- implementations (like @build@, @test@ etc) to accurately report why a target +-- cannot be used. +-- +-- Note that the type parameter is used to help enforce that command +-- implementations can only select targets that can actually be built (by +-- forcing them to return the @k@ value for the selected targets). +-- In particular 'resolveTargets' makes use of this (with @k@ as +-- @('UnitId', ComponentName')@) to identify the targets thus selected. +-- +data AvailableTarget k = AvailableTarget { + availableTargetPackageId :: PackageId, + availableTargetComponentName :: ComponentName, + availableTargetStatus :: AvailableTargetStatus k, + availableTargetLocalToProject :: Bool + } + deriving (Eq, Show, Functor) + +-- | The status of a an 'AvailableTarget' component. This tells us whether +-- it's actually possible to select this component to be built, and if not +-- why not. +-- +data AvailableTargetStatus k = + TargetDisabledByUser -- ^ When the user does @tests: False@ + | TargetDisabledBySolver -- ^ When the solver could not enable tests + | TargetNotBuildable -- ^ When the component has @buildable: False@ + | TargetNotLocal -- ^ When the component is non-core in a non-local package + | TargetBuildable k TargetRequested -- ^ The target can or should be built + deriving (Eq, Ord, Show, Functor) + +-- | This tells us whether a target ought to be built by default, or only if +-- specifically requested. The policy is that components like libraries and +-- executables are built by default by @build@, but test suites and benchmarks +-- are not, unless this is overridden in the project configuration. +-- +data TargetRequested = + TargetRequestedByDefault -- ^ To be built by default + | TargetNotRequestedByDefault -- ^ Not to be built by default + deriving (Eq, Ord, Show) + +-- | Given the install plan, produce the set of 'AvailableTarget's for each +-- package-component pair. +-- +-- Typically there will only be one such target for each component, but for +-- example if we have a plan with both normal and profiling variants of a +-- component then we would get both as available targets, or similarly if we +-- had a plan that contained two instances of the same version of a package. +-- This approach makes it relatively easy to select all instances\/variants +-- of a component. +-- +availableTargets :: ElaboratedInstallPlan + -> Map (PackageId, ComponentName) + [AvailableTarget (UnitId, ComponentName)] +availableTargets installPlan = + let rs = [ (pkgid, cname, fake, target) + | pkg <- InstallPlan.toList installPlan + , (pkgid, cname, fake, target) <- case pkg of + InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg + InstallPlan.Installed elab -> availableSourceTargets elab + InstallPlan.Configured elab -> availableSourceTargets elab + ] + in Map.union + (Map.fromListWith (++) + [ ((pkgid, cname), [target]) + | (pkgid, cname, fake, target) <- rs, not fake]) + (Map.fromList + [ ((pkgid, cname), [target]) + | (pkgid, cname, fake, target) <- rs, fake]) + -- The normal targets mask the fake ones. We get all instances of the + -- normal ones and only one copy of the fake ones (as there are many + -- duplicates of the fake ones). See 'availableSourceTargets' below for + -- more details on this fake stuff is about. + +availableInstalledTargets :: IPI.InstalledPackageInfo + -> [(PackageId, ComponentName, Bool, + AvailableTarget (UnitId, ComponentName))] +availableInstalledTargets ipkg = + let unitid = installedUnitId ipkg + cname = CLibName LMainLibName + status = TargetBuildable (unitid, cname) TargetRequestedByDefault + target = AvailableTarget (packageId ipkg) cname status False + fake = False + in [(packageId ipkg, cname, fake, target)] + +availableSourceTargets :: ElaboratedConfiguredPackage + -> [(PackageId, ComponentName, Bool, + AvailableTarget (UnitId, ComponentName))] +availableSourceTargets elab = + -- We have a somewhat awkward problem here. We need to know /all/ the + -- components from /all/ the packages because these are the things that + -- users could refer to. Unfortunately, at this stage the elaborated install + -- plan does /not/ contain all components: some components have already + -- been deleted because they cannot possibly be built. This is the case + -- for components that are marked @buildable: False@ in their .cabal files. + -- (It's not unreasonable that the unbuildable components have been pruned + -- as the plan invariant is considerably simpler if all nodes can be built) + -- + -- We can recover the missing components but it's not exactly elegant. For + -- a graph node corresponding to a component we still have the information + -- about the package that it came from, and this includes the names of + -- /all/ the other components in the package. So in principle this lets us + -- find the names of all components, plus full details of the buildable + -- components. + -- + -- Consider for example a package with 3 exe components: foo, bar and baz + -- where foo and bar are buildable, but baz is not. So the plan contains + -- nodes for the components foo and bar. Now we look at each of these two + -- nodes and look at the package they come from and the names of the + -- components in this package. This will give us the names foo, bar and + -- baz, twice (once for each of the two buildable components foo and bar). + -- + -- We refer to these reconstructed missing components as fake targets. + -- It is an invariant that they are not available to be built. + -- + -- To produce the final set of targets we put the fake targets in a finite + -- map (thus eliminating the duplicates) and then we overlay that map with + -- the normal buildable targets. (This is done above in 'availableTargets'.) + -- + [ (packageId elab, cname, fake, target) + | component <- pkgComponents (elabPkgDescription elab) + , let cname = componentName component + status = componentAvailableTargetStatus component + target = AvailableTarget { + availableTargetPackageId = packageId elab, + availableTargetComponentName = cname, + availableTargetStatus = status, + availableTargetLocalToProject = elabLocalToProject elab + } + fake = isFakeTarget cname + + -- TODO: The goal of this test is to exclude "instantiated" + -- packages as available targets. This means that you can't + -- ask for a particular instantiated component to be built; + -- it will only get built by a dependency. Perhaps the + -- correct way to implement this is to run selection + -- prior to instantiating packages. If you refactor + -- this, then you can delete this test. + , elabIsCanonical elab + + -- Filter out some bogus parts of the cross product that are never needed + , case status of + TargetBuildable{} | fake -> False + _ -> True + ] + where + isFakeTarget cname = + case elabPkgOrComp elab of + ElabPackage _ -> False + ElabComponent elabComponent -> compComponentName elabComponent + /= Just cname + + componentAvailableTargetStatus + :: Component -> AvailableTargetStatus (UnitId, ComponentName) + componentAvailableTargetStatus component = + case componentOptionalStanza $ CD.componentNameToComponent cname of + -- it is not an optional stanza, so a library, exe or foreign lib + Nothing + | not buildable -> TargetNotBuildable + | otherwise -> TargetBuildable (elabUnitId elab, cname) + TargetRequestedByDefault + + -- it is not an optional stanza, so a testsuite or benchmark + Just stanza -> + case (optStanzaLookup stanza (elabStanzasRequested elab), -- TODO + optStanzaSetMember stanza (elabStanzasAvailable elab)) of + _ | not withinPlan -> TargetNotLocal + (Just False, _) -> TargetDisabledByUser + (Nothing, False) -> TargetDisabledBySolver + _ | not buildable -> TargetNotBuildable + (Just True, True) -> TargetBuildable (elabUnitId elab, cname) + TargetRequestedByDefault + (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) + TargetNotRequestedByDefault + (Just True, False) -> + error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname + where + cname = componentName component + buildable = PD.buildable (componentBuildInfo component) + withinPlan = elabLocalToProject elab + || case elabPkgOrComp elab of + ElabComponent elabComponent -> + compComponentName elabComponent == Just cname + ElabPackage _ -> + case componentName component of + CLibName (LMainLibName) -> True + CExeName _ -> True + --TODO: what about sub-libs and foreign libs? + _ -> False + +-- | Merge component targets that overlap each other. Specially when we have +-- multiple targets for the same component and one of them refers to the whole +-- component (rather than a module or file within) then all the other targets +-- for that component are subsumed. +-- +-- We also allow for information associated with each component target, and +-- whenever we targets subsume each other we aggregate their associated info. +-- +nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])] +nubComponentTargets = + concatMap (wholeComponentOverrides . map snd) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) + . map compatSubComponentTargets + where + -- If we're building the whole component then that the only target all we + -- need, otherwise we can have several targets within the component. + wholeComponentOverrides :: [(ComponentTarget, a )] + -> [(ComponentTarget, [a])] + wholeComponentOverrides ts = + case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of + (t:_) -> [ (t, map snd ts) ] + [] -> [ (t,[x]) | (t,x) <- ts ] + + -- Not all Cabal Setup.hs versions support sub-component targets, so switch + -- them over to the whole component + compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) + compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) + | not setupHsSupportsSubComponentTargets + = (ComponentTarget cname WholeComponent, x) + | otherwise = target + + -- Actually the reality is that no current version of Cabal's Setup.hs + -- build command actually support building specific files or modules. + setupHsSupportsSubComponentTargets = False + -- TODO: when that changes, adjust this test, e.g. + -- | pkgSetupScriptCliVersion >= Version [x,y] [] + +pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool +pkgHasEphemeralBuildTargets elab = + isJust (elabReplTarget elab) + || (not . null) (elabTestTargets elab) + || (not . null) (elabBenchTargets elab) + || (not . null) (elabHaddockTargets elab) + || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab + , subtarget /= WholeComponent ] + +-- | The components that we'll build all of, meaning that after they're built +-- we can skip building them again (unlike with building just some modules or +-- other files within a component). +-- +elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage + -> Set ComponentName +elabBuildTargetWholeComponents elab = + Set.fromList + [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] + + + +------------------------------------------------------------------------------ +-- * Install plan pruning +------------------------------------------------------------------------------ + +-- | How 'pruneInstallPlanToTargets' should interpret the per-package +-- 'ComponentTarget's: as build, repl or haddock targets. +-- +data TargetAction = TargetActionConfigure + | TargetActionBuild + | TargetActionRepl + | TargetActionTest + | TargetActionBench + | TargetActionHaddock + +-- | Given a set of per-package\/per-component targets, take the subset of the +-- install plan needed to build those targets. Also, update the package config +-- to specify which optional stanzas to enable, and which targets within each +-- package to build. +-- +-- NB: Pruning happens after improvement, which is important because we +-- will prune differently depending on what is already installed (to +-- implement "sticky" test suite enabling behavior). +-- +pruneInstallPlanToTargets :: TargetAction + -> Map UnitId [ComponentTarget] + -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = + InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) + . Graph.fromDistinctList + -- We have to do the pruning in two passes + . pruneInstallPlanPass2 + . pruneInstallPlanPass1 + -- Set the targets that will be the roots for pruning + . setRootTargets targetActionType perPkgTargetsMap + . InstallPlan.toList + $ elaboratedPlan + +-- | This is a temporary data type, where we temporarily +-- override the graph dependencies of an 'ElaboratedPackage', +-- so we can take a closure over them. We'll throw out the +-- overriden dependencies when we're done so it's strictly temporary. +-- +-- For 'ElaboratedComponent', this the cached unit IDs always +-- coincide with the real thing. +data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] + +instance Package PrunedPackage where + packageId (PrunedPackage elab _) = packageId elab + +instance HasUnitId PrunedPackage where + installedUnitId = nodeKey + +instance IsNode PrunedPackage where + type Key PrunedPackage = UnitId + nodeKey (PrunedPackage elab _) = nodeKey elab + nodeNeighbors (PrunedPackage _ deps) = deps + +fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage +fromPrunedPackage (PrunedPackage elab _) = elab + +-- | Set the build targets based on the user targets (but not rev deps yet). +-- This is required before we can prune anything. +-- +setRootTargets :: TargetAction + -> Map UnitId [ComponentTarget] + -> [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +setRootTargets targetAction perPkgTargetsMap = + assert (not (Map.null perPkgTargetsMap)) $ + assert (all (not . null) (Map.elems perPkgTargetsMap)) $ + + map (mapConfiguredPackage setElabBuildTargets) + where + -- Set the targets we'll build for this package/component. This is just + -- based on the root targets from the user, not targets implied by reverse + -- dependencies. Those comes in the second pass once we know the rev deps. + -- + setElabBuildTargets elab = + case (Map.lookup (installedUnitId elab) perPkgTargetsMap, + targetAction) of + (Nothing, _) -> elab + (Just tgts, TargetActionConfigure) -> elab { elabConfigureTargets = tgts } + (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } + (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } + (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } + (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt + , elabBuildHaddocks = False } + (Just tgts, TargetActionHaddock) -> + foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts + , elabBuildHaddocks = True }) tgts + (Just _, TargetActionRepl) -> + error "pruneInstallPlanToTargets: multiple repl targets" + + setElabHaddockTargets tgt elab + | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True } + | isBenchComponentTarget tgt = elab { elabHaddockBenchmarks = True } + | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True } + | isExeComponentTarget tgt = elab { elabHaddockExecutables = True } + | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True } + | otherwise = elab + +-- | Assuming we have previously set the root build targets (i.e. the user +-- targets but not rev deps yet), the first pruning pass does two things: +-- +-- * A first go at determining which optional stanzas (testsuites, benchmarks) +-- are needed. We have a second go in the next pass. +-- * Take the dependency closure using pruned dependencies. We prune deps that +-- are used only by unneeded optional stanzas. These pruned deps are only +-- used for the dependency closure and are not persisted in this pass. +-- +pruneInstallPlanPass1 :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +pruneInstallPlanPass1 pkgs = + map (mapConfiguredPackage fromPrunedPackage) + (fromMaybe [] $ Graph.closure graph roots) + where + pkgs' = map (mapConfiguredPackage prune) pkgs + graph = Graph.fromDistinctList pkgs' + roots = mapMaybe find_root pkgs' + + prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') + where elab' = + setDocumentation + $ addOptionalStanzas elab + + is_root :: PrunedPackage -> Maybe UnitId + is_root (PrunedPackage elab _) = + if not $ and [ null (elabConfigureTargets elab) + , null (elabBuildTargets elab) + , null (elabTestTargets elab) + , null (elabBenchTargets elab) + , isNothing (elabReplTarget elab) + , null (elabHaddockTargets elab) + ] + then Just (installedUnitId elab) + else Nothing + + find_root (InstallPlan.Configured pkg) = is_root pkg + -- When using the extra-packages stanza we need to + -- look at installed packages as well. + find_root (InstallPlan.Installed pkg) = is_root pkg + find_root _ = Nothing + + -- Note [Sticky enabled testsuites] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- The testsuite and benchmark targets are somewhat special in that we need + -- to configure the packages with them enabled, and we need to do that even + -- if we only want to build one of several testsuites. + -- + -- There are two cases in which we will enable the testsuites (or + -- benchmarks): if one of the targets is a testsuite, or if all of the + -- testsuite dependencies are already cached in the store. The rationale + -- for the latter is to minimise how often we have to reconfigure due to + -- the particular targets we choose to build. Otherwise choosing to build + -- a testsuite target, and then later choosing to build an exe target + -- would involve unnecessarily reconfiguring the package with testsuites + -- disabled. Technically this introduces a little bit of stateful + -- behaviour to make this "sticky", but it should be benign. + + -- Decide whether or not to enable testsuites and benchmarks. + -- See [Sticky enabled testsuites] + addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = + elab { + elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) + } + where + stanzas :: OptionalStanzaSet + -- By default, we enabled all stanzas requested by the user, + -- as per elabStanzasRequested, done in + -- 'elaborateSolverToPackage' + stanzas = pkgStanzasEnabled pkg + -- optionalStanzasRequiredByTargets has to be done at + -- prune-time because it depends on 'elabTestTargets' + -- et al, which is done by 'setRootTargets' at the + -- beginning of pruning. + <> optionalStanzasRequiredByTargets elab + -- optionalStanzasWithDepsAvailable has to be done at + -- prune-time because it depends on what packages are + -- installed, which is not known until after improvement + -- (pruning is done after improvement) + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + addOptionalStanzas elab = elab + + setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = + elab { + elabBuildHaddocks = + elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab + } + + where + documentationEnabled c = + case c of + CD.ComponentLib -> const True + CD.ComponentSubLib _ -> elabHaddockInternal + CD.ComponentFLib _ -> elabHaddockForeignLibs + CD.ComponentExe _ -> elabHaddockExecutables + CD.ComponentTest _ -> elabHaddockTestSuites + CD.ComponentBench _ -> elabHaddockBenchmarks + CD.ComponentSetup -> const False + + setDocumentation elab = elab + + -- Calculate package dependencies but cut out those needed only by + -- optional stanzas that we've determined we will not enable. + -- These pruned deps are not persisted in this pass since they're based on + -- the optional stanzas and we'll make further tweaks to the optional + -- stanzas in the next pass. + -- + pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] + pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } + = InstallPlan.depends elab -- no pruning + pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } + = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) + where + keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas + keepNeeded _ _ = True + stanzas = pkgStanzasEnabled pkg + + optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage + -> OptionalStanzaSet + optionalStanzasRequiredByTargets pkg = + optStanzaSetFromList + [ stanza + | ComponentTarget cname _ <- elabBuildTargets pkg + ++ elabTestTargets pkg + ++ elabBenchTargets pkg + ++ maybeToList (elabReplTarget pkg) + ++ elabHaddockTargets pkg + , stanza <- maybeToList $ + componentOptionalStanza $ + CD.componentNameToComponent cname + ] + + availablePkgs = + Set.fromList + [ installedUnitId pkg + | InstallPlan.PreExisting pkg <- pkgs ] + +-- | Given a set of already installed packages @availablePkgs@, +-- determine the set of available optional stanzas from @pkg@ +-- which have all of their dependencies already installed. This is used +-- to implement "sticky" testsuites, where once we have installed +-- all of the deps needed for the test suite, we go ahead and +-- enable it always. +optionalStanzasWithDepsAvailable :: Set UnitId + -> ElaboratedConfiguredPackage + -> ElaboratedPackage + -> OptionalStanzaSet +optionalStanzasWithDepsAvailable availablePkgs elab pkg = + optStanzaSetFromList + [ stanza + | stanza <- optStanzaSetToList (elabStanzasAvailable elab) + , let deps :: [UnitId] + deps = CD.select (optionalStanzaDeps stanza) + -- TODO: probably need to select other + -- dep types too eventually + (pkgOrderDependencies pkg) + , all (`Set.member` availablePkgs) deps + ] + where + optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True + optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True + optionalStanzaDeps _ _ = False + + +-- The second pass does three things: +-- +-- * A second go at deciding which optional stanzas to enable. +-- * Prune the dependencies based on the final choice of optional stanzas. +-- * Extend the targets within each package to build, now we know the reverse +-- dependencies, ie we know which libs are needed as deps by other packages. +-- +-- Achieving sticky behaviour with enabling\/disabling optional stanzas is +-- tricky. The first approximation was handled by the first pass above, but +-- it's not quite enough. That pass will enable stanzas if all of the deps +-- of the optional stanza are already installed /in the store/. That's important +-- but it does not account for dependencies that get built inplace as part of +-- the project. We cannot take those inplace build deps into account in the +-- pruning pass however because we don't yet know which ones we're going to +-- build. Once we do know, we can have another go and enable stanzas that have +-- all their deps available. Now we can consider all packages in the pruned +-- plan to be available, including ones we already decided to build from +-- source. +-- +-- Deciding which targets to build depends on knowing which packages have +-- reverse dependencies (ie are needed). This requires the result of first +-- pass, which is another reason we have to split it into two passes. +-- +-- Note that just because we might enable testsuites or benchmarks (in the +-- first or second pass) doesn't mean that we build all (or even any) of them. +-- That depends on which targets we picked in the first pass. +-- +pruneInstallPlanPass2 :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +pruneInstallPlanPass2 pkgs = + map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs + where + setStanzasDepsAndTargets elab = + elab { + elabBuildTargets = ordNub + $ elabBuildTargets elab + ++ libTargetsRequiredForRevDeps + ++ exeTargetsRequiredForRevDeps, + elabPkgOrComp = + case elabPkgOrComp elab of + ElabPackage pkg -> + let stanzas = pkgStanzasEnabled pkg + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas + keepNeeded _ _ = True + in ElabPackage $ pkg { + pkgStanzasEnabled = stanzas, + pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), + pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), + pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) + } + r@(ElabComponent _) -> r + } + where + libTargetsRequiredForRevDeps = + [ ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent + | installedUnitId elab `Set.member` hasReverseLibDeps + ] + exeTargetsRequiredForRevDeps = + -- TODO: allow requesting executable with different name + -- than package name + [ ComponentTarget (Cabal.CExeName + $ packageNameToUnqualComponentName + $ packageName $ elabPkgSourceId elab) + WholeComponent + | installedUnitId elab `Set.member` hasReverseExeDeps + ] + + + availablePkgs :: Set UnitId + availablePkgs = Set.fromList (map installedUnitId pkgs) + + hasReverseLibDeps :: Set UnitId + hasReverseLibDeps = + Set.fromList [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderLibDependencies pkg ] + + hasReverseExeDeps :: Set UnitId + hasReverseExeDeps = + Set.fromList [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderExeDependencies pkg ] + +mapConfiguredPackage :: (srcpkg -> srcpkg') + -> InstallPlan.GenericPlanPackage ipkg srcpkg + -> InstallPlan.GenericPlanPackage ipkg srcpkg' +mapConfiguredPackage f (InstallPlan.Configured pkg) = + InstallPlan.Configured (f pkg) +mapConfiguredPackage f (InstallPlan.Installed pkg) = + InstallPlan.Installed (f pkg) +mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = + InstallPlan.PreExisting pkg + +------------------------------------ +-- Support for --only-dependencies +-- + +-- | Try to remove the given targets from the install plan. +-- +-- This is not always possible. +-- +pruneInstallPlanToDependencies :: Set UnitId + -> ElaboratedInstallPlan + -> Either CannotPruneDependencies + ElaboratedInstallPlan +pruneInstallPlanToDependencies pkgTargets installPlan = + assert (all (isJust . InstallPlan.lookup installPlan) + (Set.toList pkgTargets)) $ + + fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) + . checkBrokenDeps + . Graph.fromDistinctList + . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . InstallPlan.toList + $ installPlan + where + -- Our strategy is to remove the packages we don't want and then check + -- if the remaining graph is broken or not, ie any packages with dangling + -- dependencies. If there are then we cannot prune the given targets. + checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage + -> Either CannotPruneDependencies + (Graph.Graph ElaboratedPlanPackage) + checkBrokenDeps graph = + case Graph.broken graph of + [] -> Right graph + brokenPackages -> + Left $ CannotPruneDependencies + [ (pkg, missingDeps) + | (pkg, missingDepIds) <- brokenPackages + , let missingDeps = mapMaybe lookupDep missingDepIds + ] + where + -- lookup in the original unpruned graph + lookupDep = InstallPlan.lookup installPlan + +-- | It is not always possible to prune to only the dependencies of a set of +-- targets. It may be the case that removing a package leaves something else +-- that still needed the pruned package. +-- +-- This lists all the packages that would be broken, and their dependencies +-- that would be missing if we did prune. +-- +newtype CannotPruneDependencies = + CannotPruneDependencies [(ElaboratedPlanPackage, + [ElaboratedPlanPackage])] + deriving (Show) + + +--------------------------- +-- Setup.hs script policy +-- + +-- Handling for Setup.hs scripts is a bit tricky, part of it lives in the +-- solver phase, and part in the elaboration phase. We keep the helper +-- functions for both phases together here so at least you can see all of it +-- in one place. +-- +-- There are four major cases for Setup.hs handling: +-- +-- 1. @build-type@ Custom with a @custom-setup@ section +-- 2. @build-type@ Custom without a @custom-setup@ section +-- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ +-- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ +-- +-- It's also worth noting that packages specifying @cabal-version: >= 1.23@ +-- or later that have @build-type@ Custom will always have a @custom-setup@ +-- section. Therefore in case 2, the specified @cabal-version@ will always be +-- less than 1.23. +-- +-- In cases 1 and 2 we obviously have to build an external Setup.hs script, +-- while in case 4 we can use the internal library API. +-- +-- TODO:In case 3 we should fail. We don't know how to talk to +-- newer ./Setup.hs +-- +-- data SetupScriptStyle = ... -- see ProjectPlanning.Types + +-- | Work out the 'SetupScriptStyle' given the package description. +-- +packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle +packageSetupScriptStyle pkg + | buildType == PD.Custom + , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza + , not (PD.defaultSetupDepends setupbi) -- but not one we added internally + = SetupCustomExplicitDeps + + | buildType == PD.Custom + , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as + , PD.defaultSetupDepends setupbi -- the solver fills in the deps + = SetupCustomImplicitDeps + + | buildType == PD.Custom + , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver + = SetupCustomImplicitDeps + + -- here we should fail. + | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against + = SetupNonCustomExternalLib + + | otherwise + = SetupNonCustomInternalLib + where + buildType = PD.buildType pkg + + +-- | Part of our Setup.hs handling policy is implemented by getting the solver +-- to work out setup dependencies for packages. The solver already handles +-- packages that explicitly specify setup dependencies, but we can also tell +-- the solver to treat other packages as if they had setup dependencies. +-- That's what this function does, it gets called by the solver for all +-- packages that don't already have setup dependencies. +-- +-- The dependencies we want to add is different for each 'SetupScriptStyle'. +-- +-- Note that adding default deps means these deps are actually /added/ to the +-- packages that we get out of the solver in the 'SolverInstallPlan'. Making +-- implicit setup deps explicit is a problem in the post-solver stages because +-- we still need to distinguish the case of explicit and implict setup deps. +-- See 'rememberImplicitSetupDeps'. +-- +-- Note in addition to adding default setup deps, we also use +-- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require +-- @Cabal >= 1.20@ for Setup scripts. +-- +defaultSetupDeps :: Compiler -> Platform + -> PD.PackageDescription + -> Maybe [Dependency] +defaultSetupDeps compiler platform pkg = + case packageSetupScriptStyle pkg of + + -- For packages with build type custom that do not specify explicit + -- setup dependencies, we add a dependency on Cabal and a number + -- of other packages. + SetupCustomImplicitDeps -> + Just $ + [ Dependency depPkgname anyVersion mainLibSet + | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ + [ Dependency cabalPkgname cabalConstraint mainLibSet + | packageName pkg /= cabalPkgname ] + where + -- The Cabal dep is slightly special: + -- * We omit the dep for the Cabal lib itself, since it bootstraps. + -- * We constrain it to be < 1.25 + -- + -- Note: we also add a global constraint to require Cabal >= 1.20 + -- for Setup scripts (see use addSetupCabalMinVersionConstraint). + -- + cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) + `intersectVersionRanges` + earlierVersion cabalCompatMaxVer + -- The idea here is that at some point we will make significant + -- breaking changes to the Cabal API that Setup.hs scripts use. + -- So for old custom Setup scripts that do not specify explicit + -- constraints, we constrain them to use a compatible Cabal version. + cabalCompatMaxVer = mkVersion [1,25] + + -- For other build types (like Simple) if we still need to compile an + -- external Setup.hs, it'll be one of the simple ones that only depends + -- on Cabal and base. + SetupNonCustomExternalLib -> + Just [ Dependency cabalPkgname cabalConstraint mainLibSet + , Dependency basePkgname anyVersion mainLibSet] + where + cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) + + -- The internal setup wrapper method has no deps at all. + SetupNonCustomInternalLib -> Just [] + + -- This case gets ruled out by the caller, planPackages, see the note + -- above in the SetupCustomImplicitDeps case. + SetupCustomExplicitDeps -> + error $ "defaultSetupDeps: called for a package with explicit " + ++ "setup deps: " ++ prettyShow (packageId pkg) + where + -- we require one less + -- + -- This maps e.g. CabalSpecV3_0 to mkVersion [2,5] + csvToVersion :: CabalSpecVersion -> Version + csvToVersion = mkVersion . cabalSpecMinimumLibraryVersion + +-- | Work out which version of the Cabal we will be using to talk to the +-- Setup.hs interface for this package. +-- +-- This depends somewhat on the 'SetupScriptStyle' but most cases are a result +-- of what the solver picked for us, based on the explicit setup deps or the +-- ones added implicitly by 'defaultSetupDeps'. +-- +packageSetupScriptSpecVersion :: SetupScriptStyle + -> PD.PackageDescription + -> Graph.Graph NonSetupLibDepSolverPlanPackage + -> ComponentDeps [SolverId] + -> Version + +-- We're going to be using the internal Cabal library, so the spec version of +-- that is simply the version of the Cabal library that cabal-install has been +-- built with. +packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ = + cabalVersion + +-- If we happen to be building the Cabal lib itself then because that +-- bootstraps itself then we use the version of the lib we're building. +packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _ + | packageName pkg == cabalPkgname + = packageVersion pkg + +-- In all other cases we have a look at what version of the Cabal lib the +-- solver picked. Or if it didn't depend on Cabal at all (which is very rare) +-- then we look at the .cabal file to see what spec version it declares. +packageSetupScriptSpecVersion _ pkg libDepGraph deps = + case find ((cabalPkgname ==) . packageName) setupLibDeps of + Just dep -> packageVersion dep + Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg)) + where + setupLibDeps = map packageId $ fromMaybe [] $ + Graph.closure libDepGraph (CD.setupDeps deps) + + +cabalPkgname, basePkgname :: PackageName +cabalPkgname = mkPackageName "Cabal" +basePkgname = mkPackageName "base" + + +legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] +legacyCustomSetupPkgs compiler (Platform _ os) = + map mkPackageName $ + [ "array", "base", "binary", "bytestring", "containers" + , "deepseq", "directory", "filepath", "pretty" + , "process", "time", "transformers" ] + ++ [ "Win32" | os == Windows ] + ++ [ "unix" | os /= Windows ] + ++ [ "ghc-prim" | isGHC ] + ++ [ "template-haskell" | isGHC ] + ++ [ "old-time" | notGHC710 ] + where + isGHC = compilerCompatFlavor GHC compiler + notGHC710 = case compilerCompatVersion GHC compiler of + Nothing -> False + Just v -> v <= mkVersion [7,9] + +-- The other aspects of our Setup.hs policy lives here where we decide on +-- the 'SetupScriptOptions'. +-- +-- Our current policy for the 'SetupCustomImplicitDeps' case is that we +-- try to make the implicit deps cover everything, and we don't allow the +-- compiler to pick up other deps. This may or may not be sustainable, and +-- we might have to allow the deps to be non-exclusive, but that itself would +-- be tricky since we would have to allow the Setup access to all the packages +-- in the store and local dbs. + +setupHsScriptOptions :: ElaboratedReadyPackage + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> DistDirLayout + -> FilePath + -> FilePath + -> Bool + -> Lock + -> SetupScriptOptions +-- TODO: Fix this so custom is a separate component. Custom can ALWAYS +-- be a separate component!!! +setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + plan ElaboratedSharedConfig{..} distdir srcdir builddir + isParallelBuild cacheLock = + SetupScriptOptions { + useCabalVersion = thisVersion elabSetupScriptCliVersion, + useCabalSpecVersion = Just elabSetupScriptCliVersion, + useCompiler = Just pkgConfigCompiler, + usePlatform = Just pkgConfigPlatform, + usePackageDB = elabSetupPackageDBStack, + usePackageIndex = Nothing, + useDependencies = [ (uid, srcid) + | ConfiguredId srcid (Just (CLibName LMainLibName)) uid + <- elabSetupDependencies elab ], + useDependenciesExclusive = True, + useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, + useProgramDb = pkgConfigCompilerProgs, + useDistPref = builddir, + useLoggingHandle = Nothing, -- this gets set later + useWorkingDir = Just srcdir, + useExtraPathEnv = elabExeDependencyPaths elab, + useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan, + useWin32CleanHack = False, --TODO: [required eventually] + forceExternalSetupMethod = isParallelBuild, + setupCacheLock = Just cacheLock, + isInteractive = False + } + + +-- | To be used for the input for elaborateInstallPlan. +-- +-- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. +-- +userInstallDirTemplates :: Compiler + -> IO InstallDirs.InstallDirTemplates +userInstallDirTemplates compiler = do + InstallDirs.defaultInstallDirs + (compilerFlavor compiler) + True -- user install + False -- unused + +storePackageInstallDirs :: StoreDirLayout + -> CompilerId + -> InstalledPackageId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs storeDirLayout compid ipkgid = + storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid + +storePackageInstallDirs' :: StoreDirLayout + -> CompilerId + -> UnitId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs' StoreDirLayout{ storePackageDirectory + , storeDirectory } + compid unitid = + InstallDirs.InstallDirs {..} + where + store = storeDirectory compid + prefix = storePackageDirectory compid unitid + bindir = prefix "bin" + libdir = prefix "lib" + libsubdir = "" + -- Note: on macOS, we place libraries into + -- @store/lib@ to work around the load + -- command size limit of macOSs mach-o linker. + -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ + dynlibdir | buildOS == OSX = store "lib" + | otherwise = libdir + flibdir = libdir + libexecdir = prefix "libexec" + libexecsubdir= "" + includedir = libdir "include" + datadir = prefix "share" + datasubdir = "" + docdir = datadir "doc" + mandir = datadir "man" + htmldir = docdir "html" + haddockdir = htmldir + sysconfdir = prefix "etc" + + + +computeInstallDirs :: StoreDirLayout + -> InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> InstallDirs.InstallDirs FilePath +computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab + | elabBuildStyle elab == BuildInplaceOnly + -- use the ordinary default install dirs + = (InstallDirs.absoluteInstallDirs + (elabPkgSourceId elab) + (elabUnitId elab) + (compilerInfo (pkgConfigCompiler elaboratedShared)) + InstallDirs.NoCopyDest + (pkgConfigPlatform elaboratedShared) + defaultInstallDirs) { + + -- absoluteInstallDirs sets these as 'undefined' but we have + -- to use them as "Setup.hs configure" args + InstallDirs.libsubdir = "", + InstallDirs.libexecsubdir = "", + InstallDirs.datasubdir = "" + } + + | otherwise + -- use special simplified install dirs + = storePackageInstallDirs' + storeDirLayout + (compilerId (pkgConfigCompiler elaboratedShared)) + (elabUnitId elab) + + +--TODO: [code cleanup] perhaps reorder this code +-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, +-- make the various Setup.hs {configure,build,copy} flags + + +setupHsConfigureFlags :: ElaboratedReadyPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ConfigFlags +setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + sharedConfig@ElaboratedSharedConfig{..} + verbosity builddir = + sanityCheckElaboratedConfiguredPackage sharedConfig elab + (Cabal.ConfigFlags {..}) + where + configArgs = mempty -- unused, passed via args + configDistPref = toFlag builddir + configCabalFilePath = mempty + configVerbosity = toFlag verbosity + + configInstantiateWith = Map.toList elabInstantiatedWith + + configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese + configIPID = case elabPkgOrComp of + ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg)) + ElabComponent _ -> mempty + configCID = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent _ -> toFlag elabComponentId + + configProgramPaths = Map.toList elabProgramPaths + configProgramArgs + | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True + -- workaround for + -- + -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. + -- custom Setup.hs scripts calling out to GHC even when going via + -- @runProgram ghcProgram@, as e.g. happy does in its + -- + -- (see also ) + -- + -- So for now, let's pass the rather harmless and idempotent + -- `-hide-all-packages` flag to all invocations (which has + -- the benefit that every GHC invocation starts with a + -- conistently well-defined clean slate) until we find a + -- better way. + = Map.toList $ + Map.insertWith (++) "ghc" ["-hide-all-packages"] + elabProgramArgs + | otherwise = Map.toList elabProgramArgs + configProgramPathExtra = toNubList elabProgramPathExtra + configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcPath = mempty -- we use configProgramPaths instead + configHcPkg = mempty -- we use configProgramPaths instead + + configVanillaLib = toFlag elabVanillaLib + configSharedLib = toFlag elabSharedLib + configStaticLib = toFlag elabStaticLib + + configDynExe = toFlag elabDynExe + configFullyStaticExe = toFlag elabFullyStaticExe + configGHCiLib = toFlag elabGHCiLib + configProfExe = mempty + configProfLib = toFlag elabProfLib + configProf = toFlag elabProfExe + + -- configProfDetail is for exe+lib, but overridden by configProfLibDetail + -- so we specify both so we can specify independently + configProfDetail = toFlag elabProfExeDetail + configProfLibDetail = toFlag elabProfLibDetail + + configCoverage = toFlag elabCoverage + configLibCoverage = mempty + + configOptimization = toFlag elabOptimization + configSplitSections = toFlag elabSplitSections + configSplitObjs = toFlag elabSplitObjs + configStripExes = toFlag elabStripExes + configStripLibs = toFlag elabStripLibs + configDebugInfo = toFlag elabDebugInfo + + configConfigurationsFlags = elabFlagAssignment + configConfigureArgs = elabConfigureScriptArgs + configExtraLibDirs = elabExtraLibDirs + configExtraFrameworkDirs = elabExtraFrameworkDirs + configExtraIncludeDirs = elabExtraIncludeDirs + configProgPrefix = maybe mempty toFlag elabProgPrefix + configProgSuffix = maybe mempty toFlag elabProgSuffix + + configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) + elabInstallDirs + + -- we only use configDependencies, unless we're talking to an old Cabal + -- in which case we use configConstraints + -- NB: This does NOT use InstallPlan.depends, which includes executable + -- dependencies which should NOT be fed in here (also you don't have + -- enough info anyway) + configDependencies = [ GivenComponent + (packageName srcid) + ln + cid + | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab + , let ln = case mb_cn + of Just (CLibName lname) -> lname + Just _ -> error "non-library dependency" + Nothing -> LMainLibName + ] + configConstraints = + case elabPkgOrComp of + ElabPackage _ -> + [ thisPackageVersionConstraint srcid + | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] + ElabComponent _ -> [] + + + -- explicitly clear, then our package db stack + -- TODO: [required eventually] have to do this differently for older Cabal versions + configPackageDBs = Nothing : map Just elabBuildPackageDBStack + + configTests = case elabPkgOrComp of + ElabPackage pkg -> toFlag (TestStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + configBenchmarks = case elabPkgOrComp of + ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + + configExactConfiguration = toFlag True + configFlagError = mempty --TODO: [research required] appears not to be implemented + configRelocatable = mempty --TODO: [research required] ??? + configScratchDir = mempty -- never use + configUserInstall = mempty -- don't rely on defaults + configPrograms_ = mempty -- never use, shouldn't exist + configUseResponseFiles = mempty + configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler + +setupHsConfigureArgs :: ElaboratedConfiguredPackage + -> [String] +setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] +setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = + [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] + where + cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") + (compComponentName comp) + +setupHsBuildFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BuildFlags +setupHsBuildFlags _ _ verbosity builddir = + Cabal.BuildFlags { + buildProgramPaths = mempty, --unused, set at configure time + buildProgramArgs = mempty, --unused, set at configure time + buildVerbosity = toFlag verbosity, + buildDistPref = toFlag builddir, + buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), + buildArgs = mempty, -- unused, passed via args not flags + buildCabalFilePath= mempty + } + + +setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] +setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) + -- Fix for #3335, don't pass build arguments if it's not supported + | elabSetupScriptCliVersion elab >= mkVersion [1,17] + = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) + | otherwise + = [] +setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) + = [] + + +setupHsTestFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags + { testDistPref = toFlag builddir + , testVerbosity = toFlag verbosity + , testMachineLog = maybe mempty toFlag elabTestMachineLog + , testHumanLog = maybe mempty toFlag elabTestHumanLog + , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails + , testKeepTix = toFlag elabTestKeepTix + , testWrapper = maybe mempty toFlag elabTestWrapper + , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites + , testOptions = elabTestTestOptions + } + +setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] +-- TODO: Does the issue #3335 affects test as well +setupHsTestArgs elab = + mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) + + +setupHsBenchFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BenchmarkFlags +setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags + { benchmarkDistPref = toFlag builddir + , benchmarkVerbosity = toFlag verbosity + , benchmarkOptions = elabBenchmarkOptions + } + +setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] +setupHsBenchArgs elab = + mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) + + +setupHsReplFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ReplFlags +setupHsReplFlags _ sharedConfig verbosity builddir = + Cabal.ReplFlags { + replProgramPaths = mempty, --unused, set at configure time + replProgramArgs = mempty, --unused, set at configure time + replVerbosity = toFlag verbosity, + replDistPref = toFlag builddir, + replReload = mempty, --only used as callback from repl + replReplOptions = pkgConfigReplOptions sharedConfig --runtime override for repl flags + } + + +setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] +setupHsReplArgs elab = + maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) + --TODO: should be able to give multiple modules in one component + + +setupHsCopyFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.CopyFlags +setupHsCopyFlags _ _ verbosity builddir destdir = + Cabal.CopyFlags { + copyArgs = [], -- TODO: could use this to only copy what we enabled + copyDest = toFlag (InstallDirs.CopyTo destdir), + copyDistPref = toFlag builddir, + copyVerbosity = toFlag verbosity, + copyCabalFilePath = mempty + } + +setupHsRegisterFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.RegisterFlags +setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ + verbosity builddir pkgConfFile = + Cabal.RegisterFlags { + regPackageDB = mempty, -- misfeature + regGenScript = mempty, -- never use + regGenPkgConf = toFlag (Just pkgConfFile), + regInPlace = case elabBuildStyle of + BuildInplaceOnly -> toFlag True + _ -> toFlag False, + regPrintId = mempty, -- never use + regDistPref = toFlag builddir, + regArgs = [], + regVerbosity = toFlag verbosity, + regCabalFilePath = mempty + } + +setupHsHaddockFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.HaddockFlags +setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = + Cabal.HaddockFlags { + haddockProgramPaths = mempty, --unused, set at configure time + haddockProgramArgs = mempty, --unused, set at configure time + haddockHoogle = toFlag elabHaddockHoogle, + haddockHtml = toFlag elabHaddockHtml, + haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, + haddockForHackage = toFlag elabHaddockForHackage, + haddockForeignLibs = toFlag elabHaddockForeignLibs, + haddockExecutables = toFlag elabHaddockExecutables, + haddockTestSuites = toFlag elabHaddockTestSuites, + haddockBenchmarks = toFlag elabHaddockBenchmarks, + haddockInternal = toFlag elabHaddockInternal, + haddockCss = maybe mempty toFlag elabHaddockCss, + haddockLinkedSource = toFlag elabHaddockLinkedSource, + haddockQuickJump = toFlag elabHaddockQuickJump, + haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, + haddockContents = maybe mempty toFlag elabHaddockContents, + haddockDistPref = toFlag builddir, + haddockKeepTempFiles = mempty, --TODO: from build settings + haddockVerbosity = toFlag verbosity, + haddockCabalFilePath = mempty, + haddockArgs = mempty + } + +setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] +-- TODO: Does the issue #3335 affects test as well +setupHsHaddockArgs elab = + map (showComponentTarget (packageId elab)) (elabHaddockTargets elab) + +{- +setupHsTestFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags _ _ verbosity builddir = + Cabal.TestFlags { + } +-} + +------------------------------------------------------------------------------ +-- * Sharing installed packages +------------------------------------------------------------------------------ + +-- +-- Nix style store management for tarball packages +-- +-- So here's our strategy: +-- +-- We use a per-user nix-style hashed store, but /only/ for tarball packages. +-- So that includes packages from hackage repos (and other http and local +-- tarballs). For packages in local directories we do not register them into +-- the shared store by default, we just build them locally inplace. +-- +-- The reason we do it like this is that it's easy to make stable hashes for +-- tarball packages, and these packages benefit most from sharing. By contrast +-- unpacked dir packages are harder to hash and they tend to change more +-- frequently so there's less benefit to sharing them. +-- +-- When using the nix store approach we have to run the solver *without* +-- looking at the packages installed in the store, just at the source packages +-- (plus core\/global installed packages). Then we do a post-processing pass +-- to replace configured packages in the plan with pre-existing ones, where +-- possible. Where possible of course means where the nix-style package hash +-- equals one that's already in the store. +-- +-- One extra wrinkle is that unless we know package tarball hashes upfront, we +-- will have to download the tarballs to find their hashes. So we have two +-- options: delay replacing source with pre-existing installed packages until +-- the point during the execution of the install plan where we have the +-- tarball, or try to do as much up-front as possible and then check again +-- during plan execution. The former isn't great because we would end up +-- telling users we're going to re-install loads of packages when in fact we +-- would just share them. It'd be better to give as accurate a prediction as +-- we can. The latter is better for users, but we do still have to check +-- during plan execution because it's important that we don't replace existing +-- installed packages even if they have the same package hash, because we +-- don't guarantee ABI stability. + +-- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but +-- not replace installed packages with ghc-pkg. + +packageHashInputs :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashInputs +packageHashInputs + pkgshared + elab@(ElaboratedConfiguredPackage { + elabPkgSourceHash = Just srchash + }) = + PackageHashInputs { + pkgHashPkgId = packageId elab, + pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp), + pkgHashSourceHash = srchash, + pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab), + pkgHashDirectDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList $ + [ confInstId dep + | dep <- CD.select relevantDeps pkgLibDependencies ] ++ + [ confInstId dep + | dep <- CD.select relevantDeps pkgExeDependencies ] + ElabComponent comp -> + Set.fromList (map confInstId (compLibDependencies comp + ++ compExeDependencies comp)), + pkgHashOtherConfig = packageHashConfigInputs pkgshared elab + } + where + -- Obviously the main deps are relevant + relevantDeps CD.ComponentLib = True + relevantDeps (CD.ComponentSubLib _) = True + relevantDeps (CD.ComponentFLib _) = True + relevantDeps (CD.ComponentExe _) = True + -- Setup deps can affect the Setup.hs behaviour and thus what is built + relevantDeps CD.ComponentSetup = True + -- However testsuites and benchmarks do not get installed and should not + -- affect the result, so we do not include them. + relevantDeps (CD.ComponentTest _) = False + relevantDeps (CD.ComponentBench _) = False + +packageHashInputs _ pkg = + error $ "packageHashInputs: only for packages with source hashes. " + ++ prettyShow (packageId pkg) + +packageHashConfigInputs :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashConfigInputs +packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = + PackageHashConfigInputs { + pkgHashCompilerId = compilerId pkgConfigCompiler, + pkgHashPlatform = pkgConfigPlatform, + pkgHashFlagAssignment = elabFlagAssignment, + pkgHashConfigureScriptArgs = elabConfigureScriptArgs, + pkgHashVanillaLib = elabVanillaLib, + pkgHashSharedLib = elabSharedLib, + pkgHashDynExe = elabDynExe, + pkgHashFullyStaticExe = elabFullyStaticExe, + pkgHashGHCiLib = elabGHCiLib, + pkgHashProfLib = elabProfLib, + pkgHashProfExe = elabProfExe, + pkgHashProfLibDetail = elabProfLibDetail, + pkgHashProfExeDetail = elabProfExeDetail, + pkgHashCoverage = elabCoverage, + pkgHashOptimization = elabOptimization, + pkgHashSplitSections = elabSplitSections, + pkgHashSplitObjs = elabSplitObjs, + pkgHashStripLibs = elabStripLibs, + pkgHashStripExes = elabStripExes, + pkgHashDebugInfo = elabDebugInfo, + pkgHashProgramArgs = elabProgramArgs, + pkgHashExtraLibDirs = elabExtraLibDirs, + pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, + pkgHashExtraIncludeDirs = elabExtraIncludeDirs, + pkgHashProgPrefix = elabProgPrefix, + pkgHashProgSuffix = elabProgSuffix, + + pkgHashDocumentation = elabBuildHaddocks, + pkgHashHaddockHoogle = elabHaddockHoogle, + pkgHashHaddockHtml = elabHaddockHtml, + pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation, + pkgHashHaddockForeignLibs = elabHaddockForeignLibs, + pkgHashHaddockExecutables = elabHaddockExecutables, + pkgHashHaddockTestSuites = elabHaddockTestSuites, + pkgHashHaddockBenchmarks = elabHaddockBenchmarks, + pkgHashHaddockInternal = elabHaddockInternal, + pkgHashHaddockCss = elabHaddockCss, + pkgHashHaddockLinkedSource = elabHaddockLinkedSource, + pkgHashHaddockQuickJump = elabHaddockQuickJump, + pkgHashHaddockContents = elabHaddockContents + } + where + ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg + +-- | Given the 'InstalledPackageIndex' for a nix-style package store, and an +-- 'ElaboratedInstallPlan', replace configured source packages by installed +-- packages from the store whenever they exist. +-- +improveInstallPlanWithInstalledPackages :: Set UnitId + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan +improveInstallPlanWithInstalledPackages installedPkgIdSet = + InstallPlan.installed canPackageBeImproved + where + canPackageBeImproved pkg = + installedUnitId pkg `Set.member` installedPkgIdSet + --TODO: sanity checks: + -- * the installed package must have the expected deps etc + -- * the installed package must not be broken, valid dep closure + + --TODO: decide what to do if we encounter broken installed packages, + -- since overwriting is never safe. + + +-- Path construction +------ + +-- | The path to the directory that contains a specific executable. +-- NB: For inplace NOT InstallPaths.bindir installDirs; for an +-- inplace build those values are utter nonsense. So we +-- have to guess where the directory is going to be. +-- Fortunately this is "stable" part of Cabal API. +-- But the way we get the build directory is A HORRIBLE +-- HACK. +binDirectoryFor + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> FilePath + -> FilePath +binDirectoryFor layout config package exe = case elabBuildStyle package of + BuildAndInstall -> installedBinDirectory package + BuildInplaceOnly -> inplaceBinRoot layout config package exe + +-- package has been built and installed. +installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath +installedBinDirectory = InstallDirs.bindir . elabInstallDirs + +-- | The path to the @build@ directory for an inplace build. +inplaceBinRoot + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> FilePath +inplaceBinRoot layout config package + = distBuildDirectory layout (elabDistDirParams config package) + "build" diff --git a/src/Distribution/Client/ProjectPlanning/Types.hs b/src/Distribution/Client/ProjectPlanning/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/ProjectPlanning/Types.hs @@ -0,0 +1,851 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Types used while planning how to build everything in a project. +-- +-- Primarily this is the 'ElaboratedInstallPlan'. +-- +module Distribution.Client.ProjectPlanning.Types ( + SolverInstallPlan, + + -- * Elaborated install plan types + ElaboratedInstallPlan, + normaliseConfiguredPackage, + ElaboratedConfiguredPackage(..), + + elabDistDirParams, + elabExeDependencyPaths, + elabLibDependencies, + elabOrderLibDependencies, + elabExeDependencies, + elabOrderExeDependencies, + elabSetupDependencies, + elabPkgConfigDependencies, + elabInplaceDependencyBuildCacheFiles, + elabRequiresRegistration, + dataDirsEnvironmentForPlan, + + elabPlanPackageName, + elabConfiguredName, + elabComponentName, + + ElaboratedPackageOrComponent(..), + ElaboratedComponent(..), + ElaboratedPackage(..), + pkgOrderDependencies, + ElaboratedPlanPackage, + ElaboratedSharedConfig(..), + ElaboratedReadyPackage, + BuildStyle(..), + CabalFileText, + + -- * Build targets + ComponentTarget(..), + showComponentTarget, + showTestComponentTarget, + showBenchComponentTarget, + SubComponentTarget(..), + + isSubLibComponentTarget, + isForeignLibComponentTarget, + isExeComponentTarget, + isTestComponentTarget, + isBenchComponentTarget, + + componentOptionalStanza, + + -- * Setup script + SetupScriptStyle(..), + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.TargetSelector + ( SubComponentTarget(..) ) +import Distribution.Client.PackageHash + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( GenericInstallPlan, GenericPlanPackage(..) ) +import Distribution.Client.SolverInstallPlan + ( SolverInstallPlan ) +import Distribution.Client.DistDirLayout + +import Distribution.Backpack +import Distribution.Backpack.ModuleShape + +import Distribution.Verbosity (normal) +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PkgconfigVersion +import Distribution.Types.PackageDescription (PackageDescription(..)) +import Distribution.Package +import Distribution.System +import qualified Distribution.PackageDescription as Cabal +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.Compiler +import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) +import qualified Distribution.Simple.BuildTarget as Cabal +import Distribution.Simple.Program +import Distribution.ModuleName (ModuleName) +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), LibraryName(..) ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.InstallDirs (PathTemplate) +import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) +import Distribution.Version + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Simple.Utils (ordNub) + +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Monoid as Mon +import System.FilePath (()) + + +-- | The combination of an elaborated install plan plus a +-- 'ElaboratedSharedConfig' contains all the details necessary to be able +-- to execute the plan without having to make further policy decisions. +-- +-- It does not include dynamic elements such as resources (such as http +-- connections). +-- +type ElaboratedInstallPlan + = GenericInstallPlan InstalledPackageInfo + ElaboratedConfiguredPackage + +type ElaboratedPlanPackage + = GenericPlanPackage InstalledPackageInfo + ElaboratedConfiguredPackage + +-- | User-friendly display string for an 'ElaboratedPlanPackage'. +elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String +elabPlanPackageName verbosity (PreExisting ipkg) + | verbosity <= normal = prettyShow (packageName ipkg) + | otherwise = prettyShow (installedUnitId ipkg) +elabPlanPackageName verbosity (Configured elab) + = elabConfiguredName verbosity elab +elabPlanPackageName verbosity (Installed elab) + = elabConfiguredName verbosity elab + +--TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle +-- even platform and compiler could be different if we're building things +-- like a server + client with ghc + ghcjs +data ElaboratedSharedConfig + = ElaboratedSharedConfig { + + pkgConfigPlatform :: Platform, + pkgConfigCompiler :: Compiler, --TODO: [code cleanup] replace with CompilerInfo + -- | The programs that the compiler configured (e.g. for GHC, the progs + -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are + -- used. + pkgConfigCompilerProgs :: ProgramDb, + pkgConfigReplOptions :: [String] + } + deriving (Show, Generic, Typeable) + --TODO: [code cleanup] no Eq instance + +instance Binary ElaboratedSharedConfig +instance Structured ElaboratedSharedConfig + +data ElaboratedConfiguredPackage + = ElaboratedConfiguredPackage { + -- | The 'UnitId' which uniquely identifies this item in a build plan + elabUnitId :: UnitId, + + elabComponentId :: ComponentId, + elabInstantiatedWith :: Map ModuleName Module, + elabLinkedInstantiatedWith :: Map ModuleName OpenModule, + + -- | This is true if this is an indefinite package, or this is a + -- package with no signatures. (Notably, it's not true for instantiated + -- packages.) The motivation for this is if you ask to build + -- @foo-indef@, this probably means that you want to typecheck + -- it, NOT that you want to rebuild all of the various + -- instantiations of it. + elabIsCanonical :: Bool, + + -- | The 'PackageId' of the originating package + elabPkgSourceId :: PackageId, + + -- | Shape of the package/component, for Backpack. + elabModuleShape :: ModuleShape, + + -- | A total flag assignment for the package. + -- TODO: Actually this can be per-component if we drop + -- all flags that don't affect a component. + elabFlagAssignment :: Cabal.FlagAssignment, + + -- | The original default flag assignment, used only for reporting. + elabFlagDefaults :: Cabal.FlagAssignment, + + elabPkgDescription :: Cabal.PackageDescription, + + -- | Where the package comes from, e.g. tarball, local dir etc. This + -- is not the same as where it may be unpacked to for the build. + elabPkgSourceLocation :: PackageLocation (Maybe FilePath), + + -- | The hash of the source, e.g. the tarball. We don't have this for + -- local source dir packages. + elabPkgSourceHash :: Maybe PackageSourceHash, + + -- | Is this package one of the ones specified by location in the + -- project file? (As opposed to a dependency, or a named package pulled + -- in) + elabLocalToProject :: Bool, + + -- | Are we going to build and install this package to the store, or are + -- we going to build it and register it locally. + elabBuildStyle :: BuildStyle, + + -- | Another way of phrasing 'pkgStanzasAvailable'. + elabEnabledSpec :: ComponentRequestedSpec, + + -- | Which optional stanzas (ie testsuites, benchmarks) can be built. + -- This means the solver produced a plan that has them available. + -- This doesn't necessary mean we build them by default. + elabStanzasAvailable :: OptionalStanzaSet, + + -- | Which optional stanzas the user explicitly asked to enable or + -- to disable. This tells us which ones we build by default, and + -- helps with error messages when the user asks to build something + -- they explicitly disabled. + -- + -- TODO: The 'Bool' here should be refined into an ADT with three + -- cases: NotRequested, ExplicitlyRequested and + -- ImplicitlyRequested. A stanza is explicitly requested if + -- the user asked, for this *specific* package, that the stanza + -- be enabled; it's implicitly requested if the user asked for + -- all global packages to have this stanza enabled. The + -- difference between an explicit and implicit request is + -- error reporting behavior: if a user asks for tests to be + -- enabled for a specific package that doesn't have any tests, + -- we should warn them about it, but we shouldn't complain + -- that a user enabled tests globally, and some local packages + -- just happen not to have any tests. (But perhaps we should + -- warn if ALL local packages don't have any tests.) + elabStanzasRequested :: OptionalStanzaMap (Maybe Bool), + + elabSetupPackageDBStack :: PackageDBStack, + elabBuildPackageDBStack :: PackageDBStack, + elabRegisterPackageDBStack :: PackageDBStack, + + elabInplaceSetupPackageDBStack :: PackageDBStack, + elabInplaceBuildPackageDBStack :: PackageDBStack, + elabInplaceRegisterPackageDBStack :: PackageDBStack, + + elabPkgDescriptionOverride :: Maybe CabalFileText, + + -- TODO: make per-component variants of these flags + elabVanillaLib :: Bool, + elabSharedLib :: Bool, + elabStaticLib :: Bool, + elabDynExe :: Bool, + elabFullyStaticExe :: Bool, + elabGHCiLib :: Bool, + elabProfLib :: Bool, + elabProfExe :: Bool, + elabProfLibDetail :: ProfDetailLevel, + elabProfExeDetail :: ProfDetailLevel, + elabCoverage :: Bool, + elabOptimization :: OptimisationLevel, + elabSplitObjs :: Bool, + elabSplitSections :: Bool, + elabStripLibs :: Bool, + elabStripExes :: Bool, + elabDebugInfo :: DebugInfoLevel, + + elabProgramPaths :: Map String FilePath, + elabProgramArgs :: Map String [String], + elabProgramPathExtra :: [FilePath], + elabConfigureScriptArgs :: [String], + elabExtraLibDirs :: [FilePath], + elabExtraFrameworkDirs :: [FilePath], + elabExtraIncludeDirs :: [FilePath], + elabProgPrefix :: Maybe PathTemplate, + elabProgSuffix :: Maybe PathTemplate, + + elabInstallDirs :: InstallDirs.InstallDirs FilePath, + + elabHaddockHoogle :: Bool, + elabHaddockHtml :: Bool, + elabHaddockHtmlLocation :: Maybe String, + elabHaddockForeignLibs :: Bool, + elabHaddockForHackage :: HaddockTarget, + elabHaddockExecutables :: Bool, + elabHaddockTestSuites :: Bool, + elabHaddockBenchmarks :: Bool, + elabHaddockInternal :: Bool, + elabHaddockCss :: Maybe FilePath, + elabHaddockLinkedSource :: Bool, + elabHaddockQuickJump :: Bool, + elabHaddockHscolourCss :: Maybe FilePath, + elabHaddockContents :: Maybe PathTemplate, + + elabTestMachineLog :: Maybe PathTemplate, + elabTestHumanLog :: Maybe PathTemplate, + elabTestShowDetails :: Maybe TestShowDetails, + elabTestKeepTix :: Bool, + elabTestWrapper :: Maybe FilePath, + elabTestFailWhenNoTestSuites :: Bool, + elabTestTestOptions :: [PathTemplate], + + elabBenchmarkOptions :: [PathTemplate], + + -- Setup.hs related things: + + -- | One of four modes for how we build and interact with the Setup.hs + -- script, based on whether it's a build-type Custom, with or without + -- explicit deps and the cabal spec version the .cabal file needs. + elabSetupScriptStyle :: SetupScriptStyle, + + -- | The version of the Cabal command line interface that we are using + -- for this package. This is typically the version of the Cabal lib + -- that the Setup.hs is built against. + -- + -- TODO: We might want to turn this into a enum, + -- yet different enum than 'CabalSpecVersion'. + elabSetupScriptCliVersion :: Version, + + -- Build time related: + elabConfigureTargets :: [ComponentTarget], + elabBuildTargets :: [ComponentTarget], + elabTestTargets :: [ComponentTarget], + elabBenchTargets :: [ComponentTarget], + elabReplTarget :: Maybe ComponentTarget, + elabHaddockTargets :: [ComponentTarget], + + elabBuildHaddocks :: Bool, + + --pkgSourceDir ? -- currently passed in later because they can use temp locations + --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc + + -- | Component/package specific information + elabPkgOrComp :: ElaboratedPackageOrComponent + } + deriving (Eq, Show, Generic, Typeable) + +normaliseConfiguredPackage :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> ElaboratedConfiguredPackage +normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = + pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) } + where + knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs + + pkgDesc :: PackageDescription + pkgDesc = elabPkgDescription pkg + + removeEmpty :: [String] -> Maybe [String] + removeEmpty [] = Nothing + removeEmpty xs = Just xs + + lookupFilter :: String -> [String] -> Maybe [String] + lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of + Just p -> programNormaliseArgs p (getVersion p) pkgDesc args + Nothing -> args + + getVersion :: Program -> Maybe Version + getVersion p = lookupProgram p knownProgramDb >>= programVersion + +-- | The package/component contains/is a library and so must be registered +elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool +elabRequiresRegistration elab = + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Just cn -> is_lib cn && build_target + _ -> False + ElabPackage pkg -> + -- Tricky! Not only do we have to test if the user selected + -- a library as a build target, we also have to test if + -- the library was TRANSITIVELY depended upon, since we will + -- also require a register in this case. + -- + -- NB: It would have been far nicer to just unconditionally + -- register in all cases, but some Custom Setups will fall + -- over if you try to do that, ESPECIALLY if there actually is + -- a library but they hadn't built it. + -- + -- However, as the case of `cpphs-1.20.8` has shown in + -- #5379, in cases when a monolithic package gets + -- installed due to its executable components + -- (i.e. exe:cpphs) into the store we *have* to register + -- if there's a buildable public library (i.e. lib:cpphs) + -- that was built and installed into the same store folder + -- as otherwise this will cause build failures once a + -- target actually depends on lib:cpphs. + build_target || (elabBuildStyle elab == BuildAndInstall && + Cabal.hasPublicLib (elabPkgDescription elab)) + -- the next sub-condition below is currently redundant + -- (see discussion in #5604 for more details), but it's + -- being kept intentionally here as a safeguard because if + -- internal libraries ever start working with + -- non-per-component builds this condition won't be + -- redundant anymore. + || any (depends_on_lib pkg) (elabBuildTargets elab) + where + depends_on_lib pkg (ComponentTarget cn _) = + not (null (CD.select (== CD.componentNameToComponent cn) + (pkgDependsOnSelfLib pkg))) + build_target = + if not (null (elabBuildTargets elab)) + then any is_lib_target (elabBuildTargets elab) + -- Empty build targets mean we build /everything/; + -- that means we have to look more carefully to see + -- if there is anything to register + else Cabal.hasLibs (elabPkgDescription elab) + -- NB: this means we DO NOT reregister if you just built a + -- single file + is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn + is_lib_target _ = False + is_lib (CLibName _) = True + is_lib _ = False + +-- | Construct the environment needed for the data files to work. +-- This consists of a separate @*_datadir@ variable for each +-- inplace package in the plan. +dataDirsEnvironmentForPlan :: DistDirLayout + -> ElaboratedInstallPlan + -> [(String, Maybe FilePath)] +dataDirsEnvironmentForPlan distDirLayout = catMaybes + . fmap (InstallPlan.foldPlanPackage + (const Nothing) + (dataDirEnvVarForPackage distDirLayout)) + . InstallPlan.toList + +-- | Construct an environment variable that points +-- the package's datadir to its correct location. +-- This might be: +-- * 'Just' the package's source directory plus the data subdirectory +-- for inplace packages. +-- * 'Nothing' for packages installed in the store (the path was +-- already included in the package at install/build time). +dataDirEnvVarForPackage :: DistDirLayout + -> ElaboratedConfiguredPackage + -> Maybe (String, Maybe FilePath) +dataDirEnvVarForPackage distDirLayout pkg = + case elabBuildStyle pkg + of BuildAndInstall -> Nothing + BuildInplaceOnly -> Just + ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" + , Just $ srcPath (elabPkgSourceLocation pkg) + dataDir (elabPkgDescription pkg)) + where + srcPath (LocalUnpackedPackage path) = path + srcPath (LocalTarballPackage _path) = unpackedPath + srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath + srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath + srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout + -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc + srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error + "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" + unpackedPath = + distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg + +instance Package ElaboratedConfiguredPackage where + packageId = elabPkgSourceId + +instance HasConfiguredId ElaboratedConfiguredPackage where + configuredId elab = + ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab) + +instance HasUnitId ElaboratedConfiguredPackage where + installedUnitId = elabUnitId + +instance IsNode ElaboratedConfiguredPackage where + type Key ElaboratedConfiguredPackage = UnitId + nodeKey = elabUnitId + nodeNeighbors = elabOrderDependencies + +instance Binary ElaboratedConfiguredPackage +instance Structured ElaboratedConfiguredPackage + +data ElaboratedPackageOrComponent + = ElabPackage ElaboratedPackage + | ElabComponent ElaboratedComponent + deriving (Eq, Show, Generic) + +instance Binary ElaboratedPackageOrComponent +instance Structured ElaboratedPackageOrComponent + +elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName +elabComponentName elab = + case elabPkgOrComp elab of + ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this + ElabComponent comp -> compComponentName comp + +-- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. +elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String +elabConfiguredName verbosity elab + | verbosity <= normal + = (case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> + case compComponentName comp of + Nothing -> "setup from " + Just (CLibName LMainLibName) -> "" + Just cname -> prettyShow cname ++ " from ") + ++ prettyShow (packageId elab) + | otherwise + = prettyShow (elabUnitId elab) + +elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams +elabDistDirParams shared elab = DistDirParams { + distParamUnitId = installedUnitId elab, + distParamComponentId = elabComponentId elab, + distParamPackageId = elabPkgSourceId elab, + distParamComponentName = case elabPkgOrComp elab of + ElabComponent comp -> compComponentName comp + ElabPackage _ -> Nothing, + distParamCompilerId = compilerId (pkgConfigCompiler shared), + distParamPlatform = pkgConfigPlatform shared, + distParamOptimization = elabOptimization elab + } + +-- | The full set of dependencies which dictate what order we +-- need to build things in the install plan: "order dependencies" +-- balls everything together. This is mostly only useful for +-- ordering; if you are, for example, trying to compute what +-- @--dependency@ flags to pass to a Setup script, you need to +-- use 'elabLibDependencies'. This method is the same as +-- 'nodeNeighbors'. +-- +-- NB: this method DOES include setup deps. +elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderDependencies elab = + case elabPkgOrComp elab of + -- Important not to have duplicates: otherwise InstallPlan gets + -- confused. + ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) + ElabComponent comp -> compOrderDependencies comp + +-- | Like 'elabOrderDependencies', but only returns dependencies on +-- libraries. +elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ + ordNub $ CD.flatDeps (pkgLibDependencies pkg) + ElabComponent comp -> compOrderLibDependencies comp + +-- | The library dependencies (i.e., the libraries we depend on, NOT +-- the dependencies of the library), NOT including setup dependencies. +-- These are passed to the @Setup@ script via @--dependency@. +elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) + ElabComponent comp -> compLibDependencies comp + +-- | Like 'elabOrderDependencies', but only returns dependencies on +-- executables. (This coincides with 'elabExeDependencies'.) +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderExeDependencies = + map newSimpleUnitId . elabExeDependencies + +-- | The executable dependencies (i.e., the executables we depend on); +-- these are the executables we must add to the PATH before we invoke +-- the setup script. +elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] +elabExeDependencies elab = map confInstId $ + case elabPkgOrComp elab of + ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp + +-- | This returns the paths of all the executables we depend on; we +-- must add these paths to PATH before invoking the setup script. +-- (This is usually what you want, not 'elabExeDependencies', if you +-- actually want to build something.) +elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] +elabExeDependencyPaths elab = + case elabPkgOrComp elab of + ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabComponent comp -> map snd (compExeDependencyPaths comp) + +-- | The setup dependencies (the library dependencies of the setup executable; +-- note that it is not legal for setup scripts to have executable +-- dependencies at the moment.) +elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabSetupDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] + +elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] +elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } + = pkgPkgConfigDependencies pkg +elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } + = compPkgConfigDependencies comp + +-- | The cache files of all our inplace dependencies which, +-- when updated, require us to rebuild. See #4202 for +-- more details. Essentially, this is a list of filepaths +-- that, if our dependencies get rebuilt, will themselves +-- get updated. +-- +-- Note: the hash of these cache files gets built into +-- the build cache ourselves, which means that we end +-- up tracking transitive dependencies! +-- +-- Note: This tracks the "build" cache file, but not +-- "registration" or "config" cache files. Why not? +-- Arguably we should... +-- +-- Note: This is a bit of a hack, because it is not really +-- the hashes of the SOURCES of our (transitive) dependencies +-- that we should use to decide whether or not to rebuild, +-- but the output BUILD PRODUCTS. The strategy we use +-- here will never work if we want to implement unchanging +-- rebuilds. +elabInplaceDependencyBuildCacheFiles + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedConfiguredPackage + -> [FilePath] +elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = + go =<< InstallPlan.directDeps plan (nodeKey root_elab) + where + go = InstallPlan.foldPlanPackage (const []) $ \elab -> do + guard (elabBuildStyle elab == BuildInplaceOnly) + return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" + +-- | Some extra metadata associated with an +-- 'ElaboratedConfiguredPackage' which indicates that the "package" +-- in question is actually a single component to be built. Arguably +-- it would be clearer if there were an ADT which branched into +-- package work items and component work items, but I've structured +-- it this way to minimize change to the existing code (which I +-- don't feel qualified to rewrite.) +data ElaboratedComponent + = ElaboratedComponent { + -- | The name of the component to be built according to the solver + compSolverName :: CD.Component, + -- | The name of the component to be built. Nothing if + -- it's a setup dep. + compComponentName :: Maybe ComponentName, + -- | The *external* library dependencies of this component. We + -- pass this to the configure script. + compLibDependencies :: [ConfiguredId], + -- | In a component prior to instantiation, this list specifies + -- the 'OpenUnitId's which, after instantiation, are the + -- actual dependencies of this package. Note that this does + -- NOT include signature packages, which do not turn into real + -- ordering dependencies when we instantiate. This is intended to be + -- a purely temporary field, to carry some information to the + -- instantiation phase. It's more precise than + -- 'compLibDependencies', and also stores information about internal + -- dependencies. + compLinkedLibDependencies :: [OpenUnitId], + -- | The executable dependencies of this component (including + -- internal executables). + compExeDependencies :: [ConfiguredId], + -- | The @pkg-config@ dependencies of the component + compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], + -- | The paths all our executable dependencies will be installed + -- to once they are installed. + compExeDependencyPaths :: [(ConfiguredId, FilePath)], + -- | The UnitIds of the libraries (identifying elaborated packages/ + -- components) that must be built before this project. This + -- is used purely for ordering purposes. It can contain both + -- references to definite and indefinite packages; an indefinite + -- UnitId indicates that we must typecheck that indefinite package + -- before we can build this one. + compOrderLibDependencies :: [UnitId] + } + deriving (Eq, Show, Generic) + +instance Binary ElaboratedComponent +instance Structured ElaboratedComponent + +-- | See 'elabOrderDependencies'. +compOrderDependencies :: ElaboratedComponent -> [UnitId] +compOrderDependencies comp = + compOrderLibDependencies comp + ++ compOrderExeDependencies comp + +-- | See 'elabOrderExeDependencies'. +compOrderExeDependencies :: ElaboratedComponent -> [UnitId] +compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies + +data ElaboratedPackage + = ElaboratedPackage { + pkgInstalledId :: InstalledPackageId, + + -- | The exact dependencies (on other plan packages) + -- + pkgLibDependencies :: ComponentDeps [ConfiguredId], + + -- | Components which depend (transitively) on an internally + -- defined library. These are used by 'elabRequiresRegistration', + -- to determine if a user-requested build is going to need + -- a library registration + -- + pkgDependsOnSelfLib :: ComponentDeps [()], + + -- | Dependencies on executable packages. + -- + pkgExeDependencies :: ComponentDeps [ConfiguredId], + + -- | Paths where executable dependencies live. + -- + pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], + + -- | Dependencies on @pkg-config@ packages. + -- NB: this is NOT per-component (although it could be) + -- because Cabal library does not track per-component + -- pkg-config depends; it always does them all at once. + -- + pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], + + -- | Which optional stanzas (ie testsuites, benchmarks) will actually + -- be enabled during the package configure step. + pkgStanzasEnabled :: OptionalStanzaSet + } + deriving (Eq, Show, Generic) + +instance Binary ElaboratedPackage +instance Structured ElaboratedPackage + +-- | See 'elabOrderDependencies'. This gives the unflattened version, +-- which can be useful in some circumstances. +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] +pkgOrderDependencies pkg = + fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` + fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) + +-- | This is used in the install plan to indicate how the package will be +-- built. +-- +data BuildStyle = + -- | The classic approach where the package is built, then the files + -- installed into some location and the result registered in a package db. + -- + -- If the package came from a tarball then it's built in a temp dir and + -- the results discarded. + BuildAndInstall + + -- | The package is built, but the files are not installed anywhere, + -- rather the build dir is kept and the package is registered inplace. + -- + -- Such packages can still subsequently be installed. + -- + -- Typically 'BuildAndInstall' packages will only depend on other + -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones. + -- + | BuildInplaceOnly + deriving (Eq, Show, Generic) + +instance Binary BuildStyle +instance Structured BuildStyle +instance Semigroup BuildStyle where + BuildInplaceOnly <> _ = BuildInplaceOnly + _ <> BuildInplaceOnly = BuildInplaceOnly + _ <> _ = BuildAndInstall +instance Monoid BuildStyle where + mempty = BuildAndInstall + mappend = (<>) + +type CabalFileText = LBS.ByteString + +type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage + + +--------------------------- +-- Build targets +-- + +-- | Specific targets within a package or component to act on e.g. to build, +-- haddock or open a repl. +-- +data ComponentTarget = ComponentTarget ComponentName SubComponentTarget + deriving (Eq, Ord, Show, Generic) + +instance Binary ComponentTarget +instance Structured ComponentTarget + +-- | Unambiguously render a 'ComponentTarget', e.g., to pass +-- to a Cabal Setup script. +showComponentTarget :: PackageId -> ComponentTarget -> String +showComponentTarget pkgid = + Cabal.showBuildTarget pkgid . toBuildTarget + where + toBuildTarget :: ComponentTarget -> Cabal.BuildTarget + toBuildTarget (ComponentTarget cname subtarget) = + case subtarget of + WholeComponent -> Cabal.BuildTargetComponent cname + ModuleTarget mname -> Cabal.BuildTargetModule cname mname + FileTarget fname -> Cabal.BuildTargetFile cname fname + +showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String +showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n +showTestComponentTarget _ _ = Nothing + +isTestComponentTarget :: ComponentTarget -> Bool +isTestComponentTarget (ComponentTarget (CTestName _) _) = True +isTestComponentTarget _ = False + +showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String +showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n +showBenchComponentTarget _ _ = Nothing + +isBenchComponentTarget :: ComponentTarget -> Bool +isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True +isBenchComponentTarget _ = False + +isForeignLibComponentTarget :: ComponentTarget -> Bool +isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True +isForeignLibComponentTarget _ = False + +isExeComponentTarget :: ComponentTarget -> Bool +isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True +isExeComponentTarget _ = False + +isSubLibComponentTarget :: ComponentTarget -> Bool +isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True +isSubLibComponentTarget _ = False + +componentOptionalStanza :: CD.Component -> Maybe OptionalStanza +componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas +componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas +componentOptionalStanza _ = Nothing + +--------------------------- +-- Setup.hs script policy +-- + +-- | There are four major cases for Setup.hs handling: +-- +-- 1. @build-type@ Custom with a @custom-setup@ section +-- 2. @build-type@ Custom without a @custom-setup@ section +-- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ +-- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ +-- +-- It's also worth noting that packages specifying @cabal-version: >= 1.23@ +-- or later that have @build-type@ Custom will always have a @custom-setup@ +-- section. Therefore in case 2, the specified @cabal-version@ will always be +-- less than 1.23. +-- +-- In cases 1 and 2 we obviously have to build an external Setup.hs script, +-- while in case 4 we can use the internal library API. In case 3 we also have +-- to build an external Setup.hs script because the package needs a later +-- Cabal lib version than we can support internally. +-- +data SetupScriptStyle = SetupCustomExplicitDeps + | SetupCustomImplicitDeps + | SetupNonCustomExternalLib + | SetupNonCustomInternalLib + deriving (Eq, Show, Generic, Typeable) + +instance Binary SetupScriptStyle +instance Structured SetupScriptStyle diff --git a/src/Distribution/Client/RebuildMonad.hs b/src/Distribution/Client/RebuildMonad.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/RebuildMonad.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-} + +-- | An abstraction for re-running actions if values or files have changed. +-- +-- This is not a full-blown make-style incremental build system, it's a bit +-- more ad-hoc than that, but it's easier to integrate with existing code. +-- +-- It's a convenient interface to the "Distribution.Client.FileMonitor" +-- functions. +-- +module Distribution.Client.RebuildMonad ( + -- * Rebuild monad + Rebuild, + runRebuild, + execRebuild, + askRoot, + + -- * Setting up file monitoring + monitorFiles, + MonitorFilePath, + monitorFile, + monitorFileHashed, + monitorNonExistentFile, + monitorDirectory, + monitorNonExistentDirectory, + monitorDirectoryExistence, + monitorFileOrDirectory, + monitorFileSearchPath, + monitorFileHashedSearchPath, + -- ** Monitoring file globs + monitorFileGlob, + monitorFileGlobExistence, + FilePathGlob(..), + FilePathRoot(..), + FilePathGlobRel(..), + GlobPiece(..), + + -- * Using a file monitor + FileMonitor(..), + newFileMonitor, + rerunIfChanged, + + -- * Utils + delayInitSharedResource, + delayInitSharedResources, + matchFileGlob, + getDirectoryContentsMonitored, + createDirectoryMonitored, + monitorDirectoryStatus, + doesFileExistMonitored, + need, + needIfExists, + findFileWithExtensionMonitored, + findFirstFileMonitored, + findFileMonitored, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.FileMonitor +import Distribution.Client.Glob hiding (matchFileGlob) +import qualified Distribution.Client.Glob as Glob (matchFileGlob) + +import Distribution.Simple.Utils (debug) + +import qualified Data.Map.Strict as Map +import Control.Monad.State as State +import Control.Monad.Reader as Reader +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) +import System.FilePath +import System.Directory + + +-- | A monad layered on top of 'IO' to help with re-running actions when the +-- input files and values they depend on change. The crucial operations are +-- 'rerunIfChanged' and 'monitorFiles'. +-- +newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +-- | Use this wihin the body action of 'rerunIfChanged' to declare that the +-- action depends on the given files. This can be based on what the action +-- actually did. It is these files that will be checked for changes next +-- time 'rerunIfChanged' is called for that 'FileMonitor'. +-- +-- Relative paths are interpreted as relative to an implicit root, ultimately +-- passed in to 'runRebuild'. +-- +monitorFiles :: [MonitorFilePath] -> Rebuild () +monitorFiles filespecs = Rebuild (State.modify (filespecs++)) + +-- | Run a 'Rebuild' IO action. +unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath]) +unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) [] + +-- | Run a 'Rebuild' IO action. +runRebuild :: FilePath -> Rebuild a -> IO a +runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] + +-- | Run a 'Rebuild' IO action. +execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] +execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) [] + +-- | The root that relative paths are interpreted as being relative to. +askRoot :: Rebuild FilePath +askRoot = Rebuild Reader.ask + +-- | This captures the standard use pattern for a 'FileMonitor': given a +-- monitor, an action and the input value the action depends on, either +-- re-run the action to get its output, or if the value and files the action +-- depends on have not changed then return a previously cached action result. +-- +-- The result is still in the 'Rebuild' monad, so these can be nested. +-- +-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. +-- +rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b) + => Verbosity + -> FileMonitor a b + -> a + -> Rebuild b + -> Rebuild b +rerunIfChanged verbosity monitor key action = do + rootDir <- askRoot + changed <- liftIO $ checkFileMonitorChanged monitor rootDir key + case changed of + MonitorUnchanged result files -> do + liftIO $ debug verbosity $ "File monitor '" ++ monitorName + ++ "' unchanged." + monitorFiles files + return result + + MonitorChanged reason -> do + liftIO $ debug verbosity $ "File monitor '" ++ monitorName + ++ "' changed: " ++ showReason reason + startTime <- liftIO $ beginUpdateFileMonitor + (result, files) <- liftIO $ unRebuild rootDir action + liftIO $ updateFileMonitor monitor rootDir + (Just startTime) files key result + monitorFiles files + return result + where + monitorName = takeFileName (fileMonitorCacheFile monitor) + + showReason (MonitoredFileChanged file) = "file " ++ file + showReason (MonitoredValueChanged _) = "monitor value changed" + showReason MonitorFirstRun = "first run" + showReason MonitorCorruptCache = "invalid cache file" + + +-- | When using 'rerunIfChanged' for each element of a list of actions, it is +-- sometimes the case that each action needs to make use of some resource. e.g. +-- +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- mkResource +-- > ... -- use the resource +-- > | ... ] +-- +-- For efficiency one would like to share the resource between the actions +-- but the straightforward way of doing this means initialising it every time +-- even when no actions need re-running. +-- +-- > resource <- mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > ... -- use the resource +-- > | ... ] +-- +-- This utility allows one to get the best of both worlds: +-- +-- > getResource <- delayInitSharedResource mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- getResource +-- > ... -- use the resource +-- > | ... ] +-- +delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a) +delayInitSharedResource action = do + var <- liftIO (newMVar Nothing) + return (liftIO (getOrInitResource var)) + where + getOrInitResource :: MVar (Maybe a) -> IO a + getOrInitResource var = + modifyMVar var $ \mx -> + case mx of + Just x -> return (Just x, x) + Nothing -> do + x <- action + return (Just x, x) + + +-- | Much like 'delayInitSharedResource' but for a keyed set of resources. +-- +-- > getResource <- delayInitSharedResource mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- getResource key +-- > ... -- use the resource +-- > | ... ] +-- +delayInitSharedResources :: forall k v. Ord k + => (k -> IO v) + -> Rebuild (k -> Rebuild v) +delayInitSharedResources action = do + var <- liftIO (newMVar Map.empty) + return (liftIO . getOrInitResource var) + where + getOrInitResource :: MVar (Map k v) -> k -> IO v + getOrInitResource var k = + modifyMVar var $ \m -> + case Map.lookup k m of + Just x -> return (m, x) + Nothing -> do + x <- action k + let !m' = Map.insert k x m + return (m', x) + + +-- | Utility to match a file glob against the file system, starting from a +-- given root directory. The results are all relative to the given root. +-- +-- Since this operates in the 'Rebuild' monad, it also monitors the given glob +-- for changes. +-- +matchFileGlob :: FilePathGlob -> Rebuild [FilePath] +matchFileGlob glob = do + root <- askRoot + monitorFiles [monitorFileGlobExistence glob] + liftIO $ Glob.matchFileGlob root glob + +getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] +getDirectoryContentsMonitored dir = do + exists <- monitorDirectoryStatus dir + if exists + then liftIO $ getDirectoryContents dir + else return [] + +createDirectoryMonitored :: Bool -> FilePath -> Rebuild () +createDirectoryMonitored createParents dir = do + monitorFiles [monitorDirectoryExistence dir] + liftIO $ createDirectoryIfMissing createParents dir + +-- | Monitor a directory as in 'monitorDirectory' if it currently exists or +-- as 'monitorNonExistentDirectory' if it does not. +monitorDirectoryStatus :: FilePath -> Rebuild Bool +monitorDirectoryStatus dir = do + exists <- liftIO $ doesDirectoryExist dir + monitorFiles [if exists + then monitorDirectory dir + else monitorNonExistentDirectory dir] + return exists + +-- | Like 'doesFileExist', but in the 'Rebuild' monad. This does +-- NOT track the contents of 'FilePath'; use 'need' in that case. +doesFileExistMonitored :: FilePath -> Rebuild Bool +doesFileExistMonitored f = do + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles [if exists + then monitorFileExistence f + else monitorNonExistentFile f] + return exists + +-- | Monitor a single file +need :: FilePath -> Rebuild () +need f = monitorFiles [monitorFileHashed f] + +-- | Monitor a file if it exists; otherwise check for when it +-- gets created. This is a bit better for recompilation avoidance +-- because sometimes users give bad package metadata, and we don't +-- want to repeatedly rebuild in this case (which we would if we +-- need'ed a non-existent file). +needIfExists :: FilePath -> Rebuild () +needIfExists f = do + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles [if exists + then monitorFileHashed f + else monitorNonExistentFile f] + +-- | Like 'findFileWithExtension', but in the 'Rebuild' monad. +findFileWithExtensionMonitored + :: [String] + -> [FilePath] + -> FilePath + -> Rebuild (Maybe FilePath) +findFileWithExtensionMonitored extensions searchPath baseName = + findFirstFileMonitored id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFirstFile', but in the 'Rebuild' monad. +findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a) +findFirstFileMonitored file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExistMonitored (file x) + if exists + then return (Just x) + else findFirst xs + +-- | Like 'findFile', but in the 'Rebuild' monad. +findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath) +findFileMonitored searchPath fileName = + findFirstFileMonitored id + [ path fileName + | path <- nub searchPath] diff --git a/src/Distribution/Client/Reconfigure.hs b/src/Distribution/Client/Reconfigure.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Reconfigure.hs @@ -0,0 +1,179 @@ +module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where + +import Distribution.Client.Compat.Prelude + +import Data.Monoid ( Any(..) ) +import System.Directory ( doesFileExist ) + +import Distribution.Simple.Configure ( localBuildInfoFile ) +import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag ) +import Distribution.Simple.Utils + ( existsAndIsMoreRecentThan, defaultPackageDesc, info ) + +import Distribution.Client.Config ( SavedConfig(..) ) +import Distribution.Client.Configure ( readConfigFlags ) +import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate ) +import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs ) +import Distribution.Client.Sandbox.PackageEnvironment + ( userPackageEnvironmentFile ) +import Distribution.Client.Setup + ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) ) + +-- | @Check@ represents a function to check some condition on type @a@. The +-- returned 'Any' is 'True' if any part of the condition failed. +newtype Check a = Check { + runCheck :: Any -- Did any previous check fail? + -> a -- value returned by previous checks + -> IO (Any, a) -- Did this check fail? What value is returned? +} + +instance Semigroup (Check a) where + (<>) c d = Check $ \any0 a0 -> do + (any1, a1) <- runCheck c any0 a0 + (any2, a2) <- runCheck d (any0 <> any1) a1 + return (any0 <> any1 <> any2, a2) + +instance Monoid (Check a) where + mempty = Check $ \_ a -> return (mempty, a) + mappend = (<>) + + +-- | Re-configure the package in the current directory if needed. Deciding +-- when to reconfigure and with which options is convoluted: +-- +-- If we are reconfiguring, we must always run @configure@ with the +-- verbosity option we are given; however, that a previous configuration +-- uses a different verbosity setting is not reason enough to reconfigure. +-- +-- The package should be configured to use the same \"dist\" prefix as +-- given to the @build@ command, otherwise the build will probably +-- fail. Not only does this determine the \"dist\" prefix setting if we +-- need to reconfigure anyway, but an existing configuration should be +-- invalidated if its \"dist\" prefix differs. +-- +-- If the package has never been configured (i.e., there is no +-- LocalBuildInfo), we must configure first, using the default options. +-- +-- If the package has been configured, there will be a 'LocalBuildInfo'. +-- If there no package description file, we assume that the +-- 'PackageDescription' is up to date, though the configuration may need +-- to be updated for other reasons (see above). If there is a package +-- description file, and it has been modified since the 'LocalBuildInfo' +-- was generated, then we need to reconfigure. +-- +-- The caller of this function may also have specific requirements +-- regarding the flags the last configuration used. For example, +-- 'testAction' requires that the package be configured with test suites +-- enabled. The caller may pass the required settings to this function +-- along with a function to check the validity of the saved 'ConfigFlags'; +-- these required settings will be checked first upon determining that +-- a previous configuration exists. +reconfigure + :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()) + -- ^ configure action + -> Verbosity + -- ^ Verbosity setting + -> FilePath + -- ^ \"dist\" prefix + -> Flag (Maybe Int) + -- ^ -j flag for reinstalling add-source deps. + -> Check (ConfigFlags, ConfigExFlags) + -- ^ Check that the required flags are set. + -- If they are not set, provide a message explaining the + -- reason for reconfiguration. + -> [String] -- ^ Extra arguments + -> GlobalFlags -- ^ Global flags + -> SavedConfig + -> IO SavedConfig +reconfigure + configureAction + verbosity + dist + _numJobsFlag + check + extraArgs + globalFlags + config + = do + + savedFlags@(_, _) <- readConfigFlags dist + + useNix <- fmap isJust (findNixExpr globalFlags config) + alreadyInNixShell <- inNixShell + + if useNix && not alreadyInNixShell + then do + + -- If we are using Nix, we must reinstantiate the derivation outside + -- the shell. Eventually, the caller will invoke 'nixShell' which will + -- rerun cabal inside the shell. That will bring us back to 'reconfigure', + -- but inside the shell we'll take the second branch, below. + + -- This seems to have a problem: won't 'configureAction' call 'nixShell' + -- yet again, spawning an infinite tree of subprocesses? + -- No, because 'nixShell' doesn't spawn a new process if it is already + -- running in a Nix shell. + + nixInstantiate verbosity dist False globalFlags config + return config + + else do + + let checks = + checkVerb + <> checkDist + <> checkOutdated + <> check + (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags + + let config' = updateInstallDirs (configUserInstall configFlags) config + + when frc $ configureAction flags extraArgs globalFlags + return config' + + where + + -- Changing the verbosity does not require reconfiguration, but the new + -- verbosity should be used if reconfiguring. + checkVerb = Check $ \_ (configFlags, configExFlags) -> do + let configFlags' = configFlags { configVerbosity = toFlag verbosity} + return (mempty, (configFlags', configExFlags)) + + -- Reconfiguration is required if @--build-dir@ changes. + checkDist = Check $ \_ (configFlags, configExFlags) -> do + -- Always set the chosen @--build-dir@ before saving the flags, + -- or bad things could happen. + savedDist <- findSavedDistPref config (configDistPref configFlags) + let distChanged = dist /= savedDist + when distChanged $ info verbosity "build directory changed" + let configFlags' = configFlags { configDistPref = toFlag dist } + return (Any distChanged, (configFlags', configExFlags)) + + checkOutdated = Check $ \_ flags@(configFlags, _) -> do + let buildConfig = localBuildInfoFile dist + + -- Has the package ever been configured? If not, reconfiguration is + -- required. + configured <- doesFileExist buildConfig + unless configured $ info verbosity "package has never been configured" + + -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need + -- to force reconfigure. Note that it's possible to use @cabal.config@ + -- even without sandboxes. + userPackageEnvironmentFileModified <- + existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig + when userPackageEnvironmentFileModified $ + info verbosity ("user package environment file ('" + ++ userPackageEnvironmentFile ++ "') was modified") + + -- Is the configuration older than the package description? + descrFile <- maybe (defaultPackageDesc verbosity) return + (flagToMaybe (configCabalFilePath configFlags)) + outdated <- existsAndIsMoreRecentThan descrFile buildConfig + when outdated $ info verbosity (descrFile ++ " was changed") + + let failed = + Any outdated + <> Any userPackageEnvironmentFileModified + <> Any (not configured) + return (failed, flags) diff --git a/src/Distribution/Client/Run.hs b/src/Distribution/Client/Run.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Run.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Run +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'run' command. +----------------------------------------------------------------------------- + +module Distribution.Client.Run ( run, splitRunArgs ) + where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Types.TargetInfo (targetCLBI) +import Distribution.Types.LocalBuildInfo (componentNameTargets') + +import Distribution.Client.Utils (tryCanonicalizePath) + +import Distribution.Types.UnqualComponentName +import Distribution.PackageDescription (Executable (..), + TestSuite(..), + Benchmark(..), + PackageDescription (..), + BuildInfo(buildable)) +import Distribution.Simple.Compiler (compilerFlavor, CompilerFlavor(..)) +import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.LocalBuildInfo (ComponentName (..), + LocalBuildInfo (..), + depLibraryPaths) +import Distribution.Simple.Utils (die', notice, warn, + rawSystemExitWithEnv, + addLibraryPath) +import Distribution.System (Platform (..)) + +import qualified Distribution.Simple.GHCJS as GHCJS + +import System.Directory (getCurrentDirectory) +import Distribution.Compat.Environment (getEnvironment) +import System.FilePath ((<.>), ()) + + +-- | Return the executable to run and any extra arguments that should be +-- forwarded to it. Die in case of error. +splitRunArgs :: Verbosity -> LocalBuildInfo -> [String] + -> IO (Executable, [String]) +splitRunArgs verbosity lbi args = + case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest) + Left err -> do + warn verbosity `traverse_` maybeWarning -- If there is a warning, print it. + die' verbosity err + Right (True, exe, xs) -> return (exe, xs) + Right (False, exe, xs) -> do + let addition = " Interpreting all parameters to `run` as a parameter to" + ++ " the default executable." + -- If there is a warning, print it together with the addition. + warn verbosity `traverse_` fmap (++addition) maybeWarning + return (exe, xs) + where + pkg_descr = localPkgDescr lbi + whichExecutable :: Either String -- Error string. + ( Bool -- If it was manually chosen. + , Executable -- The executable. + , [String] -- The remaining parameters. + ) + whichExecutable = case (enabledExes, args) of + ([] , _) -> Left "Couldn't find any enabled executables." + ([exe], []) -> return (False, exe, []) + ([exe], (x:xs)) + | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs) + | otherwise -> return (False, exe, args) + (_ , []) -> Left + $ "This package contains multiple executables. " + ++ "You must pass the executable name as the first argument " + ++ "to 'cabal run'." + (_ , (x:xs)) -> + case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of + Nothing -> Left $ "No executable named '" ++ x ++ "'." + Just exe -> return (True, exe, xs) + where + enabledExes = filter (buildable . buildInfo) (executables pkg_descr) + + maybeWarning :: Maybe String + maybeWarning = case args of + [] -> Nothing + (x:_) -> lookup (mkUnqualComponentName x) components + where + components :: [(UnqualComponentName, String)] -- Component name, message. + components = + [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.") + | e <- executables pkg_descr + , not . buildable . buildInfo $ e, let name = exeName e] + + ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "'," + ++ " but the `run` command is only for executables.") + | t <- testSuites pkg_descr + , let name = testName t] + + ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "'," + ++ " but the `run` command is only for executables.") + | b <- benchmarks pkg_descr + , let name = benchmarkName b] + +-- | Run a given executable. +run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO () +run verbosity lbi exe exeArgs = do + curDir <- getCurrentDirectory + let buildPref = buildDir lbi + pkg_descr = localPkgDescr lbi + dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir", + curDir dataDir pkg_descr) + + (path, runArgs) <- + let exeName' = prettyShow $ exeName exe + in case compilerFlavor (compiler lbi) of + GHCJS -> do + let (script, cmd, cmdArgs) = + GHCJS.runCmd (withPrograms lbi) + (buildPref exeName' exeName') + script' <- tryCanonicalizePath script + return (cmd, cmdArgs ++ [script']) + _ -> do + p <- tryCanonicalizePath $ + buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbi)) + return (p, []) + + env <- (dataDirEnvVar:) <$> getEnvironment + -- Add (DY)LD_LIBRARY_PATH if needed + env' <- if withDynExe lbi + then do let (Platform _ os) = hostPlatform lbi + clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of + [target] -> return (targetCLBI target) + [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" + _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" + paths <- depLibraryPaths True False lbi clbi + return (addLibraryPath os paths env) + else return env + notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..." + rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' diff --git a/src/Distribution/Client/Sandbox.hs b/src/Distribution/Client/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Sandbox.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- UI for the sandboxing functionality. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox ( + loadConfigOrSandboxConfig, + findSavedDistPref, + + updateInstallDirs, + + getPersistOrConfigCompiler + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Setup + ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' ) +import Distribution.Client.Config + ( SavedConfig(..), defaultUserInstall, loadConfig ) + +import Distribution.Client.Sandbox.PackageEnvironment + ( PackageEnvironmentType(..) + , classifyPackageEnvironment + , loadUserConfig + ) +import Distribution.Client.SetupWrapper + ( SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Simple.Compiler ( Compiler(..) ) +import Distribution.Simple.Configure ( maybeGetPersistBuildConfig + , findDistPrefOrDefault + , findDistPref ) +import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo +import Distribution.Simple.Program ( ProgramDb ) +import Distribution.Simple.Setup ( Flag(..) + , fromFlagOrDefault, flagToMaybe ) +import Distribution.System ( Platform ) + +import System.Directory ( getCurrentDirectory ) + + +-- * Basic sandbox functions. +-- + +updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig +updateInstallDirs userInstallFlag savedConfig = savedConfig + { savedConfigureFlags = configureFlags + { configInstallDirs = installDirs + } + } + where + configureFlags = savedConfigureFlags savedConfig + userInstallDirs = savedUserInstallDirs savedConfig + globalInstallDirs = savedGlobalInstallDirs savedConfig + installDirs | userInstall = userInstallDirs + | otherwise = globalInstallDirs + userInstall = fromFlagOrDefault defaultUserInstall + (configUserInstall configureFlags `mappend` userInstallFlag) + +-- | Check which type of package environment we're in and return a +-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates +-- whether we're working in a sandbox. +loadConfigOrSandboxConfig :: Verbosity + -> GlobalFlags -- ^ For @--config-file@ and + -- @--sandbox-config-file@. + -> IO SavedConfig +loadConfigOrSandboxConfig verbosity globalFlags = do + let configFileFlag = globalConfigFile globalFlags + + pkgEnvDir <- getCurrentDirectory + pkgEnvType <- classifyPackageEnvironment pkgEnvDir + case pkgEnvType of + -- Only @cabal.config@ is present. + UserPackageEnvironment -> do + config <- loadConfig verbosity configFileFlag + userConfig <- loadUserConfig verbosity pkgEnvDir Nothing + let config' = config `mappend` userConfig + return config' + + -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present. + AmbientPackageEnvironment -> do + config <- loadConfig verbosity configFileFlag + let globalConstraintsOpt = + flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config + globalConstraintConfig <- + loadUserConfig verbosity pkgEnvDir globalConstraintsOpt + let config' = config `mappend` globalConstraintConfig + return config' + +-- | Return the saved \"dist/\" prefix, or the default prefix. +findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath +findSavedDistPref config flagDistPref = do + let defDistPref = useDistPref defaultSetupScriptOptions + flagDistPref' = configDistPref (savedConfigureFlags config) + `mappend` flagDistPref + findDistPref defDistPref flagDistPref' + +-- Utils (transitionary) +-- + +-- | Try to read the most recently configured compiler from the +-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it +-- cannot be read. +getPersistOrConfigCompiler :: ConfigFlags + -> IO (Compiler, Platform, ProgramDb) +getPersistOrConfigCompiler configFlags = do + distPref <- findDistPrefOrDefault (configDistPref configFlags) + mlbi <- maybeGetPersistBuildConfig distPref + case mlbi of + Nothing -> do configCompilerAux' configFlags + Just lbi -> return ( LocalBuildInfo.compiler lbi + , LocalBuildInfo.hostPlatform lbi + , LocalBuildInfo.withPrograms lbi + ) diff --git a/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/src/Distribution/Client/Sandbox/PackageEnvironment.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox.PackageEnvironment +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for working with the package environment file. Patterned after +-- Distribution.Client.Config. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox.PackageEnvironment ( + PackageEnvironment(..) + , PackageEnvironmentType(..) + , classifyPackageEnvironment + , readPackageEnvironmentFile + , showPackageEnvironment + , showPackageEnvironmentWithComments + , loadUserConfig + + , userPackageEnvironmentFile + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Config ( SavedConfig(..) + , configFieldDescriptions + , haddockFlagsFields + , installDirsFields, withProgramsFields + , withProgramOptionsFields + ) +import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) +import Distribution.Client.Setup ( ConfigExFlags(..) + ) +import Distribution.Client.Targets ( userConstraintPackageName ) +import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate ) +import Distribution.Simple.Setup ( Flag(..) + , ConfigFlags(..), HaddockFlags(..) + ) +import Distribution.Simple.Utils ( warn, debug ) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..) + , commaListFieldParsec, commaNewLineListFieldParsec + , liftField, lineNo, locatedErrorMsg + , readFields + , showPWarning + , syntaxError, warning ) +import System.Directory ( doesFileExist ) +import System.FilePath ( () ) +import System.IO.Error ( isDoesNotExistError ) +import Text.PrettyPrint ( ($+$) ) + +import qualified Data.ByteString as BS +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) ) + +-- +-- * Configuration saved in the package environment file +-- + +-- TODO: would be nice to remove duplication between +-- D.C.Sandbox.PackageEnvironment and D.C.Config. +data PackageEnvironment = PackageEnvironment { + pkgEnvSavedConfig :: SavedConfig +} deriving Generic + +instance Monoid PackageEnvironment where + mempty = gmempty + mappend = (<>) + +instance Semigroup PackageEnvironment where + (<>) = gmappend + +-- | Optional package environment file that can be used to customize the default +-- settings. Created by the user. +userPackageEnvironmentFile :: FilePath +userPackageEnvironmentFile = "cabal.config" + +-- | Type of the current package environment. +data PackageEnvironmentType + = UserPackageEnvironment -- ^ './cabal.config' + | AmbientPackageEnvironment -- ^ '~/.cabal/config' + +-- | Is there a 'cabal.config' in this directory? +classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType +classifyPackageEnvironment pkgEnvDir = do + isUser <- configExists userPackageEnvironmentFile + return (classify isUser) + where + configExists fname = doesFileExist (pkgEnvDir fname) + + classify :: Bool -> PackageEnvironmentType + classify True = UserPackageEnvironment + classify False = AmbientPackageEnvironment + + +-- | Load the user package environment if it exists (the optional "cabal.config" +-- file). If it does not exist locally, attempt to load an optional global one. +userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath + -> IO PackageEnvironment +userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do + let path = pkgEnvDir userPackageEnvironmentFile + minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) + mempty path + case (minp, globalConfigLocation) of + (Just parseRes, _) -> processConfigParse path parseRes + (_, Just globalLoc) -> do + minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) + mempty globalLoc + maybe (warn verbosity ("no constraints file found at " ++ globalLoc) + >> return mempty) + (processConfigParse globalLoc) + minp' + _ -> do + debug verbosity ("no user package environment file found at " ++ pkgEnvDir) + return mempty + where + processConfigParse path (ParseOk warns parseResult) = do + unless (null warns) $ warn verbosity $ + unlines (map (showPWarning path) warns) + return parseResult + processConfigParse path (ParseFailed err) = do + let (line, msg) = locatedErrorMsg err + warn verbosity $ "Error parsing package environment file " ++ path + ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + return mempty + +-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. +loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig +loadUserConfig verbosity pkgEnvDir globalConfigLocation = + fmap pkgEnvSavedConfig $ + userPackageEnvironment verbosity pkgEnvDir globalConfigLocation + + + +-- | Descriptions of all fields in the package environment file. +pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment] +pkgEnvFieldDescrs src = + [ commaNewLineListFieldParsec "constraints" + (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec) + (sortConstraints . configExConstraints + . savedConfigureExFlags . pkgEnvSavedConfig) + (\v pkgEnv -> updateConfigureExFlags pkgEnv + (\flags -> flags { configExConstraints = v })) + + , commaListFieldParsec "preferences" + pretty parsec + (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) + (\v pkgEnv -> updateConfigureExFlags pkgEnv + (\flags -> flags { configPreferences = v })) + ] + ++ map toPkgEnv configFieldDescriptions' + where + configFieldDescriptions' :: [FieldDescr SavedConfig] + configFieldDescriptions' = filter + (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint") + (configFieldDescriptions src) + + toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment + toPkgEnv fieldDescr = + liftField pkgEnvSavedConfig + (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig}) + fieldDescr + + updateConfigureExFlags :: PackageEnvironment + -> (ConfigExFlags -> ConfigExFlags) + -> PackageEnvironment + updateConfigureExFlags pkgEnv f = pkgEnv { + pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) { + savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig + $ pkgEnv + } + } + + sortConstraints = sortBy (comparing $ userConstraintPackageName . fst) + +-- | Read the package environment file. +readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath + -> IO (Maybe (ParseResult PackageEnvironment)) +readPackageEnvironmentFile src initial file = + handleNotExists $ + fmap (Just . parsePackageEnvironment src initial) (BS.readFile file) + where + handleNotExists action = catchIO action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +-- | Parse the package environment file. +parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString + -> ParseResult PackageEnvironment +parsePackageEnvironment src initial str = do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + pkgEnv <- parse others + let config = pkgEnvSavedConfig pkgEnv + installDirs0 = savedUserInstallDirs config + (haddockFlags, installDirs, paths, args) <- + foldM parseSections + (savedHaddockFlags config, installDirs0, [], []) + knownSections + return pkgEnv { + pkgEnvSavedConfig = config { + savedConfigureFlags = (savedConfigureFlags config) { + configProgramPaths = paths, + configProgramArgs = args + }, + savedHaddockFlags = haddockFlags, + savedUserInstallDirs = installDirs, + savedGlobalInstallDirs = installDirs + } + } + + where + isKnownSection :: ParseUtils.Field -> Bool + isKnownSection (ParseUtils.Section _ "haddock" _ _) = True + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True + isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True + isKnownSection _ = False + + parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment + parse = parseFields (pkgEnvFieldDescrs src) initial + + parseSections :: SectionsAccum -> ParseUtils.Field + -> ParseResult SectionsAccum + parseSections accum@(h,d,p,a) + (ParseUtils.Section _ "haddock" name fs) + | name == "" = do h' <- parseFields haddockFlagsFields h fs + return (h', d, p, a) + | otherwise = do + warning "The 'haddock' section should be unnamed" + return accum + parseSections (h,d,p,a) + (ParseUtils.Section line "install-dirs" name fs) + | name == "" = do d' <- parseFields installDirsFields d fs + return (h, d',p,a) + | otherwise = + syntaxError line $ + "Named 'install-dirs' section: '" ++ name + ++ "'. Note that named 'install-dirs' sections are not allowed in the '" + ++ userPackageEnvironmentFile ++ "' file." + parseSections accum@(h, d,p,a) + (ParseUtils.Section _ "program-locations" name fs) + | name == "" = do p' <- parseFields withProgramsFields p fs + return (h, d, p', a) + | otherwise = do + warning "The 'program-locations' section should be unnamed" + return accum + parseSections accum@(h, d, p, a) + (ParseUtils.Section _ "program-default-options" name fs) + | name == "" = do a' <- parseFields withProgramOptionsFields a fs + return (h, d, p, a') + | otherwise = do + warning "The 'program-default-options' section should be unnamed" + return accum + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | Accumulator type for 'parseSections'. +type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate) + , [(String, FilePath)], [(String, [String])]) + + + +-- | Pretty-print the package environment. +showPackageEnvironment :: PackageEnvironment -> String +showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv + +-- | Pretty-print the package environment with default values for empty fields +-- commented out (just like the default ~/.cabal/config). +showPackageEnvironmentWithComments :: (Maybe PackageEnvironment) + -> PackageEnvironment + -> String +showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $ + ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown) + mdefPkgEnv pkgEnv + $+$ Disp.text "" + $+$ ppSection "install-dirs" "" installDirsFields + (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv) + where + installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig diff --git a/src/Distribution/Client/SavedFlags.hs b/src/Distribution/Client/SavedFlags.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/SavedFlags.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Distribution.Client.SavedFlags + ( readCommandFlags, writeCommandFlags + , readSavedArgs, writeSavedArgs + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Simple.Command +import Distribution.Simple.UserHooks ( Args ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, unintersperse ) +import Distribution.Verbosity + +import System.Directory ( doesFileExist ) +import System.FilePath ( takeDirectory ) + + +writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () +writeSavedArgs verbosity path args = do + createDirectoryIfMissingVerbose + (lessVerbose verbosity) True (takeDirectory path) + writeFile path (intercalate "\0" args) + + +-- | Write command-line flags to a file, separated by null characters. This +-- format is also suitable for the @xargs -0@ command. Using the null +-- character also avoids the problem of escaping newlines or spaces, +-- because unlike other whitespace characters, the null character is +-- not valid in command-line arguments. +writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO () +writeCommandFlags verbosity path command flags = + writeSavedArgs verbosity path (commandShowOptions command flags) + + +readSavedArgs :: FilePath -> IO (Maybe [String]) +readSavedArgs path = do + exists <- doesFileExist path + if exists + then fmap (Just . unintersperse '\0') (readFile path) + else return Nothing + + +-- | Read command-line arguments, separated by null characters, from a file. +-- Returns the default flags if the file does not exist. +readCommandFlags :: FilePath -> CommandUI flags -> IO flags +readCommandFlags path command = do + savedArgs <- fmap (fromMaybe []) (readSavedArgs path) + case (commandParseArgs command True savedArgs) of + CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs) + CommandList _ -> throwIO (SavedArgsErrorList savedArgs) + CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs) + CommandReadyToGo (mkFlags, _) -> + return (mkFlags (commandDefaultFlags command)) + +-- ----------------------------------------------------------------------------- +-- * Exceptions +-- ----------------------------------------------------------------------------- + +data SavedArgsError + = SavedArgsErrorHelp Args + | SavedArgsErrorList Args + | SavedArgsErrorOther Args [String] + deriving (Typeable) + +instance Show SavedArgsError where + show (SavedArgsErrorHelp args) = + "unexpected flag '--help', saved command line was:\n" + ++ intercalate " " args + show (SavedArgsErrorList args) = + "unexpected flag '--list-options', saved command line was:\n" + ++ intercalate " " args + show (SavedArgsErrorOther args errs) = + "saved command line was:\n" + ++ intercalate " " args ++ "\n" + ++ "encountered errors:\n" + ++ intercalate "\n" errs + +instance Exception SavedArgsError diff --git a/src/Distribution/Client/Security/DNS.hs b/src/Distribution/Client/Security/DNS.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Security/DNS.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} + +module Distribution.Client.Security.DNS + ( queryBootstrapMirrors + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Network.URI (URI(..), URIAuth(..), parseURI) +import Control.Exception (try) +import Distribution.Simple.Utils + +#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) +import Network.DNS (queryTXT, Name(..), CharStr(..)) +import qualified Data.ByteString.Char8 as BS.Char8 +#else +import Distribution.Simple.Program.Db + ( emptyProgramDb, addKnownProgram + , configureAllKnownPrograms, lookupProgram ) +import Distribution.Simple.Program + ( simpleProgram + , programInvocation + , getProgramInvocationOutput ) +#endif + +-- | Try to lookup RFC1464-encoded mirror urls for a Hackage +-- repository url by performing a DNS TXT lookup on the +-- @_mirrors.@-prefixed URL hostname. +-- +-- Example: for @http://hackage.haskell.org/@ +-- perform a DNS TXT query for the hostname +-- @_mirrors.hackage.haskell.org@ which may look like e.g. +-- +-- > _mirrors.hackage.haskell.org. 300 IN TXT +-- > "0.urlbase=http://hackage.fpcomplete.com/" +-- > "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/" +-- +-- NB: hackage-security doesn't require DNS lookups being trustworthy, +-- as the trust is established via the cryptographically signed TUF +-- meta-data that is retrieved from the resolved Hackage repository. +-- Moreover, we already have to protect against a compromised +-- @hackage.haskell.org@ DNS entry, so an the additional +-- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't +-- constitute a significant new attack vector anyway. +-- +queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] + +#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) +-- use @resolv@ package for performing DNS queries +queryBootstrapMirrors verbosity repoUri + | Just auth <- uriAuthority repoUri = do + let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth)) + + mirrors' <- try $ do + txts <- queryTXT mirrorsDnsName + evaluate (force $ extractMirrors (map snd txts)) + + mirrors <- case mirrors' of + Left e -> do + warn verbosity ("Caught exception during _mirrors lookup:"++ + displayException (e :: SomeException)) + return [] + Right v -> return v + + if null mirrors + then warn verbosity ("No mirrors found for " ++ show repoUri) + else do info verbosity ("located " ++ show (length mirrors) ++ + " mirrors for " ++ show repoUri ++ " :") + for_ mirrors $ \url -> info verbosity ("- " ++ show url) + + return mirrors + + | otherwise = return [] + +-- | Extract list of mirrors from 'queryTXT' result +extractMirrors :: [[CharStr]] -> [URI] +extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals + where + vals = [ (kn,v) | CharStr e <- concat txtChunks + , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)] + , Just kn <- [isUrlBase k] + ] + +---------------------------------------------------------------------------- +#else /* !defined(MIN_VERSION_resolv) */ +-- use external method via @nslookup@ +queryBootstrapMirrors verbosity repoUri + | Just auth <- uriAuthority repoUri = do + progdb <- configureAllKnownPrograms verbosity $ + addKnownProgram nslookupProg emptyProgramDb + + case lookupProgram nslookupProg progdb of + Nothing -> do + warn verbosity "'nslookup' tool missing - can't locate mirrors" + return [] + + Just nslookup -> do + let mirrorsDnsName = "_mirrors." ++ uriRegName auth + + mirrors' <- try $ do + out <- getProgramInvocationOutput verbosity $ + programInvocation nslookup ["-query=TXT", mirrorsDnsName] + evaluate (force $ extractMirrors mirrorsDnsName out) + + mirrors <- case mirrors' of + Left e -> do + warn verbosity ("Caught exception during _mirrors lookup:"++ + displayException (e :: SomeException)) + return [] + Right v -> return v + + if null mirrors + then warn verbosity ("No mirrors found for " ++ show repoUri) + else do info verbosity ("located " ++ show (length mirrors) ++ + " mirrors for " ++ show repoUri ++ " :") + for_ mirrors $ \url -> info verbosity ("- " ++ show url) + + return mirrors + + | otherwise = return [] + where + nslookupProg = simpleProgram "nslookup" + +-- | Extract list of mirrors from @nslookup -query=TXT@ output. +extractMirrors :: String -> String -> [URI] +extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals + where + vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0 + , h == hostname + , e <- ents + , Just (k,v) <- [splitRfc1464 e] + , Just kn <- [isUrlBase k] + ] + +-- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly +parseNsLookupTxt :: String -> Maybe [(String,[String])] +parseNsLookupTxt = go0 [] [] + where + -- approximate grammar: + -- := { } + -- ( 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 + +#endif +---------------------------------------------------------------------------- + +-- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data +isUrlBase :: String -> Maybe Int +isUrlBase s + | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns + | otherwise = Nothing + where + ns = take (length s - 8) s + +-- | Split a TXT string into key and value according to RFC1464. +-- Returns 'Nothing' if parsing fails. +splitRfc1464 :: String -> Maybe (String,String) +splitRfc1464 = go "" + where + go _ [] = Nothing + go acc ('`':c:cs) = go (c:acc) cs + go acc ('=':cs) = go2 (reverse acc) "" cs + go acc (c:cs) + | isSpace c = go acc cs + | otherwise = go (c:acc) cs + + go2 k acc [] = Just (k,reverse acc) + go2 _ _ ['`'] = Nothing + go2 k acc ('`':c:cs) = go2 k (c:acc) cs + go2 k acc (c:cs) = go2 k (c:acc) cs diff --git a/src/Distribution/Client/Security/HTTP.hs b/src/Distribution/Client/Security/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Security/HTTP.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +-- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport' +module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +-- stdlibs +import System.Directory + ( getTemporaryDirectory ) +import Network.URI + ( URI ) +import qualified Data.ByteString.Lazy as BS.L +import qualified Network.HTTP as HTTP + +-- Cabal/cabal-install +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Client.HttpUtils + ( HttpTransport(..), HttpCode ) +import Distribution.Client.Utils + ( withTempFileName ) + +-- hackage-security +import Hackage.Security.Client.Repository.HttpLib (HttpLib (..)) +import qualified Hackage.Security.Client as HC +import qualified Hackage.Security.Client.Repository.HttpLib as HC +import qualified Hackage.Security.Util.Checked as HC +import qualified Hackage.Security.Util.Pretty as HC + +{------------------------------------------------------------------------------- + 'HttpLib' implementation +-------------------------------------------------------------------------------} + +-- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport' +-- +-- NOTE: The match between these two APIs is currently not perfect: +-- +-- * We don't get any response headers back from the 'HttpTransport', so we +-- don't know if the server supports range requests. For now we optimistically +-- assume that it does. +-- * The 'HttpTransport' wants to know where to place the resulting file, +-- whereas the 'HttpLib' expects an 'IO' action which streams the download; +-- the security library then makes sure that the file gets written to a +-- location which is suitable (in particular, to a temporary file in the +-- directory where the file needs to end up, so that it can "finalize" the +-- file simply by doing 'renameFile'). Right now we write the file to a +-- temporary file in the system temp directory here and then read it again +-- to pass it to the security library; this is a problem for two reasons: it +-- is a source of inefficiency; and it means that the security library cannot +-- insist on a minimum download rate (potential security attack). +-- Fixing it however would require changing the 'HttpTransport'. +transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib +transportAdapter verbosity getTransport = HttpLib{ + httpGet = \headers uri callback -> do + transport <- getTransport + httpGetImpl verbosity transport headers uri callback + , httpGetRange = \headers uri range callback -> do + transport <- getTransport + getRange verbosity transport headers uri range callback + } + +httpGetImpl + :: HC.Throws HC.SomeRemoteError + => Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] -> URI + -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a +httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do + get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br -> + case code of + 200 -> callback respHeaders br + _ -> HC.throwChecked $ UnexpectedResponse uri code + +getRange :: HC.Throws HC.SomeRemoteError + => Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] -> URI -> (Int, Int) + -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a +getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do + get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br -> + case code of + 200 -> callback HC.HttpStatus200OK respHeaders br + 206 -> callback HC.HttpStatus206PartialContent respHeaders br + _ -> HC.throwChecked $ UnexpectedResponse uri code + +-- | Internal generalization of 'get' and 'getRange' +get' :: Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int) + -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a +get' verbosity transport reqHeaders uri mRange callback = do + tempDir <- getTemporaryDirectory + withTempFileName tempDir "transportAdapterGet" $ \temp -> do + (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders' + br <- HC.bodyReaderFromBS =<< BS.L.readFile temp + callback code [HC.HttpResponseAcceptRangesBytes] br + where + reqHeaders' = mkReqHeaders reqHeaders mRange + +{------------------------------------------------------------------------------- + Request headers +-------------------------------------------------------------------------------} + +mkRangeHeader :: Int -> Int -> HTTP.Header +mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader + where + -- Content-Range header uses inclusive rather than exclusive bounds + -- See + rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1) + +mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header] +mkReqHeaders reqHeaders mRange = concat [ + tr [] reqHeaders + , [mkRangeHeader fr to | Just (fr, to) <- [mRange]] + ] + where + tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header] + tr acc [] = + concatMap finalize acc + tr acc (HC.HttpRequestMaxAge0:os) = + tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os + tr acc (HC.HttpRequestNoTransform:os) = + tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os + + -- Some headers are comma-separated, others need multiple headers for + -- multiple options. + -- + -- TODO: Right we just comma-separate all of them. + finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header] + finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] + + insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] + insert x y = modifyAssocList x (++ y) + + -- modify the first matching element + modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] + modifyAssocList a f = go where + go [] = [] + go (p@(a', b) : xs) | a == a' = (a', f b) : xs + | otherwise = p : go xs + +{------------------------------------------------------------------------------- + Custom exceptions +-------------------------------------------------------------------------------} + +data UnexpectedResponse = UnexpectedResponse URI Int + deriving (Typeable) + +instance HC.Pretty UnexpectedResponse where + pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code + ++ " for " ++ show uri + +#if MIN_VERSION_base(4,8,0) +deriving instance Show UnexpectedResponse +instance Exception UnexpectedResponse where displayException = HC.pretty +#else +instance Show UnexpectedResponse where show = HC.pretty +instance Exception UnexpectedResponse +#endif + +wrapCustomEx :: ( ( HC.Throws UnexpectedResponse + , HC.Throws IOException + ) => IO a) + -> (HC.Throws HC.SomeRemoteError => IO a) +wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex) + $ HC.handleChecked (\(ex :: IOException) -> go ex) + $ act + where + go ex = HC.throwChecked (HC.SomeRemoteError ex) diff --git a/src/Distribution/Client/Setup.hs b/src/Distribution/Client/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Setup.hs @@ -0,0 +1,2581 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Setup +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Setup + ( globalCommand, GlobalFlags(..), defaultGlobalFlags + , RepoContext(..), withRepoContext + , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags + , configPackageDB', configCompilerAux' + , configureExCommand, ConfigExFlags(..), defaultConfigExFlags + , buildCommand, BuildFlags(..) + , filterTestFlags + , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions + , configureExOptions, reconfigureCommand + , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , filterHaddockArgs, filterHaddockFlags, haddockOptions + , defaultSolver, defaultMaxBackjumps + , listCommand, ListFlags(..), listNeedsCompiler + ,UpdateFlags(..), defaultUpdateFlags + , infoCommand, InfoFlags(..) + , fetchCommand, FetchFlags(..) + , freezeCommand, FreezeFlags(..) + , genBoundsCommand + , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..) + , getCommand, unpackCommand, GetFlags(..) + , checkCommand + , formatCommand + , uploadCommand, UploadFlags(..), IsCandidate(..) + , reportCommand, ReportFlags(..) + , runCommand + , initCommand, initOptions, IT.InitFlags(..) + , actAsSetupCommand, ActAsSetupFlags(..) + , userConfigCommand, UserConfigFlags(..) + , manpageCommand + , haddockCommand + , cleanCommand + , copyCommand + , registerCommand + + , liftOptions + , yesNoOpt + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get) + +import Distribution.Client.Types.Credentials (Username (..), Password (..)) +import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..)) +import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..)) +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy + +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Dependency.Types + ( PreSolver(..) ) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) +import Distribution.Client.IndexUtils.IndexState + ( TotalIndexState, headTotalIndexState ) +import qualified Distribution.Client.Init.Types as IT + ( InitFlags(..), PackageType(..), defaultInitFlags ) +import Distribution.Client.Targets + ( UserConstraint, readUserConstraint ) +import Distribution.Utils.NubList + ( NubList, toNubList, fromNubList) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Settings + +import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack ) +import Distribution.Simple.Program (ProgramDb, defaultProgramDb) +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Configure + ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Flag + ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag + , flagElim, fromFlagOrDefault + ) +import Distribution.Simple.Setup + ( ConfigFlags(..), BuildFlags(..), ReplFlags + , TestFlags, BenchmarkFlags + , HaddockFlags(..) + , CleanFlags(..) + , CopyFlags(..), RegisterFlags(..) + , readPackageDbList, showPackageDbList + , BooleanFlag(..), optionVerbosity + , boolOpt, boolOpt', trueArg, falseArg + , optionNumJobs ) +import Distribution.Simple.InstallDirs + ( PathTemplate, InstallDirs(..) + , toPathTemplate, fromPathTemplate, combinePathTemplate ) +import Distribution.Version + ( Version, mkVersion ) +import Distribution.Package + ( PackageName ) +import Distribution.Types.GivenComponent + ( GivenComponent(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint(..) ) +import Distribution.Types.UnqualComponentName + ( unqualComponentNameToPackageName ) +import Distribution.PackageDescription + ( BuildType(..), RepoKind(..), LibraryName(..) ) +import Distribution.System ( Platform ) +import Distribution.ReadE + ( ReadE(..), succeedReadE, parsecToReadE ) +import qualified Distribution.Compat.CharParsing as P +import Distribution.Verbosity + ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) +import Distribution.Simple.Utils + ( wrapText ) +import Distribution.Client.GlobalFlags + ( GlobalFlags(..), defaultGlobalFlags + , RepoContext(..), withRepoContext + ) +import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions) +import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) + +import Data.List + ( deleteFirstsBy ) +import System.FilePath + ( () ) + +globalCommand :: [Command action] -> CommandUI GlobalFlags +globalCommand commands = CommandUI { + commandName = "", + commandSynopsis = + "Command line interface to the Haskell Cabal infrastructure.", + commandUsage = \pname -> + "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", + commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + -- if new commands are added, we want them to appear even if they + -- are not included in the custom listing below. Thus, we calculate + -- the `otherCmds` list and append it under the `other` category. + -- Alternatively, a new testcase could be added that ensures that + -- the set of commands listed here is equal to the set of commands + -- that are actually available. + otherCmds = deleteFirstsBy (==) (map fst cmdDescs) + [ "help" + , "update" + , "install" + , "fetch" + , "list" + , "info" + , "user-config" + , "get" + , "init" + , "configure" + , "build" + , "clean" + , "run" + , "repl" + , "test" + , "bench" + , "check" + , "sdist" + , "upload" + , "report" + , "freeze" + , "gen-bounds" + , "outdated" + , "haddock" + , "hscolour" + , "exec" + , "new-build" + , "new-configure" + , "new-repl" + , "new-freeze" + , "new-run" + , "new-test" + , "new-bench" + , "new-haddock" + , "new-exec" + , "new-update" + , "new-install" + , "new-clean" + , "new-sdist" + , "list-bin" + -- v1 commands, stateful style + , "v1-build" + , "v1-configure" + , "v1-repl" + , "v1-freeze" + , "v1-run" + , "v1-test" + , "v1-bench" + , "v1-haddock" + , "v1-exec" + , "v1-update" + , "v1-install" + , "v1-clean" + , "v1-sdist" + , "v1-doctest" + , "v1-copy" + , "v1-register" + , "v1-reconfigure" + -- v2 commands, nix-style + , "v2-build" + , "v2-configure" + , "v2-repl" + , "v2-freeze" + , "v2-run" + , "v2-test" + , "v2-bench" + , "v2-haddock" + , "v2-exec" + , "v2-update" + , "v2-install" + , "v2-clean" + , "v2-sdist" + ] + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + startGroup n = " ["++n++"]" + par = "" + addCmd n = case lookup n cmdDescs of + Nothing -> "" + Just d -> " " ++ align n ++ " " ++ d + in + "Commands:\n" + ++ unlines ( + [ startGroup "global" + , addCmd "update" + , addCmd "install" + , par + , addCmd "help" + , addCmd "info" + , addCmd "list" + , addCmd "fetch" + , addCmd "user-config" + , par + , startGroup "package" + , addCmd "get" + , addCmd "init" + , par + , addCmd "configure" + , addCmd "build" + , addCmd "clean" + , par + , addCmd "run" + , addCmd "repl" + , addCmd "test" + , addCmd "bench" + , par + , addCmd "check" + , addCmd "sdist" + , addCmd "upload" + , addCmd "report" + , par + , addCmd "freeze" + , addCmd "gen-bounds" + , addCmd "outdated" + , addCmd "haddock" + , addCmd "hscolour" + , addCmd "exec" + , addCmd "list-bin" + , par + , startGroup "new-style projects (forwards-compatible aliases)" + , addCmd "v2-build" + , addCmd "v2-configure" + , addCmd "v2-repl" + , addCmd "v2-run" + , addCmd "v2-test" + , addCmd "v2-bench" + , addCmd "v2-freeze" + , addCmd "v2-haddock" + , addCmd "v2-exec" + , addCmd "v2-update" + , addCmd "v2-install" + , addCmd "v2-clean" + , addCmd "v2-sdist" + , par + , startGroup "legacy command aliases" + , addCmd "v1-build" + , addCmd "v1-configure" + , addCmd "v1-repl" + , addCmd "v1-run" + , addCmd "v1-test" + , addCmd "v1-bench" + , addCmd "v1-freeze" + , addCmd "v1-haddock" + , addCmd "v1-exec" + , addCmd "v1-update" + , addCmd "v1-install" + , addCmd "v1-clean" + , addCmd "v1-sdist" + , addCmd "v1-doctest" + , addCmd "v1-copy" + , addCmd "v1-register" + , addCmd "v1-reconfigure" + ] ++ if null otherCmds then [] else par + :startGroup "other" + :[addCmd n | n <- otherCmds]) + ++ "\n" + ++ "For more information about a command use:\n" + ++ " " ++ pname ++ " COMMAND --help\n" + ++ "or " ++ pname ++ " help COMMAND\n" + ++ "\n" + ++ "To install Cabal packages from hackage use:\n" + ++ " " ++ pname ++ " install foo [--dry-run]\n" + ++ "\n" + ++ "Occasionally you need to update the list of available packages:\n" + ++ " " ++ pname ++ " update\n", + commandNotes = Nothing, + commandDefaultFlags = mempty, + commandOptions = args + } + where + args :: ShowOrParseArgs -> [OptionField GlobalFlags] + args ShowArgs = argsShown + args ParseArgs = argsShown ++ argsNotShown + + -- arguments we want to show in the help + argsShown :: [OptionField GlobalFlags] + argsShown = [ + option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + + ,option [] ["config-file"] + "Set an alternate location for the config file" + globalConfigFile (\v flags -> flags { globalConfigFile = v }) + (reqArgFlag "FILE") + + ,option [] ["default-user-config"] + "Set a location for a cabal.config file for projects without their own cabal.config freeze file." + globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v}) + (reqArgFlag "FILE") + + ,option [] ["ignore-expiry"] + "Ignore expiry dates on signed metadata (use only in exceptional circumstances)" + globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v }) + trueArg + + ,option [] ["http-transport"] + "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" + globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) + (reqArgFlag "HttpTransport") + ,option [] ["nix"] + "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" + globalNix (\v flags -> flags { globalNix = v }) + (boolOpt [] []) + + ] + + -- arguments we don't want shown in the help + argsNotShown :: [OptionField GlobalFlags] + argsNotShown = [ + option [] ["remote-repo"] + "The name and url for a remote repository" + globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) + (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) + + ,option [] ["local-no-index-repo"] + "The name and a path for a local no-index repository" + globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v }) + (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) + + ,option [] ["remote-repo-cache"] + "The location where downloads from all remote repos are cached" + globalCacheDir (\v flags -> flags { globalCacheDir = v }) + (reqArgFlag "DIR") + + ,option [] ["logs-dir", "logsdir"] + "The location to put log files" + globalLogsDir (\v flags -> flags { globalLogsDir = v }) + (reqArgFlag "DIR") + + ,option [] ["world-file"] + "The location of the world file" + globalWorldFile (\v flags -> flags { globalWorldFile = v }) + (reqArgFlag "FILE") + + ,option [] ["store-dir", "storedir"] + "The location of the nix-local-build store" + globalStoreDir (\v flags -> flags { globalStoreDir = v }) + (reqArgFlag "DIR") + + , option [] ["active-repositories"] + "The active package repositories" + globalActiveRepos (\v flags -> flags { globalActiveRepos = v }) + (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err) + (toFlag `fmap` parsec)) + (map prettyShow . flagToList)) + ] + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +configureCommand :: CommandUI ConfigFlags +configureCommand = c + { commandName = "configure" + , commandDefaultFlags = mempty + , commandDescription = Just $ \_ -> wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n" + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-configure [FLAGS]\n" + , commandNotes = Just $ \pname -> + (Cabal.programFlagsDescription defaultProgramDb ++ "\n") + ++ "Examples:\n" + ++ " " ++ pname ++ " v1-configure\n" + ++ " Configure with defaults;\n" + ++ " " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n" + ++ " Configure building package including tests,\n" + ++ " with some package-specific flag.\n" + } + where + c = Cabal.configureCommand defaultProgramDb + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions = commandOptions configureCommand + +-- | Given some 'ConfigFlags' for the version of Cabal that +-- cabal-install was built with, and a target older 'Version' of +-- Cabal that we want to pass these flags to, convert the +-- flags into a form that will be accepted by the older +-- Setup script. Generally speaking, this just means filtering +-- out flags that the old Cabal library doesn't understand, but +-- in some cases it may also mean "emulating" a feature using +-- some more legacy flags. +filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags +filterConfigureFlags flags cabalLibVersion + -- NB: we expect the latest version to be the most common case, + -- so test it first. + | cabalLibVersion >= mkVersion [2,5,0] = flags_latest + -- The naming convention is that flags_version gives flags with + -- all flags *introduced* in version eliminated. + -- It is NOT the latest version of Cabal library that + -- these flags work for; version of introduction is a more + -- natural metric. + | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10 + | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0 + | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0 + | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0 + | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0 + | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1 + | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2 + | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1 + | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 + | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1 + | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 + | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 + | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 + | cabalLibVersion < mkVersion [2,5,0] = flags_2_5_0 + | otherwise = error "the impossible just happened" -- see first guard + where + flags_latest = flags { + -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. + -- Note: this is not in the wrong place. configConstraints gets + -- repopulated in flags_1_19_1 but it needs to be set to empty for + -- newer versions first. + configConstraints = [] + } + + flags_2_5_0 = flags_latest { + -- Cabal < 2.5 does not understand --dependency=pkg:component=cid + -- (public sublibraries), so we convert it to the legacy + -- --dependency=pkg_or_internal_compoent=cid + configDependencies = + let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = + Just $ GivenComponent + (unqualComponentNameToPackageName cn) + LMainLibName + cid + convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = + Just $ GivenComponent pn LMainLibName cid + in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags + -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'. + , configAllowDependingOnPrivateLibs = NoFlag + -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'. + , configFullyStaticExe = NoFlag + } + + flags_2_1_0 = flags_2_5_0 { + -- Cabal < 2.1 doesn't know about -v +timestamp modifier + configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest) + -- Cabal < 2.1 doesn't know about ---static + , configStaticLib = NoFlag + , configSplitSections = NoFlag + } + + flags_1_25_0 = flags_2_1_0 { + -- Cabal < 1.25.0 doesn't know about --dynlibdir. + configInstallDirs = configInstallDirs_1_25_0, + -- Cabal < 1.25 doesn't have extended verbosity syntax + configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0), + -- Cabal < 1.25 doesn't support --deterministic + configDeterministic = mempty + } + configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in + dirs { dynlibdir = NoFlag + , libexecsubdir = NoFlag + , libexecdir = maybeToFlag $ + combinePathTemplate <$> flagToMaybe (libexecdir dirs) + <*> flagToMaybe (libexecsubdir dirs) + } + -- Cabal < 1.23 doesn't know about '--profiling-detail'. + -- Cabal < 1.23 has a hacked up version of 'enable-profiling' + -- which we shouldn't use. + (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags + flags_1_23_0 = flags_1_25_0 { configProfDetail = NoFlag + , configProfLibDetail = NoFlag + , configIPID = NoFlag + , configProf = NoFlag + , configProfExe = Flag tryExeProfiling + , configProfLib = Flag tryLibProfiling + } + + -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d) + -- due to temporary amnesia of the --*-executable-profiling flags + flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag + , configProfExe = NoFlag + } + + -- Cabal < 1.22 doesn't know about '--disable-debug-info'. + flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag } + + -- Cabal < 1.21.1 doesn't know about 'disable-relocatable' + -- Cabal < 1.21.1 doesn't know about 'enable-profiling' + -- (but we already dealt with it in flags_1_23_0) + flags_1_21_1 = + flags_1_22_0 { configRelocatable = NoFlag + , configCoverage = NoFlag + , configLibCoverage = configCoverage flags + } + -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and + -- '--enable-library-stripping'. + flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag + , configStripLibs = NoFlag } + -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'. + flags_1_19_1 = flags_1_19_2 { configDependencies = [] + , configConstraints = configConstraints flags } + -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. + flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList [] + , configInstallDirs = configInstallDirs_1_18_0} + configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag } + -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'. + flags_1_14_0 = flags_1_18_0 { configBenchmarks = NoFlag } + -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic' + -- and '--enable/disable-library-coverage'. + flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag + , configDynExe = NoFlag } + -- Cabal < 1.10.0 doesn't know about '--disable-tests'. + flags_1_10_0 = flags_1_12_0 { configTests = NoFlag } + -- Cabal < 1.3.10 does not grok the '--constraints' flag. + flags_1_3_10 = flags_1_10_0 { configConstraints = [] } + +-- | Get the package database settings from 'ConfigFlags', accounting for +-- @--package-db@ and @--user@ flags. +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + interpretPackageDbFlags userInstall (configPackageDBs cfg) + where + userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg) + +-- | Configure the compiler, but reduce verbosity during this step. +configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) +configCompilerAux' configFlags = + configCompilerAuxEx configFlags + --FIXME: make configCompilerAux use a sensible verbosity + { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } + +-- ------------------------------------------------------------ +-- * Config extra flags +-- ------------------------------------------------------------ + +-- | cabal configure takes some extra flags beyond runghc Setup configure +-- +data ConfigExFlags = ConfigExFlags { + configCabalVersion :: Flag Version, + configExConstraints :: [(UserConstraint, ConstraintSource)], + configPreferences :: [PackageVersionConstraint], + configSolver :: Flag PreSolver, + configAllowNewer :: Maybe AllowNewer, + configAllowOlder :: Maybe AllowOlder, + configWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy + } + deriving (Eq, Show, Generic) + +defaultConfigExFlags :: ConfigExFlags +defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } + +configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) +configureExCommand = configureCommand { + commandDefaultFlags = (mempty, defaultConfigExFlags), + commandOptions = \showOrParseArgs -> + liftOptions fst setFst + (filter ((`notElem` ["constraint", "dependency", "exact-configuration"]) + . optionName) $ configureOptions showOrParseArgs) + ++ liftOptions snd setSnd + (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + +configureExOptions :: ShowOrParseArgs + -> ConstraintSource + -> [OptionField ConfigExFlags] +configureExOptions _showOrParseArgs src = + [ option [] ["cabal-lib-version"] + ("Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing).") + configCabalVersion (\v flags -> flags { configCabalVersion = v }) + (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++) + (fmap toFlag parsec)) + (map prettyShow. flagToList)) + , option [] ["constraint"] + "Specify constraints on a package (version, installed/source, flags)" + configExConstraints (\v flags -> flags { configExConstraints = v }) + (reqArg "CONSTRAINT" + ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) + (map $ prettyShow . fst)) + + , option [] ["preference"] + "Specify preferences (soft constraints) on the version of a package" + configPreferences (\v flags -> flags { configPreferences = v }) + (reqArg "CONSTRAINT" + (parsecToReadE (const "dependency expected") + (fmap (\x -> [x]) parsec)) + (map prettyShow)) + + , optionSolver configSolver (\v flags -> flags { configSolver = v }) + + , option [] ["allow-older"] + ("Ignore lower bounds in all dependencies or DEPS") + (fmap unAllowOlder . configAllowOlder) + (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) + (optArg "DEPS" + (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) + (Just RelaxDepsAll) relaxDepsPrinter) + + , option [] ["allow-newer"] + ("Ignore upper bounds in all dependencies or DEPS") + (fmap unAllowNewer . configAllowNewer) + (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) + (optArg "DEPS" + (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) + (Just RelaxDepsAll) relaxDepsPrinter) + + , option [] ["write-ghc-environment-files"] + ("Whether to create a .ghc.environment file after a successful build" + ++ " (v2-build only)") + configWriteGhcEnvironmentFilesPolicy + (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v}) + (reqArg "always|never|ghc8.4.4+" + writeGhcEnvironmentFilesPolicyParser + writeGhcEnvironmentFilesPolicyPrinter) + ] + + +writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) +writeGhcEnvironmentFilesPolicyParser = ReadE $ \case + "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles + "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles + "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + policy -> Left $ "Cannot parse the GHC environment file write policy '" + <> policy <> "'" + +writeGhcEnvironmentFilesPolicyPrinter + :: Flag WriteGhcEnvironmentFilesPolicy -> [String] +writeGhcEnvironmentFilesPolicyPrinter = \case + (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"] + (Flag NeverWriteGhcEnvironmentFiles) -> ["never"] + (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] + NoFlag -> [] + + +relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) +relaxDepsParser = + (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',') + +relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] +relaxDepsPrinter Nothing = [] +relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] +relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs + + +instance Monoid ConfigExFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ConfigExFlags where + (<>) = gmappend + +reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags) +reconfigureCommand + = configureExCommand + { commandName = "reconfigure" + , commandSynopsis = "Reconfigure the package if necessary." + , commandDescription = Just $ \pname -> wrapText $ + "Run `configure` with the most recently used flags, or append FLAGS " + ++ "to the most recently used configuration. " + ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. " + ++ "If the package has never been configured, the default flags are " + ++ "used." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-reconfigure\n" + ++ " Configure with the most recently used flags.\n" + ++ " " ++ pname ++ " v1-reconfigure -w PATH\n" + ++ " Reconfigure with the most recently used flags,\n" + ++ " but use the compiler at PATH.\n\n" + , commandUsage = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ] + , commandDefaultFlags = mempty + } + +-- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +buildCommand :: CommandUI BuildFlags +buildCommand = parent { + commandName = "build", + commandDescription = Just $ \_ -> wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `v1-configure`.\n", + commandDefaultFlags = commandDefaultFlags parent, + commandUsage = usageAlternatives "v1-build" $ + [ "[FLAGS]", "COMPONENTS [FLAGS]" ], + commandOptions = commandOptions parent + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-build " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " v1-build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ Cabal.programFlagsDescription defaultProgramDb + } + where + parent = Cabal.buildCommand defaultProgramDb + +-- ------------------------------------------------------------ +-- * Test flags +-- ------------------------------------------------------------ + +-- | Given some 'TestFlags' for the version of Cabal that +-- cabal-install was built with, and a target older 'Version' of +-- Cabal that we want to pass these flags to, convert the +-- flags into a form that will be accepted by the older +-- Setup script. Generally speaking, this just means filtering +-- out flags that the old Cabal library doesn't understand, but +-- in some cases it may also mean "emulating" a feature using +-- some more legacy flags. +filterTestFlags :: TestFlags -> Version -> TestFlags +filterTestFlags flags cabalLibVersion + -- NB: we expect the latest version to be the most common case, + -- so test it first. + | cabalLibVersion >= mkVersion [3,0,0] = flags_latest + -- The naming convention is that flags_version gives flags with + -- all flags *introduced* in version eliminated. + -- It is NOT the latest version of Cabal library that + -- these flags work for; version of introduction is a more + -- natural metric. + | cabalLibVersion < mkVersion [3,0,0] = flags_3_0_0 + | otherwise = error "the impossible just happened" -- see first guard + where + flags_latest = flags + flags_3_0_0 = flags_latest { + -- Cabal < 3.0 doesn't know about --test-wrapper + Cabal.testWrapper = NoFlag + } + +-- ------------------------------------------------------------ +-- * Repl command +-- ------------------------------------------------------------ + +replCommand :: CommandUI ReplFlags +replCommand = parent { + commandName = "repl", + commandDescription = Just $ \pname -> wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session;\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" ++ pname + ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n", + commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n", + commandDefaultFlags = commandDefaultFlags parent, + commandOptions = commandOptions parent, + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-repl " + ++ " The first component in the package\n" + ++ " " ++ pname ++ " v1-repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" + } + where + parent = Cabal.replCommand defaultProgramDb + +-- ------------------------------------------------------------ +-- * Test command +-- ------------------------------------------------------------ + +testCommand :: CommandUI (BuildFlags, TestFlags) +testCommand = parent { + commandName = "test", + commandDescription = Just $ \pname -> wrapText $ + "If necessary (re)configures with `--enable-tests` flag and builds" + ++ " the test suite.\n" + ++ "\n" + ++ "Remember that the tests' dependencies must be installed if there" + ++ " are additional ones; e.g. with `" ++ pname + ++ " v1-install --only-dependencies --enable-tests`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running tests.\n", + commandUsage = usageAlternatives "v1-test" + [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ], + commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), + commandOptions = + \showOrParseArgs -> liftOptions get1 set1 + (Cabal.buildOptions progDb showOrParseArgs) + ++ + liftOptions get2 set2 + (commandOptions parent showOrParseArgs) + } + where + get1 (a,_) = a; set1 a (_,b) = (a,b) + get2 (_,b) = b; set2 b (a,_) = (a,b) + + parent = Cabal.testCommand + progDb = defaultProgramDb + +-- ------------------------------------------------------------ +-- * Bench command +-- ------------------------------------------------------------ + +benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags) +benchmarkCommand = parent { + commandName = "bench", + commandUsage = usageAlternatives "v1-bench" + [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ], + commandDescription = Just $ \pname -> wrapText $ + "If necessary (re)configures with `--enable-benchmarks` flag and" + ++ " builds the benchmarks.\n" + ++ "\n" + ++ "Remember that the benchmarks' dependencies must be installed if" + ++ " there are additional ones; e.g. with `" ++ pname + ++ " v1-install --only-dependencies --enable-benchmarks`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running" + ++ " benchmarks.\n", + commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), + commandOptions = + \showOrParseArgs -> liftOptions get1 set1 + (Cabal.buildOptions progDb showOrParseArgs) + ++ + liftOptions get2 set2 + (commandOptions parent showOrParseArgs) + } + where + get1 (a,_) = a; set1 a (_,b) = (a,b) + get2 (_,b) = b; set2 b (a,_) = (a,b) + + parent = Cabal.benchmarkCommand + progDb = defaultProgramDb + +-- ------------------------------------------------------------ +-- * Fetch command +-- ------------------------------------------------------------ + +data FetchFlags = FetchFlags { +-- fetchOutput :: Flag FilePath, + fetchDeps :: Flag Bool, + fetchDryRun :: Flag Bool, + fetchSolver :: Flag PreSolver, + fetchMaxBackjumps :: Flag Int, + fetchReorderGoals :: Flag ReorderGoals, + fetchCountConflicts :: Flag CountConflicts, + fetchFineGrainedConflicts :: Flag FineGrainedConflicts, + fetchMinimizeConflictSet :: Flag MinimizeConflictSet, + fetchIndependentGoals :: Flag IndependentGoals, + fetchShadowPkgs :: Flag ShadowPkgs, + fetchStrongFlags :: Flag StrongFlags, + fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, + fetchOnlyConstrained :: Flag OnlyConstrained, + fetchTests :: Flag Bool, + fetchBenchmarks :: Flag Bool, + fetchVerbosity :: Flag Verbosity + } + +defaultFetchFlags :: FetchFlags +defaultFetchFlags = FetchFlags { +-- fetchOutput = mempty, + fetchDeps = toFlag True, + fetchDryRun = toFlag False, + fetchSolver = Flag defaultSolver, + fetchMaxBackjumps = Flag defaultMaxBackjumps, + fetchReorderGoals = Flag (ReorderGoals False), + fetchCountConflicts = Flag (CountConflicts True), + fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), + fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), + fetchIndependentGoals = Flag (IndependentGoals False), + fetchShadowPkgs = Flag (ShadowPkgs False), + fetchStrongFlags = Flag (StrongFlags False), + fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + fetchOnlyConstrained = Flag OnlyConstrainedNone, + fetchTests = toFlag False, + fetchBenchmarks = toFlag False, + fetchVerbosity = toFlag normal + } + +fetchCommand :: CommandUI FetchFlags +fetchCommand = CommandUI { + commandName = "fetch", + commandSynopsis = "Downloads packages for later installation.", + commandUsage = usageAlternatives "fetch" [ "[FLAGS] PACKAGES" + ], + commandDescription = Just $ \_ -> + "Note that it currently is not possible to fetch the dependencies for a\n" + ++ "package in the current directory.\n", + commandNotes = Nothing, + commandDefaultFlags = defaultFetchFlags, + commandOptions = \ showOrParseArgs -> [ + optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) + +-- , option "o" ["output"] +-- "Put the package(s) somewhere specific rather than the usual cache." +-- fetchOutput (\v flags -> flags { fetchOutput = v }) +-- (reqArgFlag "PATH") + + , option [] ["dependencies", "deps"] + "Resolve and fetch dependencies (default)" + fetchDeps (\v flags -> flags { fetchDeps = v }) + trueArg + + , option [] ["no-dependencies", "no-deps"] + "Ignore dependencies" + fetchDeps (\v flags -> flags { fetchDeps = v }) + falseArg + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + fetchDryRun (\v flags -> flags { fetchDryRun = v }) + trueArg + + , option "" ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + fetchTests (\v flags -> flags { fetchTests = v }) + (boolOpt [] []) + + , option "" ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v }) + (boolOpt [] []) + + ] ++ + + optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) : + optionSolverFlags showOrParseArgs + fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) + fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) + fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) + fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) + fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) + fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) + fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) + fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) + fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) + fetchOnlyConstrained (\v flags -> flags { fetchOnlyConstrained = v }) + + } + +-- ------------------------------------------------------------ +-- * Freeze command +-- ------------------------------------------------------------ + +data FreezeFlags = FreezeFlags { + freezeDryRun :: Flag Bool, + freezeTests :: Flag Bool, + freezeBenchmarks :: Flag Bool, + freezeSolver :: Flag PreSolver, + freezeMaxBackjumps :: Flag Int, + freezeReorderGoals :: Flag ReorderGoals, + freezeCountConflicts :: Flag CountConflicts, + freezeFineGrainedConflicts :: Flag FineGrainedConflicts, + freezeMinimizeConflictSet :: Flag MinimizeConflictSet, + freezeIndependentGoals :: Flag IndependentGoals, + freezeShadowPkgs :: Flag ShadowPkgs, + freezeStrongFlags :: Flag StrongFlags, + freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, + freezeOnlyConstrained :: Flag OnlyConstrained, + freezeVerbosity :: Flag Verbosity + } + +defaultFreezeFlags :: FreezeFlags +defaultFreezeFlags = FreezeFlags { + freezeDryRun = toFlag False, + freezeTests = toFlag False, + freezeBenchmarks = toFlag False, + freezeSolver = Flag defaultSolver, + freezeMaxBackjumps = Flag defaultMaxBackjumps, + freezeReorderGoals = Flag (ReorderGoals False), + freezeCountConflicts = Flag (CountConflicts True), + freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), + freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), + freezeIndependentGoals = Flag (IndependentGoals False), + freezeShadowPkgs = Flag (ShadowPkgs False), + freezeStrongFlags = Flag (StrongFlags False), + freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + freezeOnlyConstrained = Flag OnlyConstrainedNone, + freezeVerbosity = toFlag normal + } + +freezeCommand :: CommandUI FreezeFlags +freezeCommand = CommandUI { + commandName = "freeze", + commandSynopsis = "Freeze dependencies.", + commandDescription = Just $ \_ -> wrapText $ + "Calculates a valid set of dependencies and their exact versions. " + ++ "If successful, saves the result to the file `cabal.config`.\n" + ++ "\n" + ++ "The package versions specified in `cabal.config` will be used for " + ++ "any future installs.\n" + ++ "\n" + ++ "An existing `cabal.config` is ignored and overwritten.\n", + commandNotes = Nothing, + commandUsage = usageFlags "freeze", + commandDefaultFlags = defaultFreezeFlags, + commandOptions = \ showOrParseArgs -> [ + optionVerbosity freezeVerbosity + (\v flags -> flags { freezeVerbosity = v }) + + , option [] ["dry-run"] + "Do not freeze anything, only print what would be frozen" + freezeDryRun (\v flags -> flags { freezeDryRun = v }) + trueArg + + , option [] ["tests"] + ("freezing of the dependencies of any tests suites " + ++ "in the package description file.") + freezeTests (\v flags -> flags { freezeTests = v }) + (boolOpt [] []) + + , option [] ["benchmarks"] + ("freezing of the dependencies of any benchmarks suites " + ++ "in the package description file.") + freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v }) + (boolOpt [] []) + + ] ++ + + optionSolver + freezeSolver (\v flags -> flags { freezeSolver = v }): + optionSolverFlags showOrParseArgs + freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) + freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) + freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) + freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) + freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) + freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) + freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) + freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) + freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) + freezeOnlyConstrained (\v flags -> flags { freezeOnlyConstrained = v }) + + } + +-- ------------------------------------------------------------ +-- * 'gen-bounds' command +-- ------------------------------------------------------------ + +genBoundsCommand :: CommandUI FreezeFlags +genBoundsCommand = CommandUI { + commandName = "gen-bounds", + commandSynopsis = "Generate dependency bounds.", + commandDescription = Just $ \_ -> wrapText $ + "Generates bounds for all dependencies that do not currently have them. " + ++ "Generated bounds are printed to stdout. " + ++ "You can then paste them into your .cabal file.\n" + ++ "\n", + commandNotes = Nothing, + commandUsage = usageFlags "gen-bounds", + commandDefaultFlags = defaultFreezeFlags, + commandOptions = \ _ -> [ + optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v }) + ] + } + +-- ------------------------------------------------------------ +-- * 'outdated' command +-- ------------------------------------------------------------ + +data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone + | IgnoreMajorVersionBumpsAll + | IgnoreMajorVersionBumpsSome [PackageName] + +instance Monoid IgnoreMajorVersionBumps where + mempty = IgnoreMajorVersionBumpsNone + mappend = (<>) + +instance Semigroup IgnoreMajorVersionBumps where + IgnoreMajorVersionBumpsNone <> r = r + l@IgnoreMajorVersionBumpsAll <> _ = l + l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l + (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r + (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) = + IgnoreMajorVersionBumpsSome (a ++ b) + +data OutdatedFlags = OutdatedFlags { + outdatedVerbosity :: Flag Verbosity, + outdatedFreezeFile :: Flag Bool, + outdatedNewFreezeFile :: Flag Bool, + outdatedProjectFile :: Flag FilePath, + outdatedSimpleOutput :: Flag Bool, + outdatedExitCode :: Flag Bool, + outdatedQuiet :: Flag Bool, + outdatedIgnore :: [PackageName], + outdatedMinor :: Maybe IgnoreMajorVersionBumps + } + +defaultOutdatedFlags :: OutdatedFlags +defaultOutdatedFlags = OutdatedFlags { + outdatedVerbosity = toFlag normal, + outdatedFreezeFile = mempty, + outdatedNewFreezeFile = mempty, + outdatedProjectFile = mempty, + outdatedSimpleOutput = mempty, + outdatedExitCode = mempty, + outdatedQuiet = mempty, + outdatedIgnore = mempty, + outdatedMinor = mempty + } + +outdatedCommand :: CommandUI OutdatedFlags +outdatedCommand = CommandUI { + commandName = "outdated", + commandSynopsis = "Check for outdated dependencies", + commandDescription = Just $ \_ -> wrapText $ + "Checks for outdated dependencies in the package description file " + ++ "or freeze file", + commandNotes = Nothing, + commandUsage = usageFlags "outdated", + commandDefaultFlags = defaultOutdatedFlags, + commandOptions = \ _ -> [ + optionVerbosity outdatedVerbosity + (\v flags -> flags { outdatedVerbosity = v }) + + ,option [] ["freeze-file", "v1-freeze-file"] + "Act on the freeze file" + outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v }) + trueArg + + ,option [] ["v2-freeze-file", "new-freeze-file"] + "Act on the new-style freeze file (default: cabal.project.freeze)" + outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v }) + trueArg + + ,option [] ["project-file"] + "Act on the new-style freeze file named PROJECTFILE.freeze rather than the default cabal.project.freeze" + outdatedProjectFile (\v flags -> flags { outdatedProjectFile = v }) + (reqArgFlag "PROJECTFILE") + + ,option [] ["simple-output"] + "Only print names of outdated dependencies, one per line" + outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v }) + trueArg + + ,option [] ["exit-code"] + "Exit with non-zero when there are outdated dependencies" + outdatedExitCode (\v flags -> flags { outdatedExitCode = v }) + trueArg + + ,option ['q'] ["quiet"] + "Don't print any output. Implies '--exit-code' and '-v0'" + outdatedQuiet (\v flags -> flags { outdatedQuiet = v }) + trueArg + + ,option [] ["ignore"] + "Packages to ignore" + outdatedIgnore (\v flags -> flags { outdatedIgnore = v }) + (reqArg "PKGS" pkgNameListParser (map prettyShow)) + + ,option [] ["minor"] + "Ignore major version bumps for these packages" + outdatedMinor (\v flags -> flags { outdatedMinor = v }) + (optArg "PKGS" ignoreMajorVersionBumpsParser + (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter) + ] + } + where + ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps) + -> [Maybe String] + ignoreMajorVersionBumpsPrinter Nothing = [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] + ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = + map (Just . prettyShow) $ pkgs + + ignoreMajorVersionBumpsParser = + (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser + + pkgNameListParser = parsecToReadE + ("Couldn't parse the list of package names: " ++) + (fmap toList (P.sepByNonEmpty parsec (P.char ','))) + +-- ------------------------------------------------------------ +-- * Update command +-- ------------------------------------------------------------ + +data UpdateFlags + = UpdateFlags { + updateVerbosity :: Flag Verbosity, + updateIndexState :: Flag TotalIndexState + } deriving Generic + +defaultUpdateFlags :: UpdateFlags +defaultUpdateFlags + = UpdateFlags { + updateVerbosity = toFlag normal, + updateIndexState = toFlag headTotalIndexState + } + +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + +cleanCommand :: CommandUI CleanFlags +cleanCommand = Cabal.cleanCommand + { commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" + } + +checkCommand :: CommandUI (Flag Verbosity) +checkCommand = CommandUI { + commandName = "check", + commandSynopsis = "Check the package for common mistakes.", + commandDescription = Just $ \_ -> wrapText $ + "Expects a .cabal package file in the current directory.\n" + ++ "\n" + ++ "The checks correspond to the requirements to packages on Hackage. " + ++ "If no errors and warnings are reported, Hackage will accept this " + ++ "package.\n", + commandNotes = Nothing, + commandUsage = usageFlags "check", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +formatCommand :: CommandUI (Flag Verbosity) +formatCommand = CommandUI { + commandName = "format", + commandSynopsis = "Reformat the .cabal file using the standard style.", + commandDescription = Nothing, + commandNotes = Nothing, + commandUsage = usageAlternatives "format" ["[FILE]"], + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [] + } + +manpageCommand :: CommandUI ManpageFlags +manpageCommand = CommandUI { + commandName = "man", + commandSynopsis = "Outputs manpage source.", + commandDescription = Just $ \_ -> + "Output manpage source to STDOUT.\n", + commandNotes = Nothing, + commandUsage = usageFlags "man", + commandDefaultFlags = defaultManpageFlags, + commandOptions = manpageOptions + } + +runCommand :: CommandUI BuildFlags +runCommand = CommandUI { + commandName = "run", + commandSynopsis = "Builds and runs an executable.", + commandDescription = Just $ \pname -> wrapText $ + "Builds and then runs the specified executable. If no executable is " + ++ "specified, but the package contains just one executable, that one " + ++ "is built and executed.\n" + ++ "\n" + ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a " + ++ "test-suite and get its full output.\n", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-run\n" + ++ " Run the only executable in the current package;\n" + ++ " " ++ pname ++ " v1-run foo -- --fooflag\n" + ++ " Works similar to `./foo --fooflag`.\n", + commandUsage = usageAlternatives "v1-run" + ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"], + commandDefaultFlags = mempty, + commandOptions = commandOptions parent + } + where + parent = Cabal.buildCommand defaultProgramDb + +-- ------------------------------------------------------------ +-- * Report flags +-- ------------------------------------------------------------ + +data ReportFlags = ReportFlags { + reportUsername :: Flag Username, + reportPassword :: Flag Password, + reportVerbosity :: Flag Verbosity + } deriving Generic + +defaultReportFlags :: ReportFlags +defaultReportFlags = ReportFlags { + reportUsername = mempty, + reportPassword = mempty, + reportVerbosity = toFlag normal + } + +reportCommand :: CommandUI ReportFlags +reportCommand = CommandUI { + commandName = "report", + commandSynopsis = "Upload build reports to a remote server.", + commandDescription = Nothing, + commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n", + commandUsage = usageAlternatives "report" ["[FLAGS]"], + commandDefaultFlags = defaultReportFlags, + commandOptions = \_ -> + [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v }) + + ,option ['u'] ["username"] + "Hackage username." + reportUsername (\v flags -> flags { reportUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + reportPassword (\v flags -> flags { reportPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + ] + } + +instance Monoid ReportFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ReportFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Get flags +-- ------------------------------------------------------------ + +data GetFlags = GetFlags { + getDestDir :: Flag FilePath, + getPristine :: Flag Bool, + getIndexState :: Flag TotalIndexState, + getActiveRepos :: Flag ActiveRepos, + getSourceRepository :: Flag (Maybe RepoKind), + getVerbosity :: Flag Verbosity + } deriving Generic + +defaultGetFlags :: GetFlags +defaultGetFlags = GetFlags { + getDestDir = mempty, + getPristine = mempty, + getIndexState = mempty, + getActiveRepos = mempty, + getSourceRepository = mempty, + getVerbosity = toFlag normal + } + +getCommand :: CommandUI GetFlags +getCommand = CommandUI { + commandName = "get", + commandSynopsis = "Download/Extract a package's source code (repository).", + commandDescription = Just $ \_ -> wrapText $ + "Creates a local copy of a package's source code. By default it gets " + ++ "the source\ntarball and unpacks it in a local subdirectory. " + ++ "Alternatively, with -s it will\nget the code from the source " + ++ "repository specified by the package.\n", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " get hlint\n" + ++ " Download the latest stable version of hlint;\n" + ++ " " ++ pname ++ " get lens --source-repository=head\n" + ++ " Download the source repository (i.e. git clone from github).\n", + commandUsage = usagePackages "get", + commandDefaultFlags = defaultGetFlags, + commandOptions = \_ -> [ + optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v }) + + ,option "d" ["destdir"] + "Where to place the package source, defaults to the current directory." + getDestDir (\v flags -> flags { getDestDir = v }) + (reqArgFlag "PATH") + + ,option "s" ["source-repository"] + "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." + getSourceRepository (\v flags -> flags { getSourceRepository = v }) + (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository") + (fmap (toFlag . Just) parsec)) + (Flag Nothing) + (map (fmap show) . flagToList)) + + , option [] ["index-state"] + ("Use source package index state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++ + "This determines which package versions are available as well as " ++ + ".cabal file revision is selected (unless --pristine is used).") + getIndexState (\v flags -> flags { getIndexState = v }) + (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["pristine"] + ("Unpack the original pristine tarball, rather than updating the " + ++ ".cabal file with the latest revision from the package archive.") + getPristine (\v flags -> flags { getPristine = v }) + trueArg + ] + } + +-- 'cabal unpack' is a deprecated alias for 'cabal get'. +unpackCommand :: CommandUI GetFlags +unpackCommand = getCommand { + commandName = "unpack", + commandUsage = usagePackages "unpack" + } + +instance Monoid GetFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup GetFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * List flags +-- ------------------------------------------------------------ + +data ListFlags = ListFlags + { listInstalled :: Flag Bool + , listSimpleOutput :: Flag Bool + , listCaseInsensitive :: Flag Bool + , listVerbosity :: Flag Verbosity + , listPackageDBs :: [Maybe PackageDB] + , listHcPath :: Flag FilePath + } + deriving Generic + +defaultListFlags :: ListFlags +defaultListFlags = ListFlags + { listInstalled = Flag False + , listSimpleOutput = Flag False + , listCaseInsensitive = Flag True + , listVerbosity = toFlag normal + , listPackageDBs = [] + , listHcPath = mempty + } + +listCommand :: CommandUI ListFlags +listCommand = CommandUI { + commandName = "list", + commandSynopsis = "List packages matching a search string.", + commandDescription = Just $ \_ -> wrapText $ + "List all packages, or all packages matching one of the search" + ++ " strings.\n" + ++ "\n" + ++ "Use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " list pandoc\n" + ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n", + commandUsage = usageAlternatives "list" [ "[FLAGS]" + , "[FLAGS] STRINGS"], + commandDefaultFlags = defaultListFlags, + commandOptions = const listOptions + } + +listOptions :: [OptionField ListFlags] +listOptions = + [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) + + , option [] ["installed"] + "Only print installed packages" + listInstalled (\v flags -> flags { listInstalled = v }) + trueArg + + , option [] ["simple-output"] + "Print in a easy-to-parse format" + listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) + trueArg + , option ['i'] ["ignore-case"] + "Ignore case destictions" + listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v }) + (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) + + , option "" ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user']," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details.") + listPackageDBs (\v flags -> flags { listPackageDBs = v }) + (reqArg' "DB" readPackageDbList showPackageDbList) + + , option "w" ["with-compiler"] + "give the path to a particular compiler" + listHcPath (\v flags -> flags { listHcPath = v }) + (reqArgFlag "PATH") + ] + +listNeedsCompiler :: ListFlags -> Bool +listNeedsCompiler f = + flagElim False (const True) (listHcPath f) + || fromFlagOrDefault False (listInstalled f) + +instance Monoid ListFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ListFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Info flags +-- ------------------------------------------------------------ + +data InfoFlags = InfoFlags { + infoVerbosity :: Flag Verbosity, + infoPackageDBs :: [Maybe PackageDB] + } deriving Generic + +defaultInfoFlags :: InfoFlags +defaultInfoFlags = InfoFlags { + infoVerbosity = toFlag normal, + infoPackageDBs = [] + } + +infoCommand :: CommandUI InfoFlags +infoCommand = CommandUI { + commandName = "info", + commandSynopsis = "Display detailed information about a particular package.", + commandDescription = Just $ \_ -> wrapText $ + "Use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n", + commandNotes = Nothing, + commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"], + commandDefaultFlags = defaultInfoFlags, + commandOptions = \_ -> [ + optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) + + , option "" ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user']," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details.") + infoPackageDBs (\v flags -> flags { infoPackageDBs = v }) + (reqArg' "DB" readPackageDbList showPackageDbList) + + ] + } + +instance Monoid InfoFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InfoFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Install takes the same flags as configure along with a few extras. +-- +data InstallFlags = InstallFlags { + installDocumentation :: Flag Bool, + installHaddockIndex :: Flag PathTemplate, + installDest :: Flag Cabal.CopyDest, + installDryRun :: Flag Bool, + installOnlyDownload :: Flag Bool, + installMaxBackjumps :: Flag Int, + installReorderGoals :: Flag ReorderGoals, + installCountConflicts :: Flag CountConflicts, + installFineGrainedConflicts :: Flag FineGrainedConflicts, + installMinimizeConflictSet :: Flag MinimizeConflictSet, + installIndependentGoals :: Flag IndependentGoals, + installShadowPkgs :: Flag ShadowPkgs, + installStrongFlags :: Flag StrongFlags, + installAllowBootLibInstalls :: Flag AllowBootLibInstalls, + installOnlyConstrained :: Flag OnlyConstrained, + installReinstall :: Flag Bool, + installAvoidReinstalls :: Flag AvoidReinstalls, + installOverrideReinstall :: Flag Bool, + installUpgradeDeps :: Flag Bool, + installOnly :: Flag Bool, + installOnlyDeps :: Flag Bool, + installIndexState :: Flag TotalIndexState, + installRootCmd :: Flag String, + installSummaryFile :: NubList PathTemplate, + installLogFile :: Flag PathTemplate, + installBuildReports :: Flag ReportLevel, + installReportPlanningFailure :: Flag Bool, + -- Note: symlink-bindir is no longer used by v2-install and can be removed + -- when removing v1 commands + installSymlinkBinDir :: Flag FilePath, + installPerComponent :: Flag Bool, + installOneShot :: Flag Bool, + installNumJobs :: Flag (Maybe Int), + installKeepGoing :: Flag Bool, + installRunTests :: Flag Bool, + installOfflineMode :: Flag Bool + } + deriving (Eq, Show, Generic) + +instance Binary InstallFlags + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installDocumentation = Flag False, + installHaddockIndex = Flag docIndexFile, + installDest = Flag Cabal.NoCopyDest, + installDryRun = Flag False, + installOnlyDownload = Flag False, + installMaxBackjumps = Flag defaultMaxBackjumps, + installReorderGoals = Flag (ReorderGoals False), + installCountConflicts = Flag (CountConflicts True), + installFineGrainedConflicts = Flag (FineGrainedConflicts True), + installMinimizeConflictSet = Flag (MinimizeConflictSet False), + installIndependentGoals= Flag (IndependentGoals False), + installShadowPkgs = Flag (ShadowPkgs False), + installStrongFlags = Flag (StrongFlags False), + installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + installOnlyConstrained = Flag OnlyConstrainedNone, + installReinstall = Flag False, + installAvoidReinstalls = Flag (AvoidReinstalls False), + installOverrideReinstall = Flag False, + installUpgradeDeps = Flag False, + installOnly = Flag False, + installOnlyDeps = Flag False, + installIndexState = mempty, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = Flag NoReports, + installReportPlanningFailure = Flag False, + installSymlinkBinDir = mempty, + installPerComponent = Flag True, + installOneShot = Flag False, + installNumJobs = mempty, + installKeepGoing = Flag False, + installRunTests = mempty, + installOfflineMode = Flag False + } + where + docIndexFile = toPathTemplate ("$datadir" "doc" + "$arch-$os-$compiler" "index.html") + +defaultMaxBackjumps :: Int +defaultMaxBackjumps = 4000 + +defaultSolver :: PreSolver +defaultSolver = AlwaysModular + +allSolvers :: String +allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver])) + +installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) +installCommand = CommandUI { + commandName = "install", + commandSynopsis = "Install packages.", + commandUsage = usageAlternatives "v1-install" [ "[FLAGS]" + , "[FLAGS] PACKAGES" + ], + commandDescription = Just $ \_ -> wrapText $ + "Installs one or more packages. By default, the installed package" + ++ " will be registered in the user's package database." + ++ "\n" + ++ "If PACKAGES are specified, downloads and installs those packages." + ++ " Otherwise, install the package in the current directory (and/or its" + ++ " dependencies) (there must be exactly one .cabal file in the current" + ++ " directory).\n" + ++ "\n" + ++ "The flags to `v1-install` are saved and" + ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for" + ++ " `v1-configure` for a list of commands being affected.\n" + ++ "\n" + ++ "Installed executables will by default" + ++ " be put into `~/.cabal/bin/`." + ++ " If you want installed executable to be available globally, make" + ++ " sure that the PATH environment variable contains that directory.\n" + ++ "\n", + commandNotes = Just $ \pname -> + ( case commandNotes + $ Cabal.configureCommand defaultProgramDb + of Just desc -> desc pname ++ "\n" + Nothing -> "" + ) + ++ "Examples:\n" + ++ " " ++ pname ++ " v1-install " + ++ " Package in the current directory\n" + ++ " " ++ pname ++ " v1-install foo " + ++ " Package from the hackage server\n" + ++ " " ++ pname ++ " v1-install foo-1.0 " + ++ " Specific version of a package\n" + ++ " " ++ pname ++ " v1-install 'foo < 2' " + ++ " Constrained package version\n" + ++ " " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" + ++ " " ++ (map (const ' ') pname) + ++ " " + ++ " Change installation destination\n", + commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), + commandOptions = \showOrParseArgs -> + liftOptions get1 set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. + (filter ((`notElem` ["constraint", "dependency" + , "exact-configuration"]) + . optionName) $ + configureOptions showOrParseArgs) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + ++ liftOptions get3 set3 + -- hide "target-package-db" flag from the + -- install options. + (filter ((`notElem` ["target-package-db"]) + . optionName) $ + installOptions showOrParseArgs) + ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) + ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) + } + where + get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) + get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) + get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) + get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) + get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) + get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) + +haddockCommand :: CommandUI HaddockFlags +haddockCommand = Cabal.haddockCommand + { commandUsage = usageAlternatives "v1-haddock" $ + [ "[FLAGS]", "COMPONENTS [FLAGS]" ] + } + +filterHaddockArgs :: [String] -> Version -> [String] +filterHaddockArgs args cabalLibVersion + | cabalLibVersion >= mkVersion [2,3,0] = args_latest + | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0 + | otherwise = args_latest + where + args_latest = args + + -- Cabal < 2.3 doesn't know about per-component haddock + args_2_3_0 = [] + +filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags +filterHaddockFlags flags cabalLibVersion + | cabalLibVersion >= mkVersion [2,3,0] = flags_latest + | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0 + | otherwise = flags_latest + where + flags_latest = flags + + flags_2_3_0 = flags_latest { + -- Cabal < 2.3 doesn't know about per-component haddock + haddockArgs = [] + } + +haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] +haddockOptions showOrParseArgs + = [ opt { optionName = "haddock-" ++ name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.haddockCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["hoogle", "html", "html-location" + ,"executables", "tests", "benchmarks", "all", "internal", "css" + ,"hyperlink-source", "quickjump", "hscolour-css" + ,"contents-location", "for-hackage"] + ] + +testOptions :: ShowOrParseArgs -> [OptionField TestFlags] +testOptions showOrParseArgs + = [ opt { optionName = prefixTest name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.testCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["log", "machine-log", "show-details", "keep-tix-files" + ,"fail-when-no-test-suites", "test-options", "test-option" + ,"test-wrapper"] + ] + where + prefixTest name | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name + +benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions showOrParseArgs + = [ opt { optionName = prefixBenchmark name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["benchmark-options", "benchmark-option"] + ] + where + prefixBenchmark name | "benchmark-" `isPrefixOf` name = name + | otherwise = "benchmark-" ++ name + +fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a +fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w +fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w +fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] +fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ option "" ["documentation"] + "building of documentation" + installDocumentation (\v flags -> flags { installDocumentation = v }) + (boolOpt [] []) + + , option [] ["doc-index-file"] + "A central index of haddock API documentation (template cannot use $pkgid)" + installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + installDryRun (\v flags -> flags { installDryRun = v }) + trueArg + + , option [] ["only-download"] + "Do not build anything, only fetch the packages." + installOnlyDownload (\v flags -> flags { installOnlyDownload = v }) + trueArg + + , option "" ["target-package-db"] + "package database to install into. Required when using ${pkgroot} prefix." + installDest (\v flags -> flags { installDest = v }) + (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb)) + (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> [])) + ] ++ + + optionSolverFlags showOrParseArgs + installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) + installReorderGoals (\v flags -> flags { installReorderGoals = v }) + installCountConflicts (\v flags -> flags { installCountConflicts = v }) + installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) + installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) + installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) + installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) + installStrongFlags (\v flags -> flags { installStrongFlags = v }) + installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) + installOnlyConstrained (\v flags -> flags { installOnlyConstrained = v }) ++ + + [ option [] ["reinstall"] + "Install even if it means installing the same version again." + installReinstall (\v flags -> flags { installReinstall = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["avoid-reinstalls"] + "Do not select versions that would destructively overwrite installed packages." + (fmap asBool . installAvoidReinstalls) + (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v }) + (yesNoOpt showOrParseArgs) + + , option [] ["force-reinstalls"] + "Reinstall packages even if they will most likely break other installed packages." + installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["upgrade-dependencies"] + "Pick the latest version for all dependencies, rather than trying to pick an installed version." + installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["only-dependencies"] + "Install only the dependencies necessary to build the given packages" + installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["dependencies-only"] + "A synonym for --only-dependencies" + installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["index-state"] + ("Use source package index state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") + installIndexState (\v flags -> flags { installIndexState = v }) + (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["root-cmd"] + "(No longer supported, do not use.)" + installRootCmd (\v flags -> flags { installRootCmd = v }) + (reqArg' "COMMAND" toFlag flagToList) + + , option [] ["symlink-bindir"] + "Add symlinks to installed executables into this directory." + installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) + (reqArgFlag "DIR") + + , option [] ["build-summary"] + "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + installSummaryFile (\v flags -> flags { installSummaryFile = v }) + (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList)) + + , option [] ["build-log"] + "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + installLogFile (\v flags -> flags { installLogFile = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["remote-build-reporting"] + "Generate build reports to send to a remote server (none, anonymous or detailed)." + installBuildReports (\v flags -> flags { installBuildReports = v }) + (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', " + ++ "'anonymous' or 'detailed'") + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["report-planning-failure"] + "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." + installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v }) + trueArg + + , option "" ["per-component"] + "Per-component builds when possible" + installPerComponent (\v flags -> flags { installPerComponent = v }) + (boolOpt [] []) + + , option [] ["one-shot"] + "Do not record the packages in the world file." + installOneShot (\v flags -> flags { installOneShot = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["run-tests"] + "Run package test suites during installation." + installRunTests (\v flags -> flags { installRunTests = v }) + trueArg + + , optionNumJobs + installNumJobs (\v flags -> flags { installNumJobs = v }) + + , option [] ["keep-going"] + "After a build failure, continue to build other unaffected packages." + installKeepGoing (\v flags -> flags { installKeepGoing = v }) + trueArg + + , option [] ["offline"] + "Don't download packages from the Internet." + installOfflineMode (\v flags -> flags { installOfflineMode = v }) + (yesNoOpt showOrParseArgs) + + ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" + -- avoids + ParseArgs -> + [ option [] ["only"] + "Only installs the package in the current directory." + installOnly (\v flags -> flags { installOnly = v }) + trueArg ] + _ -> [] + + +instance Monoid InstallFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InstallFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Upload flags +-- ------------------------------------------------------------ + +-- | Is this a candidate package or a package to be published? +data IsCandidate = IsCandidate | IsPublished + deriving Eq + +data UploadFlags = UploadFlags { + uploadCandidate :: Flag IsCandidate, + uploadDoc :: Flag Bool, + uploadUsername :: Flag Username, + uploadPassword :: Flag Password, + uploadPasswordCmd :: Flag [String], + uploadVerbosity :: Flag Verbosity + } deriving Generic + +defaultUploadFlags :: UploadFlags +defaultUploadFlags = UploadFlags { + uploadCandidate = toFlag IsCandidate, + uploadDoc = toFlag False, + uploadUsername = mempty, + uploadPassword = mempty, + uploadPasswordCmd = mempty, + uploadVerbosity = toFlag normal + } + +uploadCommand :: CommandUI UploadFlags +uploadCommand = CommandUI { + commandName = "upload", + commandSynopsis = "Uploads source packages or documentation to Hackage.", + commandDescription = Nothing, + commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n" + ++ relevantConfigValuesText ["username", "password", "password-command"], + commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", + commandDefaultFlags = defaultUploadFlags, + commandOptions = \_ -> + [optionVerbosity uploadVerbosity + (\v flags -> flags { uploadVerbosity = v }) + + ,option [] ["publish"] + "Publish the package instead of uploading it as a candidate." + uploadCandidate (\v flags -> flags { uploadCandidate = v }) + (noArg (Flag IsPublished)) + + ,option ['d'] ["documentation"] + ("Upload documentation instead of a source package. " + ++ "By default, this uploads documentation for a package candidate. " + ++ "To upload documentation for " + ++ "a published package, combine with --publish.") + uploadDoc (\v flags -> flags { uploadDoc = v }) + trueArg + + ,option ['u'] ["username"] + "Hackage username." + uploadUsername (\v flags -> flags { uploadUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + uploadPassword (\v flags -> flags { uploadPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + + ,option ['P'] ["password-command"] + "Command to get Hackage password." + uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v }) + (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe)) + ] + } + +instance Monoid UploadFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup UploadFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * Init flags +-- ------------------------------------------------------------ + +initCommand :: CommandUI IT.InitFlags +initCommand = CommandUI { + commandName = "init", + commandSynopsis = "Create a new .cabal package file.", + commandDescription = Just $ \_ -> wrapText $ + "Create a .cabal, Setup.hs, and optionally a LICENSE file.\n" + ++ "\n" + ++ "Calling init with no arguments creates an executable, " + ++ "guessing as many options as possible. The interactive " + ++ "mode can be invoked by the -i/--interactive flag, which " + ++ "will try to guess as much as possible and prompt you for " + ++ "the rest. You can change init to always be interactive by " + ++ "setting the interactive flag in your configuration file. " + ++ "Command-line arguments are provided for scripting purposes.\n", + commandNotes = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " init [FLAGS]\n", + commandDefaultFlags = IT.defaultInitFlags, + commandOptions = initOptions + } + +initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags] +initOptions _ = + [ option ['i'] ["interactive"] + "interactive mode." + IT.interactive (\v flags -> flags { IT.interactive = v }) + (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"])) + + , option ['q'] ["quiet"] + "Do not generate log messages to stdout." + IT.quiet (\v flags -> flags { IT.quiet = v }) + trueArg + + , option [] ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments (\v flags -> flags { IT.noComments = v }) + trueArg + + , option ['m'] ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal (\v flags -> flags { IT.minimal = v }) + trueArg + + , option [] ["overwrite"] + "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." + IT.overwrite (\v flags -> flags { IT.overwrite = v }) + trueArg + + , option [] ["package-dir", "packagedir"] + "Root directory of the package (default = current directory)." + IT.packageDir (\v flags -> flags { IT.packageDir = v }) + (reqArgFlag "DIRECTORY") + + , option ['p'] ["package-name"] + "Name of the Cabal package to create." + IT.packageName (\v flags -> flags { IT.packageName = v }) + (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["version"] + "Initial version of the package." + IT.version (\v flags -> flags { IT.version = v }) + (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option [] ["cabal-version"] + "Version of the Cabal specification." + IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) + (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++) + (fmap (toFlag . getSpecVersion) parsec)) + (flagToList . fmap (prettyShow . SpecVersion))) + + , option ['l'] ["license"] + "Project license." + IT.license (\v flags -> flags { IT.license = v }) + (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option ['a'] ["author"] + "Name of the project's author." + IT.author (\v flags -> flags { IT.author = v }) + (reqArgFlag "NAME") + + , option ['e'] ["email"] + "Email address of the maintainer." + IT.email (\v flags -> flags { IT.email = v }) + (reqArgFlag "EMAIL") + + , option ['u'] ["homepage"] + "Project homepage and/or repository." + IT.homepage (\v flags -> flags { IT.homepage = v }) + (reqArgFlag "URL") + + , option ['s'] ["synopsis"] + "Short project synopsis." + IT.synopsis (\v flags -> flags { IT.synopsis = v }) + (reqArgFlag "TEXT") + + , option ['c'] ["category"] + "Project category." + IT.category (\v flags -> flags { IT.category = v }) + (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) + (flagToList . fmap (either id show))) + + , option ['x'] ["extra-source-file"] + "Extra source file to be distributed with tarball." + IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) + (reqArg' "FILE" (Just . (:[])) + (fromMaybe [])) + + , option [] ["lib", "is-library"] + "Build a library." + IT.packageType (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Library)) + + , option [] ["exe", "is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Executable)) + + , option [] ["libandexe", "is-libandexe"] + "Build a library and an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.LibraryAndExecutable)) + + , option [] ["tests"] + "Generate a test suite for the library." + IT.initializeTestSuite + (\v flags -> flags { IT.initializeTestSuite = v }) + trueArg + + , option [] ["test-dir"] + "Directory containing tests." + IT.testDirs (\v flags -> flags { IT.testDirs = v }) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["simple"] + "Create a simple project with sensible defaults." + IT.simpleProject + (\v flags -> flags { IT.simpleProject = v }) + trueArg + + , option [] ["main-is"] + "Specify the main module." + IT.mainIs + (\v flags -> flags { IT.mainIs = v }) + (reqArgFlag "FILE") + + , option [] ["language"] + "Specify the default language." + IT.language + (\v flags -> flags { IT.language = v }) + (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + , option ['o'] ["expose-module"] + "Export a module from the package." + IT.exposedModules + (\v flags -> flags { IT.exposedModules = v }) + (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++) + ((Just . (:[])) `fmap` parsec)) + (maybe [] (fmap prettyShow))) + + , option [] ["extension"] + "Use a LANGUAGE extension (in the other-extensions field)." + IT.otherExts + (\v flags -> flags { IT.otherExts = v }) + (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++) + ((Just . (:[])) `fmap` parsec)) + (maybe [] (fmap prettyShow))) + + , option ['d'] ["dependency"] + "Package dependency." + IT.dependencies (\v flags -> flags { IT.dependencies = v }) + (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++) + ((Just . (:[])) `fmap` parsec)) + (maybe [] (fmap prettyShow))) + + , option [] ["application-dir"] + "Directory containing package application executable." + IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v}) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["source-dir", "sourcedir"] + "Directory containing package library source." + IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["build-tool"] + "Required external build tool." + IT.buildTools (\v flags -> flags { IT.buildTools = v }) + (reqArg' "TOOL" (Just . (:[])) + (fromMaybe [])) + + -- NB: this is a bit of a transitional hack and will likely be + -- removed again if `cabal init` is migrated to the v2-* command + -- framework + , option "w" ["with-compiler"] + "give the path to a particular compiler" + IT.initHcPath (\v flags -> flags { IT.initHcPath = v }) + (reqArgFlag "PATH") + + , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) + ] + +-- ------------------------------------------------------------ +-- * Copy and Register +-- ------------------------------------------------------------ + +copyCommand :: CommandUI CopyFlags +copyCommand = Cabal.copyCommand + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-copy " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " v1-copy foo " + ++ " A component (i.e. lib, exe, test suite)" + , commandUsage = usageAlternatives "v1-copy" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = Cabal.registerCommand + { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" } + +-- ------------------------------------------------------------ +-- * ActAsSetup flags +-- ------------------------------------------------------------ + +data ActAsSetupFlags = ActAsSetupFlags { + actAsSetupBuildType :: Flag BuildType +} deriving Generic + +defaultActAsSetupFlags :: ActAsSetupFlags +defaultActAsSetupFlags = ActAsSetupFlags { + actAsSetupBuildType = toFlag Simple +} + +actAsSetupCommand :: CommandUI ActAsSetupFlags +actAsSetupCommand = CommandUI { + commandName = "act-as-setup", + commandSynopsis = "Run as-if this was a Setup.hs", + commandDescription = Nothing, + commandNotes = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " act-as-setup\n", + commandDefaultFlags = defaultActAsSetupFlags, + commandOptions = \_ -> + [option "" ["build-type"] + "Use the given build type." + actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v }) + (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++) + (fmap toFlag parsec)) + (map prettyShow . flagToList)) + ] +} + +instance Monoid ActAsSetupFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ActAsSetupFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ +-- * UserConfig flags +-- ------------------------------------------------------------ + +data UserConfigFlags = UserConfigFlags { + userConfigVerbosity :: Flag Verbosity, + userConfigForce :: Flag Bool, + userConfigAppendLines :: Flag [String] + } deriving Generic + +instance Monoid UserConfigFlags where + mempty = UserConfigFlags { + userConfigVerbosity = toFlag normal, + userConfigForce = toFlag False, + userConfigAppendLines = toFlag [] + } + mappend = (<>) + +instance Semigroup UserConfigFlags where + (<>) = gmappend + +userConfigCommand :: CommandUI UserConfigFlags +userConfigCommand = CommandUI { + commandName = "user-config", + commandSynopsis = "Display and update the user's global cabal configuration.", + commandDescription = Just $ \_ -> wrapText $ + "When upgrading cabal, the set of configuration keys and their default" + ++ " values may change. This command provides means to merge the existing" + ++ " config in ~/.cabal/config" + ++ " (i.e. all bindings that are actually defined and not commented out)" + ++ " and the default config of the new version.\n" + ++ "\n" + ++ "init: Creates a new config file at either ~/.cabal/config or as" + ++ " specified by --config-file, if given. An existing file won't be " + ++ " overwritten unless -f or --force is given.\n" + ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and" + ++ " the default configuration that would be created by cabal if the" + ++ " config file did not exist.\n" + ++ "update: Applies the pseudo-diff to the configuration that would be" + ++ " created by default, and write the result back to ~/.cabal/config.", + + commandNotes = Nothing, + commandUsage = usageAlternatives "user-config" ["init", "diff", "update"], + commandDefaultFlags = mempty, + commandOptions = \ _ -> [ + optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v }) + , option ['f'] ["force"] + "Overwrite the config file if it already exists." + userConfigForce (\v flags -> flags { userConfigForce = v }) + trueArg + , option ['a'] ["augment"] + "Additional setting to augment the config file (replacing a previous setting if it existed)." + userConfigAppendLines (\v flags -> flags + {userConfigAppendLines = + Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)}) + (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe)) + ] + } + + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +reqArgFlag :: ArgPlaceHolder -> + MkOptDescr (b -> Flag String) (Flag String -> b -> b) b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +liftOptions :: (b -> a) -> (a -> b -> b) + -> [OptionField a] -> [OptionField b] +liftOptions get set = map (liftOption get set) + +yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b +yesNoOpt ShowArgs sf lf = trueArg sf lf +yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf + +optionSolver :: (flags -> Flag PreSolver) + -> (Flag PreSolver -> flags -> flags) + -> OptionField flags +optionSolver get set = + option [] ["solver"] + ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") + get set + (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + +optionSolverFlags :: ShowOrParseArgs + -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) + -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) + -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) + -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) + -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) + -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) + -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) + -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) + -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) + -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) + -> [OptionField flags] +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc + getfgc setfgc getmc setmc getig setig getsip setsip + getstrfl setstrfl getib setib getoc setoc = + [ option [] ["max-backjumps"] + ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") + getmbj setmbj + (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral)) + (map show . flagToList)) + , option [] ["reorder-goals"] + "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." + (fmap asBool . getrg) + (setrg . fmap ReorderGoals) + (yesNoOpt showOrParseArgs) + , option [] ["count-conflicts"] + "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." + (fmap asBool . getcc) + (setcc . fmap CountConflicts) + (yesNoOpt showOrParseArgs) + , option [] ["fine-grained-conflicts"] + "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." + (fmap asBool . getfgc) + (setfgc . fmap FineGrainedConflicts) + (yesNoOpt showOrParseArgs) + , option [] ["minimize-conflict-set"] + ("When there is no solution, try to improve the error message by finding " + ++ "a minimal conflict set (default: false). May increase run time " + ++ "significantly.") + (fmap asBool . getmc) + (setmc . fmap MinimizeConflictSet) + (yesNoOpt showOrParseArgs) + , option [] ["independent-goals"] + "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." + (fmap asBool . getig) + (setig . fmap IndependentGoals) + (yesNoOpt showOrParseArgs) + , option [] ["shadow-installed-packages"] + "If multiple package instances of the same version are installed, treat all but one as shadowed." + (fmap asBool . getsip) + (setsip . fmap ShadowPkgs) + (yesNoOpt showOrParseArgs) + , option [] ["strong-flags"] + "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." + (fmap asBool . getstrfl) + (setstrfl . fmap StrongFlags) + (yesNoOpt showOrParseArgs) + , option [] ["allow-boot-library-installs"] + "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." + (fmap asBool . getib) + (setib . fmap AllowBootLibInstalls) + (yesNoOpt showOrParseArgs) + , option [] ["reject-unconstrained-dependencies"] + "Require these packages to have constraints on them if they are to be selected (default: none)." + getoc + setoc + (reqArg "none|all" + (parsecToReadE + (const "reject-unconstrained-dependencies must be 'none' or 'all'") + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) + + ] + +usagePackages :: String -> String -> String +usagePackages name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" + +usageFlags :: String -> String -> String +usageFlags name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" + +-- ------------------------------------------------------------ +-- * Repo helpers +-- ------------------------------------------------------------ + +showRemoteRepo :: RemoteRepo -> String +showRemoteRepo = prettyShow + +readRemoteRepo :: String -> Maybe RemoteRepo +readRemoteRepo = simpleParsec + +showLocalRepo :: LocalRepo -> String +showLocalRepo = prettyShow + +readLocalRepo :: String -> Maybe LocalRepo +readLocalRepo = simpleParsec + +-- ------------------------------------------------------------ +-- * Helpers for Documentation +-- ------------------------------------------------------------ + +relevantConfigValuesText :: [String] -> String +relevantConfigValuesText vs = + "Relevant global configuration keys:\n" + ++ concat [" " ++ v ++ "\n" |v <- vs] diff --git a/src/Distribution/Client/SetupWrapper.hs b/src/Distribution/Client/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/SetupWrapper.hs @@ -0,0 +1,919 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SetupWrapper +-- Copyright : (c) The University of Glasgow 2006, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : alpha +-- Portability : portable +-- +-- An interface to building and installing Cabal packages. +-- If the @Built-Type@ field is specified as something other than +-- 'Custom', and the current version of Cabal is acceptable, this performs +-- setup actions directly. Otherwise it builds the setup script and +-- runs it with the given arguments. + +module Distribution.Client.SetupWrapper ( + getSetup, runSetup, runSetupCommand, setupWrapper, + SetupScriptOptions(..), + defaultSetupScriptOptions, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) +import qualified Distribution.Make as Make +import qualified Distribution.Simple as Simple +import Distribution.Version + ( Version, mkVersion, versionNumbers, VersionRange, anyVersion + , intersectVersionRanges, orLaterVersion + , withinRange ) +import qualified Distribution.Backpack as Backpack +import Distribution.Package + ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId + , PackageId, mkPackageName + , PackageIdentifier(..), packageVersion, packageName ) +import Distribution.PackageDescription + ( GenericPackageDescription(packageDescription) + , PackageDescription(..), specVersion, buildType + , BuildType(..) ) +import Distribution.Types.ModuleRenaming (defaultRenaming) +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) +import Distribution.Simple.Configure + ( configCompilerEx ) +import Distribution.Compiler + ( buildCompilerId, CompilerFlavor(GHC, GHCJS) ) +import Distribution.Simple.Compiler + ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack ) +import Distribution.Simple.PreProcess + ( runSimplePreProcessor, ppUnlit ) +import Distribution.Simple.Build.Macros + ( generatePackageVersionMacros ) +import Distribution.Simple.Program + ( ProgramDb, emptyProgramDb + , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram + , ghcjsProgram ) +import Distribution.Simple.Program.Find + ( programSearchPathAsPATHVar + , ProgramSearchPathEntry(ProgramSearchPathDir) ) +import Distribution.Simple.Program.Run + ( getEffectiveEnvironment ) +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.BuildPaths + ( defaultDistPref, exeExtension ) + +import Distribution.Simple.Command + ( CommandUI(..), commandShowOptions ) +import Distribution.Simple.Program.GHC + ( GhcMode(..), GhcOptions(..), renderGhcOptions ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Client.Types +import Distribution.Client.Config + ( getCabalDir ) +import Distribution.Client.IndexUtils + ( getInstalledPackages ) +import Distribution.Client.JobControl + ( Lock, criticalSection ) +import Distribution.Simple.Setup + ( Flag(..) ) +import Distribution.Utils.Generic + ( safeHead ) +import Distribution.Simple.Utils + ( die', debug, info, infoNoWrap + , cabalVersion, tryFindPackageDesc + , createDirectoryIfMissingVerbose, installExecutableFile + , copyFileVerbose, rewriteFileEx, rewriteFileLBS ) +import Distribution.Client.Utils + ( inDir, tryCanonicalizePath, withExtraPathEnv + , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides +#ifdef mingw32_HOST_OS + , canonicalizePathNoThrow +#endif + ) + +import Distribution.ReadE +import Distribution.System ( Platform(..), buildPlatform ) +import Distribution.Utils.NubList + ( toNubListR ) +import Distribution.Verbosity +import Distribution.Compat.Stack + +import System.Directory ( doesFileExist ) +import System.FilePath ( (), (<.>) ) +import System.IO ( Handle, hPutStr ) +import Distribution.Compat.Process (createProcess) +import System.Process ( StdStream(..), proc, waitForProcess + , ProcessHandle ) +import qualified System.Process as Process +import Data.List ( foldl1' ) +import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) + +import qualified Data.ByteString.Lazy as BS + +#ifdef mingw32_HOST_OS +import Distribution.Simple.Utils + ( withTempDirectory ) + +import Control.Exception ( bracket ) +import System.FilePath ( equalFilePath, takeDirectory ) +import System.Directory ( doesDirectoryExist ) +import qualified System.Win32 as Win32 +#endif + +-- | @Setup@ encapsulates the outcome of configuring a setup method to build a +-- particular package. +data Setup = Setup { setupMethod :: SetupMethod + , setupScriptOptions :: SetupScriptOptions + , setupVersion :: Version + , setupBuildType :: BuildType + , setupPackage :: PackageDescription + } + +-- | @SetupMethod@ represents one of the methods used to run Cabal commands. +data SetupMethod = InternalMethod + -- ^ run Cabal commands through \"cabal\" in the + -- current process + | SelfExecMethod + -- ^ run Cabal commands through \"cabal\" as a + -- child process + | ExternalMethod FilePath + -- ^ run Cabal commands through a custom \"Setup\" executable + +-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two +-- parts: one that has no policy and just does as it's told with all the +-- explicit options, and an optional initial part that applies certain +-- policies (like if we should add the Cabal lib as a dep, and if so which +-- version). This could be structured as an action that returns a fully +-- elaborated 'SetupScriptOptions' containing no remaining policy choices. +-- +-- See also the discussion at https://github.com/haskell/cabal/pull/3094 + +-- | @SetupScriptOptions@ are options used to configure and run 'Setup', as +-- opposed to options given to the Cabal command at runtime. +data SetupScriptOptions = SetupScriptOptions { + -- | The version of the Cabal library to use (if 'useDependenciesExclusive' + -- is not set). A suitable version of the Cabal library must be installed + -- (or for some build-types be the one cabal-install was built with). + -- + -- The version found also determines the version of the Cabal specification + -- that we us for talking to the Setup.hs, unless overridden by + -- 'useCabalSpecVersion'. + -- + useCabalVersion :: VersionRange, + + -- | This is the version of the Cabal specification that we believe that + -- this package uses. This affects the semantics and in particular the + -- Setup command line interface. + -- + -- This is similar to 'useCabalVersion' but instead of probing the system + -- for a version of the /Cabal library/ you just say exactly which version + -- of the /spec/ we will use. Using this also avoid adding the Cabal + -- library as an additional dependency, so add it to 'useDependencies' + -- if needed. + -- + useCabalSpecVersion :: Maybe Version, + useCompiler :: Maybe Compiler, + usePlatform :: Maybe Platform, + usePackageDB :: PackageDBStack, + usePackageIndex :: Maybe InstalledPackageIndex, + useProgramDb :: ProgramDb, + useDistPref :: FilePath, + useLoggingHandle :: Maybe Handle, + useWorkingDir :: Maybe FilePath, + -- | Extra things to add to PATH when invoking the setup script. + useExtraPathEnv :: [FilePath], + -- | Extra environment variables paired with overrides, where + -- + -- * @'Just' v@ means \"set the environment variable's value to @v@\". + -- * 'Nothing' means \"unset the environment variable\". + useExtraEnvOverrides :: [(String, Maybe FilePath)], + forceExternalSetupMethod :: Bool, + + -- | List of dependencies to use when building Setup.hs. + useDependencies :: [(ComponentId, PackageId)], + + -- | Is the list of setup dependencies exclusive? + -- + -- When this is @False@, if we compile the Setup.hs script we do so with the + -- list in 'useDependencies' but all other packages in the environment are + -- also visible. A suitable version of @Cabal@ library (see + -- 'useCabalVersion') is also added to the list of dependencies, unless + -- 'useDependencies' already contains a Cabal dependency. + -- + -- When @True@, only the 'useDependencies' packages are used, with other + -- packages in the environment hidden. + -- + -- This feature is here to support the setup stanza in .cabal files that + -- specifies explicit (and exclusive) dependencies, as well as the old + -- style with no dependencies. + useDependenciesExclusive :: Bool, + + -- | Should we build the Setup.hs with CPP version macros available? + -- We turn this on when we have a setup stanza in .cabal that declares + -- explicit setup dependencies. + -- + useVersionMacros :: Bool, + + -- Used only by 'cabal clean' on Windows. + -- + -- Note: win32 clean hack + ------------------------- + -- On Windows, running './dist/setup/setup clean' doesn't work because the + -- setup script will try to delete itself (which causes it to fail horribly, + -- unlike on Linux). So we have to move the setup exe out of the way first + -- and then delete it manually. This applies only to the external setup + -- method. + useWin32CleanHack :: Bool, + + -- Used only when calling setupWrapper from parallel code to serialise + -- access to the setup cache; should be Nothing otherwise. + -- + -- Note: setup exe cache + ------------------------ + -- When we are installing in parallel, we always use the external setup + -- method. Since compiling the setup script each time adds noticeable + -- overhead, we use a shared setup script cache + -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal + -- version) combination the cache holds a compiled setup script + -- executable. This only affects the Simple build type; for the Custom, + -- Configure and Make build types we always compile the setup script anew. + setupCacheLock :: Maybe Lock, + + -- | Is the task we are going to run an interactive foreground task, + -- or an non-interactive background task? Based on this flag we + -- decide whether or not to delegate ctrl+c to the spawned task + isInteractive :: Bool + } + +defaultSetupScriptOptions :: SetupScriptOptions +defaultSetupScriptOptions = SetupScriptOptions { + useCabalVersion = anyVersion, + useCabalSpecVersion = Nothing, + useCompiler = Nothing, + usePlatform = Nothing, + usePackageDB = [GlobalPackageDB, UserPackageDB], + usePackageIndex = Nothing, + useDependencies = [], + useDependenciesExclusive = False, + useVersionMacros = False, + useProgramDb = emptyProgramDb, + useDistPref = defaultDistPref, + useLoggingHandle = Nothing, + useWorkingDir = Nothing, + useExtraPathEnv = [], + useExtraEnvOverrides = [], + useWin32CleanHack = False, + forceExternalSetupMethod = False, + setupCacheLock = Nothing, + isInteractive = False + } + +workingDir :: SetupScriptOptions -> FilePath +workingDir options = + case fromMaybe "" (useWorkingDir options) of + [] -> "." + dir -> dir + +-- | A @SetupRunner@ implements a 'SetupMethod'. +type SetupRunner = Verbosity + -> SetupScriptOptions + -> BuildType + -> [String] + -> IO () + +-- | Prepare to build a package by configuring a 'SetupMethod'. The returned +-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed +-- during the configuration process; the final values are given by +-- 'setupScriptOptions'. +getSetup :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> IO Setup +getSetup verbosity options mpkg = do + pkg <- maybe getPkg return mpkg + let options' = options { + useCabalVersion = intersectVersionRanges + (useCabalVersion options) + (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)))) + } + buildType' = buildType pkg + (version, method, options'') <- + getSetupMethod verbosity options' pkg buildType' + return Setup { setupMethod = method + , setupScriptOptions = options'' + , setupVersion = version + , setupBuildType = buildType' + , setupPackage = pkg + } + where + getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options)) + >>= readGenericPackageDescription verbosity + >>= return . packageDescription + +-- | Decide if we're going to be able to do a direct internal call to the +-- entry point in the Cabal library or if we're going to have to compile +-- and execute an external Setup.hs script. +-- +getSetupMethod + :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType + -> IO (Version, SetupMethod, SetupScriptOptions) +getSetupMethod verbosity options pkg buildType' + | buildType' == Custom + || maybe False (cabalVersion /=) (useCabalSpecVersion options) + || not (cabalVersion `withinRange` useCabalVersion options) = + getExternalSetupMethod verbosity options pkg buildType' + | isJust (useLoggingHandle options) + -- Forcing is done to use an external process e.g. due to parallel + -- build concerns. + || forceExternalSetupMethod options = + return (cabalVersion, SelfExecMethod, options) + | otherwise = return (cabalVersion, InternalMethod, options) + +runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner) +runSetupMethod InternalMethod = internalSetupMethod +runSetupMethod (ExternalMethod path) = externalSetupMethod path +runSetupMethod SelfExecMethod = selfExecSetupMethod + +-- | Run a configured 'Setup' with specific arguments. +runSetup :: Verbosity -> Setup + -> [String] -- ^ command-line arguments + -> IO () +runSetup verbosity setup args0 = do + let method = setupMethod setup + options = setupScriptOptions setup + bt = setupBuildType setup + args = verbosityHack (setupVersion setup) args0 + when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $ + infoNoWrap verbose $ + "Applied verbosity hack:\n" ++ + " Before: " ++ show args0 ++ "\n" ++ + " After: " ++ show args ++ "\n" + runSetupMethod method verbosity options bt args + +-- | This is a horrible hack to make sure passing fancy verbosity +-- flags (e.g., @-v'info +callstack'@) doesn't break horribly on +-- old Setup. We can't do it in 'filterConfigureFlags' because +-- verbosity applies to ALL commands. +verbosityHack :: Version -> [String] -> [String] +verbosityHack ver args0 + | ver >= mkVersion [2,1] = args0 + | otherwise = go args0 + where + go (('-':'v':rest) : args) + | Just rest' <- munch rest = ("-v" ++ rest') : go args + go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args) + | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args + go ("--verbose" : rest : args) + | Just rest' <- munch rest = "--verbose" : rest' : go args + go rest@("--" : _) = rest + go (arg:args) = arg : go args + go [] = [] + + munch rest = + case runReadE flagToVerbosity rest of + Right v + | ver < mkVersion [2,0], verboseHasFlags v + -- We could preserve the prefix, but since we're assuming + -- it's Cabal's verbosity flag, we can assume that + -- any format is OK + -> Just (showForCabal (verboseNoFlags v)) + | ver < mkVersion [2,1], isVerboseTimestamp v + -- +timestamp wasn't yet available in Cabal-2.0.0 + -> Just (showForCabal (verboseNoTimestamp v)) + _ -> Nothing + +-- | Run a command through a configured 'Setup'. +runSetupCommand :: Verbosity -> Setup + -> CommandUI flags -- ^ command definition + -> flags -- ^ command flags + -> [String] -- ^ extra command-line arguments + -> IO () +runSetupCommand verbosity setup cmd flags extraArgs = do + let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs + runSetup verbosity setup args + +-- | Configure a 'Setup' and run a command in one step. The command flags +-- may depend on the Cabal library version in use. +setupWrapper :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> CommandUI flags + -> (Version -> flags) + -- ^ produce command flags given the Cabal library version + -> (Version -> [String]) + -> IO () +setupWrapper verbosity options mpkg cmd flags extraArgs = do + setup <- getSetup verbosity options mpkg + runSetupCommand verbosity setup + cmd (flags $ setupVersion setup) + (extraArgs $ setupVersion setup) + +-- ------------------------------------------------------------ +-- * Internal SetupMethod +-- ------------------------------------------------------------ + +internalSetupMethod :: SetupRunner +internalSetupMethod verbosity options bt args = do + info verbosity $ "Using internal setup method with build-type " ++ show bt + ++ " and args:\n " ++ show args + inDir (useWorkingDir options) $ do + withEnv "HASKELL_DIST_DIR" (useDistPref options) $ + withExtraPathEnv (useExtraPathEnv options) $ + withEnvOverrides (useExtraEnvOverrides options) $ + buildTypeAction bt args + +buildTypeAction :: BuildType -> ([String] -> IO ()) +buildTypeAction Simple = Simple.defaultMainArgs +buildTypeAction Configure = Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks +buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Custom = error "buildTypeAction Custom" + + +-- | @runProcess'@ is a version of @runProcess@ where we have +-- the additional option to decide whether or not we should +-- delegate CTRL+C to the spawned process. +runProcess' :: FilePath -- ^ Filename of the executable + -> [String] -- ^ Arguments to pass to executable + -> Maybe FilePath -- ^ Optional path to working directory + -> Maybe [(String, String)] -- ^ Optional environment + -> Maybe Handle -- ^ Handle for @stdin@ + -> Maybe Handle -- ^ Handle for @stdout@ + -> Maybe Handle -- ^ Handle for @stderr@ + -> Bool -- ^ Delegate Ctrl+C ? + -> IO ProcessHandle +runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do + (_,_,_,ph) <- + createProcess + (proc cmd args){ Process.cwd = mb_cwd + , Process.env = mb_env + , Process.std_in = mbToStd mb_stdin + , Process.std_out = mbToStd mb_stdout + , Process.std_err = mbToStd mb_stderr + , Process.delegate_ctlc = _delegate + } + return ph + where + mbToStd :: Maybe Handle -> StdStream + mbToStd Nothing = Inherit + mbToStd (Just hdl) = UseHandle hdl + +-- ------------------------------------------------------------ +-- * Self-Exec SetupMethod +-- ------------------------------------------------------------ + +selfExecSetupMethod :: SetupRunner +selfExecSetupMethod verbosity options bt args0 = do + let args = ["act-as-setup", + "--build-type=" ++ prettyShow bt, + "--"] ++ args0 + info verbosity $ "Using self-exec internal setup method with build-type " + ++ show bt ++ " and args:\n " ++ show args + path <- getExecutablePath + info verbosity $ unwords (path : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + + searchpath <- programSearchPathAsPATHVar + (map ProgramSearchPathDir (useExtraPathEnv options) ++ + getProgramSearchPath (useProgramDb options)) + env <- getEffectiveEnvironment $ + [ ("PATH", Just searchpath) + , ("HASKELL_DIST_DIR", Just (useDistPref options)) + ] ++ useExtraEnvOverrides options + process <- runProcess' path args + (useWorkingDir options) env Nothing + (useLoggingHandle options) (useLoggingHandle options) + (isInteractive options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +-- ------------------------------------------------------------ +-- * External SetupMethod +-- ------------------------------------------------------------ + +externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) +externalSetupMethod path verbosity options _ args = do + info verbosity $ unwords (path : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + + -- See 'Note: win32 clean hack' above. +#ifdef mingw32_HOST_OS + if useWin32CleanHack options then doWin32CleanHack path else doInvoke path +#else + doInvoke path +#endif + + where + doInvoke path' = do + searchpath <- programSearchPathAsPATHVar + (map ProgramSearchPathDir (useExtraPathEnv options) ++ + getProgramSearchPath (useProgramDb options)) + env <- getEffectiveEnvironment $ + [ ("PATH", Just searchpath) + , ("HASKELL_DIST_DIR", Just (useDistPref options)) + ] ++ useExtraEnvOverrides options + + debug verbosity $ "Setup arguments: "++unwords args + process <- runProcess' path' args + (useWorkingDir options) env Nothing + (useLoggingHandle options) (useLoggingHandle options) + (isInteractive options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +#ifdef mingw32_HOST_OS + doWin32CleanHack path' = do + info verbosity $ "Using the Win32 clean hack." + -- Recursively removes the temp dir on exit. + withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir -> + bracket (moveOutOfTheWay tmpDir path') + (maybeRestore path') + doInvoke + + moveOutOfTheWay tmpDir path' = do + let newPath = tmpDir "setup" <.> exeExtension buildPlatform + Win32.moveFile path' newPath + return newPath + + maybeRestore oldPath path' = do + let oldPathDir = takeDirectory oldPath + oldPathDirExists <- doesDirectoryExist oldPathDir + -- 'setup clean' didn't complete, 'dist/setup' still exists. + when oldPathDirExists $ + Win32.moveFile path' oldPath +#endif + +getExternalSetupMethod + :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType + -> IO (Version, SetupMethod, SetupScriptOptions) +getExternalSetupMethod verbosity options pkg bt = do + debug verbosity $ "Using external setup method with build-type " ++ show bt + debug verbosity $ "Using explicit dependencies: " + ++ show (useDependenciesExclusive options) + createDirectoryIfMissingVerbose verbosity True setupDir + (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse + debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion + path <- if useCachedSetupExecutable + then getCachedSetupExecutable options' + cabalLibVersion mCabalLibInstalledPkgId + else compileSetupExecutable options' + cabalLibVersion mCabalLibInstalledPkgId False + + -- Since useWorkingDir can change the relative path, the path argument must + -- be turned into an absolute path. On some systems, runProcess' will take + -- path as relative to the new working directory instead of the current + -- working directory. + path' <- tryCanonicalizePath path + + -- See 'Note: win32 clean hack' above. +#ifdef mingw32_HOST_OS + -- setupProgFile may not exist if we're using a cached program + setupProgFile' <- canonicalizePathNoThrow setupProgFile + let win32CleanHackNeeded = (useWin32CleanHack options) + -- Skip when a cached setup script is used. + && setupProgFile' `equalFilePath` path' +#else + let win32CleanHackNeeded = False +#endif + let options'' = options' { useWin32CleanHack = win32CleanHackNeeded } + + return (cabalLibVersion, ExternalMethod path', options'') + + where + setupDir = workingDir options useDistPref options "setup" + setupVersionFile = setupDir "setup" <.> "version" + setupHs = setupDir "setup" <.> "hs" + setupProgFile = setupDir "setup" <.> exeExtension buildPlatform + platform = fromMaybe buildPlatform (usePlatform options) + + useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make) + + maybeGetInstalledPackages :: SetupScriptOptions -> Compiler + -> ProgramDb -> IO InstalledPackageIndex + maybeGetInstalledPackages options' comp progdb = + case usePackageIndex options' of + Just index -> return index + Nothing -> getInstalledPackages verbosity + comp (usePackageDB options') progdb + + -- Choose the version of Cabal to use if the setup script has a dependency on + -- Cabal, and possibly update the setup script options. The version also + -- determines how to filter the flags to Setup. + -- + -- We first check whether the dependency solver has specified a Cabal version. + -- If it has, we use the solver's version without looking at the installed + -- package index (See issue #3436). Otherwise, we pick the Cabal version by + -- checking 'useCabalSpecVersion', then the saved version, and finally the + -- versions available in the index. + -- + -- The version chosen here must match the one used in 'compileSetupExecutable' + -- (See issue #3433). + cabalLibVersionToUse :: IO (Version, Maybe ComponentId + ,SetupScriptOptions) + cabalLibVersionToUse = + case find (isCabalPkgId . snd) (useDependencies options) of + Just (unitId, pkgId) -> do + let version = pkgVersion pkgId + updateSetupScript version bt + writeSetupVersionFile version + return (version, Just unitId, options) + Nothing -> + case useCabalSpecVersion options of + Just version -> do + updateSetupScript version bt + writeSetupVersionFile version + return (version, Nothing, options) + Nothing -> do + savedVer <- savedVersion + case savedVer of + Just version | version `withinRange` useCabalVersion options + -> do updateSetupScript version bt + -- Does the previously compiled setup executable + -- still exist and is it up-to date? + useExisting <- canUseExistingSetup version + if useExisting + then return (version, Nothing, options) + else installedVersion + _ -> installedVersion + where + -- This check duplicates the checks in 'getCachedSetupExecutable' / + -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice + -- because the selected Cabal version may change as a result of this + -- check. + canUseExistingSetup :: Version -> IO Bool + canUseExistingSetup version = + if useCachedSetupExecutable + then do + (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version + doesFileExist cachedSetupProgFile + else + (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs + <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile + + writeSetupVersionFile :: Version -> IO () + writeSetupVersionFile version = + writeFile setupVersionFile (show version ++ "\n") + + installedVersion :: IO (Version, Maybe InstalledPackageId + ,SetupScriptOptions) + installedVersion = do + (comp, progdb, options') <- configureCompiler options + (version, mipkgid, options'') <- installedCabalVersion options' + comp progdb + updateSetupScript version bt + writeSetupVersionFile version + return (version, mipkgid, options'') + + savedVersion :: IO (Maybe Version) + savedVersion = do + versionString <- readFile setupVersionFile `catchIO` \_ -> return "" + case reads versionString of + [(version,s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + -- | Update a Setup.hs script, creating it if necessary. + updateSetupScript :: Version -> BuildType -> IO () + updateSetupScript _ Custom = do + useHs <- doesFileExist customSetupHs + useLhs <- doesFileExist customSetupLhs + unless (useHs || useLhs) $ die' verbosity + "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." + let src = (if useHs then customSetupHs else customSetupLhs) + srcNewer <- src `moreRecentFile` setupHs + when srcNewer $ if useHs + then copyFileVerbose verbosity src setupHs + else runSimplePreProcessor ppUnlit src setupHs verbosity + where + customSetupHs = workingDir options "Setup.hs" + customSetupLhs = workingDir options "Setup.lhs" + + updateSetupScript cabalLibVersion _ = + rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion) + + buildTypeScript :: Version -> BS.ByteString + buildTypeScript cabalLibVersion = case bt of + Simple -> "import Distribution.Simple; main = defaultMain\n" + Configure | cabalLibVersion >= mkVersion [1,3,10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" + | otherwise -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" + Make -> "import Distribution.Make; main = defaultMain\n" + Custom -> error "buildTypeScript Custom" + + installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb + -> IO (Version, Maybe InstalledPackageId + ,SetupScriptOptions) + installedCabalVersion options' _ _ | packageName pkg == mkPackageName "Cabal" + && bt == Custom = + return (packageVersion pkg, Nothing, options') + installedCabalVersion options' compiler progdb = do + index <- maybeGetInstalledPackages options' compiler progdb + let cabalDepName = mkPackageName "Cabal" + cabalDepVersion = useCabalVersion options' + options'' = options' { usePackageIndex = Just index } + case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of + [] -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg) + ++ "' requires Cabal library version " + ++ prettyShow (useCabalVersion options) + ++ " but no suitable version is installed." + pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs + err = error "Distribution.Client.installedCabalVersion: empty version list" + in return (packageVersion ipkginfo + ,Just . IPI.installedComponentId $ ipkginfo, options'') + + bestVersion :: (a -> Version) -> [a] -> a + bestVersion f = firstMaximumBy (comparing (preference . f)) + where + -- Like maximumBy, but picks the first maximum element instead of the + -- last. In general, we expect the preferred version to go first in the + -- list. For the default case, this has the effect of choosing the version + -- installed in the user package DB instead of the global one. See #1463. + -- + -- Note: firstMaximumBy could be written as just + -- `maximumBy cmp . reverse`, but the problem is that the behaviour of + -- maximumBy is not fully specified in the case when there is not a single + -- greatest element. + firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a + firstMaximumBy _ [] = + error "Distribution.Client.firstMaximumBy: empty list" + firstMaximumBy cmp xs = foldl1' maxBy xs + where + maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; } + + preference version = (sameVersion, sameMajorVersion + ,stableVersion, latestVersion) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionNumbers + stableVersion = case versionNumbers version of + (_:x:_) -> even x + _ -> False + latestVersion = version + + configureCompiler :: SetupScriptOptions + -> IO (Compiler, ProgramDb, SetupScriptOptions) + configureCompiler options' = do + (comp, progdb) <- case useCompiler options' of + Just comp -> return (comp, useProgramDb options') + Nothing -> do (comp, _, progdb) <- + configCompilerEx (Just GHC) Nothing Nothing + (useProgramDb options') verbosity + return (comp, progdb) + -- Whenever we need to call configureCompiler, we also need to access the + -- package index, so let's cache it in SetupScriptOptions. + index <- maybeGetInstalledPackages options' comp progdb + return (comp, progdb, options' { useCompiler = Just comp, + usePackageIndex = Just index, + useProgramDb = progdb }) + + -- | Path to the setup exe cache directory and path to the cached setup + -- executable. + cachedSetupDirAndProg :: SetupScriptOptions -> Version + -> IO (FilePath, FilePath) + cachedSetupDirAndProg options' cabalLibVersion = do + cabalDir <- getCabalDir + let setupCacheDir = cabalDir "setup-exe-cache" + cachedSetupProgFile = setupCacheDir + ("setup-" ++ buildTypeString ++ "-" + ++ cabalVersionString ++ "-" + ++ platformString ++ "-" + ++ compilerVersionString) + <.> exeExtension buildPlatform + return (setupCacheDir, cachedSetupProgFile) + where + buildTypeString = show bt + cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion + compilerVersionString = prettyShow $ + maybe buildCompilerId compilerId + $ useCompiler options' + platformString = prettyShow platform + + -- | Look up the setup executable in the cache; update the cache if the setup + -- executable is not found. + getCachedSetupExecutable :: SetupScriptOptions + -> Version -> Maybe InstalledPackageId + -> IO FilePath + getCachedSetupExecutable options' cabalLibVersion + maybeCabalLibInstalledPkgId = do + (setupCacheDir, cachedSetupProgFile) <- + cachedSetupDirAndProg options' cabalLibVersion + cachedSetupExists <- doesFileExist cachedSetupProgFile + if cachedSetupExists + then debug verbosity $ + "Found cached setup executable: " ++ cachedSetupProgFile + else criticalSection' $ do + -- The cache may have been populated while we were waiting. + cachedSetupExists' <- doesFileExist cachedSetupProgFile + if cachedSetupExists' + then debug verbosity $ + "Found cached setup executable: " ++ cachedSetupProgFile + else do + debug verbosity $ "Setup executable not found in the cache." + src <- compileSetupExecutable options' + cabalLibVersion maybeCabalLibInstalledPkgId True + createDirectoryIfMissingVerbose verbosity True setupCacheDir + installExecutableFile verbosity src cachedSetupProgFile + -- Do not strip if we're using GHCJS, since the result may be a script + when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $ + Strip.stripExe verbosity platform (useProgramDb options') + cachedSetupProgFile + return cachedSetupProgFile + where + criticalSection' = maybe id criticalSection $ setupCacheLock options' + + -- | If the Setup.hs is out of date wrt the executable then recompile it. + -- Currently this is GHC/GHCJS only. It should really be generalised. + -- + compileSetupExecutable :: SetupScriptOptions + -> Version -> Maybe ComponentId -> Bool + -> IO FilePath + compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId + forceCompile = do + setupHsNewer <- setupHs `moreRecentFile` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when (outOfDate || forceCompile) $ do + debug verbosity "Setup executable needs to be updated, compiling..." + (compiler, progdb, options'') <- configureCompiler options' + let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion + (program, extraOpts) + = case compilerFlavor compiler of + GHCJS -> (ghcjsProgram, ["-build-runner"]) + _ -> (ghcProgram, ["-threaded"]) + cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)]) + maybeCabalLibInstalledPkgId + + -- With 'useDependenciesExclusive' we enforce the deps specified, + -- so only the given ones can be used. Otherwise we allow the use + -- of packages in the ambient environment, and add on a dep on the + -- Cabal library (unless 'useDependencies' already contains one). + -- + -- With 'useVersionMacros' we use a version CPP macros .h file. + -- + -- Both of these options should be enabled for packages that have + -- opted-in and declared a custom-settup stanza. + -- + selectedDeps | useDependenciesExclusive options' + = useDependencies options' + | otherwise = useDependencies options' ++ + if any (isCabalPkgId . snd) + (useDependencies options') + then [] + else cabalDep + addRenaming (ipid, _) = + -- Assert 'DefUnitId' invariant + (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) + ,defaultRenaming) + cppMacrosFile = setupDir "setup_macros.h" + ghcOptions = mempty { + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use + -- --ghc-option=-v instead! + ghcOptVerbosity = Flag (min verbosity normal) + , ghcOptMode = Flag GhcModeMake + , ghcOptInputFiles = toNubListR [setupHs] + , ghcOptOutputFile = Flag setupProgFile + , ghcOptObjDir = Flag setupDir + , ghcOptHiDir = Flag setupDir + , ghcOptSourcePathClear = Flag True + , ghcOptSourcePath = case bt of + Custom -> toNubListR [workingDir options'] + _ -> mempty + , ghcOptPackageDBs = usePackageDB options'' + , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') + , ghcOptCabal = Flag (useDependenciesExclusive options') + , ghcOptPackages = toNubListR $ map addRenaming selectedDeps + , ghcOptCppIncludes = toNubListR [ cppMacrosFile + | useVersionMacros options' ] + , ghcOptExtra = extraOpts + } + let ghcCmdLine = renderGhcOptions compiler platform ghcOptions + when (useVersionMacros options') $ + rewriteFileEx verbosity cppMacrosFile + $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) + case useLoggingHandle options of + Nothing -> runDbProgram verbosity program progdb ghcCmdLine + + -- If build logging is enabled, redirect compiler output to + -- the log file. + (Just logHandle) -> do output <- getDbProgramOutput verbosity program + progdb ghcCmdLine + hPutStr logHandle output + return setupProgFile + + +isCabalPkgId :: PackageIdentifier -> Bool +isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/src/Distribution/Client/SolverInstallPlan.hs b/src/Distribution/Client/SolverInstallPlan.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/SolverInstallPlan.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SolverInstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'SolverInstallPlan' is the graph of packages produced by the +-- dependency solver, and specifies at the package-granularity what +-- things are going to be installed. To put it another way: the +-- dependency solver produces a 'SolverInstallPlan', which is then +-- consumed by various other parts of Cabal. +-- +----------------------------------------------------------------------------- +module Distribution.Client.SolverInstallPlan( + SolverInstallPlan(..), + SolverPlanPackage, + ResolverPackage(..), + + -- * Operations on 'SolverInstallPlan's + new, + toList, + toMap, + + remove, + + showPlanIndex, + showInstallPlan, + + -- * Checking validity of plans + valid, + closed, + consistent, + acyclic, + + -- ** Details on invalid plans + SolverPlanProblem(..), + showPlanProblem, + problems, + + -- ** Querying the install plan + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, +) where + +import Distribution.Client.Compat.Prelude hiding (toList) +import Prelude () + +import Distribution.Package + ( PackageIdentifier(..), Package(..), PackageName + , HasUnitId(..), PackageId, packageVersion, packageName ) +import Distribution.Types.Flag (nullFlagAssignment) +import qualified Distribution.Solver.Types.ComponentDeps as CD + +import Distribution.Client.Types + ( UnresolvedPkgLoc ) +import Distribution.Version + ( Version ) + +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage + +import Distribution.Compat.Graph (Graph, IsNode(..)) +import qualified Data.Foldable as Foldable +import qualified Data.Graph as OldGraph +import qualified Distribution.Compat.Graph as Graph +import qualified Data.Map as Map +import Data.Array ((!)) + +type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc + +type SolverPlanIndex = Graph SolverPlanPackage + +data SolverInstallPlan = SolverInstallPlan { + planIndex :: !SolverPlanIndex, + planIndepGoals :: !IndependentGoals + } + deriving (Typeable, Generic) + +{- +-- | Much like 'planPkgIdOf', but mapping back to full packages. +planPkgOf :: SolverInstallPlan + -> Graph.Vertex + -> SolverPlanPackage +planPkgOf plan v = + case Graph.lookupKey (planIndex plan) + (planPkgIdOf plan v) of + Just pkg -> pkg + Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" +-} + + + +instance Binary SolverInstallPlan +instance Structured SolverInstallPlan + +showPlanIndex :: [SolverPlanPackage] -> String +showPlanIndex = intercalate "\n" . map showPlanPackage + +showInstallPlan :: SolverInstallPlan -> String +showInstallPlan = showPlanIndex . toList + +showPlanPackage :: SolverPlanPackage -> String +showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg) + ++ " (" ++ prettyShow (installedUnitId ipkg) + ++ ")" +showPlanPackage (Configured spkg) = + "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps + where + flags + | nullFlagAssignment fa = "" + | otherwise = " " ++ prettyShow (solverPkgFlags spkg) + where + fa = solverPkgFlags spkg + + comps | null deps = "" + | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps) + where + deps = CD.components (solverPkgLibDeps spkg) + <> CD.components (solverPkgExeDeps spkg) + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: IndependentGoals + -> SolverPlanIndex + -> Either [SolverPlanProblem] SolverInstallPlan +new indepGoals index = + case problems indepGoals index of + [] -> Right (SolverInstallPlan index indepGoals) + probs -> Left probs + +toList :: SolverInstallPlan -> [SolverPlanPackage] +toList = Foldable.toList . planIndex + +toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage +toMap = Graph.toMap . planIndex + +-- | Remove packages from the install plan. This will result in an +-- error if there are remaining packages that depend on any matching +-- package. This is primarily useful for obtaining an install plan for +-- the dependencies of a package or set of packages without actually +-- installing the package itself, as when doing development. +-- +remove :: (SolverPlanPackage -> Bool) + -> SolverInstallPlan + -> Either [SolverPlanProblem] + (SolverInstallPlan) +remove shouldRemove plan = + new (planIndepGoals plan) newIndex + where + newIndex = Graph.fromDistinctList $ + filter (not . shouldRemove) (toList plan) + +-- ------------------------------------------------------------ +-- * Checking validity of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is 'acyclic', +-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the +-- plan has to have a valid configuration (see 'configuredPackageValid'). +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: IndependentGoals + -> SolverPlanIndex + -> Bool +valid indepGoals index = + null $ problems indepGoals index + +data SolverPlanProblem = + PackageMissingDeps SolverPlanPackage + [PackageIdentifier] + | PackageCycle [SolverPlanPackage] + | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageStateInvalid SolverPlanPackage SolverPlanPackage + +showPlanProblem :: SolverPlanProblem -> String +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ prettyShow (packageId pkg) + ++ " depends on the following packages which are missing from the plan: " + ++ intercalate ", " (map prettyShow missingDeps) + +showPlanProblem (PackageCycle cycleGroup) = + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (prettyShow.packageId) cycleGroup) + +showPlanProblem (PackageInconsistency name inconsistencies) = + "Package " ++ prettyShow name + ++ " is required by several packages," + ++ " but they require inconsistent versions:\n" + ++ unlines [ " package " ++ prettyShow pkg ++ " requires " + ++ prettyShow (PackageIdentifier name ver) + | (pkg, ver) <- inconsistencies ] + +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ prettyShow (packageId pkg) + ++ " is in the " ++ showPlanState pkg + ++ " state but it depends on package " ++ prettyShow (packageId pkg') + ++ " which is in the " ++ showPlanState pkg' + ++ " state" + where + showPlanState (PreExisting _) = "pre-existing" + showPlanState (Configured _) = "configured" + +-- | For an invalid plan, produce a detailed list of problems as human readable +-- error messages. This is mainly intended for debugging purposes. +-- Use 'showPlanProblem' for a human readable explanation. +-- +problems :: IndependentGoals + -> SolverPlanIndex + -> [SolverPlanProblem] +problems indepGoals index = + + [ PackageMissingDeps pkg + (mapMaybe + (fmap packageId . flip Graph.lookup index) + missingDeps) + | (pkg, missingDeps) <- Graph.broken index ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- Graph.cycles index ] + + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- + dependencyInconsistencies indepGoals index ] + + ++ [ PackageStateInvalid pkg pkg' + | pkg <- Foldable.toList index + , Just pkg' <- map (flip Graph.lookup index) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') ] + + +-- | Compute all roots of the install plan, and verify that the transitive +-- plans from those roots are all consistent. +-- +-- NOTE: This does not check for dependency cycles. Moreover, dependency cycles +-- may be absent from the subplans even if the larger plan contains a dependency +-- cycle. Such cycles may or may not be an issue; either way, we don't check +-- for them here. +dependencyInconsistencies :: IndependentGoals + -> SolverPlanIndex + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies indepGoals index = + concatMap dependencyInconsistencies' subplans + where + subplans :: [SolverPlanIndex] + subplans = -- Not Graph.closure!! + map (nonSetupClosure index) + (rootSets indepGoals index) + +-- NB: When we check for inconsistencies, packages from the setup +-- scripts don't count as part of the closure (this way, we +-- can build, e.g., Cabal-1.24.1 even if its setup script is +-- built with Cabal-1.24.0). +-- +-- This is a best effort function that swallows any non-existent +-- SolverIds. +nonSetupClosure :: SolverPlanIndex + -> [SolverId] + -> SolverPlanIndex +nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 + where + closure completed [] = completed + closure completed (pkgid:pkgids) = + case Graph.lookup pkgid index of + Nothing -> closure completed pkgids + Just pkg -> + case Graph.lookup (nodeKey pkg) completed of + Just _ -> closure completed pkgids + Nothing -> closure completed' pkgids' + where completed' = Graph.insert pkg completed + pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids + +-- | Compute the root sets of a plan +-- +-- A root set is a set of packages whose dependency closure must be consistent. +-- This is the set of all top-level library roots (taken together normally, or +-- as singletons sets if we are considering them as independent goals), along +-- with all setup dependencies of all packages. +rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]] +rootSets (IndependentGoals indepGoals) index = + if indepGoals then map (:[]) libRoots else [libRoots] + ++ setupRoots index + where + libRoots = libraryRoots index + +-- | Compute the library roots of a plan +-- +-- The library roots are the set of packages with no reverse dependencies +-- (no reverse library dependencies but also no reverse setup dependencies). +libraryRoots :: SolverPlanIndex -> [SolverId] +libraryRoots index = + map (nodeKey . toPkgId) roots + where + (graph, toPkgId, _) = Graph.toGraph index + indegree = OldGraph.indegree graph + roots = filter isRoot (OldGraph.vertices graph) + isRoot v = indegree ! v == 0 + +-- | The setup dependencies of each package in the plan +setupRoots :: SolverPlanIndex -> [[SolverId]] +setupRoots = filter (not . null) + . map (CD.setupDeps . resolverPackageLibDeps) + . Foldable.toList + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies' :: SolverPlanIndex + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies' index = + [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids]) + | (name, ipid_map) <- Map.toList inverseIndex + , let uses = Map.elems ipid_map + , reallyIsInconsistent (map fst uses) + ] + where + -- For each package name (of a dependency, somewhere) + -- and each installed ID of that package + -- the associated package instance + -- and a list of reverse dependencies (as source IDs) + inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId])) + inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) + [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) + | -- For each package @pkg@ + pkg <- Foldable.toList index + -- Find out which @sid@ @pkg@ depends on + , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) + -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) + , Just dep <- [Graph.lookup sid index] + ] + + -- If, in a single install plan, we depend on more than one version of a + -- package, then this is ONLY okay in the (rather special) case that we + -- depend on precisely two versions of that package, and one of them + -- depends on the other. This is necessary for example for the base where + -- we have base-3 depending on base-4. + reallyIsInconsistent :: [SolverPlanPackage] -> Bool + reallyIsInconsistent [] = False + reallyIsInconsistent [_p] = False + reallyIsInconsistent [p1, p2] = + let pid1 = nodeKey p1 + pid2 = nodeKey p2 + in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) + && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) + reallyIsInconsistent _ = True + + +-- | The graph of packages (nodes) and dependencies (edges) must be acyclic. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out +-- which packages are involved in dependency cycles. +-- +acyclic :: SolverPlanIndex -> Bool +acyclic = null . Graph.cycles + +-- | An installation plan is closed if for every package in the set, all of +-- its dependencies are also in the set. That is, the set is closed under the +-- dependency relation. +-- +-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out +-- which packages depend on packages not in the index. +-- +closed :: SolverPlanIndex -> Bool +closed = null . Graph.broken + +-- | An installation plan is consistent if all dependencies that target a +-- single package name, target the same version. +-- +-- This is slightly subtle. It is not the same as requiring that there be at +-- most one version of any package in the set. It only requires that of +-- packages which have more than one other package depending on them. We could +-- actually make the condition even more precise and say that different +-- versions are OK so long as they are not both in the transitive closure of +-- any other package (or equivalently that their inverse closures do not +-- intersect). The point is we do not want to have any packages depending +-- directly or indirectly on two different versions of the same package. The +-- current definition is just a safe approximation of that. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to +-- find out which packages are. +-- +consistent :: SolverPlanIndex -> Bool +consistent = null . dependencyInconsistencies (IndependentGoals False) + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @dependencyStatesOk a b = True@. +-- +stateDependencyRelation :: SolverPlanPackage + -> SolverPlanPackage + -> Bool +stateDependencyRelation PreExisting{} PreExisting{} = True + +stateDependencyRelation (Configured _) PreExisting{} = True +stateDependencyRelation (Configured _) (Configured _) = True + +stateDependencyRelation _ _ = False + + +-- | Compute the dependency closure of a package in a install plan +-- +dependencyClosure :: SolverInstallPlan + -> [SolverId] + -> [SolverPlanPackage] +dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan) + + +reverseDependencyClosure :: SolverInstallPlan + -> [SolverId] + -> [SolverPlanPackage] +reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan) + + +topologicalOrder :: SolverInstallPlan + -> [SolverPlanPackage] +topologicalOrder plan = Graph.topSort (planIndex plan) + + +reverseTopologicalOrder :: SolverInstallPlan + -> [SolverPlanPackage] +reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan) diff --git a/src/Distribution/Client/SourceFiles.hs b/src/Distribution/Client/SourceFiles.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/SourceFiles.hs @@ -0,0 +1,161 @@ +-- | Contains an @sdist@ like function which computes the source files +-- that we should track to determine if a rebuild is necessary. +-- Unlike @sdist@, we can operate directly on the true +-- 'PackageDescription' (not flattened). +-- +-- The naming convention, roughly, is that to declare we need the +-- source for some type T, you use the function needT; some functions +-- need auxiliary information. +-- +-- We can only use this code for non-Custom scripts; Custom scripts +-- may have arbitrary extra dependencies (esp. new preprocessors) which +-- we cannot "see" easily. +module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where + +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Simple.PreProcess + +import Distribution.Types.PackageDescription +import Distribution.Types.Component +import Distribution.Types.Library +import Distribution.Types.Executable +import Distribution.Types.Benchmark +import Distribution.Types.BenchmarkInterface +import Distribution.Types.TestSuite +import Distribution.Types.TestSuiteInterface +import Distribution.Types.BuildInfo +import Distribution.Types.ForeignLib +import Distribution.Utils.Path + +import Distribution.ModuleName + +import Prelude () +import Distribution.Client.Compat.Prelude + +import System.FilePath + +needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild () +needElaboratedConfiguredPackage elab = + case elabPkgOrComp elab of + ElabComponent ecomp -> needElaboratedComponent elab ecomp + ElabPackage epkg -> needElaboratedPackage elab epkg + +needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () +needElaboratedPackage elab epkg = + traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) + where + pkg_descr = elabPkgDescription elab + enabled_stanzas = pkgStanzasEnabled epkg + enabled = enableStanzas enabled_stanzas + +needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild () +needElaboratedComponent elab ecomp = + case mb_comp of + Nothing -> needSetup + Just comp -> needComponent pkg_descr comp + where + pkg_descr = elabPkgDescription elab + mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) + +needComponent :: PackageDescription -> Component -> Rebuild () +needComponent pkg_descr comp = + case comp of + CLib lib -> needLibrary pkg_descr lib + CFLib flib -> needForeignLib pkg_descr flib + CExe exe -> needExecutable pkg_descr exe + CTest test -> needTestSuite pkg_descr test + CBench bench -> needBenchmark pkg_descr bench + +needSetup :: Rebuild () +needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () + +needLibrary :: PackageDescription -> Library -> Rebuild () +needLibrary pkg_descr (Library { exposedModules = modules + , signatures = sigs + , libBuildInfo = bi }) + = needBuildInfo pkg_descr bi (modules ++ sigs) + +needForeignLib :: PackageDescription -> ForeignLib -> Rebuild () +needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs + , foreignLibBuildInfo = bi }) + = do traverse_ needIfExists fs + needBuildInfo pkg_descr bi [] + +needExecutable :: PackageDescription -> Executable -> Rebuild () +needExecutable pkg_descr (Executable { modulePath = mainPath + , buildInfo = bi }) + = do needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + +needTestSuite :: PackageDescription -> TestSuite -> Rebuild () +needTestSuite pkg_descr t + = case testInterface t of + TestSuiteExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + TestSuiteLibV09 _ m -> + needBuildInfo pkg_descr bi [m] + TestSuiteUnsupported _ -> return () -- soft fail + where + bi = testBuildInfo t + +needMainFile :: BuildInfo -> FilePath -> Rebuild () +needMainFile bi mainPath = do + -- The matter here is subtle. It might *seem* that we + -- should just search for mainPath, but as per + -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' + -- will actually be the source file AFTER preprocessing, + -- whereas we need to get the file *prior* to preprocessing. + ppFile <- findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers) + (map getSymbolicPath (hsSourceDirs bi)) + (dropExtension mainPath) + case ppFile of + -- But check the original path in the end, because + -- maybe it's a non-preprocessed file with a non-traditional + -- extension. + Nothing -> findFileMonitored (map getSymbolicPath (hsSourceDirs bi)) mainPath + >>= maybe (return ()) need + Just pp -> need pp + +needBenchmark :: PackageDescription -> Benchmark -> Rebuild () +needBenchmark pkg_descr bm + = case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + BenchmarkUnsupported _ -> return () -- soft fail + where + bi = benchmarkBuildInfo bm + +needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild () +needBuildInfo pkg_descr bi modules = do + -- NB: These are separate because there may be both A.hs and + -- A.hs-boot; need to track both. + findNeededModules ["hs", "lhs", "hsig", "lhsig"] + findNeededModules ["hs-boot", "lhs-boot"] + traverse_ needIfExists $ concat + [ cSources bi + , cxxSources bi + , jsSources bi + , cmmSources bi + , asmSources bi + , extraSrcFiles pkg_descr + ] + for_ (installIncludes bi) $ \f -> + findFileMonitored ("." : includeDirs bi) f + >>= maybe (return ()) need + where + findNeededModules exts = traverse_ + (findNeededModule exts) + (modules ++ otherModules bi) + findNeededModule exts m = + findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers ++ exts) + (map getSymbolicPath (hsSourceDirs bi)) + (toFilePath m) + >>= maybe (return ()) need diff --git a/src/Distribution/Client/SrcDist.hs b/src/Distribution/Client/SrcDist.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/SrcDist.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Utilities to implemenet cabal @v2-sdist@. +module Distribution.Client.SrcDist ( + allPackageSourceFiles, + packageDirToSdist, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify) +import Control.Monad.Trans (liftIO) +import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell) +import System.FilePath (normalise, takeDirectory, ()) + +import Distribution.Client.Utils (tryFindAddSourcePackageDesc) +import Distribution.Package (Package (packageId)) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Parsec (readGenericPackageDescription) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.SrcDist (listPackageSourcesWithDie) +import Distribution.Simple.Utils (die') +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Set as Set + +-- | List all source files of a given add-source dependency. Exits with error if +-- something is wrong (e.g. there is no .cabal file in the given directory). +-- +-- Used in sandbox and projectbuilding. +-- TODO: when sandboxes are removed, move to ProjectBuilding. +-- +allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] +allPackageSourceFiles verbosity packageDir = do + pd <- do + let err = "Error reading source files of package." + desc <- tryFindAddSourcePackageDesc verbosity packageDir err + flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc + + listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers + +-- | Create a tarball for a package in a directory +packageDirToSdist + :: Verbosity + -> GenericPackageDescription -- ^ read in GPD + -> FilePath -- ^ directory containing that GPD + -> IO BSL.ByteString -- ^ resulting sdist tarball +packageDirToSdist verbosity gpd dir = do + let thisDie :: Verbosity -> String -> IO a + thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s + + files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers + let files = nub $ sort $ map normalise files' + + let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () + entriesM = do + let prefix = prettyShow (packageId gpd) + modify (Set.insert prefix) + case Tar.toTarPath True prefix of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + for_ files $ \file -> do + let fileDir = takeDirectory (prefix file) + needsEntry <- gets (Set.notMember fileDir) + + when needsEntry $ do + modify (Set.insert fileDir) + case Tar.toTarPath True fileDir of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir file + case Tar.toTarPath False (prefix file) of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }] + + entries <- execWriterT (evalStateT entriesM mempty) + let -- Pretend our GZip file is made on Unix. + normalize bs = BSL.concat [pfx, "\x03", rest'] + where + (pfx, rest) = BSL.splitAt 9 bs + rest' = BSL.tail rest + -- The Unix epoch, which is the default value, is + -- unsuitable because it causes unpacking problems on + -- Windows; we need a post-1980 date. One gigasecond + -- after the epoch is during 2001-09-09, so that does + -- nicely. See #5596. + setModTime entry = entry { Tar.entryTime = 1000000000 } + return . normalize . GZip.compress . Tar.write $ fmap setModTime entries diff --git a/src/Distribution/Client/Store.hs b/src/Distribution/Client/Store.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Store.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-} + + +-- | Management for the installed package store. +-- +module Distribution.Client.Store ( + + -- * The store layout + StoreDirLayout(..), + defaultStoreDirLayout, + + -- * Reading store entries + getStoreEntries, + doesStoreEntryExist, + + -- * Creating store entries + newStoreEntry, + NewStoreEntryOutcome(..), + + -- * Concurrency strategy + -- $concurrency + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.DistDirLayout +import Distribution.Client.RebuildMonad + +import Distribution.Package (UnitId, mkUnitId) +import Distribution.Compiler (CompilerId) + +import Distribution.Simple.Utils + ( withTempDirectory, debug, info ) +import Distribution.Verbosity + ( silent ) + +import qualified Data.Set as Set +import Control.Exception +import System.FilePath +import System.Directory + +#ifdef MIN_VERSION_lukko +import Lukko +#else +import System.IO (openFile, IOMode(ReadWriteMode), hClose) +import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock)) +#if MIN_VERSION_base(4,11,0) +import GHC.IO.Handle.Lock (hUnlock) +#endif +#endif + +-- $concurrency +-- +-- We access and update the store concurrently. Our strategy to do that safely +-- is as follows. +-- +-- The store entries once created are immutable. This alone simplifies matters +-- considerably. +-- +-- Additionally, the way 'UnitId' hashes are constructed means that if a store +-- entry exists already then we can assume its content is ok to reuse, rather +-- than having to re-recreate. This is the nix-style input hashing concept. +-- +-- A consequence of this is that with a little care it is /safe/ to race +-- updates against each other. Consider two independent concurrent builds that +-- both want to build a particular 'UnitId', where that entry does not yet +-- exist in the store. It is safe for both to build and try to install this +-- entry into the store provided that: +-- +-- * only one succeeds +-- * the looser discovers that they lost, they abandon their own build and +-- re-use the store entry installed by the winner. +-- +-- Note that because builds are not reproducible in general (nor even +-- necessarily ABI compatible) then it is essential that the loser abandon +-- their build and use the one installed by the winner, so that subsequent +-- packages are built against the exact package from the store rather than some +-- morally equivalent package that may not be ABI compatible. +-- +-- Our overriding goal is that store reads be simple, cheap and not require +-- locking. We will derive our write-side protocol to make this possible. +-- +-- The read-side protocol is simply: +-- +-- * check for the existence of a directory entry named after the 'UnitId' in +-- question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then +-- the store entry can be assumed to be complete and immutable. +-- +-- Given our read-side protocol, the final step on the write side must be to +-- atomically rename a fully-formed store entry directory into its final +-- location. While this will indeed be the final step, the preparatory steps +-- are more complicated. The tricky aspect is that the store also contains a +-- number of shared package databases (one per compiler version). Our read +-- strategy means that by the time we install the store dir entry the package +-- db must already have been updated. We cannot do the package db update +-- as part of atomically renaming the store entry directory however. Furthermore +-- it is not safe to allow either package db update because the db entry +-- contains the ABI hash and this is not guaranteed to be deterministic. So we +-- must register the new package prior to the atomic dir rename. Since this +-- combination of steps are not atomic then we need locking. +-- +-- The write-side protocol is: +-- +-- * Create a unique temp dir and write all store entry files into it. +-- +-- * Take a lock named after the 'UnitId' in question. +-- +-- * Once holding the lock, check again for the existence of the final store +-- entry directory. If the entry exists then the process lost the race and it +-- must abandon, unlock and re-use the existing store entry. If the entry +-- does not exist then the process won the race and it can proceed. +-- +-- * Register the package into the package db. Note that the files are not in +-- their final location at this stage so registration file checks may need +-- to be disabled. +-- +-- * Atomically rename the temp dir to the final store entry location. +-- +-- * Release the previously-acquired lock. +-- +-- Obviously this means it is possible to fail after registering but before +-- installing the store entry, leaving a dangling package db entry. This is not +-- much of a problem because this entry does not determine package existence +-- for cabal. It does mean however that the package db update should be insert +-- or replace, i.e. not failing if the db entry already exists. + + +-- | Check if a particular 'UnitId' exists in the store. +-- +doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool +doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = + doesDirectoryExist (storePackageDirectory compid unitid) + + +-- | Return the 'UnitId's of all packages\/components already installed in the +-- store. +-- +getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) +getStoreEntries StoreDirLayout{storeDirectory} compid = do + paths <- getDirectoryContentsMonitored (storeDirectory compid) + return $! mkEntries paths + where + mkEntries = Set.delete (mkUnitId "package.db") + . Set.delete (mkUnitId "incoming") + . Set.fromList + . map mkUnitId + . filter valid + valid ('.':_) = False + valid _ = True + + +-- | The outcome of 'newStoreEntry': either the store entry was newly created +-- or it existed already. The latter case happens if there was a race between +-- two builds of the same store entry. +-- +data NewStoreEntryOutcome = UseNewStoreEntry + | UseExistingStoreEntry + deriving (Eq, Show) + +-- | Place a new entry into the store. See the concurrency strategy description +-- for full details. +-- +-- In particular, it takes two actions: one to place files into a temporary +-- location, and a second to perform any necessary registration. The first +-- action is executed without any locks held (the temp dir is unique). The +-- second action holds a lock that guarantees that only one cabal process is +-- able to install this store entry. This means it is safe to register into +-- the compiler package DB or do other similar actions. +-- +-- Note that if you need to use the registration information later then you +-- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry' +-- then you must read the existing registration information (unless your +-- registration information is constructed fully deterministically). +-- +newStoreEntry :: Verbosity + -> StoreDirLayout + -> CompilerId + -> UnitId + -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. + -> IO () -- ^ Register action, if necessary. + -> IO NewStoreEntryOutcome +newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} + compid unitid + copyFiles register = + -- See $concurrency above for an explanation of the concurrency protocol + + withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do + + -- Write all store entry files within the temp dir and return the prefix. + (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir + + -- Take a lock named after the 'UnitId' in question. + withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do + + -- Check for the existence of the final store entry directory. + exists <- doesStoreEntryExist storeDirLayout compid unitid + + if exists + -- If the entry exists then we lost the race and we must abandon, + -- unlock and re-use the existing store entry. + then do + info verbosity $ + "Concurrent build race: abandoning build in favour of existing " + ++ "store entry " ++ prettyShow compid prettyShow unitid + return UseExistingStoreEntry + + -- If the entry does not exist then we won the race and can proceed. + else do + + -- Register the package into the package db (if appropriate). + register + + -- Atomically rename the temp dir to the final store entry location. + renameDirectory incomingEntryDir finalEntryDir + for_ otherFiles $ \file -> do + let finalStoreFile = storeDirectory compid makeRelative (incomingTmpDir (dropDrive (storeDirectory compid))) file + createDirectoryIfMissing True (takeDirectory finalStoreFile) + renameFile file finalStoreFile + + debug verbosity $ + "Installed store entry " ++ prettyShow compid prettyShow unitid + return UseNewStoreEntry + where + finalEntryDir = storePackageDirectory compid unitid + + +withTempIncomingDir :: StoreDirLayout -> CompilerId + -> (FilePath -> IO a) -> IO a +withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do + createDirectoryIfMissing True incomingDir + withTempDirectory silent incomingDir "new" action + where + incomingDir = storeIncomingDirectory compid + + +withIncomingUnitIdLock :: Verbosity -> StoreDirLayout + -> CompilerId -> UnitId + -> IO a -> IO a +withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} + compid unitid action = + bracket takeLock releaseLock (\_hnd -> action) + where +#ifdef MIN_VERSION_lukko + takeLock + | fileLockingSupported = do + fd <- fdOpen (storeIncomingLock compid unitid) + gotLock <- fdTryLock fd ExclusiveLock + unless gotLock $ do + info verbosity $ "Waiting for file lock on store entry " + ++ prettyShow compid prettyShow unitid + fdLock fd ExclusiveLock + return fd + + -- if there's no locking, do nothing. Be careful on AIX. + | otherwise = return undefined -- :( + + releaseLock fd + | fileLockingSupported = do + fdUnlock fd + fdClose fd + | otherwise = return () +#else + takeLock = do + h <- openFile (storeIncomingLock compid unitid) ReadWriteMode + -- First try non-blocking, but if we would have to wait then + -- log an explanation and do it again in blocking mode. + gotlock <- hTryLock h ExclusiveLock + unless gotlock $ do + info verbosity $ "Waiting for file lock on store entry " + ++ prettyShow compid prettyShow unitid + hLock h ExclusiveLock + return h + + releaseLock h = hUnlock h >> hClose h +#endif diff --git a/src/Distribution/Client/Tar.hs b/src/Distribution/Client/Tar.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Tar.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Tar +-- Copyright : (c) 2007 Bjorn Bringert, +-- 2008 Andrea Vezzosi, +-- 2008-2009 Duncan Coutts +-- License : BSD3 +-- +-- Maintainer : duncan@community.haskell.org +-- Portability : portable +-- +-- Reading, writing and manipulating \"@.tar@\" archive files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Tar ( + -- * @tar.gz@ operations + createTarGzFile, + extractTarGzFile, + + -- * Other local utils + buildTreeRefTypeCode, + buildTreeSnapshotTypeCode, + isBuildTreeRefTypeCode, + filterEntries, + filterEntriesM, + entriesToList, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Data.ByteString.Lazy as BS +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Archive.Tar.Check as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Distribution.Client.GZipUtils as GZipUtils + +-- for foldEntries... +import Control.Exception (throw) + +-- +-- * High level operations +-- + +createTarGzFile :: FilePath -- ^ Full Tarball path + -> FilePath -- ^ Base directory + -> FilePath -- ^ Directory to archive, relative to base dir + -> IO () +createTarGzFile tar base dir = + BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir] + +extractTarGzFile :: FilePath -- ^ Destination directory + -> FilePath -- ^ Expected subdir (to check for tarbombs) + -> FilePath -- ^ Tarball + -> IO () +extractTarGzFile dir expected tar = + Tar.unpack dir . Tar.checkTarbomb expected . Tar.read + . GZipUtils.maybeDecompress =<< BS.readFile tar + +instance (Exception a, Exception b) => Exception (Either a b) where + toException (Left e) = toException e + toException (Right e) = toException e + + fromException e = + case fromException e of + Just e' -> Just (Left e') + Nothing -> case fromException e of + Just e' -> Just (Right e') + Nothing -> Nothing + + +-- | Type code for the local build tree reference entry type. We don't use the +-- symbolic link entry type because it allows only 100 ASCII characters for the +-- path. +buildTreeRefTypeCode :: Tar.TypeCode +buildTreeRefTypeCode = 'C' + +-- | Type code for the local build tree snapshot entry type. +buildTreeSnapshotTypeCode :: Tar.TypeCode +buildTreeSnapshotTypeCode = 'S' + +-- | Is this a type code for a build tree reference? +isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool +isBuildTreeRefTypeCode typeCode + | (typeCode == buildTreeRefTypeCode + || typeCode == buildTreeSnapshotTypeCode) = True + | otherwise = False + +filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e +filterEntries p = + Tar.foldEntries + (\e es -> if p e then Tar.Next e es else es) + Tar.Done + Tar.Fail + +filterEntriesM :: Monad m => (Tar.Entry -> m Bool) + -> Tar.Entries e -> m (Tar.Entries e) +filterEntriesM p = + Tar.foldEntries + (\entry rest -> do + keep <- p entry + xs <- rest + if keep + then return (Tar.Next entry xs) + else return xs) + (return Tar.Done) + (return . Tar.Fail) + +entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry] +entriesToList = Tar.foldEntries (:) [] throw + diff --git a/src/Distribution/Client/TargetProblem.hs b/src/Distribution/Client/TargetProblem.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/TargetProblem.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Client.TargetProblem ( + TargetProblem(..), + TargetProblem', +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectPlanning (AvailableTarget) +import Distribution.Client.TargetSelector (SubComponentTarget, TargetSelector) +import Distribution.Package (PackageId, PackageName) +import Distribution.Simple.LocalBuildInfo (ComponentName (..)) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +-- | Target problems that occur during project orchestration. +data TargetProblem a + = TargetNotInProject PackageName + | TargetAvailableInIndex PackageName + + | TargetComponentNotProjectLocal + PackageId ComponentName SubComponentTarget + + | TargetComponentNotBuildable + PackageId ComponentName SubComponentTarget + + | TargetOptionalStanzaDisabledByUser + PackageId ComponentName SubComponentTarget + + | TargetOptionalStanzaDisabledBySolver + PackageId ComponentName SubComponentTarget + + | TargetProblemUnknownComponent + PackageName (Either UnqualComponentName ComponentName) + + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] + -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable + + | TargetProblemNoTargets TargetSelector + -- ^ There are no targets at all + + -- The target matching stuff only returns packages local to the project, + -- so these lookups should never fail, but if 'resolveTargets' is called + -- directly then of course it can. + | TargetProblemNoSuchPackage PackageId + | TargetProblemNoSuchComponent PackageId ComponentName + + -- | A custom target problem + | CustomTargetProblem a + deriving (Eq, Show, Functor) + +-- | Type alias for a 'TargetProblem' with no user-defined problems/errors. +-- +-- Can use the utilities below for reporting/rendering problems. +type TargetProblem' = TargetProblem Void diff --git a/src/Distribution/Client/TargetSelector.hs b/src/Distribution/Client/TargetSelector.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/TargetSelector.hs @@ -0,0 +1,2491 @@ +{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, + RecordWildCards, NamedFieldPuns #-} +-- TODO +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.TargetSelector +-- Copyright : (c) Duncan Coutts 2012, 2015, 2016 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified target selectors. +-- +----------------------------------------------------------------------------- +module Distribution.Client.TargetSelector ( + + -- * Target selectors + TargetSelector(..), + TargetImplicitCwd(..), + ComponentKind(..), + ComponentKindFilter, + SubComponentTarget(..), + QualLevel(..), + componentKind, + + -- * Reading target selectors + readTargetSelectors, + TargetSelectorProblem(..), + reportTargetSelectorProblems, + showTargetSelector, + TargetString(..), + showTargetString, + parseTargetString, + -- ** non-IO + readTargetSelectorsWith, + DirActions(..), + defaultDirActions, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Package + ( Package(..), PackageId, PackageName, packageName ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName + , packageNameToUnqualComponentName ) +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..) ) + +import Distribution.PackageDescription + ( PackageDescription + , Executable(..) + , TestSuite(..), TestSuiteInterface(..), testModules + , Benchmark(..), BenchmarkInterface(..), benchmarkModules + , BuildInfo(..), explicitLibModules, exeModules ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.ModuleName + ( ModuleName, toFilePath ) +import Distribution.Simple.LocalBuildInfo + ( Component(..), ComponentName(..), LibraryName(..) + , pkgComponents, componentName, componentBuildInfo ) +import Distribution.Types.ForeignLib + +import Distribution.Simple.Utils + ( die', lowercase, ordNub ) +import Distribution.Client.Utils + ( makeRelativeCanonical ) + +import Data.List + ( stripPrefix, groupBy ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Lazy as Map.Lazy +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Control.Arrow ((&&&)) +import Control.Monad + hiding ( mfilter ) +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Deprecated.ReadP + ( (+++), (<++) ) +import Distribution.Deprecated.ParseUtils + ( readPToMaybe ) +import System.FilePath as FilePath + ( takeExtension, dropExtension + , splitDirectories, joinPath, splitPath ) +import qualified System.Directory as IO + ( doesFileExist, doesDirectoryExist, canonicalizePath + , getCurrentDirectory ) +import System.FilePath + ( (), (<.>), normalise, dropTrailingPathSeparator ) +import Text.EditDistance + ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) +import Distribution.Utils.Path + +import qualified Prelude (foldr1) + +-- ------------------------------------------------------------ +-- * Target selector terms +-- ------------------------------------------------------------ + +-- | A target selector is expression selecting a set of components (as targets +-- for a actions like @build@, @run@, @test@ etc). A target selector +-- corresponds to the user syntax for referring to targets on the command line. +-- +-- From the users point of view a target can be many things: packages, dirs, +-- component names, files etc. Internally we consider a target to be a specific +-- component (or module\/file within a component), and all the users' notions +-- of targets are just different ways of referring to these component targets. +-- +-- So target selectors are expressions in the sense that they are interpreted +-- to refer to one or more components. For example a 'TargetPackage' gets +-- interpreted differently by different commands to refer to all or a subset +-- of components within the package. +-- +-- The syntax has lots of optional parts: +-- +-- > [ package name | package dir | package .cabal file ] +-- > [ [lib:|exe:] component name ] +-- > [ module name | source file ] +-- +data TargetSelector = + + -- | One (or more) packages as a whole, or all the components of a + -- particular kind within the package(s). + -- + -- These are always packages that are local to the project. In the case + -- that there is more than one, they all share the same directory location. + -- + TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) + + -- | A package specified by name. This may refer to @extra-packages@ from + -- the @cabal.project@ file, or a dependency of a known project package or + -- could refer to a package from a hackage archive. It needs further + -- context to resolve to a specific package. + -- + | TargetPackageNamed PackageName (Maybe ComponentKindFilter) + + -- | All packages, or all components of a particular kind in all packages. + -- + | TargetAllPackages (Maybe ComponentKindFilter) + + -- | A specific component in a package within the project. + -- + | TargetComponent PackageId ComponentName SubComponentTarget + + -- | A component in a package, but where it cannot be verified that the + -- package has such a component, or because the package is itself not + -- known. + -- + | TargetComponentUnknown PackageName + (Either UnqualComponentName ComponentName) + SubComponentTarget + deriving (Eq, Ord, Show, Generic) + +-- | Does this 'TargetPackage' selector arise from syntax referring to a +-- package in the current directory (e.g. @tests@ or no giving no explicit +-- target at all) or does it come from syntax referring to a package name +-- or location. +-- +data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed + deriving (Eq, Ord, Show, Generic) + +data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Enum, Show) + +type ComponentKindFilter = ComponentKind + +-- | Either the component as a whole or detail about a file or module target +-- within a component. +-- +data SubComponentTarget = + + -- | The component as a whole + WholeComponent + + -- | A specific module within a component. + | ModuleTarget ModuleName + + -- | A specific file within a component. Note that this does not carry the + -- file extension. + | FileTarget FilePath + deriving (Eq, Ord, Show, Generic) + +instance Binary SubComponentTarget +instance Structured SubComponentTarget + + +-- ------------------------------------------------------------ +-- * Top level, do everything +-- ------------------------------------------------------------ + + +-- | Parse a bunch of command line args as 'TargetSelector's, failing with an +-- error if any are unrecognised. The possible target selectors are based on +-- the available packages (and their locations). +-- +readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKindFilter + -- ^ This parameter is used when there are ambiguous selectors. + -- If it is 'Just', then we attempt to resolve ambiguitiy + -- by applying it, since otherwise there is no way to allow + -- contextually valid yet syntactically ambiguous selectors. + -- (#4676, #5461) + -> [String] + -> IO (Either [TargetSelectorProblem] [TargetSelector]) +readTargetSelectors = readTargetSelectorsWith defaultDirActions + +readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKindFilter + -> [String] + -> m (Either [TargetSelectorProblem] [TargetSelector]) +readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = + case parseTargetStrings targetStrs of + ([], usertargets) -> do + usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets + knowntargets <- getKnownTargets dirActions pkgs + case resolveTargetSelectors knowntargets usertargets' mfilter of + ([], btargets) -> return (Right btargets) + (problems, _) -> return (Left problems) + (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) + + +data DirActions m = DirActions { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool, + canonicalizePath :: FilePath -> m FilePath, + getCurrentDirectory :: m FilePath + } + +defaultDirActions :: DirActions IO +defaultDirActions = + DirActions { + doesFileExist = IO.doesFileExist, + doesDirectoryExist = IO.doesDirectoryExist, + -- Workaround for + canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator, + getCurrentDirectory = IO.getCurrentDirectory + } + +makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath +makeRelativeToCwd DirActions{..} path = + makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory + + +-- ------------------------------------------------------------ +-- * Parsing target strings +-- ------------------------------------------------------------ + +-- | The outline parse of a target selector. It takes one of the forms: +-- +-- > str1 +-- > str1:str2 +-- > str1:str2:str3 +-- > str1:str2:str3:str4 +-- +data TargetString = + TargetString1 String + | TargetString2 String String + | TargetString3 String String String + | TargetString4 String String String String + | TargetString5 String String String String String + | TargetString7 String String String String String String String + deriving (Show, Eq) + +-- | Parse a bunch of 'TargetString's (purely without throwing exceptions). +-- +parseTargetStrings :: [String] -> ([String], [TargetString]) +parseTargetStrings = + partitionEithers + . map (\str -> maybe (Left str) Right (parseTargetString str)) + +parseTargetString :: String -> Maybe TargetString +parseTargetString = + readPToMaybe parseTargetApprox + where + parseTargetApprox :: Parse.ReadP r TargetString + parseTargetApprox = + (do a <- tokenQ + return (TargetString1 a)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + return (TargetString2 a b)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + _ <- Parse.char ':' + c <- tokenQ + return (TargetString3 a b c)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + return (TargetString4 a b c d)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + return (TargetString5 a b c d e)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + _ <- Parse.char ':' + f <- tokenQ + _ <- Parse.char ':' + g <- tokenQ + return (TargetString7 a b c d e f g)) + + token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') + tokenQ = parseHaskellString <++ token + token0 = Parse.munch (\x -> not (isSpace x) && x /= ':') + tokenQ0= parseHaskellString <++ token0 + parseHaskellString :: Parse.ReadP r String + parseHaskellString = Parse.readS_to_P reads + + +-- | Render a 'TargetString' back as the external syntax. This is mainly for +-- error messages. +-- +showTargetString :: TargetString -> String +showTargetString = intercalate ":" . components + where + components (TargetString1 s1) = [s1] + components (TargetString2 s1 s2) = [s1,s2] + components (TargetString3 s1 s2 s3) = [s1,s2,s3] + components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4] + components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] + components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] + +showTargetSelector :: TargetSelector -> String +showTargetSelector ts = + case [ t | ql <- [QL1 .. QLFull] + , t <- renderTargetSelector ql ts ] + of (t':_) -> showTargetString (forgetFileStatus t') + [] -> "" + +showTargetSelectorKind :: TargetSelector -> String +showTargetSelectorKind bt = case bt of + TargetPackage TargetExplicitNamed _ Nothing -> "package" + TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" + TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" + TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" + TargetPackageNamed _ Nothing -> "named-package" + TargetPackageNamed _ (Just _) -> "named-package:filter" + TargetAllPackages Nothing -> "package *" + TargetAllPackages (Just _) -> "package *:filter" + TargetComponent _ _ WholeComponent -> "component" + TargetComponent _ _ ModuleTarget{} -> "module" + TargetComponent _ _ FileTarget{} -> "file" + TargetComponentUnknown _ _ WholeComponent -> "unknown-component" + TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" + TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" + + +-- ------------------------------------------------------------ +-- * Checking if targets exist as files +-- ------------------------------------------------------------ + +data TargetStringFileStatus = + TargetStringFileStatus1 String FileStatus + | TargetStringFileStatus2 String FileStatus String + | TargetStringFileStatus3 String FileStatus String String + | TargetStringFileStatus4 String String String String + | TargetStringFileStatus5 String String String String String + | TargetStringFileStatus7 String String String String String String String + deriving (Eq, Ord, Show) + +data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath + | FileStatusExistsDir FilePath -- the canonicalised filepath + | FileStatusNotExists Bool -- does the parent dir exist even? + deriving (Eq, Ord, Show) + +noFileStatus :: FileStatus +noFileStatus = FileStatusNotExists False + +getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m + -> TargetString -> m TargetStringFileStatus +getTargetStringFileStatus DirActions{..} t = + case t of + TargetString1 s1 -> + (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 + TargetString2 s1 s2 -> + (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 + TargetString3 s1 s2 s3 -> + (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 + TargetString4 s1 s2 s3 s4 -> + return (TargetStringFileStatus4 s1 s2 s3 s4) + TargetString5 s1 s2 s3 s4 s5 -> + return (TargetStringFileStatus5 s1 s2 s3 s4 s5) + TargetString7 s1 s2 s3 s4 s5 s6 s7 -> + return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) + where + fileStatus f = do + fexists <- doesFileExist f + dexists <- doesDirectoryExist f + case splitPath f of + _ | fexists -> FileStatusExistsFile <$> canonicalizePath f + | dexists -> FileStatusExistsDir <$> canonicalizePath f + (d:_) -> FileStatusNotExists <$> doesDirectoryExist d + _ -> pure (FileStatusNotExists False) + +forgetFileStatus :: TargetStringFileStatus -> TargetString +forgetFileStatus t = case t of + TargetStringFileStatus1 s1 _ -> TargetString1 s1 + TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 + TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 + TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 + TargetStringFileStatus5 s1 s2 s3 s4 + s5 -> TargetString5 s1 s2 s3 s4 s5 + TargetStringFileStatus7 s1 s2 s3 s4 + s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 + +getFileStatus :: TargetStringFileStatus -> Maybe FileStatus +getFileStatus (TargetStringFileStatus1 _ f) = Just f +getFileStatus (TargetStringFileStatus2 _ f _) = Just f +getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f +getFileStatus _ = Nothing + +setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus +setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f +setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2 +setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3 +setFileStatus _ t = t + +copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus +copyFileStatus src dst = + case getFileStatus src of + Just f -> setFileStatus f dst + Nothing -> dst + +-- ------------------------------------------------------------ +-- * Resolving target strings to target selectors +-- ------------------------------------------------------------ + + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +-- +resolveTargetSelectors :: KnownTargets + -> [TargetStringFileStatus] + -> Maybe ComponentKindFilter + -> ([TargetSelectorProblem], + [TargetSelector]) +-- default local dir target if there's no given target: +resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = + ([TargetSelectorNoTargetsInProject], []) + +resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ = + ([TargetSelectorNoTargetsInCwd], []) + +resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = + ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) + where + pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] + +resolveTargetSelectors knowntargets targetStrs mfilter = + partitionEithers + . map (resolveTargetSelector knowntargets mfilter) + $ targetStrs + +resolveTargetSelector :: KnownTargets + -> Maybe ComponentKindFilter + -> TargetStringFileStatus + -> Either TargetSelectorProblem TargetSelector +resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = + case findMatch (matcher targetStrStatus) of + + Unambiguous _ + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + + Unambiguous (TargetPackage TargetImplicitCwd [] _) + -> Left (TargetSelectorNoCurrentPackage targetStr) + + Unambiguous target -> Right target + + None errs + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + | otherwise -> Left (classifyMatchErrors errs) + + Ambiguous _ targets + | Just kfilter <- mfilter + , [target] <- applyKindFilter kfilter targets -> Right target + + Ambiguous exactMatch targets -> + case disambiguateTargetSelectors + matcher targetStrStatus exactMatch + targets of + Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') + Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) + Left [] -> internalError "resolveTargetSelector" + where + matcher = matchTargetSelector knowntargets + + targetStr = forgetFileStatus targetStrStatus + + projectIsEmpty = null knownPackagesAll + + classifyMatchErrors errs + | Just expectedNE <- NE.nonEmpty expected + = let (things, got:|_) = NE.unzip expectedNE in + TargetSelectorExpected targetStr (NE.toList things) got + + | not (null nosuch) + = TargetSelectorNoSuch targetStr nosuch + + | otherwise + = internalError $ "classifyMatchErrors: " ++ show errs + where + expected = [ (thing, got) + | (_, MatchErrorExpected thing got) + <- map (innerErr Nothing) errs ] + -- Trim the list of alternatives by dropping duplicates and + -- retaining only at most three most similar (by edit distance) ones. + nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ + [ ((inside, thing, got), Set.fromList alts) + | (inside, MatchErrorNoSuch thing got alts) + <- map (innerErr Nothing) errs + ] + + genResults (inside, thing, got) alts acc = ( + inside + , thing + , got + , take maxResults + $ map fst + $ takeWhile distanceLow + $ sortBy (comparing snd) + $ map addLevDist + $ Set.toList alts + ) : acc + where + addLevDist = id &&& restrictedDamerauLevenshteinDistance + defaultEditCosts got + + distanceLow (_, dist) = dist < length got `div` 2 + + maxResults = 3 + + innerErr _ (MatchErrorIn kind thing m) + = innerErr (Just (kind,thing)) m + innerErr c m = (c,m) + + applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] + applyKindFilter kfilter = filter go + where + go (TargetPackage _ _ (Just filter')) = kfilter == filter' + go (TargetPackageNamed _ (Just filter')) = kfilter == filter' + go (TargetAllPackages (Just filter')) = kfilter == filter' + go (TargetComponent _ cname _) + | CLibName _ <- cname = kfilter == LibKind + | CFLibName _ <- cname = kfilter == FLibKind + | CExeName _ <- cname = kfilter == ExeKind + | CTestName _ <- cname = kfilter == TestKind + | CBenchName _ <- cname = kfilter == BenchKind + go _ = True + +-- | The various ways that trying to resolve a 'TargetString' to a +-- 'TargetSelector' can fail. +-- +data TargetSelectorProblem + = TargetSelectorExpected TargetString [String] String + -- ^ [expected thing] (actually got) + | TargetSelectorNoSuch TargetString + [(Maybe (String, String), String, String, [String])] + -- ^ [([in thing], no such thing, actually got, alternatives)] + | TargetSelectorAmbiguous TargetString + [(TargetString, TargetSelector)] + + | MatchingInternalError TargetString TargetSelector + [(TargetString, [TargetSelector])] + | TargetSelectorUnrecognised String + -- ^ Syntax error when trying to parse a target string. + | TargetSelectorNoCurrentPackage TargetString + | TargetSelectorNoTargetsInCwd + | TargetSelectorNoTargetsInProject + deriving (Show, Eq) + +-- | Qualification levels. +-- Given the filepath src/F, executable component A, and package foo: +data QualLevel = QL1 -- ^ @src/F@ + | QL2 -- ^ @foo:src/F | A:src/F@ + | QL3 -- ^ @foo:A:src/F | exe:A:src/F@ + | QLFull -- ^ @pkg:foo:exe:A:file:src/F@ + deriving (Eq, Enum, Show) + +disambiguateTargetSelectors + :: (TargetStringFileStatus -> Match TargetSelector) + -> TargetStringFileStatus -> MatchClass + -> [TargetSelector] + -> Either [(TargetSelector, [(TargetString, [TargetSelector])])] + [(TargetString, TargetSelector)] +disambiguateTargetSelectors matcher matchInput exactMatch matchResults = + case partitionEithers results of + (errs@(_:_), _) -> Left errs + ([], ok) -> Right ok + where + -- So, here's the strategy. We take the original match results, and make a + -- table of all their renderings at all qualification levels. + -- Note there can be multiple renderings at each qualification level. + + -- Note that renderTargetSelector won't immediately work on any file syntax + -- When rendering syntax, the FileStatus is always FileStatusNotExists, + -- which will never match on syntaxForm1File! + -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile. + -- So we need to copy over the file status from the input + -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus + matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])] + matchResultsRenderings = + [ (matchResult, matchRenderings) + | matchResult <- matchResults + , let matchRenderings = + [ copyFileStatus matchInput rendering + | ql <- [QL1 .. QLFull] + , rendering <- renderTargetSelector ql matchResult ] + ] + + -- Of course the point is that we're looking for renderings that are + -- unambiguous matches. So we build another memo table of all the matches + -- for all of those renderings. So by looking up in this table we can see + -- if we've got an unambiguous match. + + memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) + memoisedMatches = + -- avoid recomputing the main one if it was an exact match + (if exactMatch == Exact + then Map.insert matchInput (Match Exact 0 matchResults) + else id) + $ Map.Lazy.fromList + -- (matcher rendering) should *always* be a Match! Otherwise we will hit + -- the internal error later on. + [ (rendering, matcher rendering) + | rendering <- concatMap snd matchResultsRenderings ] + + -- Finally, for each of the match results, we go through all their + -- possible renderings (in order of qualification level, though remember + -- there can be multiple renderings per level), and find the first one + -- that has an unambiguous match. + results :: [Either (TargetSelector, [(TargetString, [TargetSelector])]) + (TargetString, TargetSelector)] + results = + [ case findUnambiguous originalMatch matchRenderings of + Just unambiguousRendering -> + Right ( forgetFileStatus unambiguousRendering + , originalMatch) + + -- This case is an internal error, but we bubble it up and report it + Nothing -> + Left ( originalMatch + , [ (forgetFileStatus rendering, matches) + | rendering <- matchRenderings + , let Match m _ matches = + memoisedMatches Map.! rendering + , m /= Inexact + ] ) + + | (originalMatch, matchRenderings) <- matchResultsRenderings ] + + findUnambiguous :: TargetSelector + -> [TargetStringFileStatus] + -> Maybe TargetStringFileStatus + findUnambiguous _ [] = Nothing + findUnambiguous t (r:rs) = + case memoisedMatches Map.! r of + Match Exact _ [t'] | t == t' + -> Just r + Match Exact _ _ -> findUnambiguous t rs + Match Unknown _ _ -> findUnambiguous t rs + Match Inexact _ _ -> internalError "Match Inexact" + NoMatch _ _ -> internalError "NoMatch" + +internalError :: String -> a +internalError msg = + error $ "TargetSelector: internal error: " ++ msg + + +-- | Throw an exception with a formatted message if there are any problems. +-- +reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a +reportTargetSelectorProblems verbosity problems = do + + case [ str | TargetSelectorUnrecognised str <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised target syntax for '" ++ name ++ "'." + | name <- targets ] + + case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of + [] -> return () + ((target, originalMatch, renderingsAndMatches):_) -> + die' verbosity $ "Internal error in target matching. It should always " + ++ "be possible to find a syntax that's sufficiently qualified to " + ++ "give an unambiguous match. However when matching '" + ++ showTargetString target ++ "' we found " + ++ showTargetSelector originalMatch + ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does " + ++ "not have an unambiguous syntax. The possible syntax and the " + ++ "targets they match are as follows:\n" + ++ unlines + [ "'" ++ showTargetString rendering ++ "' which matches " + ++ intercalate ", " + [ showTargetSelector match ++ + " (" ++ showTargetSelectorKind match ++ ")" + | match <- matches ] + | (rendering, matches) <- renderingsAndMatches ] + + case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised target '" ++ showTargetString target + ++ "'.\n" + ++ "Expected a " ++ intercalate " or " expected + ++ ", rather than '" ++ got ++ "'." + | (target, expected, got) <- targets ] + + case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unknown target '" ++ showTargetString target ++ + "'.\n" ++ unlines + [ (case inside of + Just (kind, "") + -> "The " ++ kind ++ " has no " + Just (kind, thing) + -> "The " ++ kind ++ " " ++ thing ++ " has no " + Nothing -> "There is no ") + ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got, _alts) <- nosuch' ] ++ "." + ++ if null alternatives then "" else + "\nPerhaps you meant " ++ intercalate ";\nor " + [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" + | (thing, alts) <- alternatives ] + | (inside, nosuch') <- groupByContainer nosuch + , let alternatives = + [ (thing, alts) + | (thing,_got,alts@(_:_)) <- nosuch' ] + ] + | (target, nosuch) <- targets + , let groupByContainer = + map (\g@((inside,_,_,_):_) -> + (inside, [ (thing,got,alts) + | (_,thing,got,alts) <- g ])) + . groupBy ((==) `on` (\(x,_,_,_) -> x)) + . sortBy (compare `on` (\(x,_,_,_) -> x)) + ] + where + mungeThing "file" = "file target" + mungeThing thing = thing + + case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Ambiguous target '" ++ showTargetString target + ++ "'. It could be:\n " + ++ unlines [ " "++ showTargetString ut ++ + " (" ++ showTargetSelectorKind bt ++ ")" + | (ut, bt) <- amb ] + | (target, amb) <- targets ] + + case [ t | TargetSelectorNoCurrentPackage t <- problems ] of + [] -> return () + target:_ -> + die' verbosity $ + "The target '" ++ showTargetString target ++ "' refers to the " + ++ "components in the package in the current directory, but there " + ++ "is no package in the current directory (or at least not listed " + ++ "as part of the project)." + --TODO: report a different error if there is a .cabal file but it's + -- not a member of the project + + case [ () | TargetSelectorNoTargetsInCwd <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "No targets given and there is no package in the current " + ++ "directory. Use the target 'all' for all packages in the " + ++ "project or specify packages or components by name or location. " + ++ "See 'cabal build --help' for more details on target options." + + case [ () | TargetSelectorNoTargetsInProject <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "There is no .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 +type Renderer = TargetSelector -> [TargetStringFileStatus] + +foldSyntax :: (a -> a -> a) -> (a -> a -> a) + -> (QualLevel -> Matcher -> Renderer -> a) + -> (Syntax -> a) +foldSyntax ambiguous unambiguous syntax = go + where + go (Syntax ql match render) = syntax ql match render + go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) + go (ShadowingAlternatives a b) = unambiguous (go a) (go b) + + +---------------------------------- +-- Top level renderer and matcher +-- + +renderTargetSelector :: QualLevel -> TargetSelector + -> [TargetStringFileStatus] +renderTargetSelector ql ts = + foldSyntax + (++) (++) + (\ql' _ render -> guard (ql == ql') >> render ts) + syntax + where + syntax = syntaxForms emptyKnownTargets + -- don't need known targets for rendering + +matchTargetSelector :: KnownTargets + -> TargetStringFileStatus + -> Match TargetSelector +matchTargetSelector knowntargets = \usertarget -> + nubMatchesBy (==) $ + + let ql = targetQualLevel usertarget in + foldSyntax + (<|>) () + (\ql' match _ -> guard (ql == ql') >> match usertarget) + syntax + where + syntax = syntaxForms knowntargets + + targetQualLevel TargetStringFileStatus1{} = QL1 + targetQualLevel TargetStringFileStatus2{} = QL2 + targetQualLevel TargetStringFileStatus3{} = QL3 + targetQualLevel TargetStringFileStatus4{} = QLFull + targetQualLevel TargetStringFileStatus5{} = QLFull + targetQualLevel TargetStringFileStatus7{} = QLFull + + +---------------------------------- +-- Syntax forms +-- + +-- | All the forms of syntax for 'TargetSelector'. +-- +syntaxForms :: KnownTargets -> Syntax +syntaxForms KnownTargets { + knownPackagesAll = pinfo, + knownPackagesPrimary = ppinfo, + knownComponentsAll = cinfo, + knownComponentsPrimary = pcinfo, + knownComponentsOther = ocinfo + } = + -- The various forms of syntax here are ambiguous in many cases. + -- Our policy is by default we expose that ambiguity and report + -- ambiguous matches. In certain cases we override the ambiguity + -- by having some forms shadow others. + -- + -- We make modules shadow files because module name "Q" clashes + -- with file "Q" with no extension but these refer to the same + -- thing anyway so it's not a useful ambiguity. Other cases are + -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q". + + ambiguousAlternatives + -- convenient single-component forms + [ shadowingAlternatives + [ ambiguousAlternatives + [ syntaxForm1All + , syntaxForm1Filter ppinfo + , shadowingAlternatives + [ syntaxForm1Component pcinfo + , syntaxForm1Package pinfo + ] + ] + , syntaxForm1Component ocinfo + , syntaxForm1Module cinfo + , syntaxForm1File pinfo + ] + + -- two-component partially qualified forms + -- fully qualified form for 'all' + , syntaxForm2MetaAll + , syntaxForm2AllFilter + , syntaxForm2NamespacePackage pinfo + , syntaxForm2PackageComponent pinfo + , syntaxForm2PackageFilter pinfo + , syntaxForm2KindComponent cinfo + , shadowingAlternatives + [ syntaxForm2PackageModule pinfo + , syntaxForm2PackageFile pinfo + ] + , shadowingAlternatives + [ syntaxForm2ComponentModule cinfo + , syntaxForm2ComponentFile cinfo + ] + + -- rarely used partially qualified forms + , syntaxForm3PackageKindComponent pinfo + , shadowingAlternatives + [ syntaxForm3PackageComponentModule pinfo + , syntaxForm3PackageComponentFile pinfo + ] + , shadowingAlternatives + [ syntaxForm3KindComponentModule cinfo + , syntaxForm3KindComponentFile cinfo + ] + , syntaxForm3NamespacePackageFilter pinfo + + -- fully-qualified forms for all and cwd with filter + , syntaxForm3MetaAllFilter + , syntaxForm3MetaCwdFilter ppinfo + + -- fully-qualified form for package and package with filter + , syntaxForm3MetaNamespacePackage pinfo + , syntaxForm4MetaNamespacePackageFilter pinfo + + -- fully-qualified forms for component, module and file + , syntaxForm5MetaNamespacePackageKindComponent pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo + ] + where + ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives + shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives + + +-- | Syntax: "all" to select all packages in the project +-- +-- > cabal build all +-- +syntaxForm1All :: Syntax +syntaxForm1All = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardMetaAll str1 + return (TargetAllPackages Nothing) + where + render (TargetAllPackages Nothing) = + [TargetStringFileStatus1 "all" noFileStatus] + render _ = [] + +-- | Syntax: filter +-- +-- > cabal build tests +-- +syntaxForm1Filter :: [KnownPackage] -> Syntax +syntaxForm1Filter ps = + syntaxForm1 render $ \str1 _fstatus1 -> do + kfilter <- matchComponentKindFilter str1 + return (TargetPackage TargetImplicitCwd pids (Just kfilter)) + where + pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] + render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = + [TargetStringFileStatus1 (dispF kfilter) noFileStatus] + render _ = [] + + +-- | Syntax: package (name, dir or file) +-- +-- > cabal build foo +-- > cabal build ../bar ../bar/bar.cabal +-- +syntaxForm1Package :: [KnownPackage] -> Syntax +syntaxForm1Package pinfo = + syntaxForm1 render $ \str1 fstatus1 -> do + guardPackage str1 fstatus1 + p <- matchPackage pinfo str1 fstatus1 + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) + where + render (TargetPackage TargetExplicitNamed [p] Nothing) = + [TargetStringFileStatus1 (dispP p) noFileStatus] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus1 (dispPN pn) noFileStatus] + render _ = [] + +-- | Syntax: component +-- +-- > cabal build foo +-- +syntaxForm1Component :: [KnownComponent] -> Syntax +syntaxForm1Component cs = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus1 (dispC p c) noFileStatus] + render _ = [] + +-- | Syntax: module +-- +-- > cabal build Data.Foo +-- +syntaxForm1Module :: [KnownComponent] -> Syntax +syntaxForm1Module cs = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardModuleName str1 + let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str1 + return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent _p _c (ModuleTarget m)) = + [TargetStringFileStatus1 (dispM m) noFileStatus] + render _ = [] + +-- | Syntax: file name +-- +-- > cabal build Data/Foo.hs bar/Main.hsc +-- +syntaxForm1File :: [KnownPackage] -> Syntax +syntaxForm1File ps = + -- Note there's a bit of an inconsistency here vs the other syntax forms + -- for files. For the single-part syntax the target has to point to a file + -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for + -- all the other forms we don't require that. + syntaxForm1 render $ \str1 fstatus1 -> + expecting "file" str1 $ do + (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) + -- always returns the KnownPackage case + <- matchPackageDirectoryPrefix ps fstatus1 + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents pkgfile + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent _p _c (FileTarget f)) = + [TargetStringFileStatus1 f noFileStatus] + render _ = [] + +--- + +-- | Syntax: :all +-- +-- > cabal build :all +-- +syntaxForm2MetaAll :: Syntax +syntaxForm2MetaAll = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardNamespaceMeta str1 + guardMetaAll str2 + return (TargetAllPackages Nothing) + where + render (TargetAllPackages Nothing) = + [TargetStringFileStatus2 "" noFileStatus "all"] + render _ = [] + +-- | Syntax: all : filer +-- +-- > cabal build all:tests +-- +syntaxForm2AllFilter :: Syntax +syntaxForm2AllFilter = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardMetaAll str1 + kfilter <- matchComponentKindFilter str2 + return (TargetAllPackages (Just kfilter)) + where + render (TargetAllPackages (Just kfilter)) = + [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)] + render _ = [] + +-- | Syntax: package : filer +-- +-- > cabal build foo:tests +-- +syntaxForm2PackageFilter :: [KnownPackage] -> Syntax +syntaxForm2PackageFilter ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + p <- matchPackage ps str1 fstatus1 + kfilter <- matchComponentKindFilter str2 + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)] + render _ = [] + +-- | Syntax: pkg : package name +-- +-- > cabal build pkg:foo +-- +syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax +syntaxForm2NamespacePackage pinfo = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardNamespacePackage str1 + guardPackageName str2 + p <- matchPackage pinfo str2 noFileStatus + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) + where + render (TargetPackage TargetExplicitNamed [p] Nothing) = + [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)] + render _ = [] + +-- | Syntax: package : component +-- +-- > cabal build foo:foo +-- > cabal build ./foo:foo +-- > cabal build ./foo.cabal:foo +-- +syntaxForm2PackageComponent :: [KnownPackage] -> Syntax +syntaxForm2PackageComponent ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + --TODO: the error here ought to say there's no component by that name in + -- this package, and name the package + KnownPackageName pn -> + let cn = mkUnqualComponentName str2 in + return (TargetComponentUnknown pn (Left cn) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] + render (TargetComponentUnknown pn (Left cn) WholeComponent) = + [TargetStringFileStatus2 (dispPN pn) noFileStatus (prettyShow cn)] + render _ = [] + +-- | Syntax: namespace : component +-- +-- > cabal build lib:foo exe:foo +-- +syntaxForm2KindComponent :: [KnownComponent] -> Syntax +syntaxForm2KindComponent cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)] + render _ = [] + +-- | Syntax: package : module +-- +-- > cabal build foo:Data.Foo +-- > cabal build ./foo:Data.Foo +-- > cabal build ./foo.cabal:Data.Foo +-- +syntaxForm2PackageModule :: [KnownPackage] -> Syntax +syntaxForm2PackageModule ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + guardModuleName str2 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str2 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + m <- matchModuleNameUnknown str2 + -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m)) + where + render (TargetComponent p _c (ModuleTarget m)) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] + render _ = [] + +-- | Syntax: component : module +-- +-- > cabal build foo:Data.Foo +-- +syntaxForm2ComponentModule :: [KnownComponent] -> Syntax +syntaxForm2ComponentModule cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (TargetComponent (cinfoPackageId c) (cinfoName c) + (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)] + render _ = [] + +-- | Syntax: package : filename +-- +-- > cabal build foo:Data/Foo.hs +-- > cabal build ./foo:Data/Foo.hs +-- > cabal build ./foo.cabal:Data/Foo.hs +-- +syntaxForm2PackageFile :: [KnownPackage] -> Syntax +syntaxForm2PackageFile ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents str2 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let filepath = str2 in + -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath)) + where + render (TargetComponent p _c (FileTarget f)) = + [TargetStringFileStatus2 (dispP p) noFileStatus f] + render _ = [] + +-- | Syntax: component : filename +-- +-- > cabal build foo:Data/Foo.hs +-- +syntaxForm2ComponentFile :: [KnownComponent] -> Syntax +syntaxForm2ComponentFile cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str2 + return (TargetComponent (cinfoPackageId c) (cinfoName c) + (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus2 (dispC p c) noFileStatus f] + render _ = [] + +--- + +-- | Syntax: :all : filter +-- +-- > cabal build :all:tests +-- +syntaxForm3MetaAllFilter :: Syntax +syntaxForm3MetaAllFilter = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardMetaAll str2 + kfilter <- matchComponentKindFilter str3 + return (TargetAllPackages (Just kfilter)) + where + render (TargetAllPackages (Just kfilter)) = + [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] + render _ = [] + +syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax +syntaxForm3MetaCwdFilter ps = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardNamespaceCwd str2 + kfilter <- matchComponentKindFilter str3 + return (TargetPackage TargetImplicitCwd pids (Just kfilter)) + where + pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] + render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = + [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] + render _ = [] + +-- | Syntax: :pkg : package name +-- +-- > cabal build :pkg:foo +-- +syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax +syntaxForm3MetaNamespacePackage pinfo = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + p <- matchPackage pinfo str3 noFileStatus + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) + where + render (TargetPackage TargetExplicitNamed [p] Nothing) = + [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)] + render _ = [] + +-- | Syntax: package : namespace : component +-- +-- > cabal build foo:lib:foo +-- > cabal build foo/:lib:foo +-- > cabal build foo.cabal:lib:foo +-- +syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax +syntaxForm3PackageKindComponent ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + ckind <- matchComponentKind str2 + guardComponentName str3 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str3 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in + return (TargetComponentUnknown pn (Right cn) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] + render (TargetComponentUnknown pn (Right c) WholeComponent) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)] + render _ = [] + +-- | Syntax: package : component : module +-- +-- > cabal build foo:foo:Data.Foo +-- > cabal build foo/:foo:Data.Foo +-- > cabal build foo.cabal:foo:Data.Foo +-- +syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax +syntaxForm3PackageComponentModule ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + guardModuleName str3 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + let cn = mkUnqualComponentName str2 + m <- matchModuleNameUnknown str3 + return (TargetComponentUnknown pn (Left cn) (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] + render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)] + render _ = [] + +-- | Syntax: namespace : component : module +-- +-- > cabal build lib:foo:Data.Foo +-- +syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax +syntaxForm3KindComponentModule cs = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + guardModuleName str3 + c <- matchComponentKindAndName cs ckind str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent (cinfoPackageId c) (cinfoName c) + (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)] + render _ = [] + +-- | Syntax: package : component : filename +-- +-- > cabal build foo:foo:Data/Foo.hs +-- > cabal build foo/:foo:Data/Foo.hs +-- > cabal build foo.cabal:foo:Data/Foo.hs +-- +syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax +syntaxForm3PackageComponentFile ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + p <- matchPackage ps str1 fstatus1 + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let cn = mkUnqualComponentName str2 + filepath = str3 in + return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] + render (TargetComponentUnknown pn (Left c) (FileTarget f)) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f] + render _ = [] + +-- | Syntax: namespace : component : filename +-- +-- > cabal build lib:foo:Data/Foo.hs +-- +syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax +syntaxForm3KindComponentFile cs = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent (cinfoPackageId c) (cinfoName c) + (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f] + render _ = [] + +syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax +syntaxForm3NamespacePackageFilter ps = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespacePackage str1 + guardPackageName str2 + p <- matchPackage ps str2 noFileStatus + kfilter <- matchComponentKindFilter str3 + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = + [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)] + render _ = [] + +-- + +syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax +syntaxForm4MetaNamespacePackageFilter ps = + syntaxForm4 render $ \str1 str2 str3 str4 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + p <- matchPackage ps str3 noFileStatus + kfilter <- matchComponentKindFilter str4 + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = + [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component +-- +-- > cabal build :pkg:foo:lib:foo +-- +syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax +syntaxForm5MetaNamespacePackageKindComponent ps = + syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + p <- matchPackage ps str3 noFileStatus + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in + return (TargetComponentUnknown pn (Right cn) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] + render (TargetComponentUnknown pn (Right c) WholeComponent) = + [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component : module : module +-- +-- > cabal build :pkg:foo:lib:foo:module:Data.Foo +-- +syntaxForm7MetaNamespacePackageKindComponentNamespaceModule + :: [KnownPackage] -> Syntax +syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = + syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + guardNamespaceModule str6 + p <- matchPackage ps str3 noFileStatus + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str7 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + let cn = mkComponentName pn ckind (mkUnqualComponentName str2) + m <- matchModuleNameUnknown str7 + return (TargetComponentUnknown pn (Right cn) (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus7 "" "pkg" (dispP p) + (dispCK c) (dispC p c) + "module" (dispM m)] + render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) = + [TargetStringFileStatus7 "" "pkg" (dispPN pn) + (dispCK c) (dispC' pn c) + "module" (dispM m)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component : file : filename +-- +-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs +-- +syntaxForm7MetaNamespacePackageKindComponentNamespaceFile + :: [KnownPackage] -> Syntax +syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = + syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + guardNamespaceFile str6 + p <- matchPackage ps str3 noFileStatus + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath,_) <- matchComponentFile [c] str7 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) + filepath = str7 in + return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus7 "" "pkg" (dispP p) + (dispCK c) (dispC p c) + "file" f] + render (TargetComponentUnknown pn (Right c) (FileTarget f)) = + [TargetStringFileStatus7 "" "pkg" (dispPN pn) + (dispCK c) (dispC' pn c) + "file" f] + render _ = [] + + +--------------------------------------- +-- Syntax utils +-- + +type Match1 = String -> FileStatus -> Match TargetSelector +type Match2 = String -> FileStatus -> String + -> Match TargetSelector +type Match3 = String -> FileStatus -> String -> String + -> Match TargetSelector +type Match4 = String -> String -> String -> String + -> Match TargetSelector +type Match5 = String -> String -> String -> String -> String + -> Match TargetSelector +type Match7 = String -> String -> String -> String -> String -> String -> String + -> Match TargetSelector + +syntaxForm1 :: Renderer -> Match1 -> Syntax +syntaxForm2 :: Renderer -> Match2 -> Syntax +syntaxForm3 :: Renderer -> Match3 -> Syntax +syntaxForm4 :: Renderer -> Match4 -> Syntax +syntaxForm5 :: Renderer -> Match5 -> Syntax +syntaxForm7 :: Renderer -> Match7 -> Syntax + +syntaxForm1 render f = + Syntax QL1 match render + where + match = \(TargetStringFileStatus1 str1 fstatus1) -> + f str1 fstatus1 + +syntaxForm2 render f = + Syntax QL2 match render + where + match = \(TargetStringFileStatus2 str1 fstatus1 str2) -> + f str1 fstatus1 str2 + +syntaxForm3 render f = + Syntax QL3 match render + where + match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) -> + f str1 fstatus1 str2 str3 + +syntaxForm4 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus4 str1 str2 str3 str4) + = f str1 str2 str3 str4 + match _ = mzero + +syntaxForm5 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus5 str1 str2 str3 str4 str5) + = f str1 str2 str3 str4 str5 + match _ = mzero + +syntaxForm7 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) + = f str1 str2 str3 str4 str5 str6 str7 + match _ = mzero + +dispP :: Package p => p -> String +dispP = prettyShow . packageName + +dispPN :: PackageName -> String +dispPN = prettyShow + +dispC :: PackageId -> ComponentName -> String +dispC = componentStringName . packageName + +dispC' :: PackageName -> ComponentName -> String +dispC' = componentStringName + +dispCN :: UnqualComponentName -> String +dispCN = prettyShow + +dispK :: ComponentKind -> String +dispK = showComponentKindShort + +dispCK :: ComponentName -> String +dispCK = dispK . componentKind + +dispF :: ComponentKind -> String +dispF = showComponentKindFilterShort + +dispM :: ModuleName -> String +dispM = prettyShow + + +------------------------------- +-- Package and component info +-- + +data KnownTargets = KnownTargets { + knownPackagesAll :: [KnownPackage], + knownPackagesPrimary :: [KnownPackage], + knownPackagesOther :: [KnownPackage], + knownComponentsAll :: [KnownComponent], + knownComponentsPrimary :: [KnownComponent], + knownComponentsOther :: [KnownComponent] + } + deriving Show + +data KnownPackage = + KnownPackage { + pinfoId :: PackageId, + pinfoDirectory :: Maybe (FilePath, FilePath), + pinfoPackageFile :: Maybe (FilePath, FilePath), + pinfoComponents :: [KnownComponent] + } + | KnownPackageName { + pinfoName :: PackageName + } + deriving Show + +data KnownComponent = KnownComponent { + cinfoName :: ComponentName, + cinfoStrName :: ComponentStringName, + cinfoPackageId :: PackageId, + cinfoSrcDirs :: [FilePath], + cinfoModules :: [ModuleName], + cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoCFiles :: [FilePath], + cinfoJsFiles :: [FilePath] + } + deriving Show + +type ComponentStringName = String + +knownPackageName :: KnownPackage -> PackageName +knownPackageName KnownPackage{pinfoId} = packageName pinfoId +knownPackageName KnownPackageName{pinfoName} = pinfoName + +emptyKnownTargets :: KnownTargets +emptyKnownTargets = KnownTargets [] [] [] [] [] [] + +getKnownTargets :: (Applicative m, Monad m) + => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> m KnownTargets +getKnownTargets dirActions@DirActions{..} pkgs = do + pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs + cwd <- getCurrentDirectory + let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo + return KnownTargets { + knownPackagesAll = pinfo, + knownPackagesPrimary = ppinfo, + knownPackagesOther = opinfo, + knownComponentsAll = allComponentsIn pinfo, + knownComponentsPrimary = allComponentsIn ppinfo, + knownComponentsOther = allComponentsIn opinfo + } + where + selectPrimaryPackage :: FilePath + -> [KnownPackage] + -> ([KnownPackage], [KnownPackage]) + selectPrimaryPackage cwd = partition isPkgDirCwd + where + isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) } + | dir == cwd = True + isPkgDirCwd _ = False + allComponentsIn ps = + [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] + + +collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m + -> PackageSpecifier (SourcePackage (PackageLocation a)) + -> m KnownPackage +collectKnownPackageInfo _ (NamedPackage pkgname _props) = + return (KnownPackageName pkgname) +collectKnownPackageInfo dirActions@DirActions{..} + (SpecificSourcePackage SourcePackage { + srcpkgDescription = pkg, + srcpkgSource = loc + }) = do + (pkgdir, pkgfile) <- + case loc of + --TODO: local tarballs, remote tarballs etc + LocalUnpackedPackage dir -> do + dirabs <- canonicalizePath dir + dirrel <- makeRelativeToCwd dirActions dirabs + --TODO: ought to get this earlier in project reading + let fileabs = dirabs prettyShow (packageName pkg) <.> "cabal" + filerel = dirrel prettyShow (packageName pkg) <.> "cabal" + exists <- doesFileExist fileabs + return ( Just (dirabs, dirrel) + , if exists then Just (fileabs, filerel) else Nothing + ) + _ -> return (Nothing, Nothing) + let pinfo = + KnownPackage { + pinfoId = packageId pkg, + pinfoDirectory = pkgdir, + pinfoPackageFile = pkgfile, + pinfoComponents = collectKnownComponentInfo + (flattenPackageDescription pkg) + } + return pinfo + + +collectKnownComponentInfo :: PackageDescription -> [KnownComponent] +collectKnownComponentInfo pkg = + [ KnownComponent { + cinfoName = componentName c, + cinfoStrName = componentStringName (packageName pkg) (componentName c), + cinfoPackageId = packageId pkg, + cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi)), + cinfoModules = ordNub (componentModules c), + cinfoHsFiles = ordNub (componentHsFiles c), + cinfoCFiles = ordNub (cSources bi), + cinfoJsFiles = ordNub (jsSources bi) + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c ] + + +componentStringName :: PackageName -> ComponentName -> ComponentStringName +componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname +componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name + +componentModules :: Component -> [ModuleName] +-- I think it's unlikely users will ask to build a requirement +-- which is not mentioned locally. +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [FilePath] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles (CTest TestSuite { + testInterface = TestSuiteExeV10 _ mainfile + }) = [mainfile] +componentHsFiles (CBench Benchmark { + benchmarkInterface = BenchmarkExeV10 _ mainfile + }) = [mainfile] +componentHsFiles _ = [] + + +------------------------------ +-- Matching meta targets +-- + +guardNamespaceMeta :: String -> Match () +guardNamespaceMeta = guardToken [""] "meta namespace" + +guardMetaAll :: String -> Match () +guardMetaAll = guardToken ["all"] "meta-target 'all'" + +guardNamespacePackage :: String -> Match () +guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace" + +guardNamespaceCwd :: String -> Match () +guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace" + +guardNamespaceModule :: String -> Match () +guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace" + +guardNamespaceFile :: String -> Match () +guardNamespaceFile = guardToken ["file"] "'file' namespace" + +guardToken :: [String] -> String -> String -> Match () +guardToken tokens msg s + | caseFold s `elem` tokens = increaseConfidence + | otherwise = matchErrorExpected msg s + + +------------------------------ +-- Matching component kinds +-- + +componentKind :: ComponentName -> ComponentKind +componentKind (CLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: KnownComponent -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` benchlabels = increaseConfidence >> return BenchKind + | otherwise = matchErrorExpected "component kind" s + where + s' = caseFold s + liblabels = ["lib", "library"] + fliblabels = ["flib", "foreign-library"] + exelabels = ["exe", "executable"] + testlabels = ["tst", "test", "test-suite"] + benchlabels = ["bench", "benchmark"] + +matchComponentKindFilter :: String -> Match ComponentKind +matchComponentKindFilter s + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` benchlabels = increaseConfidence >> return BenchKind + | otherwise = matchErrorExpected "component kind filter" s + where + s' = caseFold s + liblabels = ["libs", "libraries"] + fliblabels = ["flibs", "foreign-libraries"] + exelabels = ["exes", "executables"] + testlabels = ["tests", "test-suites"] + benchlabels = ["benches", "benchmarks"] + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +showComponentKindFilterShort :: ComponentKind -> String +showComponentKindFilterShort LibKind = "libs" +showComponentKindFilterShort FLibKind = "flibs" +showComponentKindFilterShort ExeKind = "exes" +showComponentKindFilterShort TestKind = "tests" +showComponentKindFilterShort BenchKind = "benchmarks" + + +------------------------------ +-- Matching package targets +-- + +guardPackage :: String -> FileStatus -> Match () +guardPackage str fstatus = + guardPackageName str + <|> guardPackageDir str fstatus + <|> guardPackageFile str fstatus + + +guardPackageName :: String -> Match () +guardPackageName s + | validPackageName s = increaseConfidence + | otherwise = matchErrorExpected "package name" s + +validPackageName :: String -> Bool +validPackageName s = + all validPackageNameChar s + && not (null s) + where + validPackageNameChar c = isAlphaNum c || c == '-' + + +guardPackageDir :: String -> FileStatus -> Match () +guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence +guardPackageDir str _ = matchErrorExpected "package directory" str + + +guardPackageFile :: String -> FileStatus -> Match () +guardPackageFile _ (FileStatusExistsFile file) + | takeExtension file == ".cabal" + = increaseConfidence +guardPackageFile str _ = matchErrorExpected "package .cabal file" str + + +matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage +matchPackage pinfo = \str fstatus -> + orNoThingIn "project" "" $ + matchPackageName pinfo str + (matchPackageNameUnknown str + <|> matchPackageDir pinfo str fstatus + <|> matchPackageFile pinfo str fstatus) + + +matchPackageName :: [KnownPackage] -> String -> Match KnownPackage +matchPackageName ps = \str -> do + guard (validPackageName str) + orNoSuchThing "package" str + (map (prettyShow . knownPackageName) ps) $ + increaseConfidenceFor $ + matchInexactly caseFold (prettyShow . knownPackageName) ps str + + +matchPackageNameUnknown :: String -> Match KnownPackage +matchPackageNameUnknown str = do + pn <- matchParse str + unknownMatch (KnownPackageName pn) + + +matchPackageDir :: [KnownPackage] + -> String -> FileStatus -> Match KnownPackage +matchPackageDir ps = \str fstatus -> + case fstatus of + FileStatusExistsDir canondir -> + orNoSuchThing "package directory" str (map (snd . fst) dirs) $ + increaseConfidenceFor $ + fmap snd $ matchExactly (fst . fst) dirs canondir + _ -> mzero + where + dirs = [ ((dabs,drel),p) + | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ] + + +matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage +matchPackageFile ps = \str fstatus -> do + case fstatus of + FileStatusExistsFile canonfile -> + orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ + increaseConfidenceFor $ + fmap snd $ matchExactly (fst . fst) files canonfile + _ -> mzero + where + files = [ ((fabs,frel),p) + | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ] + +--TODO: test outcome when dir exists but doesn't match any known one + +--TODO: perhaps need another distinction, vs no such thing, point is the +-- thing is not known, within the project, but could be outside project + + +------------------------------ +-- Matching component targets +-- + + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = isAlphaNum c || c == '.' + || c == '_' || c == '-' || c == '\'' + + +matchComponentName :: [KnownComponent] -> String -> Match KnownComponent +matchComponentName cs str = + orNoSuchThing "component" str (map cinfoStrName cs) + $ increaseConfidenceFor + $ matchInexactly caseFold cinfoStrName cs str + + +matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String + -> Match KnownComponent +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str + (map render cs) + $ increaseConfidenceFor + $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) + (\c -> (cinfoKind c, cinfoStrName c)) + cs + (ckind, str) + where + render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c + + +------------------------------ +-- Matching module targets +-- + +guardModuleName :: String -> Match () +guardModuleName s = + case simpleParsec s :: Maybe ModuleName of + Just _ -> increaseConfidence + _ | all validModuleChar s + && not (null s) -> return () + | otherwise -> matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str (map prettyShow ms) + $ increaseConfidenceFor + $ matchInexactly caseFold prettyShow ms str + + +matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) +matchModuleNameAnd ms str = + orNoSuchThing "module" str (map (prettyShow . fst) ms) + $ increaseConfidenceFor + $ matchInexactly caseFold (prettyShow . fst) ms str + + +matchModuleNameUnknown :: String -> Match ModuleName +matchModuleNameUnknown str = + expecting "module" str + $ increaseConfidenceFor + $ matchParse str + + +------------------------------ +-- Matching file targets +-- + +matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus + -> Match (FilePath, KnownPackage) +matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = + increaseConfidenceFor $ + matchDirectoryPrefix pkgdirs filepath + where + pkgdirs = [ (dir, p) + | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] +matchPackageDirectoryPrefix _ _ = mzero + + +matchComponentFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) +matchComponentFile cs str = + orNoSuchThing "file" str [] $ + matchComponentModuleFile cs str + <|> matchComponentOtherFile cs str + + +matchComponentOtherFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) +matchComponentOtherFile cs = + matchFile + [ (normalise (srcdir file), c) + | c <- cs + , srcdir <- cinfoSrcDirs c + , file <- cinfoHsFiles c + ++ cinfoCFiles c + ++ cinfoJsFiles c + ] + . normalise + + +matchComponentModuleFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) +matchComponentModuleFile cs str = do + matchFile + [ (normalise (d toFilePath m), c) + | c <- cs + , d <- cinfoSrcDirs c + , m <- cinfoModules c + ] + (dropExtension (normalise str)) -- Drop the extension because FileTarget + -- is stored without the extension + +-- utils + +matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) +matchFile fs = + increaseConfidenceFor + . matchInexactly caseFold fst fs + +matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) +matchDirectoryPrefix dirs filepath = + tryEach $ + [ (file, x) + | (dir,x) <- dirs + , file <- maybeToList (stripDirectory dir) ] + where + stripDirectory :: FilePath -> Maybe FilePath + stripDirectory dir = + joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit + + filepathsplit = splitDirectories filepath + + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we +-- can run a matcher against an input using 'findMatch'. +-- +data Match a = NoMatch !Confidence [MatchError] + | Match !MatchClass !Confidence [a] + deriving Show + +-- | The kind of match, inexact or exact. We keep track of this so we can +-- prefer exact over inexact matches. The 'Ord' here is important: we try +-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. +-- +data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package + -- name without it being a specific known package + | Inexact -- ^ Matches a known thing inexactly + -- e.g. matches a known package case insensitively + | Exact -- ^ Exactly matches a known thing, + -- e.g. matches a known package case sensitively + deriving (Show, Eq, Ord) + +type Confidence = Int + +data MatchError = MatchErrorExpected String String -- thing got + | MatchErrorNoSuch String String [String] -- thing got alts + | MatchErrorIn String String MatchError -- kind thing + deriving (Show, Eq) + + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (Match m d xs) = Match m d (fmap f xs) + +instance Applicative Match where + pure a = Match Exact 0 [a] + (<*>) = ap + +instance Alternative Match where + empty = NoMatch 0 [] + (<|>) = matchPlus + +instance Monad Match where + return = pure + NoMatch d ms >>= _ = NoMatch d ms + Match m d xs >>= f = + -- To understand this, it needs to be read in context with the + -- implementation of 'matchPlus' below + case msum (map f xs) of + Match m' d' xs' -> Match (min m m') (d + d') xs' + -- The minimum match class is the one we keep. The match depth is + -- tracked but not used in the Match case. + + NoMatch d' ms -> NoMatch (d + d') ms + -- Here is where we transfer the depth we were keeping track of in + -- the Match case over to the NoMatch case where it finally gets used. + +instance MonadPlus Match where + mzero = empty + mplus = matchPlus + +() :: Match a -> Match a -> Match a +() = matchPlusShadowing + +infixl 3 + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +-- +-- This operator is associative, has unit 'mzero' and is also commutative. +-- +matchPlus :: Match a -> Match a -> Match a +matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a +matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b +matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b) + | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. + | d_a < d_b = b + | otherwise = NoMatch d_a (ms_a ++ ms_b) +matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) + | m_a > m_b = a -- exact over inexact + | m_a < m_b = b -- exact over inexact + | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b) + +-- | Combine two matchers. This is similar to 'matchPlus' with the +-- difference that an exact match from the left matcher shadows any exact +-- match on the right. Inexact matches are still collected however. +-- +-- This operator is associative, has unit 'mzero' and is not commutative. +-- +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(Match Exact _ _) _ = a +matchPlusShadowing a b = matchPlus a b + + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] + +matchErrorNoSuch :: String -> String -> [String] -> Match a +matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> [String] -> Match a -> Match a +orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts +orNoSuchThing _ _ _ m = m + +orNoThingIn :: String -> String -> Match a -> Match a +orNoThingIn kind name (NoMatch n ms) = + NoMatch n [ MatchErrorIn kind name m | m <- ms ] +orNoThingIn _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = Match Exact 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a +nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs +nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) + +-- | Lift a list of matches to an exact match. +-- +exactMatches, inexactMatches :: [a] -> Match a + +exactMatches [] = mzero +exactMatches xs = Match Exact 0 xs + +inexactMatches [] = mzero +inexactMatches xs = Match Inexact 0 xs + +unknownMatch :: a -> Match a +unknownMatch x = Match Unknown 0 [x] + +tryEach :: [a] -> Match a +tryEach = exactMatches + + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +-- +findMatch :: Match a -> MaybeAmbiguous a +findMatch match = case match of + NoMatch _ msgs -> None msgs + Match _ _ [x] -> Unambiguous x + Match m d [] -> error $ "findMatch: impossible: " ++ show match' + where match' = Match m d [] :: Match () + -- TODO: Maybe use Data.List.NonEmpty inside + -- Match so that this case would be correct + -- by construction? + Match m _ xs -> Ambiguous m xs + +data MaybeAmbiguous a = None [MatchError] + | Unambiguous a + | Ambiguous MatchClass [a] + deriving Show + + +------------------------------ +-- Basic matchers +-- + +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) +matchExactly key xs = + \k -> case Map.lookup k m of + Nothing -> mzero + Just ys -> exactMatches ys + where + m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +-- +matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) + -> [a] -> (k -> Match a) +matchInexactly cannonicalise key xs = + \k -> case Map.lookup k m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise k) m' of + Just ys -> inexactMatches ys + Nothing -> mzero + where + m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + +matchParse :: Parsec a => String -> Match a +matchParse = maybe mzero return . simpleParsec + + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase + +-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the +-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's +-- primary library from named private libraries. +-- +mkComponentName :: PackageName + -> ComponentKind + -> UnqualComponentName + -> ComponentName +mkComponentName pkgname ckind ucname = + case ckind of + LibKind + | packageNameToUnqualComponentName pkgname == ucname + -> CLibName LMainLibName + | otherwise -> CLibName $ LSubLibName ucname + FLibKind -> CFLibName ucname + ExeKind -> CExeName ucname + TestKind -> CTestName ucname + BenchKind -> CBenchName ucname + + +------------------------------ +-- Example inputs +-- + +{- +ex1pinfo :: [KnownPackage] +ex1pinfo = + [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ + KnownPackage { + pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), + pinfoDirectory = Just ("/the/foo", "foo"), + pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), + pinfoComponents = [] + } + , KnownPackage { + pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), + pinfoDirectory = Just ("/the/bar", "bar"), + pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), + pinfoComponents = [] + } + ] + where + addComponent n ds ms p = + p { + pinfoComponents = + KnownComponent n (componentStringName (pinfoId p) n) + p ds (map mkMn ms) + [] [] [] + : pinfoComponents p + } + + mkMn :: String -> ModuleName + mkMn = ModuleName.fromString +-} +{- +stargets = + [ TargetComponent (CExeName "foo") WholeComponent + , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo")) + , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo")) + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +{- +ex_cs :: [KnownComponent] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} diff --git a/src/Distribution/Client/Targets.hs b/src/Distribution/Client/Targets.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Targets.hs @@ -0,0 +1,746 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Targets +-- Copyright : (c) Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified targets +----------------------------------------------------------------------------- +module Distribution.Client.Targets ( + -- * User targets + UserTarget(..), + readUserTargets, + + -- * Resolving user targets to package specifiers + resolveUserTargets, + + -- ** Detailed interface + UserTargetProblem(..), + readUserTarget, + reportUserTargetProblems, + expandUserTarget, + + PackageTarget(..), + fetchPackageTarget, + readPackageTarget, + + PackageTargetProblem(..), + reportPackageTargetProblems, + + disambiguatePackageTargets, + disambiguatePackageName, + + -- * User constraints + UserQualifier(..), + UserConstraintScope(..), + UserConstraint(..), + userConstraintPackageName, + readUserConstraint, + userToPackageConstraint, + + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Package + ( Package(..), PackageName, unPackageName, mkPackageName + , packageName ) +import Distribution.Types.Dependency +import Distribution.Client.Types + ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage + , PackageSpecifier(..) ) + +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackageIndex (PackageIndex) +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + +import qualified Distribution.Client.World as World +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.FetchUtils +import Distribution.Client.Utils ( tryFindPackageDesc ) +import Distribution.Client.GlobalFlags + ( RepoContext(..) ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint (..) ) + +import Distribution.PackageDescription + ( GenericPackageDescription ) +import Distribution.Types.Flag + ( nullFlagAssignment, parsecFlagAssignmentNonEmpty ) +import Distribution.Version + ( anyVersion, isAnyVersion ) +import Distribution.Simple.Utils + ( die', warn, lowercase ) + +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) + +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS +import qualified Distribution.Client.GZipUtils as GZipUtils +import qualified Distribution.Compat.CharParsing as P +import System.FilePath + ( takeExtension, dropExtension, takeDirectory, splitPath ) +import System.Directory + ( doesFileExist, doesDirectoryExist ) +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI ) + +-- ------------------------------------------------------------ +-- * User targets +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a package or package collection. +-- +data UserTarget = + + -- | A partially specified package, identified by name and possibly with + -- an exact version or a version constraint. + -- + -- > cabal install foo + -- > cabal install foo-1.0 + -- > cabal install 'foo < 2' + -- + UserTargetNamed PackageVersionConstraint + + -- | A special virtual package that refers to the collection of packages + -- recorded in the world file that the user specifically installed. + -- + -- > cabal install world + -- + | UserTargetWorld + + -- | A specific package that is unpacked in a local directory, often the + -- current directory. + -- + -- > cabal install . + -- > cabal install ../lib/other + -- + -- * Note: in future, if multiple @.cabal@ files are allowed in a single + -- directory then this will refer to the collection of packages. + -- + | UserTargetLocalDir FilePath + + -- | A specific local unpacked package, identified by its @.cabal@ file. + -- + -- > cabal install foo.cabal + -- > cabal install ../lib/other/bar.cabal + -- + | UserTargetLocalCabalFile FilePath + + -- | A specific package that is available as a local tarball file + -- + -- > cabal install dist/foo-1.0.tar.gz + -- > cabal install ../build/baz-1.0.tar.gz + -- + | UserTargetLocalTarball FilePath + + -- | A specific package that is available as a remote tarball file + -- + -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz + -- + | UserTargetRemoteTarball URI + deriving (Show,Eq) + + +-- ------------------------------------------------------------ +-- * Parsing and checking user targets +-- ------------------------------------------------------------ + +readUserTargets :: Verbosity -> [String] -> IO [UserTarget] +readUserTargets verbosity targetStrs = do + (problems, targets) <- liftM partitionEithers + (traverse readUserTarget targetStrs) + reportUserTargetProblems verbosity problems + return targets + + +data UserTargetProblem + = UserTargetUnexpectedFile String + | UserTargetNonexistantFile String + | UserTargetUnexpectedUriScheme String + | UserTargetUnrecognisedUri String + | UserTargetUnrecognised String + | UserTargetBadWorldPkg + deriving Show + +readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) +readUserTarget targetstr = + case eitherParsec targetstr of + Right (PackageVersionConstraint pkgn verrange) + | pkgn == mkPackageName "world" + -> return $ if verrange == anyVersion + then Right UserTargetWorld + else Left UserTargetBadWorldPkg + Right dep -> return (Right (UserTargetNamed dep)) + Left _err -> do + fileTarget <- testFileTargets targetstr + case fileTarget of + Just target -> return target + Nothing -> + case testUriTargets targetstr of + Just target -> return target + Nothing -> return (Left (UserTargetUnrecognised targetstr)) + where + testFileTargets filename = do + isDir <- doesDirectoryExist filename + isFile <- doesFileExist filename + parentDirExists <- case takeDirectory filename of + [] -> return False + dir -> doesDirectoryExist dir + let result + | isDir + = Just (Right (UserTargetLocalDir filename)) + + | isFile && extensionIsTarGz filename + = Just (Right (UserTargetLocalTarball filename)) + + | isFile && takeExtension filename == ".cabal" + = Just (Right (UserTargetLocalCabalFile filename)) + + | isFile + = Just (Left (UserTargetUnexpectedFile filename)) + + | parentDirExists + = Just (Left (UserTargetNonexistantFile filename)) + + | otherwise + = Nothing + return result + + testUriTargets str = + case parseAbsoluteURI str of + Just uri@URI { + uriScheme = scheme, + uriAuthority = Just URIAuth { uriRegName = host } + } + | scheme /= "http:" && scheme /= "https:" -> + Just (Left (UserTargetUnexpectedUriScheme targetstr)) + + | null host -> + Just (Left (UserTargetUnrecognisedUri targetstr)) + + | otherwise -> + Just (Right (UserTargetRemoteTarball uri)) + _ -> Nothing + + extensionIsTarGz f = takeExtension f == ".gz" + && takeExtension (dropExtension f) == ".tar" + +reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () +reportUserTargetProblems verbosity problems = do + case [ target | UserTargetUnrecognised target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "Unrecognised target '" ++ name ++ "'." + | name <- target ] + ++ "Targets can be:\n" + ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" + ++ " - the special 'world' target\n" + ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" + ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" + + case [ () | UserTargetBadWorldPkg <- problems ] of + [] -> return () + _ -> die' verbosity "The special 'world' target does not take any version." + + case [ target | UserTargetNonexistantFile target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "The file does not exist '" ++ name ++ "'." + | name <- target ] + + case [ target | UserTargetUnexpectedFile target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "Unrecognised file target '" ++ name ++ "'." + | name <- target ] + ++ "File targets can be either package tarballs 'pkgname.tar.gz' " + ++ "or cabal files 'pkgname.cabal'." + + case [ target | UserTargetUnexpectedUriScheme target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "URL target not supported '" ++ name ++ "'." + | name <- target ] + ++ "Only 'http://' and 'https://' URLs are supported." + + case [ target | UserTargetUnrecognisedUri target <- problems ] of + [] -> return () + target -> die' verbosity + $ unlines + [ "Unrecognise URL target '" ++ name ++ "'." + | name <- target ] + + +-- ------------------------------------------------------------ +-- * Resolving user targets to package specifiers +-- ------------------------------------------------------------ + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. They can either be specific packages (local dirs, tarballs etc) +-- or they can be named packages (with or without version info). +-- +resolveUserTargets :: Package pkg + => Verbosity + -> RepoContext + -> FilePath + -> PackageIndex pkg + -> [UserTarget] + -> IO [PackageSpecifier UnresolvedSourcePackage] +resolveUserTargets verbosity repoCtxt worldFile available userTargets = do + + -- given the user targets, get a list of fully or partially resolved + -- package references + packageTargets <- traverse (readPackageTarget verbosity) + =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat + =<< traverse (expandUserTarget verbosity worldFile) userTargets + + -- users are allowed to give package names case-insensitively, so we must + -- disambiguate named package references + let (problems, packageSpecifiers) = + disambiguatePackageTargets available availableExtra packageTargets + + -- use any extra specific available packages to help us disambiguate + availableExtra = [ packageName pkg + | PackageTargetLocation pkg <- packageTargets ] + + reportPackageTargetProblems verbosity problems + + return packageSpecifiers + + +-- ------------------------------------------------------------ +-- * Package targets +-- ------------------------------------------------------------ + +-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. +-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. +-- +data PackageTarget pkg = + PackageTargetNamed PackageName [PackageProperty] UserTarget + + -- | A package identified by name, but case insensitively, so it needs + -- to be resolved to the right case-sensitive name. + | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget + | PackageTargetLocation pkg + deriving (Show, Functor, Foldable, Traversable) + + +-- ------------------------------------------------------------ +-- * Converting user targets to package targets +-- ------------------------------------------------------------ + +-- | Given a user-specified target, expand it to a bunch of package targets +-- (each of which refers to only one package). +-- +expandUserTarget :: Verbosity + -> FilePath + -> UserTarget + -> IO [PackageTarget (PackageLocation ())] +expandUserTarget verbosity worldFile userTarget = case userTarget of + + UserTargetNamed (PackageVersionConstraint name vrange) -> + let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + in return [PackageTargetNamedFuzzy name props userTarget] + + UserTargetWorld -> do + worldPkgs <- World.getContents verbosity worldFile + --TODO: should we warn if there are no world targets? + return [ PackageTargetNamed name props userTarget + | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs + , let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + ++ [ PackagePropertyFlags flags + | not (nullFlagAssignment flags) ] ] + + UserTargetLocalDir dir -> + return [ PackageTargetLocation (LocalUnpackedPackage dir) ] + + UserTargetLocalCabalFile file -> do + let dir = takeDirectory file + _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check + return [ PackageTargetLocation (LocalUnpackedPackage dir) ] + + UserTargetLocalTarball tarballFile -> + return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] + + UserTargetRemoteTarball tarballURL -> + return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] + +localPackageError :: FilePath -> String +localPackageError dir = + "Error reading local package.\nCouldn't find .cabal file in: " ++ dir + +-- ------------------------------------------------------------ +-- * Fetching and reading package targets +-- ------------------------------------------------------------ + + +-- | Fetch any remote targets so that they can be read. +-- +fetchPackageTarget :: Verbosity + -> RepoContext + -> PackageTarget (PackageLocation ()) + -> IO (PackageTarget ResolvedPkgLoc) +fetchPackageTarget verbosity repoCtxt = traverse $ + fetchPackage verbosity repoCtxt . fmap (const Nothing) + + +-- | Given a package target that has been fetched, read the .cabal file. +-- +-- This only affects targets given by location, named targets are unaffected. +-- +readPackageTarget :: Verbosity + -> PackageTarget ResolvedPkgLoc + -> IO (PackageTarget UnresolvedSourcePackage) +readPackageTarget verbosity = traverse modifyLocation + where + modifyLocation location = case location of + + LocalUnpackedPackage dir -> do + pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= + readGenericPackageDescription verbosity + return SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location + , srcpkgDescrOverride = Nothing + } + + LocalTarballPackage tarballFile -> + readTarballPackageTarget location tarballFile tarballFile + + RemoteTarballPackage tarballURL tarballFile -> + readTarballPackageTarget location tarballFile (show tarballURL) + + RepoTarballPackage _repo _pkgid _ -> + error "TODO: readPackageTarget RepoTarballPackage" + -- For repo tarballs this info should be obtained from the index. + + RemoteSourceRepoPackage _srcRepo _ -> + error "TODO: readPackageTarget RemoteSourceRepoPackage" + -- This can't happen, because it would have errored out already + -- in fetchPackage, via fetchPackageTarget before it gets to this + -- function. + -- + -- When that is corrected, this will also need to be fixed. + + readTarballPackageTarget location tarballFile tarballOriginalLoc = do + (filename, content) <- extractTarballPackageCabalFile + tarballFile tarballOriginalLoc + case parsePackageDescription' content of + Nothing -> die' verbosity $ "Could not parse the cabal file " + ++ filename ++ " in " ++ tarballFile + Just pkg -> + return SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location + , srcpkgDescrOverride = Nothing + } + + extractTarballPackageCabalFile :: FilePath -> String + -> IO (FilePath, BS.ByteString) + extractTarballPackageCabalFile tarballFile tarballOriginalLoc = + either (die' verbosity . formatErr) return + . check + . accumEntryMap + . Tar.filterEntries isCabalFile + . Tar.read + . GZipUtils.maybeDecompress + =<< BS.readFile tarballFile + where + formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg + + accumEntryMap = Tar.foldlEntries + (\m e -> Map.insert (Tar.entryTarPath e) e m) + Map.empty + + check (Left e) = Left (show e) + check (Right m) = case Map.elems m of + [] -> Left noCabalFile + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left noCabalFile + _files -> Left multipleCabalFiles + where + noCabalFile = "No cabal file found" + multipleCabalFiles = "Multiple cabal files found" + + isCabalFile e = case splitPath (Tar.entryPath e) of + [ _dir, file] -> takeExtension file == ".cabal" + [".", _dir, file] -> takeExtension file == ".cabal" + _ -> False + + parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription + parsePackageDescription' bs = + parseGenericPackageDescriptionMaybe (BS.toStrict bs) + +-- ------------------------------------------------------------ +-- * Checking package targets +-- ------------------------------------------------------------ + +data PackageTargetProblem + = PackageNameUnknown PackageName UserTarget + | PackageNameAmbiguous PackageName [PackageName] UserTarget + deriving Show + + +-- | Users are allowed to give package names case-insensitively, so we must +-- disambiguate named package references. +-- +disambiguatePackageTargets :: Package pkg' + => PackageIndex pkg' + -> [PackageName] + -> [PackageTarget pkg] + -> ( [PackageTargetProblem] + , [PackageSpecifier pkg] ) +disambiguatePackageTargets availablePkgIndex availableExtra targets = + partitionEithers (map disambiguatePackageTarget targets) + where + disambiguatePackageTarget packageTarget = case packageTarget of + PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) + + PackageTargetNamed pkgname props userTarget + | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) + -> Left (PackageNameUnknown pkgname userTarget) + | otherwise -> Right (NamedPackage pkgname props) + + PackageTargetNamedFuzzy pkgname props userTarget -> + case disambiguatePackageName packageNameEnv pkgname of + None -> Left (PackageNameUnknown + pkgname userTarget) + Ambiguous pkgnames -> Left (PackageNameAmbiguous + pkgname pkgnames userTarget) + Unambiguous pkgname' -> Right (NamedPackage pkgname' props) + + -- use any extra specific available packages to help us disambiguate + packageNameEnv :: PackageNameEnv + packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) + (extraPackageNameEnv availableExtra) + + +-- | Report problems to the user. That is, if there are any problems +-- then raise an exception. +reportPackageTargetProblems :: Verbosity + -> [PackageTargetProblem] -> IO () +reportPackageTargetProblems verbosity problems = do + case [ pkg | PackageNameUnknown pkg originalTarget <- problems + , not (isUserTagetWorld originalTarget) ] of + [] -> return () + pkgs -> die' verbosity $ unlines + [ "There is no package named '" ++ prettyShow name ++ "'. " + | name <- pkgs ] + ++ "You may need to run 'cabal update' to get the latest " + ++ "list of available packages." + + case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of + [] -> return () + ambiguities -> die' verbosity $ unlines + [ "There is no package named '" ++ prettyShow name ++ "'. " + ++ (if length matches > 1 + then "However, the following package names exist: " + else "However, the following package name exists: ") + ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches] + ++ "." + | (name, matches) <- ambiguities ] + + case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of + [] -> return () + pkgs -> warn verbosity $ + "The following 'world' packages will be ignored because " + ++ "they refer to packages that cannot be found: " + ++ intercalate ", " (map prettyShow pkgs) ++ "\n" + ++ "You can suppress this warning by correcting the world file." + where + isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False + + +-- ------------------------------------------------------------ +-- * Disambiguating package names +-- ------------------------------------------------------------ + +data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] + +-- | Given a package name and a list of matching names, figure out +-- which one it might be referring to. If there is an exact +-- case-sensitive match then that's ok (i.e. returned via +-- 'Unambiguous'). If it matches just one package case-insensitively +-- or if it matches multiple packages case-insensitively, in that case +-- the result is 'Ambiguous'. +-- +-- Note: Before cabal 2.2, when only a single package matched +-- case-insensitively it would be considered 'Unambigious'. +-- +disambiguatePackageName :: PackageNameEnv + -> PackageName + -> MaybeAmbiguous PackageName +disambiguatePackageName (PackageNameEnv pkgNameLookup) name = + case nub (pkgNameLookup name) of + [] -> None + names -> case find (name==) names of + Just name' -> Unambiguous name' + Nothing -> Ambiguous names + + +newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) + +instance Monoid PackageNameEnv where + mempty = PackageNameEnv (const []) + mappend = (<>) + +instance Semigroup PackageNameEnv where + PackageNameEnv lookupA <> PackageNameEnv lookupB = + PackageNameEnv (\name -> lookupA name ++ lookupB name) + +indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv +indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup + where + pkgNameLookup pname = + map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname) + +extraPackageNameEnv :: [PackageName] -> PackageNameEnv +extraPackageNameEnv names = PackageNameEnv pkgNameLookup + where + pkgNameLookup pname = + [ pname' + | let lname = lowercase (unPackageName pname) + , pname' <- names + , lowercase (unPackageName pname') == lname ] + + +-- ------------------------------------------------------------ +-- * Package constraints +-- ------------------------------------------------------------ + +-- | Version of 'Qualifier' that a user may specify on the +-- command line. +data UserQualifier = + -- | Top-level dependency. + UserQualToplevel + + -- | Setup dependency. + | UserQualSetup PackageName + + -- | Executable dependency. + | UserQualExe PackageName PackageName + deriving (Eq, Show, Generic) + +instance Binary UserQualifier +instance Structured UserQualifier + +-- | Version of 'ConstraintScope' that a user may specify on the +-- command line. +data UserConstraintScope = + -- | Scope that applies to the package when it has the specified qualifier. + UserQualified UserQualifier PackageName + + -- | Scope that applies to the package when it has a setup qualifier. + | UserAnySetupQualifier PackageName + + -- | Scope that applies to the package when it has any qualifier. + | UserAnyQualifier PackageName + deriving (Eq, Show, Generic) + +instance Binary UserConstraintScope +instance Structured UserConstraintScope + +fromUserQualifier :: UserQualifier -> Qualifier +fromUserQualifier UserQualToplevel = QualToplevel +fromUserQualifier (UserQualSetup name) = QualSetup name +fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 + +fromUserConstraintScope :: UserConstraintScope -> ConstraintScope +fromUserConstraintScope (UserQualified q pn) = + ScopeQualified (fromUserQualifier q) pn +fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn +fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn + +-- | Version of 'PackageConstraint' that the user can specify on +-- the command line. +data UserConstraint = + UserConstraint UserConstraintScope PackageProperty + deriving (Eq, Show, Generic) + +instance Binary UserConstraint +instance Structured UserConstraint + +userConstraintPackageName :: UserConstraint -> PackageName +userConstraintPackageName (UserConstraint scope _) = scopePN scope + where + scopePN (UserQualified _ pn) = pn + scopePN (UserAnyQualifier pn) = pn + scopePN (UserAnySetupQualifier pn) = pn + +userToPackageConstraint :: UserConstraint -> PackageConstraint +userToPackageConstraint (UserConstraint scope prop) = + PackageConstraint (fromUserConstraintScope scope) prop + +readUserConstraint :: String -> Either String UserConstraint +readUserConstraint str = + case explicitEitherParsec parsec str of + Left err -> Left $ msgCannotParse ++ err + Right c -> Right c + where + msgCannotParse = + "expected a (possibly qualified) package name followed by a " ++ + "constraint, which is either a version range, 'installed', " ++ + "'source', 'test', 'bench', or flags. " + +instance Pretty UserConstraint where + pretty (UserConstraint scope prop) = + dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop + +instance Parsec UserConstraint where + parsec = do + scope <- parseConstraintScope + P.spaces + prop <- P.choice + [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-" + , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be) + , PackagePropertyInstalled <$ P.string "installed" + , PackagePropertySource <$ P.string "source" + , PackagePropertyStanzas [TestStanzas] <$ P.string "test" + , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" + ] + return (UserConstraint scope prop) + + where + parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope + parseConstraintScope = do + pn <- parsec + P.choice + [ P.char '.' *> withDot pn + , P.char ':' *> withColon pn + , return (UserQualified UserQualToplevel pn) + ] + where + withDot :: PackageName -> m UserConstraintScope + withDot pn + | pn == mkPackageName "any" = UserAnyQualifier <$> parsec + | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec + | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn + + withColon :: PackageName -> m UserConstraintScope + withColon pn = UserQualified (UserQualSetup pn) + <$ P.string "setup." + <*> parsec diff --git a/src/Distribution/Client/Types.hs b/src/Distribution/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Types +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Various common data types for the entire cabal-install system +----------------------------------------------------------------------------- +module Distribution.Client.Types ( + module Distribution.Client.Types.AllowNewer, + module Distribution.Client.Types.ConfiguredId, + module Distribution.Client.Types.ConfiguredPackage, + module Distribution.Client.Types.BuildResults, + module Distribution.Client.Types.PackageLocation, + module Distribution.Client.Types.PackageSpecifier, + module Distribution.Client.Types.ReadyPackage, + module Distribution.Client.Types.Repo, + module Distribution.Client.Types.RepoName, + module Distribution.Client.Types.SourcePackageDb, + module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy, +) where + + +import Distribution.Client.Types.AllowNewer +import Distribution.Client.Types.BuildResults +import Distribution.Client.Types.ConfiguredId +import Distribution.Client.Types.ConfiguredPackage +import Distribution.Client.Types.PackageLocation +import Distribution.Client.Types.PackageSpecifier +import Distribution.Client.Types.Repo +import Distribution.Client.Types.RepoName +import Distribution.Client.Types.ReadyPackage +import Distribution.Client.Types.SourcePackageDb +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy diff --git a/src/Distribution/Client/Types/AllowNewer.hs b/src/Distribution/Client/Types/AllowNewer.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/AllowNewer.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.AllowNewer ( + AllowNewer (..), + AllowOlder (..), + RelaxDeps (..), + mkRelaxDepSome, + RelaxDepMod (..), + RelaxDepScope (..), + RelaxDepSubject (..), + RelaxedDep (..), + isRelaxDeps, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Parsec (parsecLeadingCommaNonEmpty) +import Distribution.Types.PackageId (PackageId, PackageIdentifier (..)) +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Types.Version (nullVersion) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled, +-- it may make sense to move these definitions to the Solver.Types +-- module + +-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag) +newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps } + deriving (Eq, Read, Show, Generic) + +-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) +newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } + deriving (Eq, Read, Show, Generic) + +-- | Generic data type for policy when relaxing bounds in dependencies. +-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending +-- on whether or not you are relaxing an lower or upper bound +-- (respectively). +data RelaxDeps = + + -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages. + -- + -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all + -- dependencies, never choose versions newer (resp. older) than allowed. + RelaxDepsSome [RelaxedDep] + + -- | Ignore upper (resp. lower) bounds in dependencies on all packages. + -- + -- __Note__: This is should be semantically equivalent to + -- + -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] + -- + -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep') + | RelaxDepsAll + deriving (Eq, Read, Show, Generic) + +-- | Dependencies can be relaxed either for all packages in the install plan, or +-- only for some packages. +data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject + deriving (Eq, Read, Show, Generic) + +-- | Specify the scope of a relaxation, i.e. limit which depending +-- packages are allowed to have their version constraints relaxed. +data RelaxDepScope = RelaxDepScopeAll + -- ^ Apply relaxation in any package + | RelaxDepScopePackage !PackageName + -- ^ Apply relaxation to in all versions of a package + | RelaxDepScopePackageId !PackageId + -- ^ Apply relaxation to a specific version of a package only + deriving (Eq, Read, Show, Generic) + +-- | Modifier for dependency relaxation +data RelaxDepMod = RelaxDepModNone -- ^ Default semantics + | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints + deriving (Eq, Read, Show, Generic) + +-- | Express whether to relax bounds /on/ @all@ packages, or a single package +data RelaxDepSubject = RelaxDepSubjectAll + | RelaxDepSubjectPkg !PackageName + deriving (Eq, Ord, Read, Show, Generic) + +instance Pretty RelaxedDep where + pretty (RelaxedDep scope rdmod subj) = case scope of + RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep + RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep + RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep + where + modDep = case rdmod of + RelaxDepModNone -> pretty subj + RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj + +instance Parsec RelaxedDep where + parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) + +-- continuation after * +relaxedDepStarP :: CabalParsing m => m RelaxedDep +relaxedDepStarP = + RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec + <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) + +-- continuation after package identifier +relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep +relaxedDepPkgidP pid@(PackageIdentifier pn v) + | pn == mkPackageName "all" + , v == nullVersion + = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec + <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) + + | v == nullVersion + = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec + <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)) + + | otherwise + = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec + +modP :: P.CharParsing m => m RelaxDepMod +modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone + +instance Pretty RelaxDepSubject where + pretty RelaxDepSubjectAll = Disp.text "*" + pretty (RelaxDepSubjectPkg pn) = pretty pn + +instance Parsec RelaxDepSubject where + parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn + where + pkgn = do + pn <- parsec + pure $ if pn == mkPackageName "all" + then RelaxDepSubjectAll + else RelaxDepSubjectPkg pn + +instance Pretty RelaxDeps where + pretty rd | not (isRelaxDeps rd) = Disp.text "none" + pretty (RelaxDepsSome pkgs) = Disp.fsep . + Disp.punctuate Disp.comma . + map pretty $ pkgs + pretty RelaxDepsAll = Disp.text "all" + +-- | +-- +-- >>> simpleParsec "all" :: Maybe RelaxDeps +-- Just RelaxDepsAll +-- +-- >>> simpleParsec "none" :: Maybe RelaxDeps +-- Just (RelaxDepsSome []) +-- +-- >>> simpleParsec "*, *" :: Maybe RelaxDeps +-- Just RelaxDepsAll +-- +-- >>> simpleParsec "*:*" :: Maybe RelaxDeps +-- Just RelaxDepsAll +-- +-- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps +-- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))]) +-- +-- This is not a glitch, even it looks like: +-- +-- >>> simpleParsec ", all" :: Maybe RelaxDeps +-- Just RelaxDepsAll +-- +-- >>> simpleParsec "" :: Maybe RelaxDeps +-- Nothing +-- +instance Parsec RelaxDeps where + parsec = do + xs <- parsecLeadingCommaNonEmpty parsec + pure $ case toList xs of + [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] + -> RelaxDepsAll + [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)] + | pn == mkPackageName "none" + -> mempty + xs' -> mkRelaxDepSome xs' + +instance Binary RelaxDeps +instance Binary RelaxDepMod +instance Binary RelaxDepScope +instance Binary RelaxDepSubject +instance Binary RelaxedDep +instance Binary AllowNewer +instance Binary AllowOlder + +instance Structured RelaxDeps +instance Structured RelaxDepMod +instance Structured RelaxDepScope +instance Structured RelaxDepSubject +instance Structured RelaxedDep +instance Structured AllowNewer +instance Structured AllowOlder + +-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations +-- +-- Equivalent to @isRelaxDeps = (/= 'mempty')@ +isRelaxDeps :: RelaxDeps -> Bool +isRelaxDeps (RelaxDepsSome []) = False +isRelaxDeps (RelaxDepsSome (_:_)) = True +isRelaxDeps RelaxDepsAll = True + +-- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@. +mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps +mkRelaxDepSome xs + | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs + = RelaxDepsAll + + | otherwise + = RelaxDepsSome xs + +-- | 'RelaxDepsAll' is the /absorbing element/ +instance Semigroup RelaxDeps where + -- identity element + RelaxDepsSome [] <> r = r + l@(RelaxDepsSome _) <> RelaxDepsSome [] = l + -- absorbing element + l@RelaxDepsAll <> _ = l + (RelaxDepsSome _) <> r@RelaxDepsAll = r + -- combining non-{identity,absorbing} elements + (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) + +-- | @'RelaxDepsSome' []@ is the /identity element/ +instance Monoid RelaxDeps where + mempty = RelaxDepsSome [] + mappend = (<>) + +instance Semigroup AllowNewer where + AllowNewer x <> AllowNewer y = AllowNewer (x <> y) + +instance Semigroup AllowOlder where + AllowOlder x <> AllowOlder y = AllowOlder (x <> y) + +instance Monoid AllowNewer where + mempty = AllowNewer mempty + mappend = (<>) + +instance Monoid AllowOlder where + mempty = AllowOlder mempty + mappend = (<>) diff --git a/src/Distribution/Client/Types/BuildResults.hs b/src/Distribution/Client/Types/BuildResults.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/BuildResults.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.BuildResults ( + BuildOutcome, + BuildOutcomes, + BuildFailure (..), + BuildResult (..), + TestsResult (..), + DocsResult (..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Types.PackageId (PackageId) +import Distribution.Types.UnitId (UnitId) + +-- | A summary of the outcome for building a single package. +-- +type BuildOutcome = Either BuildFailure BuildResult + +-- | A summary of the outcome for building a whole set of packages. +-- +type BuildOutcomes = Map UnitId BuildOutcome + +data BuildFailure = PlanningFailed + | DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | TestsFailed SomeException + | InstallFailed SomeException + deriving (Show, Typeable, Generic) + +instance Exception BuildFailure + +-- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only +-- the public library's 'InstalledPackageInfo' is stored here, even if +-- there were 'InstalledPackageInfo' from internal libraries. This +-- 'InstalledPackageInfo' is not used anyway, so it makes no difference. +data BuildResult = BuildResult DocsResult TestsResult + (Maybe InstalledPackageInfo) + deriving (Show, Generic) + +data DocsResult = DocsNotTried | DocsFailed | DocsOk + deriving (Show, Generic, Typeable) +data TestsResult = TestsNotTried | TestsOk + deriving (Show, Generic, Typeable) + +instance Binary BuildFailure +instance Binary BuildResult +instance Binary DocsResult +instance Binary TestsResult + +instance Structured BuildFailure +instance Structured BuildResult +instance Structured DocsResult +instance Structured TestsResult diff --git a/src/Distribution/Client/Types/ConfiguredId.hs b/src/Distribution/Client/Types/ConfiguredId.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/ConfiguredId.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.ConfiguredId ( + InstalledPackageId, + ConfiguredId (..), + annotatedIdToConfiguredId, + HasConfiguredId (..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId) +import Distribution.Package (Package (..)) +import Distribution.Types.AnnotatedId (AnnotatedId (..)) +import Distribution.Types.ComponentId (ComponentId) +import Distribution.Types.ComponentName (ComponentName) +import Distribution.Types.PackageId (PackageId) + +------------------------------------------------------------------------------- +-- InstalledPackageId +------------------------------------------------------------------------------- + +-- | Within Cabal the library we no longer have a @InstalledPackageId@ type. +-- That's because it deals with the compilers' notion of a registered library, +-- and those really are libraries not packages. Those are now named units. +-- +-- The package management layer does however deal with installed packages, as +-- whole packages not just as libraries. So we do still need a type for +-- installed package ids. At the moment however we track instaled packages via +-- their primary library, which is a unit id. In future this may change +-- slightly and we may distinguish these two types and have an explicit +-- conversion when we register units with the compiler. +-- +type InstalledPackageId = ComponentId + +------------------------------------------------------------------------------- +-- ConfiguredId +------------------------------------------------------------------------------- + +-- | A ConfiguredId is a package ID for a configured package. +-- +-- Once we configure a source package we know its UnitId. It is still +-- however useful in lots of places to also know the source ID for the package. +-- We therefore bundle the two. +-- +-- An already installed package of course is also "configured" (all its +-- configuration parameters and dependencies have been specified). +data ConfiguredId = ConfiguredId { + confSrcId :: PackageId + , confCompName :: Maybe ComponentName + , confInstId :: ComponentId + } + deriving (Eq, Ord, Generic) + +annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId +annotatedIdToConfiguredId aid = ConfiguredId { + confSrcId = ann_pid aid, + confCompName = Just (ann_cname aid), + confInstId = ann_id aid + } + +instance Binary ConfiguredId +instance Structured ConfiguredId + +instance Show ConfiguredId where + show cid = show (confInstId cid) + +instance Package ConfiguredId where + packageId = confSrcId + +------------------------------------------------------------------------------- +-- HasConfiguredId class +------------------------------------------------------------------------------- + +class HasConfiguredId a where + configuredId :: a -> ConfiguredId + +-- NB: This instance is slightly dangerous, in that you'll lose +-- information about the specific UnitId you depended on. +instance HasConfiguredId InstalledPackageInfo where + configuredId ipkg = ConfiguredId (packageId ipkg) + (Just (sourceComponentName ipkg)) + (installedComponentId ipkg) diff --git a/src/Distribution/Client/Types/ConfiguredPackage.hs b/src/Distribution/Client/Types/ConfiguredPackage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/ConfiguredPackage.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +module Distribution.Client.Types.ConfiguredPackage ( + ConfiguredPackage (..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId) +import Distribution.Types.Flag (FlagAssignment) +import Distribution.Types.ComponentName +import Distribution.Types.LibraryName (LibraryName (..)) +import Distribution.Types.MungedPackageId (computeCompatPackageId) +import Distribution.Simple.Utils (ordNub) + +import Distribution.Client.Types.ConfiguredId +import Distribution.Solver.Types.OptionalStanza (OptionalStanzaSet) +import Distribution.Solver.Types.PackageFixedDeps +import Distribution.Solver.Types.SourcePackage (SourcePackage) + +import qualified Distribution.Solver.Types.ComponentDeps as CD + +-- | A 'ConfiguredPackage' is a not-yet-installed package along with the +-- total configuration information. The configuration information is total in +-- the sense that it provides all the configuration information and so the +-- final configure process will be independent of the environment. +-- +-- 'ConfiguredPackage' is assumed to not support Backpack. Only the +-- @v2-build@ codepath supports Backpack. +-- +data ConfiguredPackage loc = ConfiguredPackage + { confPkgId :: InstalledPackageId + , confPkgSource :: SourcePackage loc -- ^ package info, including repo + , confPkgFlags :: FlagAssignment -- ^ complete flag assignment for the package + , confPkgStanzas :: OptionalStanzaSet -- ^ list of enabled optional stanzas for the package + , confPkgDeps :: CD.ComponentDeps [ConfiguredId] + -- ^ set of exact dependencies (installed or source). + -- + -- These must be consistent with the 'buildDepends' + -- in the 'PackageDescription' that you'd get by + -- applying the flag assignment and optional stanzas. + } + deriving (Eq, Show, Generic) + +-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'. +-- This type class is mostly used to conveniently finesse between +-- 'ElaboratedPackage' and 'ElaboratedComponent'. +-- +instance HasConfiguredId (ConfiguredPackage loc) where + configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg) + +-- 'ConfiguredPackage' is the legacy codepath, we are guaranteed +-- to never have a nontrivial 'UnitId' +instance PackageFixedDeps (ConfiguredPackage loc) where + depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps + +instance IsNode (ConfiguredPackage loc) where + type Key (ConfiguredPackage loc) = UnitId + nodeKey = newSimpleUnitId . confPkgId + -- TODO: if we update ConfiguredPackage to support order-only + -- dependencies, need to include those here. + -- NB: have to deduplicate, otherwise the planner gets confused + nodeNeighbors = ordNub . CD.flatDeps . depends + +instance (Binary loc) => Binary (ConfiguredPackage loc) + + + + +instance Package (ConfiguredPackage loc) where + packageId cpkg = packageId (confPkgSource cpkg) + +instance HasMungedPackageId (ConfiguredPackage loc) where + mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName + +-- Never has nontrivial UnitId +instance HasUnitId (ConfiguredPackage loc) where + installedUnitId = newSimpleUnitId . confPkgId + +instance PackageInstalled (ConfiguredPackage loc) where + installedDepends = CD.flatDeps . depends + + + diff --git a/src/Distribution/Client/Types/Credentials.hs b/src/Distribution/Client/Types/Credentials.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/Credentials.hs @@ -0,0 +1,9 @@ +module Distribution.Client.Types.Credentials ( + Username (..), + Password (..), +) where + +import Prelude (String) + +newtype Username = Username { unUsername :: String } +newtype Password = Password { unPassword :: String } diff --git a/src/Distribution/Client/Types/InstallMethod.hs b/src/Distribution/Client/Types/InstallMethod.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/InstallMethod.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.InstallMethod where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +data InstallMethod + = InstallMethodCopy + | InstallMethodSymlink + deriving (Eq, Show, Generic, Bounded, Enum) + +instance Binary InstallMethod +instance Structured InstallMethod + +-- | Last +instance Semigroup InstallMethod where + _ <> x = x + +instance Parsec InstallMethod where + parsec = do + name <- P.munch1 isAlpha + case name of + "copy" -> pure InstallMethodCopy + "symlink" -> pure InstallMethodSymlink + _ -> P.unexpected $ "InstallMethod: " ++ name + +instance Pretty InstallMethod where + pretty InstallMethodCopy = PP.text "copy" + pretty InstallMethodSymlink = PP.text "symlink" diff --git a/src/Distribution/Client/Types/OverwritePolicy.hs b/src/Distribution/Client/Types/OverwritePolicy.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/OverwritePolicy.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.OverwritePolicy where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +data OverwritePolicy + = NeverOverwrite + | AlwaysOverwrite + deriving (Show, Eq, Generic, Bounded, Enum) + +instance Binary OverwritePolicy +instance Structured OverwritePolicy + +instance Parsec OverwritePolicy where + parsec = do + name <- P.munch1 isAlpha + case name of + "always" -> pure AlwaysOverwrite + "never" -> pure NeverOverwrite + _ -> P.unexpected $ "OverwritePolicy: " ++ name + +instance Pretty OverwritePolicy where + pretty NeverOverwrite = PP.text "never" + pretty AlwaysOverwrite = PP.text "always" diff --git a/src/Distribution/Client/Types/PackageLocation.hs b/src/Distribution/Client/Types/PackageLocation.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/PackageLocation.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.PackageLocation ( + PackageLocation (..), + UnresolvedPkgLoc, + ResolvedPkgLoc, + UnresolvedSourcePackage, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Network.URI (URI) + +import Distribution.Types.PackageId (PackageId) + +import Distribution.Client.Types.Repo +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe) +import Distribution.Solver.Types.SourcePackage (SourcePackage) + +type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) + +type ResolvedPkgLoc = PackageLocation FilePath + +data PackageLocation local = + + -- | An unpacked package in the given dir, or current dir + LocalUnpackedPackage FilePath + + -- | A package as a tarball that's available as a local tarball + | LocalTarballPackage FilePath + + -- | A package as a tarball from a remote URI + | RemoteTarballPackage URI local + + -- | A package available as a tarball from a repository. + -- + -- It may be from a local repository or from a remote repository, with a + -- locally cached copy. ie a package available from hackage + | RepoTarballPackage Repo PackageId local + + -- | A package available from a version control system source repository + | RemoteSourceRepoPackage SourceRepoMaybe local + deriving (Show, Functor, Eq, Ord, Generic, Typeable) + +instance Binary local => Binary (PackageLocation local) +instance Structured local => Structured (PackageLocation local) + +-- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. +type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc diff --git a/src/Distribution/Client/Types/PackageSpecifier.hs b/src/Distribution/Client/Types/PackageSpecifier.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/PackageSpecifier.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.PackageSpecifier ( + PackageSpecifier (..), + pkgSpecifierTarget, + pkgSpecifierConstraints, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Package (Package (..), packageName, packageVersion) +import Distribution.Types.PackageName (PackageName) +import Distribution.Version (thisVersion) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.PackageConstraint + +-- | A fully or partially resolved reference to a package. +-- +data PackageSpecifier pkg = + + -- | A partially specified reference to a package (either source or + -- installed). It is specified by package name and optionally some + -- required properties. Use a dependency resolver to pick a specific + -- package satisfying these properties. + -- + NamedPackage PackageName [PackageProperty] + + -- | A fully specified source package. + -- + | SpecificSourcePackage pkg + deriving (Eq, Show, Functor, Generic) + +instance Binary pkg => Binary (PackageSpecifier pkg) +instance Structured pkg => Structured (PackageSpecifier pkg) + +pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName +pkgSpecifierTarget (NamedPackage name _) = name +pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg + +pkgSpecifierConstraints :: Package pkg + => PackageSpecifier pkg -> [LabeledPackageConstraint] +pkgSpecifierConstraints (NamedPackage name props) = map toLpc props + where + toLpc prop = LabeledPackageConstraint + (PackageConstraint (scopeToplevel name) prop) + ConstraintSourceUserTarget +pkgSpecifierConstraints (SpecificSourcePackage pkg) = + [LabeledPackageConstraint pc ConstraintSourceUserTarget] + where + pc = PackageConstraint + (ScopeTarget $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) diff --git a/src/Distribution/Client/Types/ReadyPackage.hs b/src/Distribution/Client/Types/ReadyPackage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/ReadyPackage.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Client.Types.ReadyPackage ( + GenericReadyPackage (..), + ReadyPackage, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) + +import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage) +import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc) +import Distribution.Solver.Types.PackageFixedDeps + +-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be +-- installed already, hence itself ready to be installed. +newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. + deriving (Eq, Show, Generic, Package, PackageFixedDeps, + HasMungedPackageId, HasUnitId, PackageInstalled, Binary) + +-- Can't newtype derive this +instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where + type Key (GenericReadyPackage srcpkg) = Key srcpkg + nodeKey (ReadyPackage spkg) = nodeKey spkg + nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg + +type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) diff --git a/src/Distribution/Client/Types/Repo.hs b/src/Distribution/Client/Types/Repo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/Repo.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.Repo ( + -- * Remote repository + RemoteRepo (..), + emptyRemoteRepo, + -- * Local repository (no-index) + LocalRepo (..), + emptyLocalRepo, + localRepoCacheKey, + -- * Repository + Repo (..), + repoName, + isRepoRemote, + maybeRepoRemote, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString) + +import Distribution.Simple.Utils (toUTF8BS) + +import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash) + +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +import Distribution.Client.Types.RepoName + +------------------------------------------------------------------------------- +-- Remote repository +------------------------------------------------------------------------------- + +data RemoteRepo = + RemoteRepo { + remoteRepoName :: RepoName, + remoteRepoURI :: URI, + + -- | Enable secure access? + -- + -- 'Nothing' here represents "whatever the default is"; this is important + -- to allow for a smooth transition from opt-in to opt-out security + -- (once we switch to opt-out, all access to the central Hackage + -- repository should be secure by default) + remoteRepoSecure :: Maybe Bool, + + -- | Root key IDs (for bootstrapping) + remoteRepoRootKeys :: [String], + + -- | Threshold for verification during bootstrapping + remoteRepoKeyThreshold :: Int, + + -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a + -- special case we may know a repo supports both and want to try HTTPS + -- if we can, but still allow falling back to HTTP. + -- + -- This field is not currently stored in the config file, but is filled + -- in automagically for known repos. + remoteRepoShouldTryHttps :: Bool + } + + deriving (Show, Eq, Ord, Generic) + +instance Binary RemoteRepo +instance Structured RemoteRepo + +instance Pretty RemoteRepo where + pretty r = + pretty (remoteRepoName r) <<>> Disp.colon <<>> + Disp.text (uriToString id (remoteRepoURI r) []) + +-- | Note: serialised format represends 'RemoteRepo' only partially. +instance Parsec RemoteRepo where + parsec = do + name <- parsec + _ <- P.char ':' + uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String)) + uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr) + return RemoteRepo + { remoteRepoName = name + , remoteRepoURI = uri + , remoteRepoSecure = Nothing + , remoteRepoRootKeys = [] + , remoteRepoKeyThreshold = 0 + , remoteRepoShouldTryHttps = False + } + +-- | Construct a partial 'RemoteRepo' value to fold the field parser list over. +emptyRemoteRepo :: RepoName -> RemoteRepo +emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False + +------------------------------------------------------------------------------- +-- Local repository +------------------------------------------------------------------------------- + +-- | /no-index/ style local repositories. +-- +-- https://github.com/haskell/cabal/issues/6359 +data LocalRepo = LocalRepo + { localRepoName :: RepoName + , localRepoPath :: FilePath + , localRepoSharedCache :: Bool + } + deriving (Show, Eq, Ord, Generic) + +instance Binary LocalRepo +instance Structured LocalRepo + +-- | Note: doesn't parse 'localRepoSharedCache' field. +instance Parsec LocalRepo where + parsec = do + n <- parsec + _ <- P.char ':' + p <- P.munch1 (const True) -- restrict what can be a path? + return (LocalRepo n p False) + +instance Pretty LocalRepo where + pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p + +-- | Construct a partial 'LocalRepo' value to fold the field parser list over. +emptyLocalRepo :: RepoName -> LocalRepo +emptyLocalRepo name = LocalRepo name "" False + +-- | Calculate a cache key for local-repo. +-- +-- For remote repositories we just use name, but local repositories may +-- all be named "local", so we add a bit of `localRepoPath` into the +-- mix. +localRepoCacheKey :: LocalRepo -> String +localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where + hashPart + = showHashValue $ truncateHash 8 $ hashValue + $ LBS.fromStrict $ toUTF8BS $ localRepoPath local + +------------------------------------------------------------------------------- +-- Any repository +------------------------------------------------------------------------------- + +-- | Different kinds of repositories +-- +-- NOTE: It is important that this type remains serializable. +data Repo + -- | Local repository, without index. + -- + -- https://github.com/haskell/cabal/issues/6359 + = RepoLocalNoIndex + { repoLocal :: LocalRepo + , repoLocalDir :: FilePath + } + + -- | Standard (unsecured) remote repositores + | RepoRemote { + repoRemote :: RemoteRepo + , repoLocalDir :: FilePath + } + + -- | Secure repositories + -- + -- Although this contains the same fields as 'RepoRemote', we use a separate + -- constructor to avoid confusing the two. + -- + -- Not all access to a secure repo goes through the hackage-security + -- library currently; code paths that do not still make use of the + -- 'repoRemote' and 'repoLocalDir' fields directly. + | RepoSecure { + repoRemote :: RemoteRepo + , repoLocalDir :: FilePath + } + deriving (Show, Eq, Ord, Generic) + +instance Binary Repo +instance Structured Repo + +-- | Check if this is a remote repo +isRepoRemote :: Repo -> Bool +isRepoRemote RepoLocalNoIndex{} = False +isRepoRemote _ = True + +-- | Extract @RemoteRepo@ from @Repo@ if remote. +maybeRepoRemote :: Repo -> Maybe RemoteRepo +maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing +maybeRepoRemote (RepoRemote r _localDir) = Just r +maybeRepoRemote (RepoSecure r _localDir) = Just r + +repoName :: Repo -> RepoName +repoName (RepoLocalNoIndex r _) = localRepoName r +repoName (RepoRemote r _) = remoteRepoName r +repoName (RepoSecure r _) = remoteRepoName r diff --git a/src/Distribution/Client/Types/RepoName.hs b/src/Distribution/Client/Types/RepoName.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/RepoName.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.RepoName ( + RepoName (..), + unRepoName, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +-- | Repository name. +-- +-- May be used as path segment. +-- +newtype RepoName = RepoName String + deriving (Show, Eq, Ord, Generic) + +unRepoName :: RepoName -> String +unRepoName (RepoName n) = n + +instance Binary RepoName +instance Structured RepoName +instance NFData RepoName + +instance Pretty RepoName where + pretty = Disp.text . unRepoName + +-- | +-- +-- >>> simpleParsec "hackage.haskell.org" :: Maybe RepoName +-- Just (RepoName "hackage.haskell.org") +-- +-- >>> simpleParsec "0123" :: Maybe RepoName +-- Nothing +-- +instance Parsec RepoName where + parsec = RepoName <$> parser where + parser = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlpha c || c == '_' || c == '-' || c == '.') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.') diff --git a/src/Distribution/Client/Types/SourcePackageDb.hs b/src/Distribution/Client/Types/SourcePackageDb.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/SourcePackageDb.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.SourcePackageDb ( + SourcePackageDb (..), +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.VersionRange (VersionRange) + +import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage) +import Distribution.Solver.Types.PackageIndex (PackageIndex) + +-- | This is the information we get from a @00-index.tar.gz@ hackage index. +-- +data SourcePackageDb = SourcePackageDb + { packageIndex :: PackageIndex UnresolvedSourcePackage + , packagePreferences :: Map PackageName VersionRange + } + deriving (Eq, Generic) + +instance Binary SourcePackageDb diff --git a/src/Distribution/Client/Types/SourceRepo.hs b/src/Distribution/Client/Types/SourceRepo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/SourceRepo.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Distribution.Client.Types.SourceRepo ( + SourceRepositoryPackage (..), + SourceRepoList, + SourceRepoMaybe, + SourceRepoProxy, + srpHoist, + srpToProxy, + srpFanOut, + sourceRepositoryPackageGrammar, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Lens (Lens, Lens') +import Prelude () + +import Distribution.FieldGrammar +import Distribution.Types.SourceRepo (RepoType (..)) + +-- | @source-repository-package@ definition +-- +data SourceRepositoryPackage f = SourceRepositoryPackage + { srpType :: !RepoType + , srpLocation :: !String + , srpTag :: !(Maybe String) + , srpBranch :: !(Maybe String) + , srpSubdir :: !(f FilePath) + , srpCommand :: ![String] + } + deriving (Generic) + +deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f) +deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f) +deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f) +deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f) +deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f) + +-- | Read from @cabal.project@ +type SourceRepoList = SourceRepositoryPackage [] + +-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo' +type SourceRepoMaybe = SourceRepositoryPackage Maybe + +-- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory. +type SourceRepoProxy = SourceRepositoryPackage Proxy + +srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g +srpHoist nt s = s { srpSubdir = nt (srpSubdir s) } + +srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy +srpToProxy s = s { srpSubdir = Proxy } + +-- | Split single @source-repository-package@ declaration with multiple subdirs, +-- into multiple ones with at most single subdir. +srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe) +srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } = + s { srpSubdir = Nothing } :| [] +srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where + f subdir = s { srpSubdir = Just subdir } + +------------------------------------------------------------------------------- +-- Lens +------------------------------------------------------------------------------- + +srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType +srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s)) +{-# INLINE srpTypeLens #-} + +srpLocationLens :: Lens' (SourceRepositoryPackage f) String +srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s)) +{-# INLINE srpLocationLens #-} + +srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String) +srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s)) +{-# INLINE srpTagLens #-} + +srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String) +srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s)) +{-# INLINE srpBranchLens #-} + +srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath) +srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s)) +{-# INLINE srpSubdirLens #-} + +srpCommandLensNE :: Lens' (SourceRepositoryPackage f) (Maybe (NonEmpty String)) +srpCommandLensNE f s = fmap (\x -> s { srpCommand = maybe [] toList x }) (f (nonEmpty (srpCommand s))) +{-# INLINE srpCommandLensNE #-} + +------------------------------------------------------------------------------- +-- Parser & PPrinter +------------------------------------------------------------------------------- + +sourceRepositoryPackageGrammar + :: ( FieldGrammar c g, Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => g SourceRepoList SourceRepoList +sourceRepositoryPackageGrammar = SourceRepositoryPackage + <$> uniqueField "type" srpTypeLens + <*> uniqueFieldAla "location" Token srpLocationLens + <*> optionalFieldAla "tag" Token srpTagLens + <*> optionalFieldAla "branch" Token srpBranchLens + <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there... + <*> fmap (maybe [] toList) pcc + where + pcc = optionalFieldAla "post-checkout-command" (alaNonEmpty' NoCommaFSep Token) srpCommandLensNE +{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-} +{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-} diff --git a/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( + WriteGhcEnvironmentFilesPolicy (..), +) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +-- | Whether 'v2-build' should write a .ghc.environment file after +-- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+' +-- (8.4.4 is the earliest version that supports +-- '-package-env -'). +data WriteGhcEnvironmentFilesPolicy + = AlwaysWriteGhcEnvironmentFiles + | NeverWriteGhcEnvironmentFiles + | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + deriving (Eq, Enum, Bounded, Generic, Show) + +instance Binary WriteGhcEnvironmentFilesPolicy +instance Structured WriteGhcEnvironmentFilesPolicy diff --git a/src/Distribution/Client/Upload.hs b/src/Distribution/Client/Upload.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Upload.hs @@ -0,0 +1,225 @@ +module Distribution.Client.Upload (upload, uploadDoc, report) where + +import Distribution.Client.Compat.Prelude +import qualified Prelude as Unsafe (tail, head, read) + +import Distribution.Client.Types.Credentials ( Username(..), Password(..) ) +import Distribution.Client.Types.Repo (RemoteRepo(..), maybeRepoRemote) +import Distribution.Client.Types.RepoName (unRepoName) +import Distribution.Client.HttpUtils + ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) +import Distribution.Client.Setup + ( IsCandidate(..), RepoContext(..) ) + +import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS) +import Distribution.Client.Config + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (parseBuildReport) +import qualified Distribution.Client.BuildReports.Upload as BuildReport + +import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName)) +import Network.HTTP (Header(..), HeaderName(..)) + +import System.IO (hFlush, stdout) +import System.IO.Echo (withoutInputEcho) +import System.FilePath ((), takeExtension, takeFileName, dropExtension) +import qualified System.FilePath.Posix as FilePath.Posix (()) +import System.Directory + +type Auth = Maybe (String, String) + +-- > stripExtensions ["tar", "gz"] "foo.tar.gz" +-- Just "foo" +-- > stripExtensions ["tar", "gz"] "foo.gz.tar" +-- Nothing +stripExtensions :: [String] -> FilePath -> Maybe String +stripExtensions exts path = foldM f path (reverse exts) + where + f p e + | takeExtension p == '.':e = Just (dropExtension p) + | otherwise = Nothing + +upload :: Verbosity -> RepoContext + -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath] + -> IO () +upload verbosity repoCtxt mUsername mPassword isCandidate paths = do + let repos = repoContextRepos repoCtxt + transport <- repoContextGetTransport repoCtxt + targetRepo <- + case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of + [] -> die' verbosity "Cannot upload. No remote repositories are configured." + (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) + let targetRepoURI = remoteRepoURI targetRepo + domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI + rootIfEmpty x = if null x then "/" else x + uploadURI = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. + case isCandidate of + IsCandidate -> "packages/candidates" + IsPublished -> "upload" + } + packageURI pkgid = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + ] + } + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + let auth = Just (username,password) + for_ paths $ \path -> do + notice verbosity $ "Uploading " ++ path ++ "... " + case fmap takeFileName (stripExtensions ["tar", "gz"] path) of + Just pkgid -> handlePackage transport verbosity uploadURI + (packageURI pkgid) auth isCandidate path + -- This case shouldn't really happen, since we check in Main that we + -- only pass tar.gz files to upload. + Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path + +uploadDoc :: Verbosity -> RepoContext + -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath + -> IO () +uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do + let repos = repoContextRepos repoCtxt + transport <- repoContextGetTransport repoCtxt + targetRepo <- + case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of + [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." + (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) + let targetRepoURI = remoteRepoURI targetRepo + domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI + rootIfEmpty x = if null x then "/" else x + uploadURI = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + , "/docs" + ] + } + packageUri = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + ] + } + (reverseSuffix, reversePkgid) = break (== '-') + (reverse (takeFileName path)) + pkgid = reverse $ Unsafe.tail reversePkgid + when (reverse reverseSuffix /= "docs.tar.gz" + || null reversePkgid || Unsafe.head reversePkgid /= '-') $ + die' verbosity "Expected a file name matching the pattern -docs.tar.gz" + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + + let auth = Just (username,password) + headers = + [ Header HdrContentType "application/x-tar" + , Header HdrContentEncoding "gzip" + ] + notice verbosity $ "Uploading documentation " ++ path ++ "... " + resp <- putHttpFile transport verbosity uploadURI path auth headers + case resp of + -- Hackage responds with 204 No Content when docs are uploaded + -- successfully. + (code,_) | code `elem` [200,204] -> do + notice verbosity $ okMessage packageUri + (code,err) -> do + notice verbosity $ "Error uploading documentation " + ++ path ++ ": " + ++ "http code " ++ show code ++ "\n" + ++ err + exitFailure + where + okMessage packageUri = case isCandidate of + IsCandidate -> + "Documentation successfully uploaded for package candidate. " + ++ "You can now preview the result at '" ++ show packageUri + ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'." + IsPublished -> + "Package documentation successfully published. You can now view it at '" + ++ show packageUri ++ "'." + + +promptUsername :: String -> IO Username +promptUsername domain = do + putStr $ domain ++ " username: " + hFlush stdout + fmap Username getLine + +promptPassword :: String -> IO Password +promptPassword domain = do + putStr $ domain ++ " password: " + hFlush stdout + -- save/restore the terminal echoing status (no echoing for entering the password) + passwd <- withoutInputEcho $ fmap Password getLine + putStrLn "" + return passwd + +report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO () +report verbosity repoCtxt mUsername mPassword = do + let repos = repoContextRepos repoCtxt + remoteRepos = mapMaybe maybeRepoRemote repos + for_ remoteRepos $ \remoteRepo -> do + let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo) + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + let auth = (username, password) + + dotCabal <- getCabalDir + let srcDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) + -- We don't want to bomb out just because we haven't built any packages + -- from this repo yet. + srcExists <- doesDirectoryExist srcDir + when srcExists $ do + contents <- getDirectoryContents srcDir + for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> + do inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse + case parseBuildReport (toUTF8BS reportStr) of + Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME + Right report' -> + do info verbosity $ "Uploading report for " + ++ prettyShow (BuildReport.package report') + BuildReport.uploadReports verbosity repoCtxt auth + (remoteRepoURI remoteRepo) [(report', Just buildLog)] + return () + +handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth + -> IsCandidate -> FilePath -> IO () +handlePackage transport verbosity uri packageUri auth isCandidate path = + do resp <- postHttpFile transport verbosity uri path auth + case resp of + (code,warnings) | code `elem` [200, 204] -> + notice verbosity $ okMessage isCandidate ++ + if null warnings then "" else "\n" ++ formatWarnings (trim warnings) + (code,err) -> do + notice verbosity $ "Error uploading " ++ path ++ ": " + ++ "http code " ++ show code ++ "\n" + ++ err + exitFailure + where + okMessage IsCandidate = + "Package successfully uploaded as candidate. " + ++ "You can now preview the result at '" ++ show packageUri + ++ "'. To publish the candidate, use 'cabal upload --publish'." + okMessage IsPublished = + "Package successfully published. You can now view it at '" + ++ show packageUri ++ "'." + +formatWarnings :: String -> String +formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x + +-- Trim +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace diff --git a/src/Distribution/Client/Utils.hs b/src/Distribution/Client/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Utils.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE ForeignFunctionInterface, CPP #-} + +module Distribution.Client.Utils ( MergeResult(..) + , mergeBy, duplicates, duplicatesBy + , readMaybe + , inDir, withEnv, withEnvOverrides + , logDirChange, withExtraPathEnv + , determineNumJobs, numberOfProcessors + , removeExistingFile + , withTempFileName + , makeAbsoluteToCwd + , makeRelativeToCwd, makeRelativeToDir + , makeRelativeCanonical + , filePathToByteString + , byteStringToFilePath, tryCanonicalizePath + , canonicalizePathNoThrow + , moreRecentFile, existsAndIsMoreRecentThan + , tryFindAddSourcePackageDesc + , tryFindPackageDesc + , relaxEncodingErrors + , ProgressPhase (..) + , progressMessage + , cabalInstallVersion) + where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Compat.Environment +import Distribution.Compat.Time ( getModTime ) +import Distribution.Simple.Setup ( Flag(..) ) +import Distribution.Version +import Distribution.Simple.Utils ( die', findPackageDesc, noticeNoWrap ) +import qualified Data.ByteString.Lazy as BS +import Data.Bits + ( (.|.), shiftL, shiftR ) +import System.FilePath +import Control.Monad + ( zipWithM_ ) +import Data.List + ( groupBy ) +import Foreign.C.Types ( CInt(..) ) +import qualified Control.Exception as Exception + ( finally, bracket ) +import System.Directory + ( canonicalizePath, doesFileExist, getCurrentDirectory + , removeFile, setCurrentDirectory ) +import System.IO + ( Handle, hClose, openTempFile + , hGetEncoding, hSetEncoding + ) +import System.IO.Unsafe ( unsafePerformIO ) + +import GHC.IO.Encoding + ( recover, TextEncoding(TextEncoding) ) +import GHC.IO.Encoding.Failure + ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) + +#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) +import qualified System.Directory as Dir +import qualified System.IO.Error as IOError +#endif + +#ifndef __DOCTEST__ +import qualified Paths_cabal_install (version) +#endif + +-- | Generic merging utility. For sorted input lists this is a full outer join. +-- +mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] +mergeBy cmp = merge + where + merge [] ys = [ OnlyInRight y | y <- ys] + merge xs [] = [ OnlyInLeft x | x <- xs] + merge (x:xs) (y:ys) = + case x `cmp` y of + GT -> OnlyInRight y : merge (x:xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y:ys) + +data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b + +duplicates :: Ord a => [a] -> [[a]] +duplicates = duplicatesBy compare + +duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] +duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp + where + eq a b = case cmp a b of + EQ -> True + _ -> False + moreThanOne (_:_:_) = True + moreThanOne _ = False + +-- | Like 'removeFile', but does not throw an exception when the file does not +-- exist. +removeExistingFile :: FilePath -> IO () +removeExistingFile path = do + exists <- doesFileExist path + when exists $ + removeFile path + +-- | A variant of 'withTempFile' that only gives us the file name, and while +-- it will clean up the file afterwards, it's lenient if the file is +-- moved\/deleted. +-- +withTempFileName :: FilePath + -> String + -> (FilePath -> IO a) -> IO a +withTempFileName tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, _) -> removeExistingFile name) + (\(name, h) -> hClose h >> action name) + +-- | Executes the action in the specified directory. +-- +-- Warning: This operation is NOT thread-safe, because current +-- working directory is a process-global concept. +inDir :: Maybe FilePath -> IO a -> IO a +inDir Nothing m = m +inDir (Just d) m = do + old <- getCurrentDirectory + setCurrentDirectory d + m `Exception.finally` setCurrentDirectory old + +-- | Executes the action with an environment variable set to some +-- value. +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnv :: String -> String -> IO a -> IO a +withEnv k v m = do + mb_old <- lookupEnv k + setEnv k v + m `Exception.finally` (case mb_old of + Nothing -> unsetEnv k + Just old -> setEnv k old) + +-- | Executes the action with a list of environment variables and +-- corresponding overrides, where +-- +-- * @'Just' v@ means \"set the environment variable's value to @v@\". +-- * 'Nothing' means \"unset the environment variable\". +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a +withEnvOverrides overrides m = do + mb_olds <- traverse lookupEnv envVars + traverse_ (uncurry update) overrides + m `Exception.finally` zipWithM_ update envVars mb_olds + where + envVars :: [String] + envVars = map fst overrides + + update :: String -> Maybe FilePath -> IO () + update var Nothing = unsetEnv var + update var (Just val) = setEnv var val + +-- | Executes the action, increasing the PATH environment +-- in some way +-- +-- Warning: This operation is NOT thread-safe, because the +-- environment variables are a process-global concept. +withExtraPathEnv :: [FilePath] -> IO a -> IO a +withExtraPathEnv paths m = do + oldPathSplit <- getSearchPath + let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) + oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit + -- TODO: This is a horrible hack to work around the fact that + -- setEnv can't take empty values as an argument + mungePath p | p == "" = "/dev/null" + | otherwise = p + setEnv "PATH" newPath + m `Exception.finally` setEnv "PATH" oldPath + +-- | Log directory change in 'make' compatible syntax +logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a +logDirChange _ Nothing m = m +logDirChange l (Just d) m = do + l $ "cabal: Entering directory '" ++ d ++ "'\n" + m `Exception.finally` + (l $ "cabal: Leaving directory '" ++ d ++ "'\n") + +foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt + +-- The number of processors is not going to change during the duration of the +-- program, so unsafePerformIO is safe here. +numberOfProcessors :: Int +numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors + +-- | Determine the number of jobs to use given the value of the '-j' flag. +determineNumJobs :: Flag (Maybe Int) -> Int +determineNumJobs numJobsFlag = + case numJobsFlag of + NoFlag -> 1 + Flag Nothing -> numberOfProcessors + Flag (Just n) -> n + +-- | Given a relative path, make it absolute relative to the current +-- directory. Absolute paths are returned unmodified. +makeAbsoluteToCwd :: FilePath -> IO FilePath +makeAbsoluteToCwd path | isAbsolute path = return path + | otherwise = do cwd <- getCurrentDirectory + return $! cwd path + +-- | Given a path (relative or absolute), make it relative to the current +-- directory, including using @../..@ if necessary. +makeRelativeToCwd :: FilePath -> IO FilePath +makeRelativeToCwd path = + makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory + +-- | Given a path (relative or absolute), make it relative to the given +-- directory, including using @../..@ if necessary. +makeRelativeToDir :: FilePath -> FilePath -> IO FilePath +makeRelativeToDir path dir = + makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir + +-- | Given a canonical absolute path and canonical absolute dir, make the path +-- relative to the directory, including using @../..@ if necessary. Returns +-- the original absolute path if it is not on the same drive as the given dir. +makeRelativeCanonical :: FilePath -> FilePath -> FilePath +makeRelativeCanonical path dir + | takeDrive path /= takeDrive dir = path + | otherwise = go (splitPath path) (splitPath dir) + where + go (p:ps) (d:ds) | p == d = go ps ds + go [] [] = "./" + go ps ds = joinPath (replicate (length ds) ".." ++ ps) + +-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is +-- encoded as a little-endian 'Word32'. +filePathToByteString :: FilePath -> BS.ByteString +filePathToByteString p = + BS.pack $ foldr conv [] codepts + where + codepts :: [Word32] + codepts = map (fromIntegral . ord) p + + conv :: Word32 -> [Word8] -> [Word8] + conv w32 rest = b0:b1:b2:b3:rest + where + b0 = fromIntegral $ w32 + b1 = fromIntegral $ w32 `shiftR` 8 + b2 = fromIntegral $ w32 `shiftR` 16 + b3 = fromIntegral $ w32 `shiftR` 24 + +-- | Reverse operation to 'filePathToByteString'. +byteStringToFilePath :: BS.ByteString -> FilePath +byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected + | otherwise = go 0 + where + unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected" + bslen = BS.length bs + + go i | i == bslen = [] + | otherwise = (chr . fromIntegral $ w32) : go (i+4) + where + w32 :: Word32 + w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) + b0 = fromIntegral $ BS.index bs i + b1 = fromIntegral $ BS.index bs (i + 1) + b2 = fromIntegral $ BS.index bs (i + 2) + b3 = fromIntegral $ BS.index bs (i + 3) + +-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always +-- throws an error if the path refers to a non-existent file. +tryCanonicalizePath :: FilePath -> IO FilePath +tryCanonicalizePath path = do + ret <- canonicalizePath path +#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) + exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret) + unless exists $ + IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath" + Nothing (Just ret) +#endif + return ret + +-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws +-- an exception, returns the path argument unmodified. +canonicalizePathNoThrow :: FilePath -> IO FilePath +canonicalizePathNoThrow path = do + canonicalizePath path `catchIO` (\_ -> return path) + +-------------------- +-- Modification time + +-- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead +-- of getModificationTime for higher precision. We can't merge the two because +-- Distribution.Client.Time uses MIN_VERSION macros. +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModTime b + ta <- getModTime a + return (ta > tb) + +-- | Like 'moreRecentFile', but also checks that the first file exists. +existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool +existsAndIsMoreRecentThan a b = do + exists <- doesFileExist a + if not exists + then return False + else a `moreRecentFile` b + +-- | Sets the handler for encoding errors to one that transliterates invalid +-- characters into one present in the encoding (i.e., \'?\'). +-- This is opposed to the default behavior, which is to throw an exception on +-- error. This function will ignore file handles that have a Unicode encoding +-- set. It's a no-op for versions of `base` less than 4.4. +relaxEncodingErrors :: Handle -> IO () +relaxEncodingErrors handle = do + maybeEncoding <- hGetEncoding handle + case maybeEncoding of + Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) -> + let relax x = x { recover = recoverEncode TransliterateCodingFailure } + in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder)) + _ -> + return () + +-- |Like 'tryFindPackageDesc', but with error specific to add-source deps. +tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $ + err ++ "\n" ++ "Failed to read cabal file of add-source dependency: " + ++ depPath + +-- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be +-- found, with @err@ prefixing the error message. This function simply allows +-- us to give a more descriptive error than that provided by @findPackageDesc@. +tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindPackageDesc verbosity depPath err = do + errOrCabalFile <- findPackageDesc depPath + case errOrCabalFile of + Right file -> return file + Left _ -> die' verbosity err + +-- | Phase of building a dependency. Represents current status of package +-- dependency processing. See #4040 for details. +data ProgressPhase + = ProgressDownloading + | ProgressDownloaded + | ProgressStarting + | ProgressBuilding + | ProgressHaddock + | ProgressInstalling + | ProgressCompleted + +progressMessage :: Verbosity -> ProgressPhase -> String -> IO () +progressMessage verbosity phase subject = do + noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n" + where + phaseStr = case phase of + ProgressDownloading -> "Downloading " + ProgressDownloaded -> "Downloaded " + ProgressStarting -> "Starting " + ProgressBuilding -> "Building " + ProgressHaddock -> "Haddock " + ProgressInstalling -> "Installing " + ProgressCompleted -> "Completed " + +cabalInstallVersion :: Version +#ifdef __DOCTEST__ +cabalInstallVersion = mkVersion [3,3] +#else +cabalInstallVersion = mkVersion' Paths_cabal_install.version +#endif diff --git a/src/Distribution/Client/Utils/Json.hs b/src/Distribution/Client/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Utils/Json.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Minimal JSON / RFC 7159 support +-- +-- The API is heavily inspired by @aeson@'s API but puts emphasis on +-- simplicity rather than performance. The 'ToJSON' instances are +-- intended to have an encoding compatible with @aeson@'s encoding. +-- +module Distribution.Client.Utils.Json + ( Value(..) + , Object, object, Pair, (.=) + , encodeToString + , encodeToBuilder + , ToJSON(toJSON) + ) + where + +import Distribution.Client.Compat.Prelude + +import Data.Char (intToDigit) + +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB + +-- TODO: We may want to replace 'String' with 'Text' or 'ByteString' + +-- | A JSON value represented as a Haskell value. +data Value = Object !Object + | Array [Value] + | String String + | Number !Double + | Bool !Bool + | Null + deriving (Eq, Read, Show) + +-- | A key\/value pair for an 'Object' +type Pair = (String, Value) + +-- | A JSON \"object\" (key/value map). +type Object = [Pair] + +infixr 8 .= + +-- | A key-value pair for encoding a JSON object. +(.=) :: ToJSON v => String -> v -> Pair +k .= v = (k, toJSON v) + +-- | Create a 'Value' from a list of name\/value 'Pair's. +object :: [Pair] -> Value +object = Object + +instance IsString Value where + fromString = String + + +-- | A type that can be converted to JSON. +class ToJSON a where + -- | Convert a Haskell value to a JSON-friendly intermediate type. + toJSON :: a -> Value + +instance ToJSON () where + toJSON () = Array [] + +instance ToJSON Value where + toJSON = id + +instance ToJSON Bool where + toJSON = Bool + +instance ToJSON a => ToJSON [a] where + toJSON = Array . map toJSON + +instance ToJSON a => ToJSON (Maybe a) where + toJSON Nothing = Null + toJSON (Just a) = toJSON a + +instance (ToJSON a,ToJSON b) => ToJSON (a,b) where + toJSON (a,b) = Array [toJSON a, toJSON b] + +instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where + toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] + +instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where + toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] + +instance ToJSON Float where + toJSON = Number . realToFrac + +instance ToJSON Double where + toJSON = Number + +instance ToJSON Int where toJSON = Number . realToFrac +instance ToJSON Int8 where toJSON = Number . realToFrac +instance ToJSON Int16 where toJSON = Number . realToFrac +instance ToJSON Int32 where toJSON = Number . realToFrac + +instance ToJSON Word where toJSON = Number . realToFrac +instance ToJSON Word8 where toJSON = Number . realToFrac +instance ToJSON Word16 where toJSON = Number . realToFrac +instance ToJSON Word32 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Int64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Word64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Integer where toJSON = Number . fromInteger + +------------------------------------------------------------------------------ +-- 'BB.Builder'-based encoding + +-- | Serialise value as JSON/UTF8-encoded 'Builder' +encodeToBuilder :: ToJSON a => a -> Builder +encodeToBuilder = encodeValueBB . toJSON + +encodeValueBB :: Value -> Builder +encodeValueBB jv = case jv of + Bool True -> "true" + Bool False -> "false" + Null -> "null" + Number n + | isNaN n || isInfinite n -> encodeValueBB Null + | Just i <- doubleToInt64 n -> BB.int64Dec i + | otherwise -> BB.doubleDec n + Array a -> encodeArrayBB a + String s -> encodeStringBB s + Object o -> encodeObjectBB o + +encodeArrayBB :: [Value] -> Builder +encodeArrayBB [] = "[]" +encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']' + where + go = mconcat . intersperse (BB.char8 ',') . map encodeValueBB + +encodeObjectBB :: Object -> Builder +encodeObjectBB [] = "{}" +encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' + where + go = mconcat . intersperse (BB.char8 ',') . map encPair + encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x + +encodeStringBB :: String -> Builder +encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' + where + go = BB.stringUtf8 . escapeString + +------------------------------------------------------------------------------ +-- 'String'-based encoding + +-- | Serialise value as JSON-encoded Unicode 'String' +encodeToString :: ToJSON a => a -> String +encodeToString jv = encodeValue (toJSON jv) [] + +encodeValue :: Value -> ShowS +encodeValue jv = case jv of + Bool b -> showString (if b then "true" else "false") + Null -> showString "null" + Number n + | isNaN n || isInfinite n -> encodeValue Null + | Just i <- doubleToInt64 n -> shows i + | otherwise -> shows n + Array a -> encodeArray a + String s -> encodeString s + Object o -> encodeObject o + +encodeArray :: [Value] -> ShowS +encodeArray [] = showString "[]" +encodeArray jvs = ('[':) . go jvs . (']':) + where + go [] = id + go [x] = encodeValue x + go (x:xs) = encodeValue x . (',':) . go xs + +encodeObject :: Object -> ShowS +encodeObject [] = showString "{}" +encodeObject jvs = ('{':) . go jvs . ('}':) + where + go [] = id + go [(l,x)] = encodeString l . (':':) . encodeValue x + go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs + +encodeString :: String -> ShowS +encodeString str = ('"':) . showString (escapeString str) . ('"':) + +------------------------------------------------------------------------------ +-- helpers + +-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not +-- representable loss-free as integral 'Int64' value. +doubleToInt64 :: Double -> Maybe Int64 +doubleToInt64 x + | fromInteger x' == x + , x' <= toInteger (maxBound :: Int64) + , x' >= toInteger (minBound :: Int64) + = Just (fromIntegral x') + | otherwise = Nothing + where + x' = round x + +-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings" +escapeString :: String -> String +escapeString s + | not (any needsEscape s) = s + | otherwise = escape s + where + escape [] = [] + escape (x:xs) = case x of + '\\' -> '\\':'\\':escape xs + '"' -> '\\':'"':escape xs + '\b' -> '\\':'b':escape xs + '\f' -> '\\':'f':escape xs + '\n' -> '\\':'n':escape xs + '\r' -> '\\':'r':escape xs + '\t' -> '\\':'t':escape xs + c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs + | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs + | otherwise -> c : escape xs + + -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF + needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] diff --git a/src/Distribution/Client/Utils/Parsec.hs b/src/Distribution/Client/Utils/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Utils/Parsec.hs @@ -0,0 +1,102 @@ +module Distribution.Client.Utils.Parsec ( + renderParseError, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () +import System.FilePath (normalise) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) +import Distribution.Simple.Utils (fromUTF8BS) + +-- | Render parse error highlighting the part of the input file. +renderParseError + :: FilePath + -> BS.ByteString + -> NonEmpty PError + -> [PWarning] + -> String +renderParseError filepath contents errors warnings = unlines $ + [ "Errors encountered when parsing cabal file " <> filepath <> ":" + ] + ++ renderedErrors + ++ renderedWarnings + where + filepath' = normalise filepath + + -- lines of the input file. 'lines' is taken, so they are called rows + -- contents, line number, whether it's empty line + rows :: [(String, Int, Bool)] + rows = zipWith f (BS8.lines contents) [1..] where + f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s) + + rowsZipper = listToZipper rows + + isEmptyOrComment :: String -> Bool + isEmptyOrComment s = case dropWhile (== ' ') s of + "" -> True -- empty + ('-':'-':_) -> True -- comment + _ -> False + + renderedErrors = concatMap renderError errors + renderedWarnings = concatMap renderWarning warnings + + renderError :: PError -> [String] + renderError (PError pos@(Position row col) msg) + -- if position is 0:0, then it doesn't make sense to show input + -- looks like, Parsec errors have line-feed in them + | pos == zeroPos = msgs + | otherwise = msgs ++ formatInput row col + where + msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ] + + renderWarning :: PWarning -> [String] + renderWarning (PWarning _ pos@(Position row col) msg) + | pos == zeroPos = msgs + | otherwise = msgs ++ formatInput row col + where + msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ] + + -- sometimes there are (especially trailing) newlines. + trimLF :: String -> String + trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse + + -- format line: prepend the given line number + formatInput :: Int -> Int -> [String] + formatInput row col = case advance (row - 1) rowsZipper of + Zipper xs ys -> before ++ after where + before = case span (\(_, _, b) -> b) xs of + (_, []) -> [] + (zs, z : _) -> map formatInputLine $ z : reverse zs + + after = case ys of + [] -> [] + (z : _zs) -> + [ formatInputLine z -- error line + , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^ + ] + -- do we need rows after? + -- ++ map formatInputLine (take 1 zs) -- one row after + + formatInputLine :: (String, Int, Bool) -> String + formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str + + -- hopefully we don't need to work with over 99999 lines .cabal files + -- at that point small glitches in error messages are hopefully fine. + leftPadShow :: Int -> String + leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s + +data Zipper a = Zipper [a] [a] + +listToZipper :: [a] -> Zipper a +listToZipper = Zipper [] + +advance :: Int -> Zipper a -> Zipper a +advance n z@(Zipper xs ys) + | n <= 0 = z + | otherwise = case ys of + [] -> z + (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys' diff --git a/src/Distribution/Client/VCS.hs b/src/Distribution/Client/VCS.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/VCS.hs @@ -0,0 +1,642 @@ +{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} +module Distribution.Client.VCS ( + -- * VCS driver type + VCS, + vcsRepoType, + vcsProgram, + -- ** Type re-exports + RepoType, + Program, + ConfiguredProgram, + + -- * Validating 'SourceRepo's and configuring VCS drivers + validatePDSourceRepo, + validateSourceRepo, + validateSourceRepos, + SourceRepoProblem(..), + configureVCS, + configureVCSs, + + -- * Running the VCS driver + cloneSourceRepo, + syncSourceRepos, + + -- * The individual VCS drivers + knownVCSs, + vcsBzr, + vcsDarcs, + vcsGit, + vcsHg, + vcsSvn, + vcsPijul, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Types.SourceRepo + ( RepoType(..), KnownRepoType (..) ) +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) +import Distribution.Client.RebuildMonad + ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) +import Distribution.Verbosity as Verbosity + ( normal ) +import Distribution.Simple.Program + ( Program(programFindVersion) + , ConfiguredProgram(programVersion) + , simpleProgram, findProgramVersion + , ProgramInvocation(..), programInvocation, runProgramInvocation + , emptyProgramDb, requireProgram ) +import Distribution.Version + ( mkVersion ) +import qualified Distribution.PackageDescription as PD + +import Control.Monad.Trans + ( liftIO ) +import qualified Data.Char as Char +import qualified Data.Map as Map +import System.FilePath + ( takeDirectory ) +import System.Directory + ( doesDirectoryExist ) + + +-- | A driver for a version control system, e.g. git, darcs etc. +-- +data VCS program = VCS { + -- | The type of repository this driver is for. + vcsRepoType :: RepoType, + + -- | The vcs program itself. + -- This is used at type 'Program' and 'ConfiguredProgram'. + vcsProgram :: program, + + -- | The program invocation(s) to get\/clone a repository into a fresh + -- local directory. + vcsCloneRepo :: forall f. Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath -- Source URI + -> FilePath -- Destination directory + -> [ProgramInvocation], + + -- | The program invocation(s) to synchronise a whole set of /related/ + -- repositories with corresponding local directories. Also returns the + -- files that the command depends on, for change monitoring. + vcsSyncRepos :: forall f. Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + } + + +-- ------------------------------------------------------------ +-- * Selecting repos and drivers +-- ------------------------------------------------------------ + +data SourceRepoProblem = SourceRepoRepoTypeUnspecified + | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType + | SourceRepoLocationUnspecified + deriving Show + +-- | Validates that the 'SourceRepo' specifies a location URI and a repository +-- type that is supported by a VCS driver. +-- +-- | It also returns the 'VCS' driver we should use to work with it. +-- +validateSourceRepo + :: SourceRepositoryPackage f + -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) +validateSourceRepo = \repo -> do + let rtype = srpType repo + vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype + let uri = srpLocation repo + return (repo, uri, rtype, vcs) + where + a ?! e = maybe (Left e) Right a + +validatePDSourceRepo + :: PD.SourceRepo + -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) +validatePDSourceRepo repo = do + rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified + uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified + validateSourceRepo SourceRepositoryPackage + { srpType = rtype + , srpLocation = uri + , srpTag = PD.repoTag repo + , srpBranch = PD.repoBranch repo + , srpSubdir = PD.repoSubdir repo + , srpCommand = mempty + } + where + a ?! e = maybe (Left e) Right a + + + +-- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return +-- things in a convenient form to pass to 'configureVCSs', or to report +-- problems. +-- +validateSourceRepos :: [SourceRepositoryPackage f] + -> Either [(SourceRepositoryPackage f, SourceRepoProblem)] + [(SourceRepositoryPackage f, String, RepoType, VCS Program)] +validateSourceRepos rs = + case partitionEithers (map validateSourceRepo' rs) of + (problems@(_:_), _) -> Left problems + ([], vcss) -> Right vcss + where + validateSourceRepo' r = either (Left . (,) r) Right + (validateSourceRepo r) + + +configureVCS :: Verbosity + -> VCS Program + -> IO (VCS ConfiguredProgram) +configureVCS verbosity vcs@VCS{vcsProgram = prog} = + asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb + where + asVcsConfigured (prog', _) = vcs { vcsProgram = prog' } + +configureVCSs :: Verbosity + -> Map RepoType (VCS Program) + -> IO (Map RepoType (VCS ConfiguredProgram)) +configureVCSs verbosity = traverse (configureVCS verbosity) + + +-- ------------------------------------------------------------ +-- * Running the driver +-- ------------------------------------------------------------ + +-- | Clone a single source repo into a fresh directory, using a configured VCS. +-- +-- This is for making a new copy, not synchronising an existing copy. It will +-- fail if the destination directory already exists. +-- +-- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first. +-- + +cloneSourceRepo + :: Verbosity + -> VCS ConfiguredProgram + -> SourceRepositoryPackage f + -> [Char] + -> IO () +cloneSourceRepo verbosity vcs + repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir = + traverse_ (runProgramInvocation verbosity) invocations + where + invocations = vcsCloneRepo vcs verbosity + (vcsProgram vcs) repo + srcuri destdir + + +-- | Syncronise a set of 'SourceRepo's referring to the same repository with +-- corresponding local directories. The local directories may or may not +-- already exist. +-- +-- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos', +-- or used across a series of invocations with any local directory must refer +-- to the /same/ repository. That means it must be the same location but they +-- can differ in the branch, or tag or subdir. +-- +-- The reason to allow multiple related 'SourceRepo's is to allow for the +-- network or storage to be shared between different checkouts of the repo. +-- For example if a single repo contains multiple packages in different subdirs +-- and in some project it may make sense to use a different state of the repo +-- for one subdir compared to another. +-- +syncSourceRepos :: Verbosity + -> VCS ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> Rebuild () +syncSourceRepos verbosity vcs repos = do + files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos + monitorFiles files + + +-- ------------------------------------------------------------ +-- * The various VCS drivers +-- ------------------------------------------------------------ + +-- | The set of all supported VCS drivers, organised by 'RepoType'. +-- +knownVCSs :: Map RepoType (VCS Program) +knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ] + where + vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ] + + +-- | VCS driver for Bazaar. +-- +vcsBzr :: VCS Program +vcsBzr = + VCS { + vcsRepoType = KnownRepoType Bazaar, + vcsProgram = bzrProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog + ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ] + where + -- The @get@ command was deprecated in version 2.4 in favour of + -- the alias @branch@ + branchCmd | programVersion prog >= Just (mkVersion [2,4]) + = "branch" + | otherwise = "get" + + tagArgs = case srpTag repo of + Nothing -> [] + Just tag -> ["-r", "tag:" ++ tag] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" + +bzrProgram :: Program +bzrProgram = (simpleProgram "bzr") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff" + (_:_:ver:_) -> ver + _ -> "" + } + + +-- | VCS driver for Darcs. +-- +vcsDarcs :: VCS Program +vcsDarcs = + VCS { + vcsRepoType = KnownRepoType Darcs, + vcsProgram = darcsProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + where + cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg + -- At some point the @clone@ command was introduced as an alias for + -- @get@, and @clone@ seems to be the recommended one now. + cloneCmd | programVersion prog >= Just (mkVersion [2,8]) + = "clone" + | otherwise = "get" + tagArgs = case srpTag repo of + Nothing -> [] + Just tag -> ["-t", tag] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs" + +darcsProgram :: Program +darcsProgram = (simpleProgram "darcs") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "2.8.5 (release)" + (ver:_) -> ver + _ -> "" + } + + +-- | VCS driver for Git. +-- +vcsGit :: VCS Program +vcsGit = + VCS { + vcsRepoType = KnownRepoType Git, + vcsProgram = gitProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + -- And if there's a tag, we have to do that in a second step: + ++ [ (programInvocation prog (checkoutArgs tag)) { + progInvokeCwd = Just destdir + } + | tag <- maybeToList (srpTag repo) ] + where + cloneArgs = ["clone", srcuri, destdir] + ++ branchArgs ++ verboseArg + branchArgs = case srpBranch repo of + Just b -> ["--branch", b] + Nothing -> [] + checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity gitProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + + vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing + sequence_ + [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) + | (repo, localDir) <- secondaryRepos ] + return [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) ] + + vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do + exists <- doesDirectoryExist localDir + if exists + then git localDir ["fetch"] + else git (takeDirectory localDir) cloneArgs + git localDir checkoutArgs + where + git :: FilePath -> [String] -> IO () + git cwd args = runProgramInvocation verbosity $ + (programInvocation gitProg args) { + progInvokeCwd = Just cwd + } + + cloneArgs = ["clone", "--no-checkout", loc, localDir] + ++ case peer of + Nothing -> [] + Just peerLocalDir -> ["--reference", peerLocalDir] + ++ verboseArg + where loc = srpLocation + checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force" + , checkoutTarget, "--" ] + checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + +gitProgram :: Program +gitProgram = (simpleProgram "git") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "git version 2.5.5" + (_:_:ver:_) | all isTypical ver -> ver + + -- or annoyingly "git version 2.17.1.windows.2" yes, really + (_:_:ver:_) -> intercalate "." + . takeWhile (all isNum) + . split + $ ver + _ -> "" + } + where + isNum c = c >= '0' && c <= '9' + isTypical c = isNum c || c == '.' + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest + +-- | VCS driver for Mercurial. +-- +vcsHg :: VCS Program +vcsHg = + VCS { + vcsRepoType = KnownRepoType Mercurial, + vcsProgram = hgProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + where + cloneArgs = ["clone", srcuri, destdir] + ++ branchArgs ++ tagArgs ++ verboseArg + branchArgs = case srpBranch repo of + Just b -> ["--branch", b] + Nothing -> [] + tagArgs = case srpTag repo of + Just t -> ["--rev", t] + Nothing -> [] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg" + +hgProgram :: Program +hgProgram = (simpleProgram "hg") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- Mercurial Distributed SCM (version 3.5.2)\n ... long message + (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver + _ -> "" + } + + +-- | VCS driver for Subversion. +-- +vcsSvn :: VCS Program +vcsSvn = + VCS { + vcsRepoType = KnownRepoType SVN, + vcsProgram = svnProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog _repo srcuri destdir = + [ programInvocation prog checkoutArgs ] + where + checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + --TODO: branch or tag? + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn" + +svnProgram :: Program +svnProgram = (simpleProgram "svn") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- svn, version 1.9.4 (r1740329)\n ... long message + (_:_:ver:_) -> ver + _ -> "" + } + + +-- | VCS driver for Pijul. +-- Documentation for Pijul can be found at +-- +-- 2020-04-09 Oleg: +-- +-- As far as I understand pijul, there are branches and "tags" in pijul, +-- but there aren't a "commit hash" identifying an arbitrary state. +-- +-- One can create `a pijul tag`, which will make a patch hash, +-- which depends on everything currently in the repository. +-- I guess if you try to apply that patch, you'll be forced to apply +-- all the dependencies too. In other words, there are no named tags. +-- +-- It's not clear to me whether there is an option to +-- "apply this patch *and* all of its dependencies". +-- And relatedly, whether how to make sure that there are no other +-- patches applied. +-- +-- With branches it's easier, as you can `pull` and `checkout` them, +-- and they seem to be similar enough. Yet, pijul documentations says +-- +-- > Note that the purpose of branches in Pijul is quite different from Git, +-- since Git's "feature branches" can usually be implemented by just +-- patches. +-- +-- I guess it means that indeed instead of creating a branch and making PR +-- in "GitHub" workflow, you'd just create a patch and offer it. +-- You can do that with `git` too. Push (a branch with) commit to remote +-- and ask other to cherry-pick that commit. Yet, in git identity of commit +-- changes when it applied to other trees, where patches in pijul have +-- will continue to have the same hash. +-- +-- Unfortunately pijul doesn't talk about conflict resolution. +-- It seems that you get something like: +-- +-- % pijul status +-- On branch merge +-- +-- Unresolved conflicts: +-- (fix conflicts and record the resolution with "pijul record ...") +-- +-- foo +-- +-- % cat foo +-- first line +-- >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>> +-- branch BBB +-- ================================ +-- branch AAA +-- <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +-- last line +-- +-- And then the `pijul dependencies` would draw you a graph like +-- +-- +-- -----> foo on branch B -----> +-- resolve confict Initial patch +-- -----> foo on branch A -----> +-- +-- Which is seems reasonable. +-- +-- So currently, pijul support is very experimental, and most likely +-- won't work, even the basics are in place. Tests are also written +-- but disabled, as the branching model differs from `git` one, +-- for which tests are written. +-- +vcsPijul :: VCS Program +vcsPijul = + VCS { + vcsRepoType = KnownRepoType Pijul, + vcsProgram = pijulProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo _verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + -- And if there's a tag, we have to do that in a second step: + ++ [ (programInvocation prog (checkoutArgs tag)) { + progInvokeCwd = Just destdir + } + | tag <- maybeToList (srpTag repo) ] + where + cloneArgs = ["clone", srcuri, destdir] + ++ branchArgs + branchArgs = case srpBranch repo of + Just b -> ["--from-branch", b] + Nothing -> [] + checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity pijulProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + + vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing + sequence_ + [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir) + | (repo, localDir) <- secondaryRepos ] + return [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) ] + + vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do + exists <- doesDirectoryExist localDir + if exists + then pijul localDir ["pull"] -- TODO: this probably doesn't work. + else pijul (takeDirectory localDir) cloneArgs + pijul localDir checkoutArgs + where + pijul :: FilePath -> [String] -> IO () + pijul cwd args = runProgramInvocation verbosity $ + (programInvocation pijulProg args) { + progInvokeCwd = Just cwd + } + + cloneArgs = ["clone", loc, localDir] + ++ case peer of + Nothing -> [] + Just peerLocalDir -> [peerLocalDir] + where loc = srpLocation + checkoutArgs = "checkout" : ["--force", checkoutTarget, "--" ] + checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong. + +pijulProgram :: Program +pijulProgram = (simpleProgram "pijul") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "pijul 0.12.2 + (_:ver:_) | all isTypical ver -> ver + _ -> "" + } + where + isNum c = c >= '0' && c <= '9' + isTypical c = isNum c || c == '.' diff --git a/src/Distribution/Client/Win32SelfUpgrade.hs b/src/Distribution/Client/Win32SelfUpgrade.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Win32SelfUpgrade.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Win32SelfUpgrade +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Support for self-upgrading executables on Windows platforms. +----------------------------------------------------------------------------- +module Distribution.Client.Win32SelfUpgrade ( +-- * Explanation +-- +-- | Windows inherited a design choice from DOS that while initially innocuous +-- has rather unfortunate consequences. It maintains the invariant that every +-- open file has a corresponding name on disk. One positive consequence of this +-- is that an executable can always find its own executable file. The downside +-- is that a program cannot be deleted or upgraded while it is running without +-- hideous workarounds. This module implements one such hideous workaround. +-- +-- The basic idea is: +-- +-- * Move our own exe file to a new name +-- * Copy a new exe file to the previous name +-- * Run the new exe file, passing our own PID and new path +-- * Wait for the new process to start +-- * Close the new exe file +-- * Exit old process +-- +-- Then in the new process: +-- +-- * Inform the old process that we've started +-- * Wait for the old process to die +-- * Delete the old exe file +-- * Exit new process +-- + + possibleSelfUpgrade, + deleteOldExeFile, + ) where + +import Distribution.Client.Compat.Prelude hiding (log) +import Prelude () + +#ifdef mingw32_HOST_OS + +import qualified System.Win32 as Win32 +import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) +import Foreign.Ptr (Ptr, nullPtr) +import System.Process (runProcess) +import System.Directory (canonicalizePath) +import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) + +import Distribution.Verbosity as Verbosity (showForCabal) +import Distribution.Simple.Utils (debug, info) + + +-- | If one of the given files is our own exe file then we arrange things such +-- that the nested action can replace our own exe file. +-- +-- We require that the new process accepts a command line invocation that +-- calls 'deleteOldExeFile', passing in the PID and exe file. +-- +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade verbosity newPaths action = do + dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE + + newPaths' <- traverse canonicalizePath newPaths + let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' + + if not doingSelfUpgrade + then action + else do + info verbosity $ "cabal-install does the replace-own-exe-file dance..." + tmpPath <- moveOurExeOutOfTheWay verbosity + result <- action + scheduleOurDemise verbosity dstPath tmpPath + (\pid path -> ["win32selfupgrade", pid, path + ,"--verbose=" ++ Verbosity.showForCabal verbosity]) + return result + +-- | The name of a Win32 Event object that we use to synchronise between the +-- old and new processes. We need to synchronise to make sure that the old +-- process has not yet terminated by the time the new one starts up and looks +-- for the old process. Otherwise the old one might have already terminated +-- and we could not wait on it terminating reliably (eg the PID might get +-- re-used). +-- +syncEventName :: String +syncEventName = "Local\\cabal-install-upgrade" + +-- | The first part of allowing our exe file to be replaced is to move the +-- existing exe file out of the way. Although we cannot delete our exe file +-- while we're still running, fortunately we can rename it, at least within +-- the same directory. +-- +moveOurExeOutOfTheWay :: Verbosity -> IO FilePath +moveOurExeOutOfTheWay verbosity = do + ourPID <- getCurrentProcessId + dstPath <- Win32.getModuleFileName Win32.nullHANDLE + + let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) + + debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath + Win32.moveFile dstPath tmpPath + return tmpPath + +-- | Assuming we've now installed the new exe file in the right place, we +-- launch it and ask it to delete our exe file when we eventually terminate. +-- +scheduleOurDemise :: Verbosity -> FilePath -> FilePath + -> (String -> FilePath -> [String]) -> IO () +scheduleOurDemise verbosity dstPath tmpPath mkArgs = do + ourPID <- getCurrentProcessId + event <- createEvent syncEventName + + let args = mkArgs (show ourPID) tmpPath + log $ "launching child " ++ unwords (dstPath : map show args) + _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing + + log $ "waiting for the child to start up" + waitForSingleObject event (10*1000) -- wait at most 10 sec + log $ "child started ok" + + where + log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) + +-- | Assuming we're now in the new child process, we've been asked by the old +-- process to wait for it to terminate and then we can remove the old exe file +-- that it renamed itself to. +-- +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile verbosity oldPID tmpPath = do + log $ "process started. Will delete exe file of process " + ++ show oldPID ++ " at path " ++ tmpPath + + log $ "getting handle of parent process " ++ show oldPID + oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID) + + log $ "synchronising with parent" + event <- openEvent syncEventName + setEvent event + + log $ "waiting for parent process to terminate" + waitForSingleObject oldPHANDLE Win32.iNFINITE + log $ "parent process terminated" + + log $ "deleting parent's old .exe file" + Win32.deleteFile tmpPath + + where + log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) + +------------------------ +-- Win32 foreign imports +-- + +-- A bunch of functions sadly not provided by the Win32 package. + +#ifdef x86_64_HOST_ARCH +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif + +foreign import CALLCONV unsafe "windows.h GetCurrentProcessId" + getCurrentProcessId :: IO DWORD + +foreign import CALLCONV unsafe "windows.h WaitForSingleObject" + waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD + +waitForSingleObject :: HANDLE -> DWORD -> IO () +waitForSingleObject handle timeout = + Win32.failIf_ bad "WaitForSingleObject" $ + waitForSingleObject_ handle timeout + where + bad result = not (result == 0 || result == wAIT_TIMEOUT) + wAIT_TIMEOUT = 0x00000102 + +foreign import CALLCONV unsafe "windows.h CreateEventW" + createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE + +createEvent :: String -> IO HANDLE +createEvent name = do + Win32.failIfNull "CreateEvent" $ + Win32.withTString name $ + createEvent_ nullPtr False False + +foreign import CALLCONV unsafe "windows.h OpenEventW" + openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +openEvent :: String -> IO HANDLE +openEvent name = do + Win32.failIfNull "OpenEvent" $ + Win32.withTString name $ + openEvent_ eVENT_MODIFY_STATE False + where + eVENT_MODIFY_STATE :: DWORD + eVENT_MODIFY_STATE = 0x0002 + +foreign import CALLCONV unsafe "windows.h SetEvent" + setEvent_ :: HANDLE -> IO BOOL + +setEvent :: HANDLE -> IO () +setEvent handle = + Win32.failIfFalse_ "SetEvent" $ + setEvent_ handle + +#else + +import Distribution.Simple.Utils (die') + +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade _ _ action = action + +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32" + +#endif diff --git a/src/Distribution/Client/World.hs b/src/Distribution/Client/World.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/World.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.World +-- Copyright : (c) Peter Robinson 2009 +-- License : BSD-like +-- +-- Maintainer : thaldyron@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Interface to the world-file that contains a list of explicitly +-- requested packages. Meant to be imported qualified. +-- +-- A world file entry stores the package-name, package-version, and +-- user flags. +-- For example, the entry generated by +-- # cabal install stm-io-hooks --flags="-debug" +-- looks like this: +-- # stm-io-hooks -any --flags="-debug" +-- To rebuild/upgrade the packages in world (e.g. when updating the compiler) +-- use +-- # cabal install world +-- +----------------------------------------------------------------------------- +module Distribution.Client.World ( + WorldPkgInfo(..), + insert, + delete, + getContents, + ) where + +import Prelude (sequence) +import Distribution.Client.Compat.Prelude hiding (getContents) + +import Distribution.Types.Dependency +import Distribution.Types.Flag + ( FlagAssignment, unFlagAssignment + , unFlagName, parsecFlagAssignmentNonEmpty ) +import Distribution.Simple.Utils + ( die', info, chattyTry, writeFileAtomic ) +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +import Data.List + ( unionBy, deleteFirstsBy ) +import System.IO.Error + ( isDoesNotExistError ) +import qualified Data.ByteString.Lazy.Char8 as B + + +data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment + deriving (Show,Eq, Generic) + +-- | Adds packages to the world file; creates the file if it doesn't +-- exist yet. Version constraints and flag assignments for a package are +-- updated if already present. IO errors are non-fatal. +insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () +insert = modifyWorld $ unionBy equalUDep + +-- | Removes packages from the world file. +-- Note: Currently unused as there is no mechanism in Cabal (yet) to +-- handle uninstalls. IO errors are non-fatal. +delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () +delete = modifyWorld $ flip (deleteFirstsBy equalUDep) + +-- | WorldPkgInfo values are considered equal if they refer to +-- the same package, i.e., we don't care about differing versions or flags. +equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool +equalUDep (WorldPkgInfo (Dependency pkg1 _ _) _) + (WorldPkgInfo (Dependency pkg2 _ _) _) = pkg1 == pkg2 + +-- | Modifies the world file by applying an update-function ('unionBy' +-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of +-- packages. IO errors are considered non-fatal. +modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo] + -> [WorldPkgInfo]) + -- ^ Function that defines how + -- the list of user packages are merged with + -- existing world packages. + -> Verbosity + -> FilePath -- ^ Location of the world file + -> [WorldPkgInfo] -- ^ list of user supplied packages + -> IO () +modifyWorld _ _ _ [] = return () +modifyWorld f verbosity world pkgs = + chattyTry "Error while updating world-file. " $ do + pkgsOldWorld <- getContents verbosity world + -- Filter out packages that are not in the world file: + let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld + -- 'Dependency' is not an Ord instance, so we need to check for + -- equivalence the awkward way: + if not (all (`elem` pkgsOldWorld) pkgsNewWorld && + all (`elem` pkgsNewWorld) pkgsOldWorld) + then do + info verbosity "Updating world file..." + writeFileAtomic world . B.pack $ unlines + [ (prettyShow pkg) | pkg <- pkgsNewWorld] + else + info verbosity "World file is already up to date." + + +-- | Returns the content of the world file as a list +getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo] +getContents verbosity world = do + content <- safelyReadFile world + let result = map simpleParsec (lines $ B.unpack content) + case sequence result of + Nothing -> die' verbosity "Could not parse world file." + Just xs -> return xs + where + safelyReadFile :: FilePath -> IO B.ByteString + safelyReadFile file = B.readFile file `catchIO` handler + where + handler e | isDoesNotExistError e = return B.empty + | otherwise = ioError e + + +instance Pretty WorldPkgInfo where + pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags) + where + dispFlags [] = Disp.empty + dispFlags fs = Disp.text "--flags=" + <<>> Disp.doubleQuotes (flagAssToDoc fs) + flagAssToDoc = foldr (\(fname,val) flagAssDoc -> + (if not val then Disp.char '-' + else Disp.char '+') + <<>> Disp.text (unFlagName fname) + Disp.<+> flagAssDoc) + Disp.empty + +instance Parsec WorldPkgInfo where + parsec = do + dep <- parsec + P.spaces + flagAss <- P.option mempty parseFlagAssignment + return $ WorldPkgInfo dep flagAss + where + parseFlagAssignment :: CabalParsing m => m FlagAssignment + parseFlagAssignment = do + _ <- P.string "--flags=" + inDoubleQuotes parsecFlagAssignmentNonEmpty + where + inDoubleQuotes = P.between (P.char '"') (P.char '"') diff --git a/src/Distribution/Deprecated/ParseUtils.hs b/src/Distribution/Deprecated/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Deprecated/ParseUtils.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Deprecated.ParseUtils +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. +-- +-- The @.cabal@ file format is not trivial, especially with the introduction +-- of configurations and the section syntax that goes with that. This module +-- has a bunch of parsing functions that is used by the @.cabal@ parser and a +-- couple others. It has the parsing framework code and also little parsers for +-- many of the formats we get in various @.cabal@ file fields, like module +-- names, comma separated lists etc. + +-- This module is meant to be local-only to Distribution... + +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE Rank2Types #-} +module Distribution.Deprecated.ParseUtils ( + LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, + runP, runE, ParseResult(..), parseFail, showPWarning, + Field(..), lineNo, + FieldDescr(..), readFields, + parseHaskellString, parseTokenQ, + parseOptCommaList, + showFilePath, showToken, showFreeText, + field, simpleField, listField, listFieldWithSep, spaceListField, + newLineListField, + liftField, + readPToMaybe, + + fieldParsec, simpleFieldParsec, + listFieldParsec, + commaListFieldParsec, + commaNewLineListFieldParsec, + + UnrecFieldParser, + ) where + +import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Deprecated.ReadP as ReadP hiding (get) + +import Distribution.Pretty +import Distribution.ReadE +import Distribution.Utils.Generic + +import System.FilePath (normalise) +import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep) +import qualified Text.Read as Read + +import qualified Control.Monad.Fail as Fail +import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList) + +import qualified Data.ByteString as BS +import qualified Distribution.Fields as Fields +import qualified Distribution.Fields.Field as Fields +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Fields.LexerMonad as Fields +import qualified Text.Parsec.Error as PE +import qualified Text.Parsec.Pos as PP + +-- ----------------------------------------------------------------------------- + +type LineNo = Int + +data PError = AmbiguousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving (Eq, Show) + +data PWarning = PWarning String + | UTFWarning LineNo String + deriving (Eq, Show) + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning msg) = + normalise fpath ++ ": " ++ msg +showPWarning fpath (UTFWarning line fname) = + normalise fpath ++ ":" ++ show line + ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." + +data ParseResult a = ParseFailed PError | ParseOk [PWarning] a + deriving Show + +instance Functor ParseResult where + fmap _ (ParseFailed err) = ParseFailed err + fmap f (ParseOk ws x) = ParseOk ws $ f x + +instance Applicative ParseResult where + pure = ParseOk [] + (<*>) = ap + + +instance Monad ParseResult where + return = pure + ParseFailed err >>= _ = ParseFailed err + ParseOk ws x >>= f = case f x of + ParseFailed err -> ParseFailed err + ParseOk ws' x' -> ParseOk (ws'++ws) x' + +#if !(MIN_VERSION_base(4,9,0)) + fail = parseResultFail +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail ParseResult where + fail = parseResultFail + +parseResultFail :: String -> ParseResult a +parseResultFail s = parseFail (FromString s Nothing) + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + +runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a +runP line fieldname p s = + case [ x | (x,"") <- results ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + --TODO: what is this double parse thing all about? + -- Can't we just do the all isSpace test the first time? + [] -> case [ x | (x,ys) <- results, all isSpace ys ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + where results = readP_to_S p s + +runE :: LineNo -> String -> ReadE a -> String -> ParseResult a +runE line fieldname p s = + case runReadE p s of + Right a -> ParseOk (utf8Warnings line fieldname s) a + Left e -> syntaxError line $ + "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s + +utf8Warnings :: LineNo -> String -> String -> [PWarning] +utf8Warnings line fieldname s = + take 1 [ UTFWarning n fieldname + | (n,l) <- zip [line..] (lines s) + , '\xfffd' `elem` l ] + +locatedErrorMsg :: PError -> (Maybe LineNo, String) +locatedErrorMsg (AmbiguousParse f n) = (Just n, + "Ambiguous parse in field '"++f++"'.") +locatedErrorMsg (NoParse f n) = (Just n, + "Parse of field '"++f++"' failed.") +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") +locatedErrorMsg (FromString s n) = (n, s) + +syntaxError :: LineNo -> String -> ParseResult a +syntaxError n s = ParseFailed $ FromString s (Just n) + + +warning :: String -> ParseResult () +warning s = ParseOk [PWarning s] () + +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr + { fieldName :: String + , fieldGet :: a -> Doc + , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } + +field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) + +fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a +fieldParsec name showF readF = + FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of + Left err -> ParseFailed (FromString err (Just line)) + Right x -> ParseOk [] x + +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (showF . get) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) + +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> ReadP a a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF + +simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleFieldParsec name showF readF get set + = liftField get set $ fieldParsec name showF readF + +commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListFieldWithSepParsec separator name showF readF get set = + liftField get set' $ + fieldParsec name showF' (parsecLeadingCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . punctuate comma . map showF + +commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListFieldParsec = commaListFieldWithSepParsec fsep + +commaNewLineListFieldParsec + :: String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaNewLineListFieldParsec = commaListFieldWithSepParsec sep + +spaceListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField name showF readF get set = + liftField get set' $ + field name showF' (parseSpaceList readF) + where + set' xs b = set (get b ++ xs) b + showF' = fsep . map showF + +-- this is a different definition from listField, like +-- commaNewLineListField it pretty prints on multiple lines +newLineListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +newLineListField = listFieldWithSep sep + +listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldWithSep separator name showF readF get set = + liftField get set' $ + field name showF' (parseOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . map showF + +listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldWithSepParsec separator name showF readF get set = + liftField get set' $ + fieldParsec name showF' (parsecLeadingOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . map showF + +listField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField = listFieldWithSep fsep + +listFieldParsec + :: String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldParsec = listFieldWithSepParsec fsep + +-- | The type of a function which, given a name-value pair of an +-- unrecognized field, and the current structure being built, +-- decides whether to incorporate the unrecognized field +-- (by returning Just x, where x is a possibly modified version +-- of the structure being built), or not (by returning Nothing). +type UnrecFieldParser a = (String,String) -> a -> Maybe a + +------------------------------------------------------------------------------ + +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing + +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n + +readFields :: BS.ByteString -> ParseResult [Field] +readFields input = case Fields.readFields' input of + Right (fs, ws) -> ParseOk + [ PWarning msg | Fields.PWarning _ _ msg <- Fields.toPWarnings ws ] + (legacyFields fs) + Left perr -> ParseFailed $ NoParse + (PE.showErrorMessages + "or" "unknown parse error" "expecting" "unexpected" "end of file" + (PE.errorMessages perr)) + (PP.sourceLine pos) + where + pos = PE.errorPos perr + +legacyFields :: [Fields.Field Parsec.Position] -> [Field] +legacyFields = map legacyField + +legacyField :: Fields.Field Parsec.Position -> Field +legacyField (Fields.Field (Fields.Name pos name) fls) = + F (posToLineNo pos) (fromUTF8BS name) (Fields.fieldLinesToString fls) +legacyField (Fields.Section (Fields.Name pos name) args fs) = + Section (posToLineNo pos) (fromUTF8BS name) (Fields.sectionArgsToString args) (legacyFields fs) + +posToLineNo :: Parsec.Position -> LineNo +posToLineNo (Parsec.Position row _) = row + +------------------------------------------------------------------------------ + +-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a +-- because the "compat" version of ReadP isn't quite powerful enough. In +-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a +-- Hence the trick above to make 'lic' polymorphic. + +-- Different than the naive version. it turns out Read instance for String accepts +-- the ['a', 'b'] syntax, which we do not want. In particular it messes +-- up any token starting with []. +parseHaskellString :: ReadP r String +parseHaskellString = + readS_to_P $ + Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0 + +parseTokenQ :: ReadP r String +parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') + +parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSpaceList p = sepBy p skipSpaces + +-- This version avoid parse ambiguity for list element parsers +-- that have multiple valid parses of prefixes. +parseOptCommaList :: ReadP r a -> ReadP r [a] +parseOptCommaList p = sepBy p localSep + where + -- The separator must not be empty or it introduces ambiguity + localSep = (skipSpaces >> char ',' >> skipSpaces) + +++ (satisfy isSpace >> skipSpaces) + +readPToMaybe :: ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str + , all isSpace s ] diff --git a/src/Distribution/Deprecated/ReadP.hs b/src/Distribution/Deprecated/ReadP.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Deprecated/ReadP.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- +-- Module : Distribution.Deprecated.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is a library of parser combinators, originally written by Koen Claessen. +-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with +-- other parsers. The '(+++)' choice combinator is genuinely commutative; +-- it makes no difference which branch is \"shorter\". +-- +-- See also Koen's paper /Parallel Parsing Processes/ +-- (). +-- +-- This version of ReadP has been locally hacked to make it H98, by +-- Martin Sjögren +-- +-- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by +-- Mark Lentczner +----------------------------------------------------------------------------- + +module Distribution.Deprecated.ReadP + ( + -- * The 'ReadP' type + ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus + + -- * Primitive operations + get, -- :: ReadP Char + look, -- :: ReadP String + (+++), -- :: ReadP a -> ReadP a -> ReadP a + (<++), -- :: ReadP a -> ReadP a -> ReadP a + gather, -- :: ReadP a -> ReadP (String, a) + + -- * Other operations + pfail, -- :: ReadP a + eof, -- :: ReadP () + satisfy, -- :: (Char -> Bool) -> ReadP Char + char, -- :: Char -> ReadP Char + string, -- :: String -> ReadP String + munch, -- :: (Char -> Bool) -> ReadP String + munch1, -- :: (Char -> Bool) -> ReadP String + skipSpaces, -- :: ReadP () + skipSpaces1,-- :: ReadP () + choice, -- :: [ReadP a] -> ReadP a + count, -- :: Int -> ReadP a -> ReadP [a] + between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a + option, -- :: a -> ReadP a -> ReadP a + optional, -- :: ReadP a -> ReadP () + many, -- :: ReadP a -> ReadP [a] + many1, -- :: ReadP a -> ReadP [a] + skipMany, -- :: ReadP a -> ReadP () + skipMany1, -- :: ReadP a -> ReadP () + sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] + + -- * Running a parser + ReadS, -- :: *; = String -> [(a,String)] + readP_to_S, -- :: ReadP a -> ReadS a + readS_to_P, -- :: ReadS a -> ReadP a + readP_to_E, + + -- ** Internal + Parser, + ) + where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (many, get) + +import Control.Monad( replicateM, (>=>) ) + +import qualified Control.Monad.Fail as Fail + +import Distribution.ReadE (ReadE (..)) + +infixr 5 +++, <++ + +-- --------------------------------------------------------------------------- +-- The P type +-- is representation type -- should be kept abstract + +data P s a + = Get (s -> P s a) + | Look ([s] -> P s a) + | Fail + | Result a (P s a) + | Final [(a,[s])] -- invariant: list is non-empty! + +-- Monad, MonadPlus + +instance Functor (P s) where + fmap = liftM + +instance Applicative (P s) where + pure x = Result x Fail + (<*>) = ap + +instance Monad (P s) where + return = pure + + (Get f) >>= k = Get (f >=> k) + (Look f) >>= k = Look (f >=> k) + Fail >>= _ = Fail + (Result x p) >>= k = k x `mplus` (p >>= k) + (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] + +#if !(MIN_VERSION_base(4,9,0)) + fail _ = Fail +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail (P s) where + fail _ = Fail + +instance Alternative (P s) where + empty = mzero + (<|>) = mplus + +instance MonadPlus (P s) where + mzero = Fail + + -- most common case: two gets are combined + Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) + + -- results are delivered as soon as possible + Result x p `mplus` q = Result x (p `mplus` q) + p `mplus` Result x q = Result x (p `mplus` q) + + -- fail disappears + Fail `mplus` p = p + p `mplus` Fail = p + + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + Final r `mplus` Final t = Final (r ++ t) + Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) + Final r `mplus` p = Look (\s -> Final (r ++ run p s)) + Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) + p `mplus` Final r = Look (\s -> Final (run p s ++ r)) + + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + Look f `mplus` Look g = Look (\s -> f s `mplus` g s) + Look f `mplus` p = Look (\s -> f s `mplus` p) + p `mplus` Look f = Look (\s -> p `mplus` f s) + +-- --------------------------------------------------------------------------- +-- The ReadP type + +newtype Parser r s a = R ((a -> P s r) -> P s r) +type ReadP r a = Parser r Char a + +-- Functor, Monad, MonadPlus + +instance Functor (Parser r s) where + fmap h (R f) = R (\k -> f (k . h)) + +instance Applicative (Parser r s) where + pure x = R (\k -> k x) + (<*>) = ap + +instance s ~ Char => Alternative (Parser r s) where + empty = pfail + (<|>) = (+++) + +instance Monad (Parser r s) where + return = pure + R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) + +#if !(MIN_VERSION_base(4,9,0)) + fail _ = R (const Fail) +#elif !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail (Parser r s) where + fail _ = R (const Fail) + +instance s ~ Char => MonadPlus (Parser r s) where + mzero = pfail + mplus = (+++) + +-- --------------------------------------------------------------------------- +-- Operations over P + +final :: [(a,[s])] -> P s a +-- Maintains invariant for Final constructor +final [] = Fail +final r = Final r + +run :: P c a -> ([c] -> [(a, [c])]) +run (Get f) (c:s) = run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = (x,s) : run p s +run (Final r) _ = r +run _ _ = [] + +-- --------------------------------------------------------------------------- +-- Operations over ReadP + +get :: ReadP r Char +-- ^ Consumes and returns the next character. +-- Fails if there is no input left. +get = R Get + +look :: ReadP r String +-- ^ Look-ahead: returns the part of the input that is left, without +-- consuming it. +look = R Look + +pfail :: ReadP r a +-- ^ Always fails. +pfail = R (const Fail) + +eof :: ReadP r () +-- ^ Succeeds iff we are at the end of input +eof = do { s <- look + ; if null s then return () + else pfail } + +(+++) :: ReadP r a -> ReadP r a -> ReadP r a +-- ^ Symmetric choice. +R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) + +(<++) :: ReadP a a -> ReadP r a -> ReadP r a +-- ^ Local, exclusive, left-biased choice: If left parser +-- locally produces any result at all, then right parser is +-- not used. +R f <++ q = + do s <- look + probe (f return) s 0 + where + probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) + probe (Look f') s n = probe (f' s) s n + probe p@(Result _ _) _ n = discard n >> R (p >>=) + probe (Final r) _ _ = R (Final r >>=) + probe _ _ _ = q + + discard 0 = return () + discard n = get >> discard (n-1 :: Int) + +gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) +-- ^ Transforms a parser into one that does the same, but +-- in addition returns the exact characters read. +-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument +-- is built using any occurrences of readS_to_P. +gather (R m) = + R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) + where + gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) + gath _ Fail = Fail + gath l (Look f) = Look (gath l . f) + gath l (Result k p) = k (l []) `mplus` gath l p + gath _ (Final _) = error "do not use readS_to_P in gather!" + +-- --------------------------------------------------------------------------- +-- Derived operations + +satisfy :: (Char -> Bool) -> ReadP r Char +-- ^ Consumes and returns the next character, if it satisfies the +-- specified predicate. +satisfy p = do c <- get; if p c then return c else pfail + +char :: Char -> ReadP r Char +-- ^ Parses and returns the specified character. +char c = satisfy (c ==) + +string :: String -> ReadP r String +-- ^ Parses and returns the specified string. +string this = do s <- look; scan this s + where + scan [] _ = return this + scan (x:xs) (y:ys) | x == y = get >> scan xs ys + scan _ _ = pfail + +munch :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first zero or more characters satisfying the predicate. +munch p = + do s <- look + scan s + where + scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) + scan _ = do return "" + +munch1 :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first one or more characters satisfying the predicate. +munch1 p = + do c <- get + if p c then do s <- munch p; return (c:s) + else pfail + +choice :: [ReadP r a] -> ReadP r a +-- ^ Combines all parsers in the specified list. +choice [] = pfail +choice [p] = p +choice (p:ps) = p +++ choice ps + +skipSpaces :: ReadP r () +-- ^ Skips all whitespace. +skipSpaces = + do s <- look + skip s + where + skip (c:s) | isSpace c = do _ <- get; skip s + skip _ = do return () + +skipSpaces1 :: ReadP r () +-- ^ Like 'skipSpaces' but succeeds only if there is at least one +-- whitespace character to skip. +skipSpaces1 = satisfy isSpace >> skipSpaces + +count :: Int -> ReadP r a -> ReadP r [a] +-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of +-- results is returned. +count n p = replicateM n p + +between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a +-- ^ @ between open close p @ parses @open@, followed by @p@ and finally +-- @close@. Only the value of @p@ is returned. +between open close p = do _ <- open + x <- p + _ <- close + return x + +option :: a -> ReadP r a -> ReadP r a +-- ^ @option x p@ will either parse @p@ or return @x@ without consuming +-- any input. +option x p = p +++ return x + +optional :: ReadP r a -> ReadP r () +-- ^ @optional p@ optionally parses @p@ and always returns @()@. +optional p = (p >> return ()) +++ return () + +many :: ReadP r a -> ReadP r [a] +-- ^ Parses zero or more occurrences of the given parser. +many p = return [] +++ many1 p + +many1 :: ReadP r a -> ReadP r [a] +-- ^ Parses one or more occurrences of the given parser. +many1 p = liftM2 (:) p (many p) + +skipMany :: ReadP r a -> ReadP r () +-- ^ Like 'many', but discards the result. +skipMany p = many p >> return () + +skipMany1 :: ReadP r a -> ReadP r () +-- ^ Like 'many1', but discards the result. +skipMany1 p = p >> skipMany p + +sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy p sep = sepBy1 p sep +++ return [] + +sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy1 p sep = liftM2 (:) p (many (sep >> p)) + +endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended +-- by @sep@. +endBy p sep = many (do x <- p ; _ <- sep ; return x) + +endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended +-- by @sep@. +endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) + +chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /right/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainr p op x = chainr1 p op +++ return x + +chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /left/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainl p op x = chainl1 p op +++ return x + +chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainr', but parses one or more occurrences of @p@. +chainr1 p op = scan + where scan = p >>= rest + rest x = do f <- op + y <- scan + return (f x y) + +++ return x + +chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainl', but parses one or more occurrences of @p@. +chainl1 p op = p >>= rest + where rest x = do f <- op + y <- p + rest (f x y) + +++ return x + +manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] +-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ +-- succeeds. Returns a list of values returned by @p@. +manyTill p end = scan + where scan = (end >> return []) <++ (liftM2 (:) p scan) + +-- --------------------------------------------------------------------------- +-- Converting between ReadP and Read + +readP_to_S :: ReadP a a -> ReadS a +-- ^ Converts a parser into a Haskell ReadS-style function. +-- This is the main way in which you can \"run\" a 'ReadP' parser: +-- the expanded type is +-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ +readP_to_S (R f) = run (f return) + +readS_to_P :: ReadS a -> ReadP r a +-- ^ Converts a Haskell ReadS-style function into a parser. +-- Warning: This introduces local backtracking in the resulting +-- parser, and therefore a possible inefficiency. +readS_to_P r = + R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) + +------------------------------------------------------------------------------- +-- ReadE +------------------------------------------------------------------------------- + +readP_to_E :: (String -> String) -> ReadP a a -> ReadE a +readP_to_E err r = + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt + , all isSpace s ] + of [] -> Left (err txt) + (p:_) -> Right p diff --git a/src/Distribution/Deprecated/ViewAsFieldDescr.hs b/src/Distribution/Deprecated/ViewAsFieldDescr.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -0,0 +1,84 @@ +module Distribution.Deprecated.ViewAsFieldDescr ( + viewAsFieldDescr + ) where + +import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () + +import qualified Data.List.NonEmpty as NE +import Distribution.ReadE (parsecToReadE) +import Distribution.Simple.Command +import Text.PrettyPrint (cat, comma, punctuate, text) +import Text.PrettyPrint as PP (empty) + +import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError) + +-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > +-- Choice > Opt) and consider only the first one. +viewAsFieldDescr :: OptionField a -> FieldDescr a +viewAsFieldDescr (OptionField _n []) = + error "Distribution.command.viewAsFieldDescr: unexpected" +viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set + + where + optDescr = head $ NE.sortBy cmp (d:|dd) + + cmp :: OptDescr a -> OptDescr a -> Ordering + ReqArg{} `cmp` ReqArg{} = EQ + ReqArg{} `cmp` _ = GT + BoolOpt{} `cmp` ReqArg{} = LT + BoolOpt{} `cmp` BoolOpt{} = EQ + BoolOpt{} `cmp` _ = GT + ChoiceOpt{} `cmp` ReqArg{} = LT + ChoiceOpt{} `cmp` BoolOpt{} = LT + ChoiceOpt{} `cmp` ChoiceOpt{} = EQ + ChoiceOpt{} `cmp` _ = GT + OptArg{} `cmp` OptArg{} = EQ + OptArg{} `cmp` _ = LT + +-- get :: a -> Doc + get t = case optDescr of + ReqArg _ _ _ _ ppr -> + (cat . punctuate comma . map text . ppr) t + + OptArg _ _ _ _ _ ppr -> + case ppr t of [] -> PP.empty + (Nothing : _) -> text "True" + (Just a : _) -> text a + + ChoiceOpt alts -> + fromMaybe PP.empty $ listToMaybe + [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] + + BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t + +-- set :: LineNo -> String -> a -> ParseResult a + set line val a = + case optDescr of + ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val + -- We parse for a single value instead of a + -- list, as one can't really implement + -- parseList :: ReadE a -> ReadE [a] with + -- the current ReadE definition + ChoiceOpt{} -> + case getChoiceByLongFlag optDescr val of + Just f -> return (f a) + _ -> syntaxError line val + + BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("" ++) parsec) val + + OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val + -- Optional arguments are parsed just like + -- required arguments here; we don't + -- provide a method to set an OptArg field + -- to the default value. + +getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a) +getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe + [ set | (_,(_sf,lf:_), set, _) <- alts + , lf == val] + +getChoiceByLongFlag _ _ = + error "Distribution.command.getChoiceByLongFlag: expected a choice option" + + diff --git a/tests/IntegrationTests2/build/keep-going/cabal.project b/tests/IntegrationTests2/build/keep-going/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/build/keep-going/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: p q diff --git a/tests/IntegrationTests2/build/keep-going/p/P.hs b/tests/IntegrationTests2/build/keep-going/p/P.hs deleted file mode 100644 --- a/tests/IntegrationTests2/build/keep-going/p/P.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/build/keep-going/p/p.cabal +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/build/keep-going/q/Q.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/build/keep-going/q/q.cabal +++ /dev/null @@ -1,9 +0,0 @@ -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/local-tarball/cabal.project b/tests/IntegrationTests2/build/local-tarball/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/build/local-tarball/cabal.project +++ /dev/null @@ -1,2 +0,0 @@ -packages: p-0.1.tar.gz - q/ diff --git a/tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz b/tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz deleted file mode 100644 Binary files a/tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz and /dev/null differ diff --git a/tests/IntegrationTests2/build/local-tarball/q/Q.hs b/tests/IntegrationTests2/build/local-tarball/q/Q.hs deleted file mode 100644 --- a/tests/IntegrationTests2/build/local-tarball/q/Q.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Q where - -import P - -q = p ++ " world" diff --git a/tests/IntegrationTests2/build/local-tarball/q/q.cabal b/tests/IntegrationTests2/build/local-tarball/q/q.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/build/local-tarball/q/q.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: q -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: Q - build-depends: base, p diff --git a/tests/IntegrationTests2/build/setup-custom1/A.hs b/tests/IntegrationTests2/build/setup-custom1/A.hs deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-custom1/A.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-custom1/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-custom1/a.cabal +++ /dev/null @@ -1,13 +0,0 @@ -name: a -version: 0.1 -build-type: Custom -cabal-version: >= 1.10 - --- explicit setup deps: -custom-setup - setup-depends: base, Cabal >= 1.18 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests2/build/setup-custom2/A.hs b/tests/IntegrationTests2/build/setup-custom2/A.hs deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-custom2/A.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-custom2/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-custom2/a.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: a -version: 0.1 -build-type: Custom -cabal-version: >= 1.10 - --- no explicit setup deps - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests2/build/setup-simple/A.hs b/tests/IntegrationTests2/build/setup-simple/A.hs deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-simple/A.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-simple/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/tests/IntegrationTests2/build/setup-simple/a.cabal b/tests/IntegrationTests2/build/setup-simple/a.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/build/setup-simple/a.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: a -version: 0.1 -build-type: Simple -cabal-version: >= 1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests2/exception/bad-config/cabal.project b/tests/IntegrationTests2/exception/bad-config/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/exception/bad-config/cabal.project +++ /dev/null @@ -1,4 +0,0 @@ -packages: - -package foo - ghc-location: bar diff --git a/tests/IntegrationTests2/exception/build/Main.hs b/tests/IntegrationTests2/exception/build/Main.hs deleted file mode 100644 --- a/tests/IntegrationTests2/exception/build/Main.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = thisNameDoesNotExist diff --git a/tests/IntegrationTests2/exception/build/a.cabal b/tests/IntegrationTests2/exception/build/a.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/exception/build/a.cabal +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/exception/configure/a.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: a -version: 1 -build-type: Simple --- This used to be a blank package with no components, --- but I refactored new-build so that if a package has --- no buildable components, we skip configuring it. --- So put in a (failing) component so that we try to --- configure. -executable a diff --git a/tests/IntegrationTests2/exception/no-pkg/empty.in b/tests/IntegrationTests2/exception/no-pkg/empty.in deleted file mode 100644 --- a/tests/IntegrationTests2/exception/no-pkg/empty.in +++ /dev/null @@ -1,1 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/exception/no-pkg2/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ diff --git a/tests/IntegrationTests2/regression/3324/cabal.project b/tests/IntegrationTests2/regression/3324/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/regression/3324/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: p q diff --git a/tests/IntegrationTests2/regression/3324/p/P.hs b/tests/IntegrationTests2/regression/3324/p/P.hs deleted file mode 100644 --- a/tests/IntegrationTests2/regression/3324/p/P.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/regression/3324/p/p.cabal +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/regression/3324/q/Q.hs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/regression/3324/q/q.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: q -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: Q - build-depends: base - -- missing a dep on p here, so expect failure initially diff --git a/tests/IntegrationTests2/targets/all-disabled/cabal.project b/tests/IntegrationTests2/targets/all-disabled/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/all-disabled/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ diff --git a/tests/IntegrationTests2/targets/all-disabled/p.cabal b/tests/IntegrationTests2/targets/all-disabled/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/all-disabled/p.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: Q - build-depends: base, filepath - buildable: False - -executable buildable-false - main-is: Main.hs - buildable: False - -test-suite solver-disabled - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: a-package-that-does-not-exist - -benchmark user-disabled - type: exitcode-stdio-1.0 - main-is: Test.hs - diff --git a/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project b/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ ./q/ diff --git a/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal b/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal +++ /dev/null @@ -1,15 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.10 - -benchmark solver-disabled - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: a-package-that-does-not-exist - -benchmark user-disabled - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: base - diff --git a/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal b/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal +++ /dev/null @@ -1,10 +0,0 @@ -name: q -version: 0.1 -build-type: Simple -cabal-version: >= 1.10 - -benchmark buildable-false - type: exitcode-stdio-1.0 - main-is: Main.hs - buildable: False - diff --git a/tests/IntegrationTests2/targets/complex/cabal.project b/tests/IntegrationTests2/targets/complex/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/complex/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: q/ diff --git a/tests/IntegrationTests2/targets/complex/q/Q.hs b/tests/IntegrationTests2/targets/complex/q/Q.hs deleted file mode 100644 --- a/tests/IntegrationTests2/targets/complex/q/Q.hs +++ /dev/null diff --git a/tests/IntegrationTests2/targets/complex/q/q.cabal b/tests/IntegrationTests2/targets/complex/q/q.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/complex/q/q.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: q -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: Q - -- we rely that filepath has filepath-tests component - build-depends: base, filepath >=1.4.0.0 - -executable buildable-false - main-is: Main.hs - buildable: False - -test-suite solver-disabled - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: a-package-that-does-not-exist - -benchmark user-disabled - type: exitcode-stdio-1.0 - main-is: Test.hs - diff --git a/tests/IntegrationTests2/targets/empty-pkg/cabal.project b/tests/IntegrationTests2/targets/empty-pkg/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/empty-pkg/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ diff --git a/tests/IntegrationTests2/targets/empty-pkg/p.cabal b/tests/IntegrationTests2/targets/empty-pkg/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/empty-pkg/p.cabal +++ /dev/null @@ -1,5 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/targets/empty/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: diff --git a/tests/IntegrationTests2/targets/empty/foo.hs b/tests/IntegrationTests2/targets/empty/foo.hs deleted file mode 100644 --- a/tests/IntegrationTests2/targets/empty/foo.hs +++ /dev/null diff --git a/tests/IntegrationTests2/targets/exes-disabled/cabal.project b/tests/IntegrationTests2/targets/exes-disabled/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/exes-disabled/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: p/ q/ diff --git a/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal b/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -executable p - main-is: P.hs - build-depends: base - buildable: False diff --git a/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal b/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: q -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -executable q - main-is: Q.hs - build-depends: base - buildable: False diff --git a/tests/IntegrationTests2/targets/lib-only/p.cabal b/tests/IntegrationTests2/targets/lib-only/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/lib-only/p.cabal +++ /dev/null @@ -1,8 +0,0 @@ -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/libs-disabled/cabal.project b/tests/IntegrationTests2/targets/libs-disabled/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/libs-disabled/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: p/ q/ diff --git a/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal b/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: P - build-depends: base - buildable: False diff --git a/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal b/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: q -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: Q - build-depends: base - buildable: False diff --git a/tests/IntegrationTests2/targets/multiple-exes/cabal.project b/tests/IntegrationTests2/targets/multiple-exes/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/multiple-exes/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ diff --git a/tests/IntegrationTests2/targets/multiple-exes/p.cabal b/tests/IntegrationTests2/targets/multiple-exes/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/multiple-exes/p.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.10 - -executable p1 - main-is: P1.hs - build-depends: base - -executable p2 - main-is: P2.hs - build-depends: base diff --git a/tests/IntegrationTests2/targets/multiple-libs/cabal.project b/tests/IntegrationTests2/targets/multiple-libs/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/multiple-libs/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: p/ q/ diff --git a/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal b/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/targets/multiple-libs/q/q.cabal +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests2/targets/multiple-tests/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ diff --git a/tests/IntegrationTests2/targets/multiple-tests/p.cabal b/tests/IntegrationTests2/targets/multiple-tests/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/multiple-tests/p.cabal +++ /dev/null @@ -1,14 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.10 - -test-suite p1 - type: exitcode-stdio-1.0 - main-is: P1.hs - build-depends: base - -test-suite p2 - type: exitcode-stdio-1.0 - main-is: P2.hs - build-depends: base diff --git a/tests/IntegrationTests2/targets/simple/P.hs b/tests/IntegrationTests2/targets/simple/P.hs deleted file mode 100644 --- a/tests/IntegrationTests2/targets/simple/P.hs +++ /dev/null diff --git a/tests/IntegrationTests2/targets/simple/app/Main.hs b/tests/IntegrationTests2/targets/simple/app/Main.hs deleted file mode 100644 --- a/tests/IntegrationTests2/targets/simple/app/Main.hs +++ /dev/null diff --git a/tests/IntegrationTests2/targets/simple/cabal.project b/tests/IntegrationTests2/targets/simple/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/simple/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ q/ diff --git a/tests/IntegrationTests2/targets/simple/p.cabal b/tests/IntegrationTests2/targets/simple/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/simple/p.cabal +++ /dev/null @@ -1,17 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: P - build-depends: base - -executable pexe - main-is: Main.hs - other-modules: PMain - -executable ppexe - main-is: Main.hs - hs-source-dirs: app - other-modules: PMain diff --git a/tests/IntegrationTests2/targets/simple/q/Q.hs b/tests/IntegrationTests2/targets/simple/q/Q.hs deleted file mode 100644 --- a/tests/IntegrationTests2/targets/simple/q/Q.hs +++ /dev/null diff --git a/tests/IntegrationTests2/targets/simple/q/QQ.hs b/tests/IntegrationTests2/targets/simple/q/QQ.hs deleted file mode 100644 --- a/tests/IntegrationTests2/targets/simple/q/QQ.hs +++ /dev/null diff --git a/tests/IntegrationTests2/targets/simple/q/q.cabal b/tests/IntegrationTests2/targets/simple/q/q.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/simple/q/q.cabal +++ /dev/null @@ -1,13 +0,0 @@ -name: q -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: QQ - other-modules: Q - build-depends: base - -executable qexe - main-is: Main.hs - other-modules: QMain diff --git a/tests/IntegrationTests2/targets/test-only/p.cabal b/tests/IntegrationTests2/targets/test-only/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/test-only/p.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 - -test-suite pexe - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: PMain diff --git a/tests/IntegrationTests2/targets/tests-disabled/cabal.project b/tests/IntegrationTests2/targets/tests-disabled/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/tests-disabled/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ ./q/ diff --git a/tests/IntegrationTests2/targets/tests-disabled/p.cabal b/tests/IntegrationTests2/targets/tests-disabled/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/tests-disabled/p.cabal +++ /dev/null @@ -1,15 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.10 - -test-suite solver-disabled - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: a-package-that-does-not-exist - -test-suite user-disabled - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: base - diff --git a/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal b/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal +++ /dev/null @@ -1,10 +0,0 @@ -name: q -version: 0.1 -build-type: Simple -cabal-version: >= 1.10 - -test-suite buildable-false - type: exitcode-stdio-1.0 - main-is: Main.hs - buildable: False - diff --git a/tests/IntegrationTests2/targets/variety/cabal.project b/tests/IntegrationTests2/targets/variety/cabal.project deleted file mode 100644 --- a/tests/IntegrationTests2/targets/variety/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ diff --git a/tests/IntegrationTests2/targets/variety/p.cabal b/tests/IntegrationTests2/targets/variety/p.cabal deleted file mode 100644 --- a/tests/IntegrationTests2/targets/variety/p.cabal +++ /dev/null @@ -1,27 +0,0 @@ -name: p -version: 0.1 -build-type: Simple -cabal-version: >= 1.10 - -library - exposed-modules: P - build-depends: base - -foreign-library libp - type: native-shared - other-modules: FLib - -executable an-exe - main-is: Main.hs - other-modules: AModule - -test-suite a-testsuite - type: exitcode-stdio-1.0 - main-is: Test.hs - other-modules: AModule - -benchmark a-benchmark - type: exitcode-stdio-1.0 - main-is: Test.hs - other-modules: AModule -