cabal-install-2.4.0.0/0000755000000000000000000000000000000000000012510 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/BuildReports/0000755000000000000000000000000000000000000021023 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/BuildReports/Anonymous.hs0000644000000000000000000002666000000000000023361 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 new, -- * parsing and pretty printing parse, parseList, show, -- showList, ) where import Prelude () import Distribution.Client.Compat.Prelude hiding (show) import qualified Distribution.Client.Types as BR ( BuildOutcome, BuildFailure(..), BuildResult(..) , DocsResult(..), TestsResult(..) ) import Distribution.Client.Utils ( mergeBy, MergeResult(..) ) import qualified Paths_cabal_install (version) import Distribution.Package ( PackageIdentifier(..), mkPackageName ) import Distribution.PackageDescription ( FlagName, mkFlagName, unFlagName , FlagAssignment, mkFlagAssignment, unFlagAssignment ) import Distribution.Version ( mkVersion' ) import Distribution.System ( OS, Arch ) import Distribution.Compiler ( CompilerId(..) ) import qualified Distribution.Text as Text ( Text(disp, parse) ) import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..), Field(..) , simpleField, listField, ppFields, readFields , syntaxError, locatedErrorMsg ) import Distribution.Simple.Utils ( comparing ) import qualified Distribution.Compat.ReadP as Parse ( ReadP, pfail, munch1, skipSpaces ) import qualified Text.PrettyPrint as Disp ( Doc, render, char, text ) import Text.PrettyPrint ( (<+>) ) import Data.Char as Char ( isAlpha, isAlphaNum ) 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 } data InstallOutcome = PlanningFailed | DependencyFailed PackageIdentifier | DownloadFailed | UnpackFailed | SetupFailed | ConfigureFailed | BuildFailed | TestsFailed | InstallFailed | InstallOk deriving Eq data Outcome = NotTried | Failed | Ok deriving Eq new :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport new 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") (mkVersion' Paths_cabal_install.version) -- ------------------------------------------------------------ -- * External format -- ------------------------------------------------------------ initialBuildReport :: BuildReport initialBuildReport = BuildReport { package = requiredField "package", os = requiredField "os", arch = requiredField "arch", compiler = requiredField "compiler", client = requiredField "client", flagAssignment = mempty, dependencies = [], installOutcome = requiredField "install-outcome", -- cabalVersion = Nothing, -- tools = [], docsOutcome = NotTried, testsOutcome = NotTried } where requiredField fname = error ("required field: " ++ fname) -- ----------------------------------------------------------------------------- -- Parsing parse :: String -> Either String BuildReport parse s = case parseFields s of ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror ParseOk _ report -> Right report parseFields :: String -> ParseResult BuildReport parseFields input = do fields <- traverse extractField =<< readFields input let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name) sortedFieldDescrs (sortBy (comparing (\(_,name,_) -> name)) fields) checkMerged initialBuildReport merged where extractField :: Field -> ParseResult (Int, String, String) extractField (F line name value) = return (line, name, value) extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza" extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza" checkMerged report [] = return report checkMerged report (merged:remaining) = case merged of InBoth fieldDescr (line, _name, value) -> do report' <- fieldSet fieldDescr line value report checkMerged report' remaining OnlyInRight (line, name, _) -> syntaxError line ("Unrecognized field " ++ name) OnlyInLeft fieldDescr -> fail ("Missing field " ++ fieldName fieldDescr) parseList :: String -> [BuildReport] parseList str = [ report | Right report <- map parse (split str) ] where split :: String -> [String] split = filter (not . null) . unfoldr chunk . lines chunk [] = Nothing chunk ls = case break null ls of (r, rs) -> Just (unlines r, dropWhile null rs) -- ----------------------------------------------------------------------------- -- Pretty-printing show :: BuildReport -> String show = Disp.render . ppFields fieldDescrs -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing fieldDescrs :: [FieldDescr BuildReport] fieldDescrs = [ simpleField "package" Text.disp Text.parse package (\v r -> r { package = v }) , simpleField "os" Text.disp Text.parse os (\v r -> r { os = v }) , simpleField "arch" Text.disp Text.parse arch (\v r -> r { arch = v }) , simpleField "compiler" Text.disp Text.parse compiler (\v r -> r { compiler = v }) , simpleField "client" Text.disp Text.parse client (\v r -> r { client = v }) , listField "flags" dispFlag parseFlag (unFlagAssignment . flagAssignment) (\v r -> r { flagAssignment = mkFlagAssignment v }) , listField "dependencies" Text.disp Text.parse dependencies (\v r -> r { dependencies = v }) , simpleField "install-outcome" Text.disp Text.parse installOutcome (\v r -> r { installOutcome = v }) , simpleField "docs-outcome" Text.disp Text.parse docsOutcome (\v r -> r { docsOutcome = v }) , simpleField "tests-outcome" Text.disp Text.parse testsOutcome (\v r -> r { testsOutcome = v }) ] sortedFieldDescrs :: [FieldDescr BuildReport] sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs dispFlag :: (FlagName, Bool) -> Disp.Doc dispFlag (fname, True) = Disp.text (unFlagName fname) dispFlag (fname, False) = Disp.char '-' <<>> Disp.text (unFlagName fname) parseFlag :: Parse.ReadP r (FlagName, Bool) parseFlag = do name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') case name of ('-':flag) -> return (mkFlagName flag, False) flag -> return (mkFlagName flag, True) instance Text.Text InstallOutcome where disp PlanningFailed = Disp.text "PlanningFailed" disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid disp DownloadFailed = Disp.text "DownloadFailed" disp UnpackFailed = Disp.text "UnpackFailed" disp SetupFailed = Disp.text "SetupFailed" disp ConfigureFailed = Disp.text "ConfigureFailed" disp BuildFailed = Disp.text "BuildFailed" disp TestsFailed = Disp.text "TestsFailed" disp InstallFailed = Disp.text "InstallFailed" disp InstallOk = Disp.text "InstallOk" parse = do name <- Parse.munch1 Char.isAlphaNum case name of "PlanningFailed" -> return PlanningFailed "DependencyFailed" -> do Parse.skipSpaces pkgid <- Text.parse return (DependencyFailed pkgid) "DownloadFailed" -> return DownloadFailed "UnpackFailed" -> return UnpackFailed "SetupFailed" -> return SetupFailed "ConfigureFailed" -> return ConfigureFailed "BuildFailed" -> return BuildFailed "TestsFailed" -> return TestsFailed "InstallFailed" -> return InstallFailed "InstallOk" -> return InstallOk _ -> Parse.pfail instance Text.Text Outcome where disp NotTried = Disp.text "NotTried" disp Failed = Disp.text "Failed" disp Ok = Disp.text "Ok" parse = do name <- Parse.munch1 Char.isAlpha case name of "NotTried" -> return NotTried "Failed" -> return Failed "Ok" -> return Ok _ -> Parse.pfail cabal-install-2.4.0.0/Distribution/Client/BuildReports/Storage.hs0000644000000000000000000001350000000000000022762 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (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 ( comparing, equating ) import Data.List ( groupBy, sortBy ) import Data.Maybe ( mapMaybe ) 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' : BuildReport.show r ++ "\n" separate :: [(BuildReport, Maybe Repo)] -> [(Repo, [BuildReport])] separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) . map concat . 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' : BuildReport.show 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)) . 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 ( BuildReport.new os arch comp (packageId srcPkg) flags (map packageId (CD.nonSetupDeps deps)) buildResult , extractRepo srcPkg) where extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ }) = Just repo extractRepo _ = Nothing fromPlanPackage _ _ _ _ = Nothing fromPlanningFailure :: Platform -> CompilerId -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] fromPlanningFailure (Platform arch os) comp pkgids flags = [ (BuildReport.new os arch comp pkgid flags [] (Left PlanningFailed), Nothing) | pkgid <- pkgids ] cabal-install-2.4.0.0/Distribution/Client/BuildReports/Types.hs0000644000000000000000000000266600000000000022475 0ustar0000000000000000{-# 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(..), ) where import qualified Distribution.Text as Text ( Text(..) ) import qualified Distribution.Compat.ReadP as Parse ( pfail, munch1 ) import qualified Text.PrettyPrint as Disp ( text ) import Data.Char as Char ( isAlpha, toLower ) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary) data ReportLevel = NoReports | AnonymousReports | DetailedReports deriving (Eq, Ord, Enum, Show, Generic) instance Binary ReportLevel instance Text.Text ReportLevel where disp NoReports = Disp.text "none" disp AnonymousReports = Disp.text "anonymous" disp DetailedReports = Disp.text "detailed" parse = do name <- Parse.munch1 Char.isAlpha case lowercase name of "none" -> return NoReports "anonymous" -> return AnonymousReports "detailed" -> return DetailedReports _ -> Parse.pfail lowercase :: String -> String lowercase = map Char.toLower cabal-install-2.4.0.0/Distribution/Client/BuildReports/Upload.hs0000644000000000000000000000667600000000000022622 0ustar0000000000000000{-# LANGUAGE CPP, PatternGuards #-} -- This is a quick hack for uploading build reports to Hackage. module Distribution.Client.BuildReports.Upload ( BuildLog , BuildReportId , uploadReports ) where {- import Network.Browser ( BrowserAction, request, setAllowRedirects ) import Network.HTTP ( Header(..), HeaderName(..) , Request(..), RequestMethod(..), Response(..) ) import Network.TCP (HandleStream) -} import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo) import Control.Monad ( forM_ ) import System.FilePath.Posix ( () ) import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (BuildReport) import Distribution.Text (display) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils (die') import Distribution.Client.HttpUtils import Distribution.Client.Setup ( RepoContext(..) ) type BuildReportId = URI type BuildLog = String uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO () uploadReports verbosity repoCtxt auth uri reports = do forM_ 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" display (BuildReport.package buildReport) "reports" } transport <- repoContextGetTransport repoCtxt res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth) case res of (303, redir) -> return $ undefined redir --TODO parse redir _ -> die' verbosity "unrecognized response" -- give response {- setAllowRedirects False (_, response) <- request Request { rqURI = uri { uriPath = "/package" display (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 cabal-install-2.4.0.0/Distribution/Client/0000755000000000000000000000000000000000000016405 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/Check.hs0000644000000000000000000001141300000000000017756 0ustar0000000000000000{-# 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.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Check import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) import Distribution.Parsec.Common (PWarning (..), showPError, showPWarning) import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) import Distribution.Verbosity (Verbosity) 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 die' verbosity $ "Failed parsing \"" ++ fpath ++ "\"." 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) cabal-install-2.4.0.0/Distribution/Client/CmdBench.hs0000644000000000000000000002311600000000000020407 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} -- | cabal-install CLI command: bench -- module Distribution.Client.CmdBench ( -- * The @bench@ CLI and action benchCommand, benchAction, -- * Internals exposed for testing TargetProblem(..), selectPackageTargets, selectComponentTarget ) where import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils ( wrapText, die' ) import Control.Monad (when) benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) benchCommand = Client.installCommand { commandName = "new-bench", commandSynopsis = "Run benchmarks", commandUsage = usageAlternatives "new-bench" [ "[TARGETS] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Runs the specified benchmarks, first ensuring they are up to " ++ "date.\n\n" ++ "Any benchmark in any package in the project can be specified. " ++ "A package can be specified in which case all the benchmarks in the " ++ "package are run. The default is to run all the benchmarks in the " ++ "package in the current directory.\n\n" ++ "Dependencies are built or rebuilt as necessary. Additional " ++ "configuration flags can be specified on the command line and these " ++ "extend the project configuration from the 'cabal.project', " ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " new-bench\n" ++ " Run all the benchmarks in the package in the current directory\n" ++ " " ++ pname ++ " new-bench pkgname\n" ++ " Run all the benchmarks in the package named pkgname\n" ++ " " ++ pname ++ " new-bench cname\n" ++ " Run the benchmark named cname\n" ++ " " ++ pname ++ " new-bench cname -O2\n" ++ " Run the benchmark built with '-O2' (including local libs used)\n\n" ++ cmdCommonHelpTextNewBuildBeta } -- | The @build@ command does a lot. It brings the install plan up to date, -- selects that part of the plan needed by the given or implicit targets and -- then executes the plan. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () benchAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig 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 TargetProblemCommon 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 configFlags configExFlags installFlags haddockFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- or otherwise classifies the problem. -- -- For the @bench@ command we select all buildable benchmarks, -- or fail if there are no benchmarks or no buildable benchmarks. -- selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets -- If there are any buildable benchmark targets then we select those | not (null targetsBenchBuildable) = Right targetsBenchBuildable -- If there are benchmarks but none are buildable then we report those | not (null targetsBench) = Left (TargetProblemNoneEnabled targetSelector targetsBench) -- If there are no benchmarks but some other targets then we report that | not (null targets) = Left (TargetProblemNoBenchmarks targetSelector) -- If there are no targets at all then we report that | otherwise = Left (TargetProblemNoTargets targetSelector) where targetsBenchBuildable = selectBuildableTargets . filterTargetsKind BenchKind $ targets targetsBench = forgetTargetsDetail . filterTargetsKind BenchKind $ targets -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @bench@ command we just need to check it is a benchmark, in addition -- to the basic checks on being buildable etc. -- selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k selectComponentTarget subtarget@WholeComponent t | CBenchName _ <- availableTargetComponentName t = either (Left . TargetProblemCommon) return $ selectComponentTargetBasic subtarget t | otherwise = Left (TargetProblemComponentNotBenchmark (availableTargetPackageId t) (availableTargetComponentName t)) selectComponentTarget subtarget t = Left (TargetProblemIsSubComponent (availableTargetPackageId t) (availableTargetComponentName t) subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. -- data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches benchmarks but none are buildable | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all | TargetProblemNoTargets TargetSelector -- | 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) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a reportTargetProblems verbosity = die' verbosity . unlines . map renderTargetProblem renderTargetProblem :: TargetProblem -> String renderTargetProblem (TargetProblemCommon problem) = renderTargetProblemCommon "run" problem renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = renderTargetProblemNoneEnabled "benchmark" targetSelector targets renderTargetProblem (TargetProblemNoBenchmarks targetSelector) = "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector ++ "' which refers to " ++ renderTargetSelector targetSelector ++ " because " ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" ++ " not contain any benchmarks." renderTargetProblem (TargetProblemNoTargets targetSelector) = case targetSelectorFilter targetSelector of Just kind | kind /= BenchKind -> "The bench command is for running benchmarks, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ "." _ -> renderTargetProblemNoTargets "benchmark" targetSelector renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) = "The bench command is for running benchmarks, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ " from the package " ++ display pkgid ++ "." where targetSelector = TargetComponent pkgid cname WholeComponent renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = "The bench command can only run benchmarks as a whole, " ++ "not files or modules within them, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ "." where targetSelector = TargetComponent pkgid cname subtarget cabal-install-2.4.0.0/Distribution/Client/CmdBuild.hs0000644000000000000000000001757500000000000020443 0ustar0000000000000000-- | cabal-install CLI command: build -- module Distribution.Client.CmdBuild ( -- * The @build@ CLI and action buildCommand, buildAction, -- * Internals exposed for testing TargetProblem(..), selectPackageTargets, selectComponentTarget ) where import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils ( wrapText, die' ) import qualified Data.Map as Map buildCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) buildCommand = Client.installCommand { commandName = "new-build", commandSynopsis = "Compile targets within the project.", commandUsage = usageAlternatives "new-build" [ "[TARGETS] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Build one or more targets from within the project. The available " ++ "targets are the packages in the project as well as individual " ++ "components within those packages, including libraries, executables, " ++ "test-suites or benchmarks. Targets can be specified by name or " ++ "location. If no target is specified then the default is to build " ++ "the package in the current directory.\n\n" ++ "Dependencies are built or rebuilt as necessary. Additional " ++ "configuration flags can be specified on the command line and these " ++ "extend the project configuration from the 'cabal.project', " ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " new-build\n" ++ " Build the package in the current directory or all packages in the project\n" ++ " " ++ pname ++ " new-build pkgname\n" ++ " Build the package named pkgname in the project\n" ++ " " ++ pname ++ " new-build ./pkgfoo\n" ++ " Build the package in the ./pkgfoo directory\n" ++ " " ++ pname ++ " new-build cname\n" ++ " Build the component named cname in the project\n" ++ " " ++ pname ++ " new-build cname --enable-profiling\n" ++ " Build the component in profiling mode (including dependencies as needed)\n\n" ++ cmdCommonHelpTextNewBuildBeta } -- | The @build@ command does a lot. It brings the install plan up to date, -- selects that part of the plan needed by the given or implicit targets and -- then executes the plan. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () buildAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig 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 (reportTargetProblems verbosity) return $ resolveTargets selectPackageTargets selectComponentTarget TargetProblemCommon elaboratedPlan Nothing targetSelectors let elaboratedPlan' = pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan elaboratedPlan'' <- if buildSettingOnlyDeps (buildSettings baseCtx) then either (reportCannotPruneDependencies verbosity) return $ pruneInstallPlanToDependencies (Map.keysSet targets) elaboratedPlan' else return elaboratedPlan' return (elaboratedPlan'', targets) printPlan verbosity baseCtx buildCtx buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- or otherwise classifies the problem. -- -- For the @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 subtarget = either (Left . TargetProblemCommon) Right . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @build@ command. -- data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all | TargetProblemNoTargets TargetSelector deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a reportTargetProblems verbosity = die' verbosity . unlines . map renderTargetProblem renderTargetProblem :: TargetProblem -> String renderTargetProblem (TargetProblemCommon problem) = renderTargetProblemCommon "build" problem renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = renderTargetProblemNoneEnabled "build" targetSelector targets renderTargetProblem(TargetProblemNoTargets targetSelector) = renderTargetProblemNoTargets "build" targetSelector reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a reportCannotPruneDependencies verbosity = die' verbosity . renderCannotPruneDependencies cabal-install-2.4.0.0/Distribution/Client/CmdClean.hs0000644000000000000000000001005300000000000020406 0ustar0000000000000000{-# 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 ( Verbosity, normal ) import Control.Exception ( throwIO ) import System.Directory ( removeDirectoryRecursive, doesDirectoryExist ) 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 = "new-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 unpackedSrcRoot = distUnpackedSrcRootDirectory distLayout buildRootExists <- doesDirectoryExist buildRoot unpackedSrcRootExists <- doesDirectoryExist unpackedSrcRoot when buildRootExists $ do info verbosity ("Deleting build root (" ++ buildRoot ++ ")") handleDoesNotExist () $ removeDirectoryRecursive buildRoot when unpackedSrcRootExists $ do info verbosity ("Deleting unpacked source root (" ++ unpackedSrcRoot ++ ")") handleDoesNotExist () $ removeDirectoryRecursive unpackedSrcRoot else do let distRoot = distDirectory distLayout info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") handleDoesNotExist () $ removeDirectoryRecursive distRoot cabal-install-2.4.0.0/Distribution/Client/CmdConfigure.hs0000644000000000000000000001252200000000000021310 0ustar0000000000000000-- | cabal-install CLI command: configure -- module Distribution.Client.CmdConfigure ( configureCommand, configureAction, ) where import System.Directory import Control.Monad import qualified Data.Map as Map import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig ( writeProjectLocalExtraConfig ) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Verbosity ( normal ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Utils ( wrapText, notice ) import qualified Distribution.Client.Setup as Client configureCommand :: CommandUI (ConfigFlags, ConfigExFlags ,InstallFlags, HaddockFlags) configureCommand = Client.installCommand { commandName = "new-configure", commandSynopsis = "Add extra project configuration", commandUsage = usageAlternatives "new-configure" [ "[FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Adjust how the project is built by setting additional package flags " ++ "and other flags.\n\n" ++ "The configuration options are written to the 'cabal.project.local' " ++ "file (or '$project_file.local', if '--project-file' is specified) " ++ "which extends the configuration from the 'cabal.project' file " ++ "(if any). This combination is used as the project configuration for " ++ "all other commands (such as 'new-build', 'new-repl' etc) though it " ++ "can be extended/overridden on a per-command basis.\n\n" ++ "The new-configure command also checks that the project configuration " ++ "will work. In particular it checks that there is a consistent set of " ++ "dependencies for the project as a whole.\n\n" ++ "The 'cabal.project.local' file persists across 'new-clean' but is " ++ "overwritten on the next use of the 'new-configure' command. The " ++ "intention is that the 'cabal.project' file should be kept in source " ++ "control but the 'cabal.project.local' should not.\n\n" ++ "It is never necessary to use the 'new-configure' command. It is " ++ "merely a convenience in cases where you do not want to specify flags " ++ "to 'new-build' (and other commands) every time and yet do not want " ++ "to alter the 'cabal.project' persistently.", commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " new-configure --with-compiler ghc-7.10.3\n" ++ " Adjust the project configuration to use the given compiler\n" ++ " program and check the resulting configuration works.\n" ++ " " ++ pname ++ " new-configure\n" ++ " Reset the local configuration to empty and check the overall\n" ++ " project configuration works.\n\n" ++ cmdCommonHelpTextNewBuildBeta } -- | To a first approximation, the @configure@ just runs the first phase of -- the @build@ command where we bring the install plan up to date (thus -- checking that it's possible). -- -- The only difference is that @configure@ also allows the user to specify -- some extra config flags which we save in the file @cabal.project.local@. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () configureAction (configFlags, configExFlags, installFlags, haddockFlags) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there baseCtx <- establishProjectBaseContext verbosity cliConfig -- 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 exists <- doesFileExist "cabal.project.local" when exists $ do notice verbosity "'cabal.project.local' file already exists. Now overwriting it." copyFile "cabal.project.local" "cabal.project.local~" 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 configFlags configExFlags installFlags haddockFlags cabal-install-2.4.0.0/Distribution/Client/CmdErrorMessages.hs0000644000000000000000000004402000000000000022146 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -- | Utilities to help format error messages for the various CLI commands. -- module Distribution.Client.CmdErrorMessages ( module Distribution.Client.CmdErrorMessages, module Distribution.Client.TargetSelector, ) where import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetSelector ( ComponentKindFilter, componentKind, showTargetSelector ) import Distribution.Package ( packageId, PackageName, packageName ) import Distribution.Types.ComponentName ( showComponentName ) import Distribution.Solver.Types.OptionalStanza ( OptionalStanza(..) ) import Distribution.Text ( display ) import Data.Maybe (isNothing) import Data.List (sortBy, groupBy, nub) import Data.Function (on) ----------------------- -- Singular or plural -- -- | A tag used in rendering messages to distinguish singular or plural. -- data Plural = Singular | Plural -- | Used to render a singular or plural version of something -- -- > plural (listPlural theThings) "it is" "they are" -- plural :: Plural -> a -> a -> a plural Singular si _pl = si plural Plural _si pl = pl -- | Singular for singleton lists and plural otherwise. -- listPlural :: [a] -> Plural listPlural [_] = Singular listPlural _ = Plural -------------------- -- Rendering lists -- -- | Render a list of things in the style @foo, bar and baz@ renderListCommaAnd :: [String] -> String renderListCommaAnd [] = "" renderListCommaAnd [x] = x renderListCommaAnd [x,x'] = x ++ " and " ++ x' renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs -- | Render a list of things in the style @blah blah; this that; and the other@ renderListSemiAnd :: [String] -> String renderListSemiAnd [] = "" renderListSemiAnd [x] = x renderListSemiAnd [x,x'] = x ++ "; and " ++ x' renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs -- | When rendering lists of things it often reads better to group related -- things, e.g. grouping components by package name -- -- > renderListSemiAnd -- > [ "the package " ++ display pkgname ++ " components " -- > ++ renderListCommaAnd showComponentName components -- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] -- sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] sortGroupOn key = map (\xs@(x:_) -> (key x, xs)) . groupBy ((==) `on` key) . sortBy (compare `on` key) ---------------------------------------------------- -- Renderering for a few project and package types -- renderTargetSelector :: TargetSelector -> String renderTargetSelector (TargetPackage _ pkgids Nothing) = "the " ++ plural (listPlural pkgids) "package" "packages" ++ " " ++ renderListCommaAnd (map display pkgids) renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = "the " ++ renderComponentKind Plural kfilter ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " ++ renderListCommaAnd (map display pkgids) renderTargetSelector (TargetPackageNamed pkgname Nothing) = "the package " ++ display pkgname renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) = "the " ++ renderComponentKind Plural kfilter ++ " in the package " ++ display 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 " ++ display ucname ++ " in the package " ++ display 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" ++ display 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 = "library " ++ display pkgname renderComponentName _ (CSubLibName name) = "library " ++ display name renderComponentName _ (CFLibName name) = "foreign library " ++ display name renderComponentName _ (CExeName name) = "executable " ++ display name renderComponentName _ (CTestName name) = "test suite " ++ display name renderComponentName _ (CBenchName name) = "benchmark " ++ display 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 TargetProblemCommon -- renderTargetProblemCommon :: String -> TargetProblemCommon -> String renderTargetProblemCommon verb (TargetNotInProject pkgname) = "Cannot " ++ verb ++ " the package " ++ display pkgname ++ ", it is not " ++ "in this project (either directly or indirectly). If you want to add it " ++ "to the project then edit the cabal.project file." renderTargetProblemCommon verb (TargetAvailableInIndex pkgname) = "Cannot " ++ verb ++ " the package " ++ display 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." renderTargetProblemCommon verb (TargetComponentNotProjectLocal pkgid cname _) = "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " ++ "package " ++ display pkgid ++ " is not local to the project, and cabal " ++ "does not currently support building test suites or benchmarks of " ++ "non-local dependencies. To run test suites or benchmarks from " ++ "dependencies you can unpack the package locally and adjust the " ++ "cabal.project file to include that package directory." renderTargetProblemCommon verb (TargetComponentNotBuildable pkgid cname _) = "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is " ++ "marked as 'buildable: False' within the '" ++ display (packageName pkgid) ++ ".cabal' file (at least for the current configuration). If you believe it " ++ "should be buildable then check the .cabal file to see if the buildable " ++ "property is conditional on flags. Alternatively you may simply have to " ++ "edit the .cabal file to declare it as buildable and fix any resulting " ++ "build problems." renderTargetProblemCommon verb (TargetOptionalStanzaDisabledByUser _ cname _) = "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because " ++ "building " ++ compkinds ++ " has been explicitly disabled in the " ++ "configuration. You can adjust this configuration in the " ++ "cabal.project{.local} file either for all packages in the project or on " ++ "a per-package basis. Note that if you do not explicitly disable " ++ compkinds ++ " then the solver will merely try to make a plan with " ++ "them available, so you may wish to explicitly enable them which will " ++ "require the solver to find a plan with them available or to fail with an " ++ "explanation." where compkinds = renderComponentKind Plural (componentKind cname) renderTargetProblemCommon verb (TargetOptionalStanzaDisabledBySolver pkgid cname _) = "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " ++ "solver did not find a plan that included the " ++ compkinds ++ " for " ++ display pkgid ++ ". It is probably worth trying again with " ++ compkinds ++ " explicitly enabled in the configuration in the " ++ "cabal.project{.local} file. This will ask the solver to find a plan with " ++ "the " ++ compkinds ++ " available. It will either fail with an " ++ "explanation or find a different plan that uses different versions of some " ++ "other packages. Use the '--dry-run' flag to see package versions and " ++ "check that you are happy with the choices." where compkinds = renderComponentKind Plural (componentKind cname) renderTargetProblemCommon verb (TargetProblemUnknownComponent pkgname ecname) = "Cannot " ++ verb ++ " the " ++ (case ecname of Left ucname -> "component " ++ display ucname Right cname -> renderComponentName pkgname cname) ++ " from the package " ++ display pkgname ++ ", because the package does not contain a " ++ (case ecname of Left _ -> "component" Right cname -> renderComponentKind Singular (componentKind cname)) ++ " with that name." renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) = "Internal error when trying to " ++ verb ++ " the package " ++ display pkgid ++ ". The package is not in the set of available targets " ++ "for the project plan, which would suggest an inconsistency " ++ "between readTargetSelectors and resolveTargets." renderTargetProblemCommon verb (TargetProblemNoSuchComponent pkgid cname) = "Internal error when trying to " ++ verb ++ " the " ++ showComponentName cname ++ " from the package " ++ display pkgid ++ ". The package,component pair is not in the set of available targets " ++ "for the project plan, which would suggest an inconsistency " ++ "between readTargetSelectors and resolveTargets." ------------------------------------------------------------ -- Renderering error messages for TargetProblemNoneEnabled -- -- | Several commands have a @TargetProblemNoneEnabled@ problem constructor. -- This renders an error message for those cases. -- renderTargetProblemNoneEnabled :: String -> TargetSelector -> [AvailableTarget ()] -> String renderTargetProblemNoneEnabled verb targetSelector targets = "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector ++ " because none of the components are available to build: " ++ renderListSemiAnd [ case (status, mstanza) of (TargetDisabledByUser, Just stanza) -> renderListCommaAnd [ "the " ++ showComponentName availableTargetComponentName | AvailableTarget {availableTargetComponentName} <- targets' ] ++ plural (listPlural targets') " is " " are " ++ " not available because building " ++ renderOptionalStanza Plural stanza ++ " has been disabled in the configuration" (TargetDisabledBySolver, Just stanza) -> renderListCommaAnd [ "the " ++ showComponentName availableTargetComponentName | AvailableTarget {availableTargetComponentName} <- targets' ] ++ plural (listPlural targets') " is " " are " ++ "not available because the solver did not find a plan that " ++ "included the " ++ renderOptionalStanza Plural stanza (TargetNotBuildable, _) -> renderListCommaAnd [ "the " ++ showComponentName availableTargetComponentName | AvailableTarget {availableTargetComponentName} <- targets' ] ++ plural (listPlural targets') " is " " are all " ++ "marked as 'buildable: False'" (TargetNotLocal, _) -> renderListCommaAnd [ "the " ++ showComponentName availableTargetComponentName | AvailableTarget {availableTargetComponentName} <- targets' ] ++ " cannot be built because cabal does not currently support " ++ "building test suites or benchmarks of non-local dependencies" (TargetBuildable () TargetNotRequestedByDefault, Just stanza) -> renderListCommaAnd [ "the " ++ showComponentName availableTargetComponentName | AvailableTarget {availableTargetComponentName} <- targets' ] ++ " will not be built because " ++ renderOptionalStanza Plural stanza ++ " are not built by default in the current configuration (but you " ++ "can still build them specifically)" --TODO: say how _ -> error $ "renderBuildTargetProblem: unexpected status " ++ show (status, mstanza) | ((status, mstanza), targets') <- sortGroupOn groupingKey targets ] where groupingKey t = ( availableTargetStatus t , case availableTargetStatus t of TargetNotBuildable -> Nothing TargetNotLocal -> Nothing _ -> optionalStanza (availableTargetComponentName t) ) ------------------------------------------------------------ -- Renderering error messages for TargetProblemNoneEnabled -- -- | Several commands have a @TargetProblemNoTargets@ problem constructor. -- This renders an error message for those cases. -- renderTargetProblemNoTargets :: String -> TargetSelector -> 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 " ++ display pkgid ++ " is " _ -> "the packages " ++ renderListCommaAnd (map display pkgids) ++ " are ") ++ "required by a dependency of one of the other targets." where -- throw away the details and just list the deps that are needed pkgids :: [PackageId] pkgids = nub . map packageId . concatMap snd $ brokenPackages {- ++ "Syntax:\n" ++ " - build [package]\n" ++ " - build [package:]component\n" ++ " - build [package:][component:]module\n" ++ " - build [package:][component:]file\n" ++ " where\n" ++ " package is a package name, package dir or .cabal file\n\n" ++ "Examples:\n" ++ " - build foo -- package name\n" ++ " - build tests -- component name\n" ++ " (name of library, executable, test-suite or benchmark)\n" ++ " - build Data.Foo -- module name\n" ++ " - build Data/Foo.hsc -- file name\n\n" ++ "An ambigious target can be qualified by package, component\n" ++ "and/or component kind (lib|exe|test|bench|flib)\n" ++ " - build foo:tests -- component qualified by package\n" ++ " - build tests:Data.Foo -- module qualified by component\n" ++ " - build lib:foo -- component qualified by kind" -} cabal-install-2.4.0.0/Distribution/Client/CmdExec.hs0000644000000000000000000002163100000000000020254 0ustar0000000000000000------------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Exec -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Implementation of the 'new-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.Setup ( ConfigExFlags , ConfigFlags(configVerbosity) , GlobalFlags , InstallFlags ) import Distribution.Client.ProjectOrchestration ( ProjectBuildContext(..) , runProjectPreBuildPhase , 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(..) ) 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.Setup ( HaddockFlags , fromFlagOrDefault ) import Distribution.Simple.Utils ( die' , info , withTempDirectory , wrapText ) import Distribution.Verbosity ( Verbosity , normal ) import qualified Distribution.Client.CmdBuild as CmdBuild import Prelude () import Distribution.Client.Compat.Prelude import Data.Set (Set) import qualified Data.Set as S import qualified Data.Map as M execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) execCommand = CommandUI { commandName = "new-exec" , commandSynopsis = "Give a command access to the store." , commandUsage = \pname -> "Usage: " ++ pname ++ " new-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 ++ " new-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 ++ " new-exec ghc` will consult the configuration" ++ " to choose an appropriate version of ghc and to include any" ++ " ghc-specific flags requested." , commandNotes = Nothing , commandOptions = commandOptions CmdBuild.buildCommand , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand } execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () execAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig -- 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 configFlags configExFlags installFlags haddockFlags 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 = 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 cabal-install-2.4.0.0/Distribution/Client/CmdFreeze.hs0000644000000000000000000002245700000000000020617 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} -- | cabal-install CLI command: freeze -- module Distribution.Client.CmdFreeze ( freezeCommand, freezeAction, ) where import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectConfig ( ProjectConfig(..), ProjectConfigShared(..) , writeProjectLocalFreezeConfig ) import Distribution.Client.Targets ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty(..) ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.DistDirLayout ( DistDirLayout(distProjectFile) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Package ( PackageName, packageName, packageVersion ) import Distribution.Version ( VersionRange, thisVersion , unionVersionRanges, simplifyVersionRange ) import Distribution.PackageDescription ( FlagAssignment, nullFlagAssignment ) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText ) import Distribution.Verbosity ( normal ) import Data.Monoid as Monoid import qualified Data.Map as Map import Data.Map (Map) import Control.Monad (unless) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import qualified Distribution.Client.Setup as Client freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) freezeCommand = Client.installCommand { commandName = "new-freeze", commandSynopsis = "Freeze dependencies.", commandUsage = usageAlternatives "new-freeze" [ "[FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "The project configuration is frozen so that it will be reproducible " ++ "in future.\n\n" ++ "The precise dependency configuration for the project is written to " ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " ++ "'--project-file' is specified). This file extends the configuration " ++ "from the 'cabal.project' file and thus is used as the project " ++ "configuration for all other commands (such as 'new-build', " ++ "'new-repl' etc).\n\n" ++ "The freeze file can be kept in source control. To make small " ++ "adjustments it may be edited manually, or to make bigger changes " ++ "you may wish to delete the file and re-freeze. For more control, " ++ "one approach is to try variations using 'new-build --dry-run' with " ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " ++ "a satisfactory solution to freeze it using the 'new-freeze' command " ++ "with the same set of flags.", commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " new-freeze\n" ++ " Freeze the configuration of the current project\n\n" ++ " " ++ pname ++ " new-build --dry-run --constraint=\"aeson < 1\"\n" ++ " Check what a solution with the given constraints would look like\n" ++ " " ++ pname ++ " new-freeze --constraint=\"aeson < 1\"\n" ++ " Freeze a solution using the given constraints\n\n" ++ "Note: this command is part of the new project-based system (aka " ++ "nix-style\nlocal builds). These features are currently in beta. " ++ "Please see\n" ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " ++ "for\ndetails and advice on what you can expect to work. If you " ++ "encounter problems\nplease file issues at " ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " ++ "to get involved and help with testing, fixing bugs etc then\nthat " ++ "is very much appreciated.\n" } -- | To a first approximation, the @freeze@ command runs the first phase of -- the @build@ command where we bring the install plan up to date, and then -- based on the install plan we write out a @cabal.project.freeze@ config file. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () freezeAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do unless (null extraArgs) $ die' verbosity $ "'freeze' doesn't take any extra arguments: " ++ unwords extraArgs ProjectBaseContext { distDirLayout, cabalDirLayout, projectConfig, localPackages } <- establishProjectBaseContext verbosity cliConfig (_, elaboratedPlan, _) <- rebuildInstallPlan verbosity distDirLayout cabalDirLayout projectConfig localPackages let freezeConfig = projectFreezeConfig elaboratedPlan writeProjectLocalFreezeConfig distDirLayout freezeConfig notice verbosity $ "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags -- | Given the install plan, produce a config value with constraints that -- freezes the versions of packages used in the plan. -- projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig projectFreezeConfig elaboratedPlan = Monoid.mempty { projectConfigShared = Monoid.mempty { projectConfigConstraints = concat (Map.elems (projectFreezeConstraints elaboratedPlan)) } } -- | Given the install plan, produce solver constraints that will ensure the -- solver picks the same solution again in future in different environments. -- projectFreezeConstraints :: ElaboratedInstallPlan -> Map PackageName [(UserConstraint, ConstraintSource)] projectFreezeConstraints plan = -- -- TODO: [required eventually] this is currently an underapproximation -- since the constraints language is not expressive enough to specify the -- precise solution. See https://github.com/haskell/cabal/issues/3502. -- -- For the moment we deal with multiple versions in the solution by using -- constraints that allow either version. Also, we do not include any -- /version/ constraints for packages that are local to the project (e.g. -- if the solution has two instances of Cabal, one from the local project -- and one pulled in as a setup deps then we exclude all constraints on -- Cabal, not just the constraint for the local instance since any -- constraint would apply to both instances). We do however keep flag -- constraints of local packages. -- deleteLocalPackagesVersionConstraints (Map.unionWith (++) versionConstraints flagConstraints) where versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] versionConstraints = Map.mapWithKey (\p v -> [(UserConstraint (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 ] cabal-install-2.4.0.0/Distribution/Client/CmdHaddock.hs0000644000000000000000000002046500000000000020731 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} -- | cabal-install CLI command: haddock -- module Distribution.Client.CmdHaddock ( -- * The @haddock@ CLI and action haddockCommand, haddockAction, -- * Internals exposed for testing TargetProblem(..), selectPackageTargets, selectComponentTarget ) where import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils ( wrapText, die' ) import Control.Monad (when) haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags ,HaddockFlags) haddockCommand = Client.installCommand { commandName = "new-haddock", commandSynopsis = "Build Haddock documentation", commandUsage = usageAlternatives "new-haddock" [ "[FLAGS] TARGET" ], commandDescription = Just $ \_ -> wrapText $ "Build Haddock documentation for the specified packages within the " ++ "project.\n\n" ++ "Any package in the project can be specified. If no package is " ++ "specified, the default is to build the documentation for the package " ++ "in the current directory. The default behaviour is to build " ++ "documentation for the exposed modules of the library component (if " ++ "any). This can be changed with the '--internal', '--executables', " ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" ++ "Currently, documentation for dependencies is NOT built. This " ++ "behavior may change in future.\n\n" ++ "Additional configuration flags can be specified on the command line " ++ "and these extend the project configuration from the 'cabal.project', " ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " new-haddock pkgname" ++ " Build documentation for the package named pkgname\n\n" ++ cmdCommonHelpTextNewBuildBeta } --TODO: [nice to have] support haddock on specific components, not just -- whole packages and the silly --executables etc modifiers. -- | The @haddock@ command is TODO. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () haddockAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig 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 (reportTargetProblems verbosity) return $ resolveTargets (selectPackageTargets haddockFlags) selectComponentTarget TargetProblemCommon 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 configFlags configExFlags installFlags haddockFlags -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- or otherwise classifies the problem. -- -- For the @haddock@ command we select all buildable libraries. Additionally, -- depending on the @--executables@ flag we also select all the buildable exes. -- We do similarly for test-suites, benchmarks and foreign libs. -- selectPackageTargets :: HaddockFlags -> TargetSelector -> [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 new-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 subtarget = either (Left . TargetProblemCommon) Right . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @haddock@ command. -- data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all | TargetProblemNoTargets TargetSelector deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a reportTargetProblems verbosity = die' verbosity . unlines . map renderTargetProblem renderTargetProblem :: TargetProblem -> String renderTargetProblem (TargetProblemCommon problem) = renderTargetProblemCommon "build documentation for" problem renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = renderTargetProblemNoneEnabled "build documentation for" targetSelector targets renderTargetProblem(TargetProblemNoTargets targetSelector) = renderTargetProblemNoTargets "build documentation for" targetSelector cabal-install-2.4.0.0/Distribution/Client/CmdInstall.hs0000644000000000000000000007534300000000000021007 0ustar0000000000000000{-# 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 TargetProblem(..), selectPackageTargets, selectComponentTarget, establishDummyProjectBaseContext ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.CmdSdist import Distribution.Client.Setup ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags , configureExOptions, installOptions, liftOptions ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.Types ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Package ( Package(..), PackageName, mkPackageName ) import Distribution.Types.PackageId ( PackageIdentifier(..) ) import Distribution.Client.ProjectConfig.Types ( ProjectConfig(..), ProjectConfigShared(..) , ProjectConfigBuildOnly(..), PackageConfig(..) , getMapLast, getMapMappend, projectConfigLogsDir , projectConfigStoreDir, projectConfigBuildOnly , projectConfigDistDir, projectConfigConfigFile ) import Distribution.Simple.Program.Db ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb , modifyProgramSearchPath ) import Distribution.Simple.Program.Find ( ProgramSearchPathEntry(..) ) import Distribution.Client.Config ( getCabalDir ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, lookupPackageName, lookupUnitId ) import Distribution.Types.InstalledPackageInfo ( InstalledPackageInfo(..) ) import Distribution.Types.Version ( nullVersion ) import Distribution.Types.VersionRange ( thisVersion ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty(..) ) import Distribution.Client.IndexUtils ( getSourcePackages, getInstalledPackages ) import Distribution.Client.ProjectConfig ( readGlobalConfig, projectConfigWithBuilderRepoContext , resolveBuildTimeSettings, withProjectOrGlobalConfig ) import Distribution.Client.DistDirLayout ( defaultDistDirLayout, DistDirLayout(..), mkCabalDirLayout , ProjectRoot(ProjectRootImplicit) , storePackageDirectory, cabalStoreDirLayout , CabalDirLayout(..), StoreDirLayout(..) ) import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.InstallSymlink ( symlinkBinary ) import Distribution.Simple.Setup ( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe, toFlag , trueArg, configureOptions, haddockOptions, flagToList ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.ReadE ( succeedReadE ) import Distribution.Simple.Command ( CommandUI(..), ShowOrParseArgs(..), OptionField(..) , option, usageAlternatives, reqArg ) import Distribution.Simple.Configure ( configCompilerEx ) import Distribution.Simple.Compiler ( Compiler(..), CompilerId(..), CompilerFlavor(..) ) import Distribution.Simple.GHC ( ghcPlatformAndVersionString , GhcImplInfo(..), getImplInfo , GhcEnvironmentFileEntry(..) , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) import Distribution.Types.UnitId ( UnitId ) import Distribution.Types.UnqualComponentName ( UnqualComponentName, unUnqualComponentName ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils ( wrapText, die', notice, warn , withTempDirectory, createDirectoryIfMissingVerbose , ordNub ) import Distribution.Utils.Generic ( writeFileAtomic ) import Distribution.Text ( simpleParse ) import Control.Exception ( catch ) import Control.Monad ( mapM, mapM_ ) import qualified Data.ByteString.Lazy.Char8 as BS import Data.Either ( partitionEithers ) import Data.Ord ( comparing, Down(..) ) import qualified Data.Map as Map import Distribution.Utils.NubList ( fromNubList ) import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing , getTemporaryDirectory, makeAbsolute, doesDirectoryExist ) import System.FilePath ( (), takeDirectory, takeBaseName ) data NewInstallFlags = NewInstallFlags { ninstInstallLibs :: Flag Bool , ninstEnvironmentPath :: Flag FilePath } defaultNewInstallFlags :: NewInstallFlags defaultNewInstallFlags = NewInstallFlags { ninstInstallLibs = toFlag False , ninstEnvironmentPath = mempty } newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags] newInstallOptions _ = [ option [] ["lib"] "Install libraries rather than executables from the target package." ninstInstallLibs (\v flags -> flags { ninstInstallLibs = v }) trueArg , option [] ["package-env", "env"] "Set the environment file that may be modified." ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf }) (reqArg "ENV" (succeedReadE Flag) flagToList) ] installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags , HaddockFlags, NewInstallFlags ) installCommand = CommandUI { commandName = "new-install" , commandSynopsis = "Install packages." , commandUsage = usageAlternatives "new-install" [ "[TARGETS] [FLAGS]" ] , commandDescription = Just $ \_ -> wrapText $ "Installs one or more packages. This is done by installing them " ++ "in the store and symlinking the executables in the directory " ++ "specified by the --symlink-bindir 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 ++ " new-install\n" ++ " Install the package in the current directory\n" ++ " " ++ pname ++ " new-install pkgname\n" ++ " Install the package named pkgname" ++ " (fetching it from hackage if necessary)\n" ++ " " ++ pname ++ " new-install ./pkgfoo\n" ++ " Install the package in the ./pkgfoo directory\n" ++ cmdCommonHelpTextNewBuildBeta , 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 -- hide "target-package-db" flag from the -- install options. (filter ((`notElem` ["v", "verbose"]) . optionName) $ haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (newInstallOptions showOrParseArgs) , commandDefaultFlags = (mempty, mempty, mempty, mempty, defaultNewInstallFlags) } where get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e) get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e) get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e) get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e) get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e) -- | 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 uin the directory specified by --symlink-bindir. -- 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 'new-install'ing libraries -- only works on GHC >= 8.0. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, NewInstallFlags) -> [String] -> GlobalFlags -> IO () installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstallFlags) targetStrings globalFlags = 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" let withProject = do let verbosity' = lessVerbose verbosity -- First, we need to learn about what's available to be installed. localBaseCtx <- establishProjectBaseContext verbosity' cliConfig let localDistDirLayout = distDirLayout localBaseCtx pkgDb <- projectConfigWithBuilderRepoContext verbosity' (buildSettings localBaseCtx) (getSourcePackages verbosity) let (targetStrings', packageIds) = partitionEithers . flip fmap targetStrings $ \str -> case simpleParse 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 Nothing . 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) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan _ -> do -- Split into known targets and hackage packages. (targets, hackageNames) <- case resolveTargets selectPackageTargets selectComponentTarget TargetProblemCommon elaboratedPlan (Just pkgDb) targetSelectors of Right targets -> do -- Everything is a local dependency. return (targets, []) Left errs -> do -- Not everything is local. let (errs', hackageNames) = partitionEithers . flip fmap errs $ \case TargetProblemCommon (TargetAvailableInIndex name) -> Right name err -> Left err when (not . null $ errs') $ reportTargetProblems 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 (reportTargetProblems verbosity) return $ resolveTargets selectPackageTargets selectComponentTarget TargetProblemCommon elaboratedPlan Nothing targetSelectors' return (targets, hackageNames) let planMap = InstallPlan.toMap elaboratedPlan targetIds = Map.keys targets sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = SpecificSourcePackage spkg' where sdistPath = distSdistFile localDistDirLayout packageInfoId TargzFormat spkg' = spkg { packageSource = LocalTarballPackage sdistPath } sdistize named = named local = sdistize <$> localPackages localBaseCtx gatherTargets :: UnitId -> TargetSelector gatherTargets targetId = TargetPackageNamed pkgName Nothing where Just targetUnit = Map.lookup targetId planMap PackageIdentifier{..} = packageId targetUnit targets' = fmap gatherTargets targetIds hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] hackagePkgs = flip NamedPackage [] <$> hackageNames hackageTargets :: [TargetSelector] hackageTargets = flip TargetPackageNamed Nothing <$> hackageNames createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) unless (Map.null targets) $ mapM_ (\(SpecificSourcePackage pkg) -> packageToSdist verbosity (distProjectRootDirectory localDistDirLayout) (Archive TargzFormat) (distSdistFile localDistDirLayout (packageId pkg) TargzFormat) pkg ) (localPackages localBaseCtx) if null targets then return (hackagePkgs, hackageTargets) else return (local ++ hackagePkgs, targets' ++ hackageTargets) return (specs ++ packageSpecifiers, selectors ++ packageTargets, projectConfig localBaseCtx) withoutProject globalConfig = do let parsePkg pkgName | Just (pkg :: PackageId) <- simpleParse pkgName = return pkg | otherwise = die' verbosity ("Invalid package ID: " ++ pkgName) packageIds <- mapM parsePkg targetStrings let packageSpecifiers = flip fmap packageIds $ \case PackageIdentifier{..} | pkgVersion == nullVersion -> NamedPackage pkgName [] | otherwise -> NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds return (packageSpecifiers, packageTargets, globalConfig <> cliConfig) (specs, selectors, config) <- withProjectOrGlobalConfig verbosity globalConfigFlag withProject withoutProject home <- getHomeDirectory let ProjectConfig { projectConfigShared = ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg }, projectConfigLocalPackages = PackageConfig { packageConfigProgramPaths, packageConfigProgramArgs, packageConfigProgramPathExtra } } = config 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 (compiler@Compiler { compilerId = compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb') <- configCompilerEx hcFlavor hcPath hcPkg progDb verbosity let globalEnv name = home ".ghc" ghcPlatformAndVersionString platform compilerVersion "environments" name localEnv dir = dir ".ghc.environment." ++ ghcPlatformAndVersionString platform compilerVersion GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler -- Why? We know what the first part will be, we only care about the packages. filterEnvEntries = filter $ \case GhcEnvFilePackageId _ -> True _ -> False envFile <- case flagToMaybe (ninstEnvironmentPath newInstallFlags) of Just spec -- Is spec a bare word without any "pathy" content, then it refers to -- a named global environment. | takeBaseName spec == spec -> return (globalEnv 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 (localEnv spec') -- Otherwise, treat it like a literal file path. else return spec' Nothing -> return (globalEnv "default") envFileExists <- doesFileExist envFile envEntries <- 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 [] cabalDir <- getCabalDir let mstoreDir = flagToMaybe (globalStoreDir globalFlags) mlogsDir = flagToMaybe (globalLogsDir globalFlags) cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir packageDbs = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb' let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries -- 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 baseCtx <- establishDummyProjectBaseContext verbosity config tmpDir (envSpecs ++ specs) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do -- Interpret the targets on the command line as build targets targets <- either (reportTargetProblems verbosity) return $ resolveTargets selectPackageTargets selectComponentTarget TargetProblemCommon elaboratedPlan Nothing selectors let elaboratedPlan' = pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan elaboratedPlan'' <- if buildSettingOnlyDeps (buildSettings baseCtx) then either (reportCannotPruneDependencies verbosity) return $ pruneInstallPlanToDependencies (Map.keysSet targets) elaboratedPlan' else return elaboratedPlan' return (elaboratedPlan'', targets) printPlan verbosity baseCtx buildCtx buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx let mkPkgBinDir = ( "bin") . storePackageDirectory (cabalStoreDirLayout $ cabalDirLayout baseCtx) compilerId installLibs = fromFlagOrDefault False (ninstInstallLibs newInstallFlags) when (not installLibs) $ do -- If there are exes, symlink them let symlinkBindirUnknown = "symlink-bindir is not defined. Set it in your cabal config file " ++ "or use --symlink-bindir=" symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown) $ fmap makeAbsolute $ projectConfigSymlinkBinDir $ projectConfigBuildOnly $ projectConfig $ baseCtx createDirectoryIfMissingVerbose verbosity False symlinkBindir traverse_ (symlinkBuiltPackage verbosity mkPkgBinDir symlinkBindir) $ Map.toList $ targetsMap buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes when installLibs $ if supportsPkgEnvFiles then do -- Why do we get it again? If we updated a globalPackage then we need -- the new version. installedIndex' <- getInstalledPackages verbosity compiler packageDbs progDb' let getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst)) . 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)" where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags' configExFlags installFlags haddockFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) 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" ] environmentFileToSpecifiers :: InstalledPackageIndex -> [GhcEnvironmentFileEntry] -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) environmentFileToSpecifiers ipi = foldMap $ \case (GhcEnvFilePackageId unitId) | Just InstalledPackageInfo{ sourcePackageId = PackageIdentifier{..}, installedUnitId } <- 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 every exe from a package from the store to a given location symlinkBuiltPackage :: Verbosity -> (UnitId -> FilePath) -- ^ A function to get an UnitId's -- store directory -> FilePath -- ^ Where to put the symlink -> ( UnitId , [(ComponentTarget, [TargetSelector])] ) -> IO () symlinkBuiltPackage verbosity mkSourceBinDir destDir (pkg, components) = traverse_ (symlinkBuiltExe verbosity (mkSourceBinDir pkg) destDir) exes where exes = catMaybes $ (exeMaybe . fst) <$> components exeMaybe (ComponentTarget (CExeName exe) _) = Just exe exeMaybe _ = Nothing -- | Symlink a specific exe. symlinkBuiltExe :: Verbosity -> FilePath -> FilePath -> UnqualComponentName -> IO Bool symlinkBuiltExe verbosity sourceDir destDir exe = do notice verbosity $ "Symlinking " ++ unUnqualComponentName exe symlinkBinary destDir sourceDir exe $ unUnqualComponentName exe -- | 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 (ComponentTarget (CSubLibName _) _, _) = True hasLib _ = False go :: UnitId -> [(ComponentTarget, [TargetSelector])] -> [GhcEnvironmentFileEntry] go unitId targets | any hasLib targets = [GhcEnvFilePackageId unitId] | otherwise = [] -- | 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 -> FilePath -- ^ Where to put the dist directory -> [PackageSpecifier UnresolvedSourcePackage] -- ^ The packages to be included in the project -> IO ProjectBaseContext establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do cabalDir <- getCabalDir -- Create the dist directories createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout 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 } where mdistDirectory = flagToMaybe $ projectConfigDistDir $ projectConfigShared cliConfig projectRoot = ProjectRootImplicit tmpDir distDirLayout = defaultDistDirLayout projectRoot mdistDirectory -- | 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 subtarget = either (Left . TargetProblemCommon) Right . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @build@ command. -- data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all | TargetProblemNoTargets TargetSelector deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a reportTargetProblems verbosity = die' verbosity . unlines . map renderTargetProblem renderTargetProblem :: TargetProblem -> String renderTargetProblem (TargetProblemCommon problem) = renderTargetProblemCommon "build" problem renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = renderTargetProblemNoneEnabled "build" targetSelector targets renderTargetProblem(TargetProblemNoTargets targetSelector) = renderTargetProblemNoTargets "build" targetSelector reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a reportCannotPruneDependencies verbosity = die' verbosity . renderCannotPruneDependencies cabal-install-2.4.0.0/Distribution/Client/CmdLegacy.hs0000644000000000000000000001657200000000000020604 0ustar0000000000000000{-# 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 ( warn, wrapText ) import Distribution.Verbosity ( Verbosity, normal ) import Control.Exception ( SomeException(..), try ) import qualified Data.Text as T -- Tweaked versions of code from Main. regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> Bool -> CommandSpec (globals -> IO action) regularCmd ui action shouldWarn = CommandSpec ui ((flip commandAddAction) (\flags extra globals -> showWarning flags >> action flags extra globals)) NormalCommand where showWarning flags = if shouldWarn then warn (verbosity flags) (deprecationNote (commandName ui) ++ "\n") else return () wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Bool -> CommandSpec (Client.GlobalFlags -> IO ()) wrapperCmd ui verbosity' distPref shouldWarn = CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref shouldWarn) NormalCommand wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Bool -> Command (Client.GlobalFlags -> IO ()) wrapperAction command verbosityFlag distPrefFlag shouldWarn = commandAddAction command { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) if shouldWarn then warn verbosity' (deprecationNote (commandName command) ++ "\n") else return () load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) let config = either (\(SomeException _) -> mempty) snd 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 b) => HasVerbosity (a, b, c) where verbosity (_ , b, _) = verbosity b instance (HasVerbosity a) => HasVerbosity (a, b, c, d) 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 Client.SDistFlags where verbosity = verbosity . Client.sDistVerbosity instance HasVerbosity Client.SandboxFlags where verbosity = verbosity . Client.sandboxVerbosity instance HasVerbosity Setup.DoctestFlags where verbosity = verbosity . Setup.doctestVerbosity -- deprecationNote :: String -> String deprecationNote cmd = wrapText $ "The " ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ "Please switch to using either the new project style and the new-" ++ cmd ++ " command or the legacy v1-" ++ cmd ++ " alias as new-style projects will" ++ " become the default in the next version of cabal-install. Please file a" ++ " bug if you cannot replicate a working v1- use case with the new-style commands.\n\n" ++ "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n" 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 new-style" ++ " commands.\n\n" ++ "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n" toLegacyCmd :: (Bool -> CommandSpec (globals -> IO action)) -> [CommandSpec (globals -> IO action)] toLegacyCmd mkSpec = [toDeprecated (mkSpec True), toLegacy (mkSpec False)] where legacyMsg = T.unpack . T.replace "v1-" "" . T.pack 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 } toDeprecated (CommandSpec origUi@CommandUI{..} action type') = CommandSpec depUi action type' where depUi = origUi { commandName = legacyMsg commandName , commandUsage = legacyMsg . commandUsage , commandDescription = (legacyMsg .) <$> commandDescription , commandNotes = Just $ \pname -> case commandNotes of Just notes -> legacyMsg (notes pname) ++ "\n" ++ deprecationNote commandName Nothing -> deprecationNote 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 v2Ui, cmd origUi] where cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand v2Msg = T.unpack . T.replace "new-" "v2-" . T.pack v2Ui = origUi { commandName = v2Msg commandName , commandUsage = v2Msg . commandUsage , commandDescription = (v2Msg .) <$> commandDescription , commandNotes = (v2Msg .) <$> commandDescription } cabal-install-2.4.0.0/Distribution/Client/CmdRepl.hs0000644000000000000000000005607400000000000020303 0ustar0000000000000000{-# 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 TargetProblem(..), selectPackageTargets, selectComponentTarget ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L import Distribution.Client.CmdErrorMessages import Distribution.Client.CmdInstall ( establishDummyProjectBaseContext ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.ProjectBuilding ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) import Distribution.Client.ProjectConfig ( ProjectConfig(..), withProjectOrGlobalConfig , projectConfigConfigFile, readGlobalConfig ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault, replOptions , Flag(..), toFlag, trueArg, falseArg ) import Distribution.Simple.Command ( CommandUI(..), liftOption, usageAlternatives, option , ShowOrParseArgs, OptionField, reqArg ) import Distribution.Package ( Package(..), packageName, UnitId, installedUnitId ) import Distribution.PackageDescription.PrettyPrint import Distribution.Parsec.Class ( Parsec(..) ) import Distribution.Pretty ( prettyShow ) 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(..) ) import Distribution.Types.GenericPackageDescription ( emptyGenericPackageDescription ) import Distribution.Types.PackageDescription ( PackageDescription(..), emptyPackageDescription ) import Distribution.Types.Library ( Library(..), emptyLibrary ) import Distribution.Types.PackageId ( PackageIdentifier(..) ) import Distribution.Types.Version ( mkVersion, version0 ) import Distribution.Types.VersionRange ( anyVersion ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist ) import Language.Haskell.Extension ( Language(..) ) import Data.List ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as Set import System.Directory ( getTemporaryDirectory, removeDirectoryRecursive ) import System.FilePath ( () ) type ReplFlags = [String] data EnvFlags = EnvFlags { envPackages :: [Dependency] , envIncludeTransitive :: Flag Bool , envIgnoreProject :: Flag Bool } defaultEnvFlags :: EnvFlags defaultEnvFlags = EnvFlags { envPackages = [] , envIncludeTransitive = toFlag True , envIgnoreProject = toFlag False } envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] envOptions _ = [ option ['b'] ["build-depends"] "Include an additional package in the environment presented to GHCi." envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) (reqArg "DEPENDENCY" dependencyReadE (fmap prettyShow :: [Dependency] -> [String])) , option [] ["no-transitive-deps"] "Don't automatically include transitive dependencies of requested packages." envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) falseArg , option ['z'] ["ignore-project"] "Only include explicitly specified packages (and 'base')." envIgnoreProject (\p flags -> flags { envIgnoreProject = p }) trueArg ] where dependencyReadE :: ReadE [Dependency] dependencyReadE = fmap pure $ parsecToReadE ("couldn't parse dependency: " ++) parsec replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags, EnvFlags) replCommand = Client.installCommand { commandName = "new-repl", commandSynopsis = "Open an interactive session for the given component.", commandUsage = usageAlternatives "new-repl" [ "[TARGET] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Open an interactive session for a component within the project. The " ++ "available targets are the same as for the 'new-build' command: " ++ "individual components within packages in the project, including " ++ "libraries, executables, test-suites or benchmarks. Packages can " ++ "also be specified in which case the library component in the " ++ "package will be used, or the (first listed) executable in the " ++ "package if there is no library.\n\n" ++ "Dependencies are built or rebuilt as necessary. Additional " ++ "configuration flags can be specified on the command line and these " ++ "extend the project configuration from the 'cabal.project', " ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples, open an interactive session:\n" ++ " " ++ pname ++ " new-repl\n" ++ " for the default component in the package in the current directory\n" ++ " " ++ pname ++ " new-repl pkgname\n" ++ " for the default component in the package named 'pkgname'\n" ++ " " ++ pname ++ " new-repl ./pkgfoo\n" ++ " for the default component in the package in the ./pkgfoo directory\n" ++ " " ++ pname ++ " new-repl cname\n" ++ " for the component named 'cname'\n" ++ " " ++ pname ++ " new-repl pkgname:cname\n" ++ " for the component 'cname' in the package 'pkgname'\n\n" ++ " " ++ pname ++ " new-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 ++ " new-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" ++ cmdCommonHelpTextNewBuildBeta, commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,[],defaultEnvFlags), commandOptions = \showOrParseArgs -> map liftOriginal (commandOptions Client.installCommand showOrParseArgs) ++ map liftReplOpts (replOptions showOrParseArgs) ++ map liftEnvOpts (envOptions showOrParseArgs) } where (configFlags,configExFlags,installFlags,haddockFlags) = commandDefaultFlags Client.installCommand liftOriginal = liftOption projectOriginal updateOriginal liftReplOpts = liftOption projectReplOpts updateReplOpts liftEnvOpts = liftOption projectEnvOpts updateEnvOpts projectOriginal (a,b,c,d,_,_) = (a,b,c,d) updateOriginal (a,b,c,d) (_,_,_,_,e,f) = (a,b,c,d,e,f) projectReplOpts (_,_,_,_,e,_) = e updateReplOpts e (a,b,c,d,_,f) = (a,b,c,d,e,f) projectEnvOpts (_,_,_,_,_,f) = f updateEnvOpts f (a,b,c,d,e,_) = (a,b,c,d,e,f) -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit -- repl target and then executes the plan. -- -- Compared to @build@ the difference is that only one target is allowed -- (given or implicit) and the target type is repl rather than build. The -- general plan execution infrastructure handles both build and repl targets. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO () replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, envFlags) targetStrings globalFlags = do let ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags) with = withProject cliConfig verbosity targetStrings without config = withoutProject (config <> cliConfig) verbosity targetStrings (baseCtx, targetSelectors, finalizer) <- if ignoreProject then do globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag without globalConfig else withProjectOrGlobalConfig verbosity 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 <- validatedTargets elaboratedPlan targetSelectors let (unitId, _) = head $ Map.toList targets originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId oci = OriginalComponentInfo unitId originalDeps Just pkgId = 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) replFlags' = case originalComponent of Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci Nothing -> [] 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 } 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) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags 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 TargetProblemCommon 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 [TargetProblemMultipleTargets targets] return targets data OriginalComponentInfo = OriginalComponentInfo { ociUnitId :: UnitId , ociOriginalDeps :: [UnitId] } deriving (Show) withProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ()) withProject cliConfig verbosity targetStrings = do baseCtx <- establishProjectBaseContext verbosity cliConfig targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings return (baseCtx, targetSelectors, return ()) withoutProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ()) 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 { packageInfoId = pkgId , packageDescription = genericPackageDescription , packageSource = LocalUnpackedPackage tempDir , packageDescrOverride = Nothing } genericPackageDescription = emptyGenericPackageDescription & L.packageDescription .~ packageDescription & L.condLibrary .~ Just (CondNode library [baseDep] []) packageDescription = emptyPackageDescription { package = pkgId , specVersionRaw = Left (mkVersion [2, 2]) , licenseRaw = Left SPDX.NONE } library = emptyLibrary { libBuildInfo = buildInfo } buildInfo = emptyBuildInfo { targetBuildDepends = [baseDep] , defaultLanguage = Just Haskell2010 } baseDep = Dependency "base" anyVersion pkgId = PackageIdentifier "fake-package" version0 writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription baseCtx <- establishDummyProjectBaseContext verbosity config tempDir [SpecificSourcePackage sourcePackage] let targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir) return (baseCtx, targetSelectors, finalizer) 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 { packageDescription = packageDescription & (\f -> L.allCondTrees $ traverseCondTreeC f) %~ (deps ++) } addDeps spec = spec generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags where 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 = ("-package-id " ++) . prettyShow <$> 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 TargetProblem [k] selectPackageTargets targetSelector targets -- If there is exactly one buildable library then we select that | [target] <- targetsLibsBuildable = Right [target] -- but fail if there are multiple buildable libraries. | not (null targetsLibsBuildable) = Left (TargetProblemMatchesMultiple targetSelector targetsLibsBuildable') -- If there is exactly one buildable executable then we select that | [target] <- targetsExesBuildable = Right [target] -- but fail if there are multiple buildable executables. | not (null targetsExesBuildable) = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable') -- If there is exactly one other target then we select that | [target] <- targetsBuildable = Right [target] -- but fail if there are multiple such targets | not (null targetsBuildable) = Left (TargetProblemMatchesMultiple targetSelector targetsBuildable') -- If there are targets but none are buildable then we report those | not (null targets) = Left (TargetProblemNoneEnabled targetSelector targets') -- If there are no targets at all then we report that | otherwise = Left (TargetProblemNoTargets targetSelector) where targets' = forgetTargetsDetail targets (targetsLibsBuildable, targetsLibsBuildable') = selectBuildableTargets' . filterTargetsKind LibKind $ targets (targetsExesBuildable, targetsExesBuildable') = selectBuildableTargets' . filterTargetsKind ExeKind $ targets (targetsBuildable, targetsBuildable') = selectBuildableTargetsWith' (isRequested targetSelector) targets -- When there's a target filter like "pkg:tests" then we do select tests, -- but if it's just a target like "pkg" then we don't build tests unless -- they are requested by default (i.e. by using --enable-tests) isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False isRequested _ _ = True -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @repl@ command we just need the basic checks on being buildable etc. -- selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. -- data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all | TargetProblemNoTargets TargetSelector -- | A single 'TargetSelector' matches multiple targets | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] -- | Multiple 'TargetSelector's match multiple targets | TargetProblemMultipleTargets TargetsMap deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a reportTargetProblems verbosity = die' verbosity . unlines . map renderTargetProblem renderTargetProblem :: TargetProblem -> String renderTargetProblem (TargetProblemCommon problem) = renderTargetProblemCommon "open a repl for" problem renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) = "Cannot open a repl for multiple components at once. The target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ " which " ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") ++ renderListSemiAnd [ "the " ++ renderComponentKind Plural ckind ++ " " ++ renderListCommaAnd [ maybe (display pkgname) display (componentNameString cname) | t <- ts , let cname = availableTargetComponentName t pkgname = packageName (availableTargetPackageId t) ] | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets ] ++ ".\n\n" ++ explanationSingleComponentLimitation where availableTargetComponentKind = componentKind . availableTargetComponentName renderTargetProblem (TargetProblemMultipleTargets selectorMap) = "Cannot open a repl for multiple components at once. The targets " ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] ++ " refer to different components." ++ ".\n\n" ++ explanationSingleComponentLimitation renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = renderTargetProblemNoneEnabled "open a repl for" targetSelector targets renderTargetProblem (TargetProblemNoTargets targetSelector) = renderTargetProblemNoTargets "open a repl for" targetSelector explanationSingleComponentLimitation :: String explanationSingleComponentLimitation = "The reason for this limitation is that current versions of ghci do not " ++ "support loading multiple components as source. Load just one component " ++ "and when you make changes to a dependent component then quit and reload." cabal-install-2.4.0.0/Distribution/Client/CmdRun.hs0000644000000000000000000005453500000000000020145 0ustar0000000000000000{-# 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, -- * Internals exposed for testing TargetProblem(..), selectPackageTargets, selectComponentTarget ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Client.GlobalFlags ( defaultGlobalFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName ( showComponentName ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils ( wrapText, die', ordNub, info , createTempDirectory, handleDoesNotExist ) import Distribution.Client.CmdInstall ( establishDummyProjectBaseContext ) import Distribution.Client.ProjectConfig ( ProjectConfig(..), ProjectConfigShared(..) , withProjectOrGlobalConfig ) 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.CabalSpecVersion ( cabalSpecLatest ) import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..) ) import Distribution.FieldGrammar ( takeFields, parseFieldGrammar ) import Distribution.PackageDescription.FieldGrammar ( executableFieldGrammar ) import Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription ) import Distribution.Parsec.Common ( Position(..) ) import Distribution.Parsec.ParseResult ( ParseResult, parseString, parseFatalFailure ) import Distribution.Parsec.Parser ( 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.PackageId ( PackageIdentifier(..) ) import Distribution.Types.Version ( mkVersion, version0 ) 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 ( () ) runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) runCommand = Client.installCommand { commandName = "new-run", commandSynopsis = "Run an executable.", commandUsage = usageAlternatives "new-run" [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ], commandDescription = Just $ \pname -> wrapText $ "Runs the specified executable-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 ++ " new-run\n" ++ " Run the executable-like in the package in the current directory\n" ++ " " ++ pname ++ " new-run foo-tool\n" ++ " Run the named executable-like (in any package in the project)\n" ++ " " ++ pname ++ " new-run pkgfoo:foo-tool\n" ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" ++ " " ++ pname ++ " new-run foo -O2 -- dothing --fooflag\n" ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" ++ cmdCommonHelpTextNewBuildBeta } -- | The @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 :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () runAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do globalTmp <- getTemporaryDirectory tempDir <- createTempDirectory globalTmp "cabal-repl." let with = establishProjectBaseContext verbosity cliConfig without config = establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] baseCtx <- withProjectOrGlobalConfig verbosity globalConfigFlag with without let scriptOrError script err = do exists <- doesFileExist script if exists then BS.readFile script >>= handleScriptCase verbosity baseCtx tempDir 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 TargetProblemCommon 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 [TargetProblemMultipleTargets 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 " ++ display selectedUnitId [elabPkg] -> do info verbosity $ "Selecting " ++ display selectedUnitId ++ " to supply " ++ exeName return elabPkg elabPkgs -> die' verbosity $ "Multiple matching executables found matching " ++ exeName ++ ":\n" ++ unlines (fmap (\p -> " - in package " ++ display (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 elaboratedPlan } handleDoesNotExist () (removeDirectoryRecursive tempDir) where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) handleShebang :: String -> IO () handleShebang script = runAction (commandDefaultFlags runCommand) [script] 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 -> BS.ByteString -> IO (Executable, BS.ByteString) readScriptBlockFromScript verbosity str = (\x -> (x, noShebang)) <$> readScriptBlock verbosity str' where start = "{- cabal:" end = "-}" str' = BS.unlines . takeWhile (/= end) . drop 1 . dropWhile (/= start) $ lines' noShebang = BS.unlines . filter ((/= "#!") . BS.take 2) $ lines' lines' = BS.lines str handleScriptCase :: Verbosity -> ProjectBaseContext -> FilePath -> BS.ByteString -> IO (ProjectBaseContext, [TargetSelector]) handleScriptCase verbosity baseCtx tempDir scriptContents = do (executable, contents') <- readScriptBlockFromScript verbosity scriptContents -- We need to create a dummy package that lives in our dummy project. let sourcePackage = SourcePackage { packageInfoId = pkgId , SP.packageDescription = genericPackageDescription , packageSource = LocalUnpackedPackage tempDir , packageDescrOverride = Nothing } genericPackageDescription = emptyGenericPackageDescription { GPD.packageDescription = packageDescription , condExecutables = [("script", CondNode executable' targetBuildDepends [])] } executable' = executable { modulePath = "Main.hs" , buildInfo = binfo { defaultLanguage = case defaultLanguage of just@(Just _) -> just Nothing -> Just Haskell2010 } } binfo@BuildInfo{..} = buildInfo executable packageDescription = emptyPackageDescription { package = pkgId , specVersionRaw = Left (mkVersion [2, 2]) , licenseRaw = Left SPDX.NONE } pkgId = PackageIdentifier "fake-package" version0 writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription BS.writeFile (tempDir "Main.hs") 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 TargetProblem [k] selectPackageTargets targetSelector targets -- If there is exactly one buildable executable then we select that | [target] <- targetsExesBuildable = Right [target] -- but fail if there are multiple buildable executables. | not (null targetsExesBuildable) = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable') -- If there are executables but none are buildable then we report those | not (null targetsExes) = Left (TargetProblemNoneEnabled targetSelector targetsExes) -- If there are no executables but some other targets then we report that | not (null targets) = Left (TargetProblemNoExes targetSelector) -- If there are no targets at all then we report that | otherwise = Left (TargetProblemNoTargets targetSelector) where -- 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 TargetProblem k selectComponentTarget subtarget@WholeComponent t = case availableTargetComponentName t of CExeName _ -> component CTestName _ -> component CBenchName _ -> component _ -> Left (TargetProblemComponentNotExe pkgid cname) where pkgid = availableTargetPackageId t cname = availableTargetComponentName t component = either (Left . TargetProblemCommon) return $ selectComponentTargetBasic subtarget t selectComponentTarget subtarget t = Left (TargetProblemIsSubComponent (availableTargetPackageId t) (availableTargetComponentName t) subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @run@ command. -- data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all | TargetProblemNoTargets TargetSelector -- | 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) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a reportTargetProblems verbosity = die' verbosity . unlines . map renderTargetProblem renderTargetProblem :: TargetProblem -> String renderTargetProblem (TargetProblemCommon problem) = renderTargetProblemCommon "run" problem renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = renderTargetProblemNoneEnabled "run" targetSelector targets renderTargetProblem (TargetProblemNoExes targetSelector) = "Cannot run the target '" ++ showTargetSelector targetSelector ++ "' which refers to " ++ renderTargetSelector targetSelector ++ " because " ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" ++ " not contain any executables." renderTargetProblem (TargetProblemNoTargets targetSelector) = case targetSelectorFilter targetSelector of Just kind | kind /= ExeKind -> "The run command is for running executables, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ "." _ -> renderTargetProblemNoTargets "run" targetSelector renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) = "The run command is for running a single executable at once. The target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ " which includes " ++ renderListCommaAnd ( ("the "++) <$> showComponentName <$> availableTargetComponentName <$> foldMap (\kind -> filterTargetsKind kind targets) [ExeKind, TestKind, BenchKind] ) ++ "." renderTargetProblem (TargetProblemMultipleTargets selectorMap) = "The run command is for running a single executable at once. The targets " ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] ++ " refer to different executables." renderTargetProblem (TargetProblemComponentNotExe pkgid cname) = "The run command is for running executables, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ " from the package " ++ display pkgid ++ "." where targetSelector = TargetComponent pkgid cname WholeComponent renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = "The run command can only run an executable as a whole, " ++ "not files or modules within them, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ "." where targetSelector = TargetComponent pkgid cname subtarget cabal-install-2.4.0.0/Distribution/Client/CmdSdist.hs0000644000000000000000000003477500000000000020473 0ustar0000000000000000{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Distribution.Client.CmdSdist ( sdistCommand, sdistAction, packageToSdist , SdistFlags(..), defaultSdistFlags , OutputFormat(..), ArchiveFormat(..) ) where import Distribution.Client.CmdErrorMessages ( Plural(..), renderComponentKind ) import Distribution.Client.ProjectOrchestration ( ProjectBaseContext(..), establishProjectBaseContext ) import Distribution.Client.TargetSelector ( TargetSelector(..), ComponentKind , readTargetSelectors, reportTargetSelectorProblems ) import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.Setup ( ArchiveFormat(..), GlobalFlags(..) ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.Client.Types ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) import Distribution.Client.DistDirLayout ( DistDirLayout(..), defaultDistDirLayout ) import Distribution.Client.ProjectConfig ( findProjectRoot, readProjectConfig ) import Distribution.Package ( Package(packageId) ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Pretty ( prettyShow ) import Distribution.ReadE ( succeedReadE ) import Distribution.Simple.Command ( CommandUI(..), option, choiceOpt, reqArg ) import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Setup ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe , optionVerbosity, optionDistPref, trueArg ) import Distribution.Simple.SrcDist ( listPackageSources ) import Distribution.Simple.Utils ( die', notice, withOutputMarker ) import Distribution.Types.ComponentName ( ComponentName, showComponentName ) import Distribution.Types.PackageName ( PackageName, unPackageName ) import Distribution.Verbosity ( Verbosity, normal ) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Zip as Zip import qualified Codec.Compression.GZip as GZip import Control.Exception ( throwIO ) import Control.Monad ( when, forM, forM_ ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State.Lazy ( StateT, modify, gets, evalStateT ) import Control.Monad.Writer.Lazy ( WriterT, tell, execWriterT ) import Data.Bits ( shiftL ) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Either ( partitionEithers ) import Data.List ( find, sortOn, nub, intercalate ) import qualified Data.Set as Set import System.Directory ( getCurrentDirectory, setCurrentDirectory , createDirectoryIfMissing, makeAbsolute ) import System.FilePath ( (), (<.>), makeRelative, normalise, takeDirectory ) sdistCommand :: CommandUI SdistFlags sdistCommand = CommandUI { commandName = "new-sdist" , commandSynopsis = "Generate a source distribution file (.tar.gz)." , commandUsage = \pname -> "Usage: " ++ pname ++ " new-sdist [FLAGS] [PACKAGES]\n" , commandDescription = Just $ \_ -> "Generates tarballs of project packages suitable for upload to Hackage." , commandNotes = Nothing , commandDefaultFlags = defaultSdistFlags , commandOptions = \showOrParseArgs -> [ optionVerbosity sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) , optionDistPref sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) showOrParseArgs , option [] ["project-file"] "Set the name of the cabal.project file to search for in parent directories" sdistProjectFile (\pf flags -> flags { sdistProjectFile = pf }) (reqArg "FILE" (succeedReadE Flag) flagToList) , option ['l'] ["list-only"] "Just list the sources, do not make a tarball" sdistListSources (\v flags -> flags { sdistListSources = v }) trueArg , option ['z'] ["null-sep"] "Separate the source files with NUL bytes rather than newlines." sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) trueArg , option [] ["archive-format"] "Choose what type of archive to create. No effect if given with '--list-only'" sdistArchiveFormat (\v flags -> flags { sdistArchiveFormat = v }) (choiceOpt [ (Flag TargzFormat, ([], ["targz"]), "Produce a '.tar.gz' format archive (default and required for uploading to hackage)") , (Flag ZipFormat, ([], ["zip"]), "Produce a '.zip' format archive") ] ) , option ['o'] ["output-dir", "outputdir"] "Choose the output directory of this command. '-' sends all output to stdout" sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) (reqArg "PATH" (succeedReadE Flag) flagToList) ] } data SdistFlags = SdistFlags { sdistVerbosity :: Flag Verbosity , sdistDistDir :: Flag FilePath , sdistProjectFile :: Flag FilePath , sdistListSources :: Flag Bool , sdistNulSeparated :: Flag Bool , sdistArchiveFormat :: Flag ArchiveFormat , sdistOutputPath :: Flag FilePath } defaultSdistFlags :: SdistFlags defaultSdistFlags = SdistFlags { sdistVerbosity = toFlag normal , sdistDistDir = mempty , sdistProjectFile = mempty , sdistListSources = toFlag False , sdistNulSeparated = toFlag False , sdistArchiveFormat = toFlag TargzFormat , sdistOutputPath = mempty } -- sdistAction :: SdistFlags -> [String] -> GlobalFlags -> IO () sdistAction SdistFlags{..} targetStrings globalFlags = do let verbosity = fromFlagOrDefault normal sdistVerbosity mDistDirectory = flagToMaybe sdistDistDir mProjectFile = flagToMaybe sdistProjectFile globalConfig = globalConfigFile globalFlags listSources = fromFlagOrDefault False sdistListSources nulSeparated = fromFlagOrDefault False sdistNulSeparated archiveFormat = fromFlagOrDefault TargzFormat sdistArchiveFormat mOutputPath = flagToMaybe sdistOutputPath projectRoot <- either throwIO return =<< findProjectRoot Nothing mProjectFile let distLayout = defaultDistDirLayout projectRoot mDistDirectory dir <- getCurrentDirectory projectConfig <- runRebuild dir $ readProjectConfig verbosity globalConfig distLayout baseCtx <- establishProjectBaseContext verbosity projectConfig let localPkgs = localPackages baseCtx targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors localPkgs Nothing targetStrings mOutputPath' <- case mOutputPath of Just "-" -> return (Just "-") Just path -> Just <$> makeAbsolute path Nothing -> return Nothing let format = if | listSources, nulSeparated -> SourceList '\0' | listSources -> SourceList '\n' | otherwise -> Archive archiveFormat ext = case format of SourceList _ -> "list" Archive TargzFormat -> "tar.gz" Archive ZipFormat -> "zip" outputPath pkg = case mOutputPath' of Just path | path == "-" -> "-" | otherwise -> path prettyShow (packageId pkg) <.> ext Nothing | listSources -> "-" | otherwise -> distSdistFile distLayout (packageId pkg) archiveFormat createDirectoryIfMissing True (distSdistDirectory distLayout) 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 -> mapM_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs data IsExec = Exec | NoExec deriving (Show, Eq) data OutputFormat = SourceList Char | Archive ArchiveFormat deriving (Show, Eq) packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () packageToSdist verbosity projectRootDir format outputFile pkg = do dir <- case packageSource pkg of LocalUnpackedPackage path -> return path _ -> die' verbosity "The impossible happened: a local package isn't local" oldPwd <- getCurrentDirectory setCurrentDirectory dir let norm flag = fmap ((flag, ) . normalise) (norm NoExec -> nonexec, norm Exec -> exec) <- listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers let write = if outputFile == "-" then putStr . withOutputMarker verbosity . BSL.unpack else BSL.writeFile outputFile files = nub . sortOn snd $ nonexec ++ exec case format of SourceList nulSep -> do let prefix = makeRelative projectRootDir dir write (BSL.pack . (++ [nulSep]) . intercalate [nulSep] . fmap ((prefix ) . snd) $ files) when (outputFile /= "-") $ notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" Archive TargzFormat -> do let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () entriesM = do let prefix = prettyShow (packageId pkg) 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] forM_ files $ \(perm, file) -> do let fileDir = takeDirectory (prefix file) perm' = case perm of Exec -> Tar.executableFilePermissions NoExec -> Tar.ordinaryFilePermissions 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 $ 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 = perm' }] entries <- execWriterT (evalStateT entriesM mempty) let -- Pretend our GZip file is made on Unix. normalize bs = BSL.concat [first, "\x03", rest'] where (first, rest) = BSL.splitAt 9 bs rest' = BSL.tail rest write . normalize . GZip.compress . Tar.write $ entries when (outputFile /= "-") $ notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" Archive ZipFormat -> do let prefix = prettyShow (packageId pkg) entries <- forM files $ \(perm, file) -> do let perm' = case perm of -- -rwxr-xr-x Exec -> 0o010755 `shiftL` 16 -- -rw-r--r-- NoExec -> 0o010644 `shiftL` 16 contents <- BSL.readFile file return $ (Zip.toEntry (prefix file) 0 contents) { Zip.eExternalFileAttributes = perm' } let archive = foldr Zip.addEntryToArchive Zip.emptyArchive entries write (Zip.fromArchive archive) when (outputFile /= "-") $ notice verbosity $ "Wrote zip sdist to " ++ outputFile ++ "\n" setCurrentDirectory oldPwd -- 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." cabal-install-2.4.0.0/Distribution/Client/CmdTest.hs0000644000000000000000000002337400000000000020315 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} -- | cabal-install CLI command: test -- module Distribution.Client.CmdTest ( -- * The @test@ CLI and action testCommand, testAction, -- * Internals exposed for testing TargetProblem(..), selectPackageTargets, selectComponentTarget ) where import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils ( wrapText, die' ) import Control.Monad (when) testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) testCommand = Client.installCommand { commandName = "new-test", commandSynopsis = "Run test-suites", commandUsage = usageAlternatives "new-test" [ "[TARGETS] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ "Runs the specified test-suites, first ensuring they are up to " ++ "date.\n\n" ++ "Any test-suite in any package in the project can be specified. " ++ "A package can be specified in which case all the test-suites in the " ++ "package are run. The default is to run all the test-suites in the " ++ "package in the current directory.\n\n" ++ "Dependencies are built or rebuilt as necessary. Additional " ++ "configuration flags can be specified on the command line and these " ++ "extend the project configuration from the 'cabal.project', " ++ "'cabal.project.local' and other files.\n\n" ++ "To pass command-line arguments to a test suite, see the " ++ "new-run command.", commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " new-test\n" ++ " Run all the test-suites in the package in the current directory\n" ++ " " ++ pname ++ " new-test pkgname\n" ++ " Run all the test-suites in the package named pkgname\n" ++ " " ++ pname ++ " new-test cname\n" ++ " Run the test-suite named cname\n" ++ " " ++ pname ++ " new-test cname --enable-coverage\n" ++ " Run the test-suite built with code coverage (including local libs used)\n\n" ++ cmdCommonHelpTextNewBuildBeta } -- | The @test@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit -- test target(s) and then executes the plan. -- -- Compared to @build@ the difference is that there's also test targets -- which are ephemeral. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () testAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig 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) return $ resolveTargets selectPackageTargets selectComponentTarget TargetProblemCommon 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 verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags -- | This defines what a 'TargetSelector' means for the @test@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- or otherwise classifies the problem. -- -- For the @test@ command we select all buildable test-suites, -- or fail if there are no test-suites or no buildable test-suites. -- selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets -- If there are any buildable test-suite targets then we select those | not (null targetsTestsBuildable) = Right targetsTestsBuildable -- If there are test-suites but none are buildable then we report those | not (null targetsTests) = Left (TargetProblemNoneEnabled targetSelector targetsTests) -- If there are no test-suite but some other targets then we report that | not (null targets) = Left (TargetProblemNoTests targetSelector) -- If there are no targets at all then we report that | otherwise = Left (TargetProblemNoTargets targetSelector) where targetsTestsBuildable = selectBuildableTargets . filterTargetsKind TestKind $ targets targetsTests = forgetTargetsDetail . filterTargetsKind TestKind $ targets -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @test@ command we just need to check it is a test-suite, in addition -- to the basic checks on being buildable etc. -- selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k selectComponentTarget subtarget@WholeComponent t | CTestName _ <- availableTargetComponentName t = either (Left . TargetProblemCommon) return $ selectComponentTargetBasic subtarget t | otherwise = Left (TargetProblemComponentNotTest (availableTargetPackageId t) (availableTargetComponentName t)) selectComponentTarget subtarget t = Left (TargetProblemIsSubComponent (availableTargetPackageId t) (availableTargetComponentName t) subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @test@ command. -- data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all | TargetProblemNoTargets TargetSelector -- | 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) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a reportTargetProblems verbosity = die' verbosity . unlines . map renderTargetProblem renderTargetProblem :: TargetProblem -> String renderTargetProblem (TargetProblemCommon problem) = renderTargetProblemCommon "run" problem renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = renderTargetProblemNoneEnabled "test" targetSelector targets renderTargetProblem (TargetProblemNoTests targetSelector) = "Cannot run tests for the target '" ++ showTargetSelector targetSelector ++ "' which refers to " ++ renderTargetSelector targetSelector ++ " because " ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" ++ " not contain any test suites." renderTargetProblem (TargetProblemNoTargets targetSelector) = case targetSelectorFilter targetSelector of Just kind | kind /= TestKind -> "The test command is for running test suites, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ "." _ -> renderTargetProblemNoTargets "test" targetSelector renderTargetProblem (TargetProblemComponentNotTest pkgid cname) = "The test command is for running test suites, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ " from the package " ++ display pkgid ++ "." where targetSelector = TargetComponent pkgid cname WholeComponent renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = "The test command can only run test suites as a whole, " ++ "not files or modules within them, but the target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ "." where targetSelector = TargetComponent pkgid cname subtarget cabal-install-2.4.0.0/Distribution/Client/CmdUpdate.hs0000644000000000000000000002332700000000000020616 0ustar0000000000000000{-# LANGUAGE CPP, LambdaCase, NamedFieldPuns, RecordWildCards, ViewPatterns, TupleSections #-} -- | cabal-install CLI command: update -- module Distribution.Client.CmdUpdate ( updateCommand, updateAction, ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.Compat.Directory ( setModificationTime ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig ( ProjectConfig(..) , ProjectConfigShared(projectConfigConfigFile) , projectConfigWithSolverRepoContext , withProjectOrGlobalConfig ) import Distribution.Client.Types ( Repo(..), RemoteRepo(..), isRepoRemote ) import Distribution.Client.HttpUtils ( DownloadResult(..) ) import Distribution.Client.FetchUtils ( downloadIndex ) import Distribution.Client.JobControl ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags , UpdateFlags, defaultUpdateFlags , RepoContext(..) ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.IndexUtils ( updateRepoIndexCache, Index(..), writeIndexTimestamp , currentIndexTimestamp, indexBaseName ) import Distribution.Text ( Text(..), display, simpleParse ) import Data.Maybe (fromJust) import qualified Distribution.Compat.ReadP as ReadP import qualified Text.PrettyPrint as Disp import Control.Monad (mapM, mapM_) 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 Distribution.Client.Setup as Client import qualified Hackage.Security.Client as Sec updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags , InstallFlags, HaddockFlags ) updateCommand = Client.installCommand { commandName = "new-update", commandSynopsis = "Updates list of known packages.", commandUsage = usageAlternatives "new-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 ++ " new-update\n" ++ " Download the package list for all known remote repositories.\n\n" ++ " " ++ pname ++ " new-update hackage.haskell.org,@1474732068\n" ++ " " ++ pname ++ " new-update hackage.haskell.org,2016-09-24T17:47:48Z\n" ++ " " ++ pname ++ " new-update hackage.haskell.org,HEAD\n" ++ " " ++ pname ++ " new-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\n" ++ "Note: this command is part of the new project-based system (aka " ++ "nix-style\nlocal builds). These features are currently in beta. " ++ "Please see\n" ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " ++ "for\ndetails and advice on what you can expect to work. If you " ++ "encounter problems\nplease file issues at " ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " ++ "to get involved and help with testing, fixing bugs etc then\nthat " ++ "is very much appreciated.\n" } data UpdateRequest = UpdateRequest { _updateRequestRepoName :: String , _updateRequestRepoState :: IndexState } deriving (Show) instance Text UpdateRequest where disp (UpdateRequest n s) = Disp.text n Disp.<> Disp.char ',' Disp.<> disp s parse = parseWithState ReadP.+++ parseHEAD where parseWithState = do name <- ReadP.many1 (ReadP.satisfy (\c -> c /= ',')) _ <- ReadP.char ',' state <- parse return (UpdateRequest name state) parseHEAD = do name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof return (UpdateRequest name IndexStateHead) updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () updateAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag (projectConfig <$> establishProjectBaseContext verbosity cliConfig) (\globalConfig -> return $ globalConfig <> cliConfig) projectConfigWithSolverRepoContext verbosity (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) $ \repoCtxt -> do let repos = filter isRepoRemote $ repoContextRepos repoCtxt repoName = remoteRepoName . repoRemote parseArg :: String -> IO UpdateRequest parseArg s = case simpleParse s of Just r -> return r Nothing -> die' verbosity $ "'new-update' unable to parse repo: \"" ++ s ++ "\"" updateRepoRequests <- mapM 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 $ "'new-update' repo(s): \"" ++ intercalate "\", \"" unknownRepos ++ "\" can not be found in known remote repo(s): " ++ intercalate ", " remoteRepoNames let reposToUpdate :: [(Repo, IndexState)] 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 = fromJust (lookup k repoMap) in [ (lookup' name, state) | (UpdateRequest name state) <- updateRequests ] case reposToUpdate of [] -> return () [(remoteRepo, _)] -> notice verbosity $ "Downloading the latest package list from " ++ repoName remoteRepo _ -> notice verbosity . unlines $ "Downloading the latest package lists from: " : map (("- " ++) . repoName . fst) reposToUpdate jobCtrl <- newParallelJobControl (length reposToUpdate) mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) reposToUpdate mapM_ (\_ -> collectJob jobCtrl) reposToUpdate where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) -> IO () updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do transport <- repoContextGetTransport repoCtxt case repo of RepoLocal{..} -> 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{} -> 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 -- 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 new-update '" ++ remoteRepoName (repoRemote repo) ++ "," ++ display current_ts ++ "'\n" cabal-install-2.4.0.0/Distribution/Client/Compat/0000755000000000000000000000000000000000000017630 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/Compat/Directory.hs0000644000000000000000000000047100000000000022132 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Client.Compat.Directory (setModificationTime) where #if MIN_VERSION_directory(1,2,3) import System.Directory (setModificationTime) #else import Data.Time.Clock (UTCTime) setModificationTime :: FilePath -> UTCTime -> IO () setModificationTime _fp _t = return () #endif cabal-install-2.4.0.0/Distribution/Client/Compat/ExecutablePath.hs0000644000000000000000000001214100000000000023061 0ustar0000000000000000{-# 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 -- 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 cabal-install-2.4.0.0/Distribution/Client/Compat/FileLock.hsc0000644000000000000000000001461500000000000022026 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE InterruptibleFFI #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE DeriveDataTypeable #-} -- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum -- required version. Though note that the locking functionality is not in -- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module. module Distribution.Client.Compat.FileLock ( FileLockingNotSupported(..) , LockMode(..) , hLock , hTryLock ) where #if MIN_VERSION_base(4,10,0) import GHC.IO.Handle.Lock #else -- The remainder of this file is a modified copy -- of GHC.IO.Handle.Lock from ghc-8.2.x -- -- The modifications were just to the imports and the CPP, since we do not have -- access to the HAVE_FLOCK from the ./configure script. We approximate the -- lack of HAVE_FLOCK with defined(solaris2_HOST_OS) instead since that is the -- only known major Unix platform lacking flock(). import Control.Exception (Exception) import Data.Typeable #if defined(solaris2_HOST_OS) import Control.Exception (throwIO) import System.IO (Handle) #else import Data.Bits import Data.Function import Control.Concurrent.MVar import Foreign.C.Error import Foreign.C.Types import GHC.IO.Handle.Types import GHC.IO.FD import GHC.IO.Exception #if defined(mingw32_HOST_OS) #if defined(i386_HOST_ARCH) ## define WINDOWS_CCONV stdcall #elif defined(x86_64_HOST_ARCH) ## define WINDOWS_CCONV ccall #else # error Unknown mingw32 arch #endif #include import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import GHC.Windows #else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ #include #endif /* !defined(mingw32_HOST_OS) */ #endif /* !defined(solaris2_HOST_OS) */ -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. data FileLockingNotSupported = FileLockingNotSupported deriving (Typeable, Show) instance Exception FileLockingNotSupported -- | Indicates a mode in which a file should be locked. data LockMode = SharedLock | ExclusiveLock -- | If a 'Handle' references a file descriptor, attempt to lock contents of the -- underlying file in appropriate mode. If the file is already locked in -- incompatible mode, this function blocks until the lock is established. The -- lock is automatically released upon closing a 'Handle'. -- -- Things to be aware of: -- -- 1) This function may block inside a C call. If it does, in order to be able -- to interrupt it with asynchronous exceptions and/or for other threads to -- continue working, you MUST use threaded version of the runtime system. -- -- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise, -- hence all of their caveats also apply here. -- -- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this -- function throws 'FileLockingNotImplemented'. We deliberately choose to not -- provide fcntl based locking instead because of its broken semantics. -- -- @since 4.10.0.0 hLock :: Handle -> LockMode -> IO () hLock h mode = lockImpl h "hLock" mode True >> return () -- | Non-blocking version of 'hLock'. -- -- @since 4.10.0.0 hTryLock :: Handle -> LockMode -> IO Bool hTryLock h mode = lockImpl h "hTryLock" mode False ---------------------------------------- #if defined(solaris2_HOST_OS) -- | No-op implementation. lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl _ _ _ _ = throwIO FileLockingNotSupported #else /* !defined(solaris2_HOST_OS) */ #if defined(mingw32_HOST_OS) lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl h ctx mode block = do FD{fdFD = fd} <- handleToFd h wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0 let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY}) -- We want to lock the whole file without looking up its size to be -- consistent with what flock does. According to documentation of LockFileEx -- "locking a region that goes beyond the current end-of-file position is -- not an error", however e.g. Windows 10 doesn't accept maximum possible -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by -- trying 2^32-1. fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \case True -> return True False -> getLastError >>= \err -> if | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False | err == #{const ERROR_OPERATION_ABORTED} -> retry | otherwise -> failWith ctx err where sizeof_OVERLAPPED = #{size OVERLAPPED} cmode = case mode of SharedLock -> 0 ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} -- https://msdn.microsoft.com/en-us/library/aa297958.aspx foreign import ccall unsafe "_get_osfhandle" c_get_osfhandle :: CInt -> IO HANDLE -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx foreign import WINDOWS_CCONV interruptible "LockFileEx" c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL #else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl h ctx mode block = do FD{fdFD = fd} <- handleToFd h let flags = cmode .|. (if block then 0 else #{const LOCK_NB}) fix $ \retry -> c_flock fd flags >>= \case 0 -> return True _ -> getErrno >>= \errno -> if | not block && errno == eWOULDBLOCK -> return False | errno == eINTR -> retry | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing where cmode = case mode of SharedLock -> #{const LOCK_SH} ExclusiveLock -> #{const LOCK_EX} foreign import ccall interruptible "flock" c_flock :: CInt -> CInt -> IO CInt #endif /* !defined(mingw32_HOST_OS) */ -- | Turn an existing Handle into a file descriptor. This function throws an -- IOError if the Handle does not reference a file descriptor. handleToFd :: Handle -> IO FD handleToFd h = case h of FileHandle _ mv -> do Handle__{haDevice = dev} <- readMVar mv case cast dev of Just fd -> return fd Nothing -> throwErr "not a file descriptor" DuplexHandle{} -> throwErr "not a file handle" where throwErr msg = ioException $ IOError (Just h) InappropriateType "handleToFd" msg Nothing Nothing #endif /* defined(solaris2_HOST_OS) */ #endif /* MIN_VERSION_base */ cabal-install-2.4.0.0/Distribution/Client/Compat/FilePerms.hs0000644000000000000000000000202500000000000022051 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} module Distribution.Client.Compat.FilePerms ( setFileOrdinary, setFileExecutable, setFileHidden, ) where #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 cabal-install-2.4.0.0/Distribution/Client/Compat/Prelude.hs0000644000000000000000000000111500000000000021562 0ustar0000000000000000-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" {-# OPTIONS_GHC -fno-warn-deprecations #-} -- | This module does two things: -- -- * Acts as a compatiblity layer, like @base-compat@. -- -- * Provides commonly used imports. -- -- This module is a superset of "Distribution.Compat.Prelude" (which -- this module re-exports) -- module Distribution.Client.Compat.Prelude ( module Distribution.Compat.Prelude.Internal , Prelude.IO , readMaybe ) where import Prelude (IO) import Distribution.Compat.Prelude.Internal hiding (IO) import Text.Read ( readMaybe ) cabal-install-2.4.0.0/Distribution/Client/Compat/Process.hs0000644000000000000000000000343100000000000021603 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 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. 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 cabal-install-2.4.0.0/Distribution/Client/Compat/Semaphore.hs0000644000000000000000000000562300000000000022115 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Distribution.Client.Compat.Semaphore ( QSem , newQSem , waitQSem , signalQSem ) where import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, writeTVar) import Control.Exception (mask_, onException) import Control.Monad (join, unless) import Data.Typeable (Typeable) -- | '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 ys = do let (z:zs) = reverse ys writeTVar b1 zs writeTVar b2 [] return (wake s z) cabal-install-2.4.0.0/Distribution/Client/Config.hs0000644000000000000000000014754100000000000020162 0ustar0000000000000000{-# 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, defaultLogsDir, defaultUserInstall, baseSavedConfig, commentSavedConfig, initialSavedConfig, configFieldDescriptions, haddockFlagsFields, installDirsFields, withProgramsFields, withProgramOptionsFields, userConfigDiff, userConfigUpdate, createDefaultConfigFile, remoteRepoFields ) where import Distribution.Client.Types ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, defaultGlobalFlags , ConfigExFlags(..), configureExOptions, defaultConfigExFlags , InstallFlags(..), installOptions, defaultInstallFlags , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , showRepo, parseRepo, readRepo ) import Distribution.Utils.NubList ( NubList, fromNubList, toNubList, overNubList ) import Distribution.Simple.Compiler ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags , HaddockFlags(..), haddockOptions, defaultHaddockFlags , installDirsOptions, optionDistPref , programDbPaths', programDbOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs , PathTemplate, toPathTemplate ) import Distribution.ParseUtils ( FieldDescr(..), liftField , ParseResult(..), PError(..), PWarning(..) , locatedErrorMsg, showPWarning , readFields, warning, lineNo , simpleField, listField, spaceListField , parseFilePathQ, parseOptCommaList, parseTokenQ ) import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) import Distribution.Client.HttpUtils ( isOldHackageURI ) import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) import qualified Distribution.Text as Text ( Text(..), display ) import Distribution.Simple.Command ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) , viewAsFieldDescr ) import Distribution.Simple.Program ( defaultProgramDb ) import Distribution.Simple.Utils ( die', notice, warn, lowercase, cabalVersion ) import Distribution.Compiler ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Solver.Types.ConstraintSource import Data.List ( partition, find, foldl', nubBy ) import Data.Maybe ( fromMaybe ) import Control.Monad ( when, unless, foldM, liftM ) import qualified Distribution.Compat.ReadP as Parse ( (<++), option ) import Distribution.Compat.Semigroup import qualified Text.PrettyPrint as Disp ( render, text, empty ) import Text.PrettyPrint ( ($+$) ) import Text.PrettyPrint.HughesPJ ( text, Doc ) import System.Directory ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) import Network.URI ( URI(..), URIAuth(..), parseURI ) import System.FilePath ( (<.>), (), takeDirectory ) import System.IO.Error ( isDoesNotExistError ) import Distribution.Compat.Environment ( getEnvironment, lookupEnv ) import Distribution.Compat.Exception ( catchIO ) import qualified Paths_cabal_install ( version ) import Data.Version ( showVersion ) import Data.Char ( isSpace ) import qualified Data.Map as M import Data.Function ( on ) import GHC.Generics ( Generic ) -- -- * Configuration saved in the config file -- data SavedConfig = SavedConfig { savedGlobalFlags :: GlobalFlags, savedInstallFlags :: InstallFlags, savedConfigureFlags :: ConfigFlags, savedConfigureExFlags :: ConfigExFlags, savedUserInstallDirs :: InstallDirs (Flag PathTemplate), savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), savedUploadFlags :: UploadFlags, savedReportFlags :: ReportFlags, savedHaddockFlags :: HaddockFlags } deriving Generic instance Monoid SavedConfig where mempty = gmempty mappend = (<>) instance Semigroup SavedConfig where a <> b = SavedConfig { savedGlobalFlags = combinedSavedGlobalFlags, savedInstallFlags = combinedSavedInstallFlags, savedConfigureFlags = combinedSavedConfigureFlags, savedConfigureExFlags = combinedSavedConfigureExFlags, savedUserInstallDirs = combinedSavedUserInstallDirs, savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, savedUploadFlags = combinedSavedUploadFlags, savedReportFlags = combinedSavedReportFlags, savedHaddockFlags = combinedSavedHaddockFlags } 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, globalSandboxConfigFile = combine globalSandboxConfigFile, globalConstraintsFile = combine globalConstraintsFile, globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, globalCacheDir = combine globalCacheDir, globalLocalRepos = lastNonEmptyNL globalLocalRepos, globalLogsDir = combine globalLogsDir, globalWorldFile = combine globalWorldFile, globalRequireSandbox = combine globalRequireSandbox, globalIgnoreSandbox = combine globalIgnoreSandbox, globalIgnoreExpiry = combine globalIgnoreExpiry, globalHttpTransport = combine globalHttpTransport, globalNix = combine globalNix, globalStoreDir = combine globalStoreDir, globalProgPathExtra = lastNonEmptyNL globalProgPathExtra } where combine = combine' savedGlobalFlags lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags combinedSavedInstallFlags = InstallFlags { installDocumentation = combine installDocumentation, installHaddockIndex = combine installHaddockIndex, installDryRun = combine installDryRun, installDest = combine installDest, installMaxBackjumps = combine installMaxBackjumps, installReorderGoals = combine installReorderGoals, installCountConflicts = combine installCountConflicts, installIndependentGoals = combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs, installStrongFlags = combine installStrongFlags, installAllowBootLibInstalls = combine installAllowBootLibInstalls, installReinstall = combine installReinstall, installAvoidReinstalls = combine installAvoidReinstalls, installOverrideReinstall = combine installOverrideReinstall, installUpgradeDeps = combine installUpgradeDeps, installOnly = combine installOnly, installOnlyDeps = combine installOnlyDeps, installIndexState = combine installIndexState, installRootCmd = combine installRootCmd, installSummaryFile = lastNonEmptyNL installSummaryFile, installLogFile = combine installLogFile, installBuildReports = combine installBuildReports, installReportPlanningFailure = combine installReportPlanningFailure, installSymlinkBinDir = combine installSymlinkBinDir, installPerComponent = combine installPerComponent, installOneShot = combine installOneShot, installNumJobs = combine installNumJobs, installKeepGoing = combine installKeepGoing, installRunTests = combine installRunTests, installOfflineMode = combine installOfflineMode, installProjectFileName = combine installProjectFileName } where combine = combine' savedInstallFlags lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags combinedSavedConfigureFlags = ConfigFlags { configArgs = lastNonEmpty configArgs, configPrograms_ = configPrograms_ . savedConfigureFlags $ b, -- TODO: NubListify configProgramPaths = lastNonEmpty configProgramPaths, -- TODO: NubListify configProgramArgs = lastNonEmpty configProgramArgs, configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, configInstantiateWith = lastNonEmpty configInstantiateWith, configHcFlavor = combine configHcFlavor, configHcPath = combine configHcPath, configHcPkg = combine configHcPkg, configVanillaLib = combine configVanillaLib, configProfLib = combine configProfLib, configProf = combine configProf, configSharedLib = combine configSharedLib, configStaticLib = combine configStaticLib, configDynExe = combine configDynExe, 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 } 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 } 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 -- -- * 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 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 symlinkPath <- defaultSymlinkPath 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 AnonymousReports, installNumJobs = toFlag Nothing, installSymlinkBinDir = toFlag symlinkPath } } 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"] defaultSymlinkPath :: IO FilePath defaultSymlinkPath = 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 name = "hackage.haskell.org" uri = URI "http:" (Just (URIAuth "" name "")) "/" "" "" -- Note that lots of old ~/.cabal/config files will have the old url -- http://hackage.haskell.org/packages/archive -- but new config files can use the new url (without the /packages/archive) -- and avoid having to do a http redirect -- For the default repo we know extra information, fill this in. -- -- 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: " ++ Text.display cabalVersion ,"-- cabal-install version: " ++ showVersion Paths_cabal_install.version ,"","" ] -- | 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] }, savedInstallFlags = defaultInstallFlags, 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 } 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", "sandbox-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. [simpleField "compiler" (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) 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` parseOptCommaList Text.parse parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in simpleField "allow-older" (showRelaxDeps . fmap unAllowOlder) parseAllowOlder configAllowOlder (\v flags -> flags { configAllowOlder = v }) ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in simpleField "allow-newer" (showRelaxDeps . fmap unAllowNewer) parseAllowNewer configAllowNewer (\v flags -> flags { configAllowNewer = v }) ] ++ toSavedConfig liftInstallFlag (installOptions ParseArgs) ["dry-run", "only", "only-dependencies", "dependencies-only"] [] ++ 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 ] optional = Parse.option mempty . fmap toFlag 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 $ listField "repos" (Disp.text . showRepo) parseRepo (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 }) 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 user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config (remoteRepoSections0, haddockFlags, user, global, paths, args) <- foldM parseSections ([], savedHaddockFlags config, user0, global0, [], []) knownSections let remoteRepoSections = reverse . nubBy ((==) `on` remoteRepoName) $ remoteRepoSections0 return config { savedGlobalFlags = (savedGlobalFlags config) { globalRemoteRepos = toNubList remoteRepoSections, -- 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, savedUserInstallDirs = user, savedGlobalInstallDirs = global } where isKnownSection (ParseUtils.Section _ "repository" _ _) = True isKnownSection (ParseUtils.F _ "remote-repo" _) = True isKnownSection (ParseUtils.Section _ "haddock" _ _) = True isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True isKnownSection _ = False parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial parseSections (rs, h, u, g, p, a) (ParseUtils.Section _ "repository" name fs) = do r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $ warning $ "'key-threshold' for repository " ++ show (remoteRepoName r') ++ " higher than number of keys" when (not (null (remoteRepoRootKeys r')) && remoteRepoSecure r' /= Just True) $ warning $ "'root-keys' for repository " ++ show (remoteRepoName r') ++ " non-empty, but 'secure' not set to True." return (r':rs, h, u, g, p, a) parseSections (rs, h, u, g, p, a) (ParseUtils.F lno "remote-repo" raw) = do let mr' = readRepo raw r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' return (r':rs, h, u, g, p, a) parseSections accum@(rs, h, u, g, p, a) (ParseUtils.Section _ "haddock" name fs) | name == "" = do h' <- parseFields haddockFlagsFields h fs return (rs, h', u, g, p, a) | otherwise = do warning "The 'haddock' section should be unnamed" return accum parseSections accum@(rs, h, u, g, p, a) (ParseUtils.Section _ "install-dirs" name fs) | name' == "user" = do u' <- parseFields installDirsFields u fs return (rs, h, u', g, p, a) | name' == "global" = do g' <- parseFields installDirsFields g fs return (rs, h, u, g', p, a) | otherwise = do warning "The 'install-paths' section should be for 'user' or 'global'" return accum where name' = lowercase name parseSections accum@(rs, h, u, g, p, a) (ParseUtils.Section _ "program-locations" name fs) | name == "" = do p' <- parseFields withProgramsFields p fs return (rs, h, u, g, p', a) | otherwise = do warning "The 'program-locations' section should be unnamed" return accum parseSections accum@(rs, h, u, g, p, a) (ParseUtils.Section _ "program-default-options" name fs) | name == "" = do a' <- parseFields withProgramOptionsFields a fs return (rs, h, 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 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 "" $+$ 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" (remoteRepoName vals) remoteRepoFields (Just def) vals remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields = [ simpleField "url" (text . show) (parseTokenQ >>= parseURI') remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) , simpleField "secure" showSecure (Just `fmap` Text.parse) remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) , listField "root-keys" text parseTokenQ remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) , simpleField "key-threshold" showThreshold Text.parse remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) ] where parseURI' uriString = case parseURI uriString of Nothing -> fail $ "remote-repo: no parse on " ++ show uriString Just uri -> return uri showSecure Nothing = mempty -- default 'secure' setting showSecure (Just True) = text "True" -- user explicitly enabled it showSecure (Just False) = text "False" -- user explicitly disabled it -- If the key-threshold is set to 0, we omit it as this is the default -- and it looks odd to have a value for key-threshold but not for 'secure' -- (note that an empty list of keys is already omitted by default, since -- that is what we do for all list fields) showThreshold 0 = mempty showThreshold t = text (show t) -- | Fields for the 'haddock' section. haddockFlagsFields :: [FieldDescr HaddockFlags] haddockFlagsFields = [ field | opt <- haddockOptions ParseArgs , let field = viewAsFieldDescr opt name = fieldName field , name `notElem` exclusions ] where exclusions = ["verbose", "builddir", "for-hackage"] -- | 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) cabal-install-2.4.0.0/Distribution/Client/Configure.hs0000644000000000000000000004626600000000000020700 0ustar0000000000000000{-# 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.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.Dependency ( Dependency(..), thisPackageVersion ) 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 Distribution.Text ( display ) import Distribution.Verbosity as Verbosity ( Verbosity ) 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 = packageDescription (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) 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 unless (null unknownConstraints) $ warn verbosity $ "Constraint refers to an unknown package: " ++ showConstraint (head unknownConstraints) unless (null unknownPreferences) $ warn verbosity $ "Preference refers to an unknown package: " ++ display (head unknownPreferences) where unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ configExConstraints flags unknownPreferences = filter (unknown . \(Dependency name _) -> name) $ configPreferences flags unknown pkg = null (lookupPackageName installedPkgIndex pkg) && not (elemByPackageName sourcePkgIndex pkg) showConstraint (uc, src) = display uc ++ " (" ++ showConstraintSource src ++ ")" -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies. -- 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 { packageInfoId = packageId pkg, packageDescription = pkg, packageSource = LocalUnpackedPackage ".", packageDescrOverride = 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 | Dependency 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 = packageDescription spkg configureFlags = filterConfigureFlags configFlags { configIPID = if isJust (flagToMaybe (configIPID configFlags)) -- Make sure cabal configure --ipid works. then configIPID configFlags else toFlag (display ipid), configConfigurationsFlags = flags, -- We generate the legacy constraints as well as the new style precise -- deps. In the end only one set gets passed to Setup.hs configure, -- depending on the Cabal version we are talking to. configConstraints = [ thisPackageVersion srcid | ConfiguredId srcid (Just PkgDesc.CLibName) _uid <- CD.nonSetupDeps deps ], configDependencies = [ (packageName srcid, uid) | ConfiguredId srcid (Just PkgDesc.CLibName) uid <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, configVerbosity = toFlag verbosity, -- 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 cabal-install-2.4.0.0/Distribution/Client/Dependency.hs0000644000000000000000000012312700000000000021025 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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(..), -- ** Sandbox policy applySandboxInstallPolicy, -- ** Extra policy options upgradeDependencies, reinstallTargets, -- ** Policy utils addConstraints, addPreferences, setPreferenceDefault, setReorderGoals, setCountConflicts, setIndependentGoals, setAvoidReinstalls, setShadowPkgs, setStrongFlags, setAllowBootLibInstalls, setMaxBackjumps, setEnableBackjumping, setSolveExecutables, setGoalOrder, setSolverVerbosity, removeLowerBounds, removeUpperBounds, addDefaultSetupDependencies, addSetupCabalMinVersionConstraint, addSetupCabalMaxVersionConstraint, ) where 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.Client.Sandbox.Types ( SandboxPackageInfo(..) ) 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.Client.PackageUtils ( externalBuildDepends ) import Distribution.Compiler ( CompilerInfo(..) ) import Distribution.System ( Platform ) import Distribution.Client.Utils ( duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils ( comparing ) import Distribution.Simple.Setup ( asBool ) import Distribution.Text ( display ) import Distribution.Verbosity ( normal, Verbosity ) 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 ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub ) import Data.Function (on) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (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, depResolverIndependentGoals :: IndependentGoals, depResolverAvoidReinstalls :: AvoidReinstalls, depResolverShadowPkgs :: ShadowPkgs, depResolverStrongFlags :: StrongFlags, -- | Whether to allow base and its dependencies to be installed. depResolverAllowBootLibInstalls :: AllowBootLibInstalls, depResolverMaxBackjumps :: Maybe Int, depResolverEnableBackjumping :: EnableBackjumping, -- | Whether or not to solve for dependencies on executables. -- This should be true, except in the legacy code path where -- we can't tell if an executable has been installed or not, -- so we shouldn't solve for them. See #3875. depResolverSolveExecutables :: SolveExecutables, -- | Function to override the solver's goal-ordering heuristics. depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), depResolverVerbosity :: Verbosity } showDepResolverParams :: DepResolverParams -> String showDepResolverParams p = "targets: " ++ intercalate ", " (map display $ 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)) ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) ++ "\nshadow packages: " ++ show (asBool (depResolverShadowPkgs p)) ++ "\nstrong flags: " ++ show (asBool (depResolverStrongFlags p)) ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p)) ++ "\nmax backjumps: " ++ maybe "infinite" show (depResolverMaxBackjumps p) 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) = display pn ++ " " ++ display (simplifyVersionRange vr) showPackagePreference (PackageInstalledPreference pn ip) = display pn ++ " " ++ show ip showPackagePreference (PackageStanzasPreference pn st) = display 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, depResolverIndependentGoals = IndependentGoals False, depResolverAvoidReinstalls = AvoidReinstalls False, depResolverShadowPkgs = ShadowPkgs False, depResolverStrongFlags = StrongFlags False, depResolverAllowBootLibInstalls = AllowBootLibInstalls False, depResolverMaxBackjumps = Nothing, depResolverEnableBackjumping = EnableBackjumping True, depResolverSolveExecutables = SolveExecutables True, depResolverGoalOrder = Nothing, depResolverVerbosity = normal } addTargets :: [PackageName] -> DepResolverParams -> DepResolverParams addTargets extraTargets params = params { depResolverTargets = 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 } 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 } 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-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 { packageDescription = relaxPackageDeps relKind relDeps (packageDescription 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) = Dependency pkgName (removeBound relKind RelaxDepModNone verRange) 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) | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = -- a '*'-subject acts absorbing, for consistency with -- the 'Semigroup RelaxDeps' instance Dependency depName (removeBound relKind relMod verRange) | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = Dependency depName (removeBound relKind relMod verRange) | 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 { packageDescription = gpkgdesc { PD.packageDescription = pkgdesc { PD.setupBuildInfo = case PD.setupBuildInfo pkgdesc of Just sbi -> Just sbi Nothing -> case defaultSetupDeps srcpkg of Nothing -> Nothing Just deps | isCustom -> Just PD.SetupBuildInfo { PD.defaultSetupDepends = True, PD.setupDepends = deps } | otherwise -> Nothing } } } where isCustom = PD.buildType pkgdesc == PD.Custom gpkgdesc = packageDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc -- | If a package has a custom setup then we need to add a setup-depends -- on Cabal. -- addSetupCabalMinVersionConstraint :: Version -> DepResolverParams -> DepResolverParams addSetupCabalMinVersionConstraint minVersion = addConstraints [ LabeledPackageConstraint (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) (PackagePropertyVersion $ orLaterVersion minVersion)) ConstraintSetupCabalMinVersion ] where cabalPkgname = mkPackageName "Cabal" -- | 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 new-build and related commands). -- -- It extends the 'basicInstallPolicy' with a policy on setup deps. -- standardInstallPolicy :: InstalledPackageIndex -> SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = addDefaultSetupDependencies mkDefaultSetupDeps $ basicInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers where -- Force Cabal >= 1.24 dep when the package is affected by #3199. mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] mkDefaultSetupDeps srcpkg | affected = Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24])] | otherwise = Nothing where gpkgdesc = packageDescription 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 applySandboxInstallPolicy :: SandboxPackageInfo -> DepResolverParams -> DepResolverParams applySandboxInstallPolicy (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps) params = addPreferences [ PackageInstalledPreference n PreferInstalled | n <- installedNotModified ] . addTargets installedNotModified . addPreferences [ PackageVersionPreference (packageName pkg) (thisVersion (packageVersion pkg)) | pkg <- otherDeps ] . addConstraints [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) (PackagePropertyVersion $ thisVersion (packageVersion pkg)) in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep | pkg <- modifiedDeps ] . addTargets [ packageName pkg | pkg <- modifiedDeps ] . hideInstalledPackagesSpecificBySourcePackageId [ packageId pkg | pkg <- modifiedDeps ] -- We don't need to add source packages for add-source deps to the -- 'installedPkgIndex' since 'getSourcePackages' did that for us. $ params where installedPkgIds = map fst . InstalledPackageIndex.allPackagesBySourcePackageId $ allSandboxPkgs modifiedPkgIds = map packageId modifiedDeps installedNotModified = [ packageName pkg | pkg <- installedPkgIds, pkg `notElem` modifiedPkgIds ] -- ------------------------------------------------------------ -- * 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 indGoals noReinstalls shadowing strFlags allowBootLibs 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 indGoals noReinstalls shadowing strFlags allowBootLibs 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 " ++ display (packageId pkg) ++ " has an invalid configuration, in particular:\n" ++ unlines [ " " ++ showPackageProblem problem | problem <- packageProblems ] showPlanPackageProblem (DuplicatePackageSolverId pid dups) = "Package " ++ display (packageId pid) ++ " has " ++ show (length dups) ++ " duplicate instances." planPackagesProblems :: Platform -> CompilerInfo -> [ResolverPackage UnresolvedPkgLoc] -> [PlanPackageProblem] planPackagesProblems platform cinfo pkgs = [ InvalidConfiguredPackage pkg packageProblems | Configured pkg <- pkgs , let packageProblems = configuredPackageProblems platform cinfo pkg , not (null packageProblems) ] ++ [ DuplicatePackageSolverId (Graph.nodeKey (head dups)) dups | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ] data PackageProblem = DuplicateFlag PD.FlagName | MissingFlag PD.FlagName | 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 display pkgids) showPackageProblem (MissingDep dep) = "the package has a dependency " ++ display dep ++ " but no package has been selected to satisfy it." showPackageProblem (ExtraDep pkgid) = "the package configuration specifies " ++ display pkgid ++ " but (with the given flag assignment) the package does not actually" ++ " depend on any version of that package." showPackageProblem (InvalidDep dep pkgid) = "the package depends on " ++ display dep ++ " but the configuration specifies " ++ display pkgid ++ " which does not satisfy the dependency." -- | A 'ConfiguredPackage' is valid if the flag assignment is total and if -- in the configuration given by the flag assignment, all the package -- dependencies are satisfied by the specified packages. -- configuredPackageProblems :: Platform -> CompilerInfo -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _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)) specifiedDeps) ] ++ [ 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 specifiedDeps :: ComponentDeps [PackageId] specifiedDeps = fmap (map solverSrcId) specifiedDeps' mergedFlags = mergeBy compare (sort $ map PD.flagName (PD.genPackageFlags (packageDescription 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 (CD.flatDeps specifiedDeps) mergeDeps :: [Dependency] -> [PackageId] -> [MergeResult Dependency PackageId] mergeDeps required specified = let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in mergeBy (\dep pkgid -> dependencyName dep `compare` packageName pkgid) (sortNubOn dependencyName required) (sortNubOn packageName specified) 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 [] (packageDescription pkg) of Right (resolvedPkg, _) -> externalBuildDepends 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 _indGoals _avoidReinstalls _shadowing _strFlags _maxBjumps _enableBj _solveExes _allowBootLibInstalls _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 pkgDependency = Dependency pkgname requiredVersions choices = PackageIndex.lookupDependency sourcePkgIndex pkgDependency -- 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 partitionEithers :: [Either a b] -> ([a],[b]) partitionEithers = foldr (either left right) ([],[]) where left a (l, r) = (a:l, r) right a (l, r) = (l, a:r) -- | 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 " ++ display name ++ " that satisfies " ++ display (simplifyVersionRange ver) cabal-install-2.4.0.0/Distribution/Client/Dependency/0000755000000000000000000000000000000000000020463 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/Dependency/Types.hs0000644000000000000000000000347200000000000022131 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Client.Dependency.Types ( PreSolver(..), Solver(..), PackagesPreferenceDefault(..), ) where import Data.Char ( isAlpha, toLower ) import qualified Distribution.Compat.ReadP as Parse ( pfail, munch1 ) import Distribution.Text ( Text(..) ) import Text.PrettyPrint ( text ) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) -- | 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 Text PreSolver where disp AlwaysModular = text "modular" parse = do name <- Parse.munch1 isAlpha case map toLower name of "modular" -> return AlwaysModular _ -> Parse.pfail -- | 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 cabal-install-2.4.0.0/Distribution/Client/DistDirLayout.hs0000644000000000000000000002411600000000000021505 0ustar0000000000000000{-# 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 Data.Maybe (fromMaybe) import System.FilePath import Distribution.Package ( PackageId, ComponentId, UnitId ) import Distribution.Client.Setup ( ArchiveFormat(..) ) import Distribution.Compiler import Distribution.Simple.Compiler ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) import Distribution.Text import Distribution.Pretty ( prettyShow ) import Distribution.Types.ComponentName import Distribution.System -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained -- than what goes into the hashed 'InstalledPackageId', -- and for good reason: we don't want this path to change if -- the user, say, adds a dependency to their project. data DistDirParams = DistDirParams { distParamUnitId :: UnitId, distParamPackageId :: PackageId, distParamComponentId :: ComponentId, distParamComponentName :: Maybe ComponentName, distParamCompilerId :: CompilerId, distParamPlatform :: Platform, distParamOptimization :: OptimisationLevel -- TODO (see #3343): -- Flag assignments -- Optimization } -- | The layout of the project state directory. Traditionally this has been -- called the @dist@ directory. -- data DistDirLayout = DistDirLayout { -- | The 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 -> ArchiveFormat -> 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 implict project root in the current dir if no -- @cabal.project@ file is found, or an explicit root if the file is found. -- data ProjectRoot = -- | -- ^ An implict project root. It contains the absolute project -- root dir. ProjectRootImplicit FilePath -- | -- ^ An explicit project root. It contains the absolute project -- root dir and the relative @cabal.project@ file (or explicit override) | ProjectRootExplicit FilePath FilePath deriving (Eq, Show) -- | Make the default 'DistDirLayout' based on the project root dir and -- optional overrides for the location of the @dist@ directory and the -- @cabal.project@ file. -- defaultDistDirLayout :: ProjectRoot -- ^ the project root -> Maybe FilePath -- ^ the @dist@ directory or default -- (absolute or relative to the root) -> DistDirLayout defaultDistDirLayout projectRoot mdistDirectory = DistDirLayout {..} where (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 display (distParamPlatform params) display (distParamCompilerId params) display (distParamPackageId params) (case distParamComponentName params of Nothing -> "" Just CLibName -> "" Just (CSubLibName name) -> "l" display name Just (CFLibName name) -> "f" display name Just (CExeName name) -> "x" display name Just (CTestName name) -> "t" display name Just (CBenchName name) -> "b" display name) (case distParamOptimization params of NoOptimisation -> "noopt" NormalOptimisation -> "" MaximumOptimisation -> "opt") (let uid_str = display (distParamUnitId params) in if uid_str == display (distParamComponentId params) then "" else uid_str) distUnpackedSrcRootDirectory = distDirectory "src" distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory display 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 format = distSdistDirectory prettyShow pid <.> ext where ext = case format of TargzFormat -> "tar.gz" ZipFormat -> "zip" distSdistDirectory = distDirectory "sdist" distTempDirectory = distDirectory "tmp" distBinDirectory = distDirectory "bin" distPackageDBPath compid = distDirectory "packagedb" display compid distPackageDB = SpecificPackageDB . distPackageDBPath defaultStoreDirLayout :: FilePath -> StoreDirLayout defaultStoreDirLayout storeRoot = StoreDirLayout {..} where storeDirectory compid = storeRoot display compid storePackageDirectory compid ipkgid = storeDirectory compid display 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 display unitid <.> "lock" defaultCabalDirLayout :: FilePath -> CabalDirLayout defaultCabalDirLayout cabalDir = mkCabalDirLayout cabalDir Nothing Nothing mkCabalDirLayout :: FilePath -- ^ Cabal directory -> Maybe FilePath -- ^ Store directory -> 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"cabal-install-2.4.0.0/Distribution/Client/Exec.hs0000644000000000000000000002005700000000000017631 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import Distribution.Client.Sandbox (getSandboxConfigFilePath) import Distribution.Client.Sandbox.PackageEnvironment (sandboxPackageDBPath) import Distribution.Client.Sandbox.Types (UseSandbox (..)) import Distribution.Simple.Compiler (Compiler, CompilerFlavor(..), compilerFlavor) import Distribution.Simple.Program (ghcProgram, ghcjsProgram, lookupProgram) import Distribution.Simple.Program.Db (ProgramDb, requireProgram, modifyProgramSearchPath) import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..)) import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) ) import Distribution.Simple.Utils (die', warn) import Distribution.System (Platform(..), OS(..), buildOS) import Distribution.Verbosity (Verbosity) import System.Directory ( doesDirectoryExist ) import System.Environment (lookupEnv) import System.FilePath (searchPathSeparator, ()) -- | 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 -> UseSandbox -> Compiler -> Platform -> ProgramDb -> [String] -> IO () exec verbosity useSandbox comp platform programDb extraArgs = case extraArgs of (exe:args) -> do program <- requireProgram' verbosity useSandbox 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 = case useSandbox of NoSandbox -> return env (UseSandbox sandboxDir) -> sandboxEnvironment verbosity sandboxDir comp platform programDb env -- | Return the package's sandbox environment. -- -- The environment sets GHC_PACKAGE_PATH so that GHC will use the sandbox. sandboxEnvironment :: Verbosity -> FilePath -> Compiler -> Platform -> ProgramDb -> [(String, Maybe String)] -- environment overrides so far -> IO [(String, Maybe String)] sandboxEnvironment verbosity sandboxDir comp platform programDb iEnv = case compilerFlavor comp of GHC -> env GHC.getGlobalPackageDB ghcProgram "GHC_PACKAGE_PATH" GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH" _ -> die' verbosity "exec only works with GHC and GHCJS" where (Platform _ os) = platform ldPath = case os of OSX -> "DYLD_LIBRARY_PATH" Windows -> "PATH" _ -> "LD_LIBRARY_PATH" env getGlobalPackageDB hcProgram packagePathEnvVar = do let Just program = lookupProgram hcProgram programDb gDb <- getGlobalPackageDB verbosity program sandboxConfigFilePath <- getSandboxConfigFilePath mempty let sandboxPackagePath = sandboxPackageDBPath sandboxDir comp platform compilerPackagePaths = prependToSearchPath gDb sandboxPackagePath -- Packages database must exist, otherwise things will start -- failing in mysterious ways. exists <- doesDirectoryExist sandboxPackagePath unless exists $ warn verbosity $ "Package database is not a directory: " ++ sandboxPackagePath -- MASSIVE HACK. We need this to be synchronized with installLibDir -- in defaultInstallDirs' in Distribution.Simple.InstallDirs, -- which has a special case for Windows (WHY? Who knows; it's been -- around as long as Windows exists.) The sane thing to do here -- would be to read out the actual install dirs that were associated -- with the package in question, but that's not a well-formed question -- here because there is not actually install directory for the -- "entire" sandbox. Since we want to kill this code in favor of -- new-build, I decided it wasn't worth fixing this "properly." -- Also, this doesn't handle LHC correctly but I don't care -- ezyang let extraLibPath = case buildOS of Windows -> sandboxDir _ -> sandboxDir "lib" -- 2016-11-26 Apologies for the spaghetti code here. -- Essentially we just want to add the sandbox's lib/ dir to -- whatever the library search path environment variable is: -- this allows running existing executables against foreign -- libraries (meaning Haskell code with a bunch of foreign -- exports). However, on Windows this variable is equal to the -- executable search path env var. And we try to keep not only -- what was already set in the environment, but also the -- additional directories we add below in requireProgram'. So -- the strategy is that we first take the environment -- overrides from requireProgram' below. If the library search -- path env is overridden (e.g. because we're on windows), we -- prepend the lib/ dir to the relevant override. If not, we -- want to avoid wiping the user's own settings, so we first -- read the env var's current value, and then prefix ours if -- the user had any set. iEnv' <- if any ((==ldPath) . fst) iEnv then return $ updateLdPath extraLibPath iEnv else do currentLibraryPath <- lookupEnv ldPath let updatedLdPath = case currentLibraryPath of Nothing -> Just extraLibPath Just paths -> Just $ extraLibPath ++ [searchPathSeparator] ++ paths return $ (ldPath, updatedLdPath) : iEnv -- Build the environment return $ [ (packagePathEnvVar, Just compilerPackagePaths) , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths) , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath) ] ++ iEnv' prependToSearchPath path newValue = newValue ++ [searchPathSeparator] ++ path updateLdPath path = map update where update (name, Just current) | name == ldPath = (ldPath, Just $ path ++ [searchPathSeparator] ++ current) update (name, Nothing) | name == ldPath = (ldPath, Just path) update x = x -- | Check that a program is configured and available to be run. If -- a sandbox is available check in the sandbox's directory. requireProgram' :: Verbosity -> UseSandbox -> ProgramDb -> String -> IO ConfiguredProgram requireProgram' verbosity useSandbox programDb exe = do (program, _) <- requireProgram verbosity (simpleProgram exe) updateSearchPath return program where updateSearchPath = flip modifyProgramSearchPath programDb $ \searchPath -> case useSandbox of NoSandbox -> searchPath UseSandbox sandboxDir -> ProgramSearchPathDir (sandboxDir "bin") : searchPath cabal-install-2.4.0.0/Distribution/Client/Fetch.hs0000644000000000000000000002042300000000000017773 0ustar0000000000000000------------------------------------------------------------------------------- | -- 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.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 ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity ) import Control.Monad ( filterM ) -- ------------------------------------------------------------ -- * 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 mapM_ (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 . packageSource) 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 (display . packageId) pkgs' else mapM_ (fetchPackage verbosity repoCtxt . packageSource) 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 . setShadowPkgs shadowPkgs . setStrongFlags strongFlags . setAllowBootLibInstalls allowBootLibInstalls . 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) independentGoals = fromFlag (fetchIndependentGoals fetchFlags) shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) strongFlags = fromFlag (fetchStrongFlags fetchFlags) maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls 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 () cabal-install-2.4.0.0/Distribution/Client/FetchUtils.hs0000644000000000000000000002643700000000000021027 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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.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.Text ( display ) import Distribution.Verbosity ( Verbosity, verboseUnmarkOutput ) import Distribution.Client.GlobalFlags ( RepoContext(..) ) import Distribution.Client.Utils ( ProgressPhase(..), progressMessage ) import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map import Control.Monad import Control.Exception import Control.Concurrent.Async import Control.Concurrent.MVar import System.Directory ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.IO ( 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 dir) -> return (Just $ RemoteSourceRepoPackage repo dir) 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 $ display pkgid ++ " has already been downloaded." return (packageFile repo pkgid) else do progressMessage verbosity ProgressDownloading (display pkgid) res <- downloadRepoPackage progressMessage verbosity ProgressDownloaded (display pkgid) return res where downloadRepoPackage = case repo of RepoLocal{..} -> 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 <- sequence [ do v <- newEmptyMVar return (pkgloc, v) | pkgloc <- pkglocs ] let fetchPackages :: IO () fetchPackages = forM_ asyncDownloadVars $ \(pkgloc, var) -> do -- Suppress marking here, because 'withAsync' means -- that we get nondeterministic interleaving result <- try $ fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc putMVar var result withAsync fetchPackages $ \_ -> body (Map.fromList asyncDownloadVars) -- | Expect to find a download in progress in the given 'AsyncFetchMap' -- and wait on it to finish. -- -- If the download failed with an exception then this will be thrown. -- -- Note: This function is supposed to be idempotent, as our install plans -- can now use the same tarball for many builds, e.g. different -- components and/or qualified goals, and these all go through the -- download phase so we end up using 'waitAsyncFetchPackage' twice on -- the same package. C.f. #4461. waitAsyncFetchPackage :: Verbosity -> AsyncFetchMap -> UnresolvedPkgLoc -> IO ResolvedPkgLoc waitAsyncFetchPackage verbosity downloadMap srcloc = case Map.lookup srcloc downloadMap of Just hnd -> do debug verbosity $ "Waiting for download of " ++ show srcloc either throwIO return =<< readMVar hnd Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" -- ------------------------------------------------------------ -- * 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 display 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 repo pkgid = repoLocalDir repo display (packageName pkgid) display (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) ,display (packageName pkgid) ,display (packageVersion pkgid) ,display pkgid <.> "tar.gz"] } packageURI repo pkgid = (remoteRepoURI repo) { uriPath = FilePath.Posix.joinPath [uriPath (remoteRepoURI repo) ,"package" ,display pkgid <.> "tar.gz"] } cabal-install-2.4.0.0/Distribution/Client/FileMonitor.hs0000644000000000000000000013261500000000000021200 0ustar0000000000000000{-# 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, ) where import Prelude () import Distribution.Client.Compat.Prelude import qualified Data.Map.Strict as Map import qualified Data.ByteString.Lazy as BS import qualified Distribution.Compat.Binary as Binary 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 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 -- | 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 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 -- | The state necessary to determine whether the files matched by a globbing -- match have changed. -- data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir !FilePathRoot !MonitorStateGlobRel deriving (Show, Generic) data MonitorStateGlobRel = MonitorStateGlobDirs !Glob !FilePathGlobRel !ModTime ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted | MonitorStateGlobFiles !Glob !ModTime ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted | MonitorStateGlobDirTrailing deriving (Show, Generic) instance Binary MonitorStateGlob instance Binary MonitorStateGlobRel -- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by -- inspecting the state of the file system, and we can go in the reverse -- direction by just forgetting the extra info. -- reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = map 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, Binary b) => FileMonitor a b -- ^ cache file path -> FilePath -- ^ root directory -> a -- ^ guard or key value -> IO (MonitorChanged a b) -- ^ did the key or any paths change? checkFileMonitorChanged monitor@FileMonitor { fileMonitorKeyValid, fileMonitorCheckIfOnlyValueChanged } root currentKey = -- Consider it a change if the cache file does not exist, -- or we cannot decode it. Sadly ErrorCall can still happen, despite -- using decodeFileOrFail, e.g. Data.Char.chr errors handleDoesNotExist (MonitorChanged MonitorFirstRun) $ handleErrorCall (MonitorChanged MonitorCorruptCache) $ readCacheFile monitor >>= either (\_ -> return (MonitorChanged MonitorCorruptCache)) checkStatusCache where checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do change <- checkForChanges case change of Just reason -> return (MonitorChanged reason) Nothing -> return (MonitorUnchanged cachedResult monitorFiles) where monitorFiles = reconstructMonitorFilePaths cachedFileStatus where -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that -- if we return MonitoredValueChanged that only the value changed. -- We do that by checkin for file changes first. Otherwise it makes -- more sense to do the cheaper test first. checkForChanges | fileMonitorCheckIfOnlyValueChanged = checkFileChange cachedFileStatus cachedKey cachedResult `mplusMaybeT` checkValueChange cachedKey | otherwise = checkValueChange cachedKey `mplusMaybeT` checkFileChange cachedFileStatus cachedKey cachedResult mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) mplusMaybeT ma mb = do mx <- ma case mx of Nothing -> mb Just x -> return (Just x) -- Check if the guard value has changed checkValueChange cachedKey | not (fileMonitorKeyValid currentKey cachedKey) = return (Just (MonitoredValueChanged cachedKey)) | otherwise = return Nothing -- Check if any file has changed checkFileChange cachedFileStatus cachedKey cachedResult = do res <- probeFileSystem root cachedFileStatus case res of -- Some monitored file has changed Left changedPath -> return (Just (MonitoredFileChanged (normalise changedPath))) -- No monitored file has changed Right (cachedFileStatus', cacheStatus) -> do -- But we might still want to update the cache whenCacheChanged cacheStatus $ rewriteCacheFile monitor cachedFileStatus' cachedKey cachedResult return Nothing -- | Helper for reading the cache file. -- -- This determines the type and format of the binary cache file. -- readCacheFile :: (Binary a, Binary b) => FileMonitor a b -> IO (Either String (MonitorStateFileSet, a, b)) readCacheFile FileMonitor {fileMonitorCacheFile} = withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> Binary.decodeOrFailIO =<< BS.hGetContents hnd -- | Helper for writing the cache file. -- -- This determines the type and format of the binary cache file. -- rewriteCacheFile :: (Binary a, Binary b) => FileMonitor a b -> MonitorStateFileSet -> a -> b -> IO () rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = writeFileAtomic fileMonitorCacheFile $ Binary.encode (fileset, key, result) -- | Probe the file system to see if any of the monitored files have changed. -- -- It returns Nothing if any file changed, or returns a possibly updated -- file 'MonitorStateFileSet' plus an indicator of whether it actually changed. -- -- We may need to update the cache since there may be changes in the filesystem -- state which don't change any of our affected files. -- -- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a -- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run -- and find @proj2@ was created, yet contains no files matching @*.cabal@ then -- we want to update the cache despite no changes in our relevant file set. -- Specifically, we should add an mtime for this directory so we can avoid -- re-traversing the directory in future runs. -- probeFileSystem :: FilePath -> MonitorStateFileSet -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = runChangedM $ do sequence_ [ probeMonitorStateFileStatus root file status | 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' <- mapM probeMergeResult $ mergeBy (\(path1,_) path2 -> compare path1 path2) children (sort matches) return $! MonitorStateGlobDirs glob globPath mtime' children' -- Note that just because the directory has changed, we don't force -- a cache rewrite with 'cacheChanged' since that has some cost, and -- all we're saving is scanning the directory. But we do rebuild the -- cache with the new mtime', so that if the cache is rewritten for -- some other reason, we'll take advantage of that. where probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath -> ChangedM (FilePath, MonitorStateGlobRel) -- Only in cached (directory deleted) probeMergeResult (OnlyInLeft (path, fstate)) = do case allMatchingFiles (dirName path) fstate of [] -> return (path, fstate) -- Strictly speaking we should be returning 'CacheChanged' above -- as we should prune the now-missing 'MonitorStateGlobRel'. However -- we currently just leave these now-redundant entries in the -- cache as they cost no IO and keeping them allows us to avoid -- rewriting the cache. (file:_) -> somethingChanged file -- Only in current filesystem state (directory added) probeMergeResult (OnlyInRight path) = do fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty kindfile kinddir root (dirName path) globPath case allMatchingFiles (dirName path) fstate of (file:_) -> somethingChanged file -- This is the only case where we use 'cacheChanged' because we can -- have a whole new dir subtree (of unbounded size and cost), so we -- need to save the state of that new subtree in the cache. [] -> cacheChanged >> return (path, fstate) -- Found in path probeMergeResult (InBoth (path, fstate) _) = do fstate' <- probeMonitorStateGlobRel kindfile kinddir root (dirName path) fstate return (path, fstate') -- | Does a 'MonitorStateGlob' have any relevant files within it? allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = [ dir fname | (fname, _) <- entries ] allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = [ res | (subdir, fstate) <- entries , res <- allMatchingFiles (dir subdir) fstate ] allMatchingFiles dir MonitorStateGlobDirTrailing = [dir] probeMonitorStateGlobRel _ _ root dirName (MonitorStateGlobFiles glob mtime children) = do change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime mtime' <- case change of Nothing -> return mtime Just mtime' -> do -- directory modification time changed: -- a matching file may have been added or deleted matches <- return . filter (matchGlob glob) =<< liftIO (getDirectoryContents (root dirName)) mapM_ probeMergeResult $ mergeBy (\(path1,_) path2 -> compare path1 path2) children (sort matches) return mtime' -- Check that none of the children have changed forM_ children $ \(file, status) -> probeMonitorStateFileStatus root (dirName file) status return (MonitorStateGlobFiles glob mtime' children) -- Again, we don't force a cache rewite with 'cacheChanged', but we do use -- the new mtime' if any. where probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath -> ChangedM () probeMergeResult mr = case mr of InBoth _ _ -> return () -- this is just to be able to accurately report which file changed: OnlyInLeft (path, _) -> somethingChanged (dirName path) OnlyInRight path -> somethingChanged (dirName path) probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = return MonitorStateGlobDirTrailing ------------------------------------------------------------------------------ -- | Update the input value and the set of files monitored by the -- 'FileMonitor', plus the cached value that may be returned in future. -- -- This takes a snapshot of the state of the monitored files right now, so -- 'checkFileMonitorChanged' will look for file system changes relative to -- this snapshot. -- -- This is typically done once the action has been completed successfully and -- we have the action's result and we know what files it looked at. See -- 'FileMonitor' for a full explanation. -- -- If we do take the snapshot after the action has completed then we have a -- problem. The problem is that files might have changed /while/ the action was -- running but /after/ the action read them. If we take the snapshot after the -- action completes then we will miss these changes. The solution is to record -- a timestamp before beginning execution of the action and then we make the -- conservative assumption that any file that has changed since then has -- already changed, ie the file monitor state for these files will be such that -- 'checkFileMonitorChanged' will report that they have changed. -- -- So if you do use 'updateFileMonitor' after the action (so you can discover -- the files used rather than predicting them in advance) then use -- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively, -- if you take the snapshot in advance of the action, or you're not monitoring -- any files then you can use @Nothing@ for the timestamp parameter. -- updateFileMonitor :: (Binary a, Binary b) => FileMonitor a b -- ^ cache file path -> FilePath -- ^ root directory -> Maybe MonitorTimestamp -- ^ timestamp when the update action started -> [MonitorFilePath] -- ^ files of interest relative to root -> a -- ^ the current key value -> b -- ^ the current result value -> IO () updateFileMonitor monitor root startTime monitorFiles cachedKey cachedResult = do hashcache <- readCacheFileHashes monitor msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles rewriteCacheFile monitor msfs cachedKey cachedResult -- | A timestamp to help with the problem of file changes during actions. -- See 'updateFileMonitor' for details. -- newtype MonitorTimestamp = MonitorTimestamp ModTime -- | Record a timestamp at the beginning of an action, and when the action -- completes call 'updateFileMonitor' passing it the timestamp. -- See 'updateFileMonitor' for details. -- beginUpdateFileMonitor :: IO MonitorTimestamp beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime -- | Take the snapshot of the monitored files. That is, given the -- specification of the set of files we need to monitor, inspect the state -- of the file system now and collect the information we'll need later to -- determine if anything has changed. -- buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp -- of the start of the action -> FileHashCache -- ^ existing file hashes -> FilePath -- ^ root directory -> [MonitorFilePath] -- ^ patterns of interest -- relative to root -> IO MonitorStateFileSet buildMonitorStateFileSet mstartTime hashcache root = go [] [] 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 <- forM (sort subdirs) $ \subdir -> do fstate <- buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root (dir subdir) globPath' return (subdir, fstate) return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates GlobFile glob -> do let files = filter (matchGlob glob) dirEntries filesStates <- forM (sort files) $ \file -> do fstate <- buildMonitorStateFile mstartTime hashcache kindfile kinddir root (dir file) return (file, fstate) return $! MonitorStateGlobFiles glob dirMTime filesStates GlobDirTrailing -> return MonitorStateGlobDirTrailing -- | We really want to avoid re-hashing files all the time. We already make -- the assumption that if a file mtime has not changed then we don't need to -- bother checking if the content hash has changed. We can apply the same -- assumption when updating the file monitor state. In the typical case of -- updating a file monitor the set of files is the same or largely the same so -- we can grab the previously known content hashes with their corresponding -- mtimes. -- type FileHashCache = Map FilePath (ModTime, Hash) -- | We declare it a cache hit if the mtime of a file is the same as before. -- lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash lookupFileHashCache hashcache file mtime = do (mtime', hash) <- Map.lookup file hashcache guard (mtime' == mtime) return hash -- | Either get it from the cache or go read the file getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash getFileHash hashcache relfile absfile mtime = case lookupFileHashCache hashcache relfile mtime of Just hash -> return hash Nothing -> readFileHash absfile -- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While -- in principle we could preserve the structure of the previous state, given -- that the set of files to monitor can change then it's simpler just to throw -- away the structure and use a finite map. -- readCacheFileHashes :: (Binary a, Binary b) => FileMonitor a b -> IO FileHashCache readCacheFileHashes monitor = handleDoesNotExist Map.empty $ handleErrorCall Map.empty $ do res <- readCacheFile monitor case res of Left _ -> return Map.empty Right (msfs, _, _) -> return (mkFileHashCache msfs) where mkFileHashCache :: MonitorStateFileSet -> FileHashCache mkFileHashCache (MonitorStateFileSet singlePaths globPaths) = collectAllFileHashes singlePaths `Map.union` collectAllGlobHashes globPaths collectAllFileHashes 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 @e@ if there is an 'error' -- call. ('ErrorCall') handleErrorCall :: a -> IO a -> IO a handleErrorCall e = handle (\(ErrorCall _) -> return e) -- | Run an IO computation, returning @e@ if there is any 'IOException'. -- -- This policy is OK in the file monitor code because it just causes the -- monitor to report that something changed, and then code reacting to that -- will normally encounter the same IO exception when it re-runs the action -- that uses the file. -- handleIOException :: a -> IO a -> IO a handleIOException e = handle (anyIOException e) where anyIOException :: a -> IOException -> IO a anyIOException x _ = return x ------------------------------------------------------------------------------ -- Instances -- instance Binary MonitorStateFileSet where put (MonitorStateFileSet singlePaths globPaths) = do put (1 :: Int) -- version put singlePaths put globPaths get = do ver <- get if ver == (1 :: Int) then do singlePaths <- get globPaths <- get return $! MonitorStateFileSet singlePaths globPaths else fail "MonitorStateFileSet: wrong version" cabal-install-2.4.0.0/Distribution/Client/Freeze.hs0000644000000000000000000002345500000000000020172 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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.Client.Sandbox.Types ( SandboxPackageInfo(..) ) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.SolverId import Distribution.Package ( Package, packageId, packageName, packageVersion ) import Distribution.Simple.Compiler ( Compiler, compilerInfo, PackageDBStack ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils ( die', notice, debug, writeFileAtomic ) import Distribution.System ( Platform ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity ) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 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 -> Maybe SandboxPackageInfo -> GlobalFlags -> FreezeFlags -> IO () freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags = do pkgs <- getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo 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 -> Maybe SandboxPackageInfo -> GlobalFlags -> FreezeFlags -> IO [SolverPlanPackage] getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo 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 mSandboxPkgInfo 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 -> Maybe SandboxPackageInfo -> FreezeFlags -> InstalledPackageIndex -> SourcePackageDb -> PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> IO [SolverPlanPackage] planPackages verbosity comp platform mSandboxPkgInfo 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 . setShadowPkgs shadowPkgs . setStrongFlags strongFlags . setAllowBootLibInstalls allowBootLibInstalls . setSolverVerbosity verbosity . addConstraints [ let pkg = pkgSpecifierTarget pkgSpecifier pc = PackageConstraint (scopeToplevel pkg) (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] . maybe id applySandboxInstallPolicy mSandboxPkgInfo $ 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) independentGoals = fromFlag (freezeIndependentGoals freezeFlags) shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) strongFlags = fromFlag (freezeStrongFlags freezeFlags) maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) -- | Remove all unneeded packages from an install plan. -- -- 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 = BS.Char8.pack . showPackageEnvironment formatPkgs :: Package pkg => [pkg] -> [String] formatPkgs = map $ showPkg . packageId where showPkg pid = name pid ++ " == " ++ version pid name = display . packageName version = display . packageVersion cabal-install-2.4.0.0/Distribution/Client/GZipUtils.hs0000644000000000000000000000677700000000000020654 0ustar0000000000000000{-# 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 Codec.Compression.Zlib.Internal import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) #if MIN_VERSION_zlib(0,6,0) import Control.Exception (throw) import Control.Monad (liftM) 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 cabal-install-2.4.0.0/Distribution/Client/GenBounds.hs0000644000000000000000000001417300000000000020633 0ustar0000000000000000{-# 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.Sandbox.Types ( SandboxPackageInfo(..) ) 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.Text ( display ) import Distribution.Verbosity ( Verbosity ) 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 asVersionIntervals vr of [] -> False is -> if snd (last is) == NoUpperBound then False else True -- | Given a version, return an API-compatible (according to PVP) version range. -- -- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@. -- -- This version is slightly different than the one in -- 'Distribution.Client.Init'. This one uses a.b.c as the lower bound because -- the user could be using a new function introduced in a.b.c which would make -- ">= a.b" incorrect. pvpize :: Version -> VersionRange pvpize v = orLaterVersion (vn 3) `intersectVersionRanges` earlierVersion (incVersion 1 (vn 2)) where vn n = 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 [">=", display l, "&& <", display u] -- | Entry point for the @gen-bounds@ command. genBounds :: Verbosity -> PackageDBStack -> RepoContext -> Compiler -> Platform -> ProgramDb -> Maybe SandboxPackageInfo -> GlobalFlags -> FreezeFlags -> IO () genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags = do let cinfo = compilerInfo comp cwd <- getCurrentDirectory path <- tryFindPackageDesc 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 mSandboxPkgInfo globalFlags freezeFlags putStrLn boundsNeededMsg let isNeeded pkg = unPackageName (packageName pkg) `elem` map depName needBounds let thePkgs = filter isNeeded pkgs let padTo = maximum $ map (length . unPackageName . packageName) pkgs 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." , "" ] cabal-install-2.4.0.0/Distribution/Client/Get.hs0000644000000000000000000002737000000000000017471 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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.Package ( PackageId, packageId, packageName ) import Distribution.Simple.Setup ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils ( notice, die', info, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text (display) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program ( programName ) 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 as IndexUtils ( getSourcePackagesAtIndexState ) import Distribution.Solver.Types.SourcePackage import Control.Exception ( Exception(..), catch, throwIO ) import Control.Monad ( mapM, forM_, mapM_ ) import qualified Data.Map as Map import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) import System.Exit ( ExitCode(..) ) 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 $ mapM_ (checkTarget verbosity) userTargets let idxState = flagToMaybe $ getIndexState getFlags sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState 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 -> [SourceRepo] packageSourceRepos = PD.sourceRepos . PD.packageDescription . packageDescription unpack :: [UnresolvedSourcePackage] -> IO () unpack pkgs = do forM_ pkgs $ \pkg -> do location <- fetchPackage verbosity repoCtxt (packageSource pkg) let pkgid = packageId pkg descOverride | usePristine = Nothing | otherwise = packageDescrOverride 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 = display pkgid pkgdir = prefix pkgdirname pkgdir' = addTrailingPathSeparator pkgdir existsDir <- doesDirectoryExist pkgdir when existsDir $ die' verbosity $ "The directory \"" ++ pkgdir' ++ "\" already exists, 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 display (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 SourceRepo | ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType | ClonePackageNoRepoLocation PackageId SourceRepo | ClonePackageDestinationExists PackageId FilePath Bool | ClonePackageFailedWithExitCode PackageId SourceRepo String ExitCode deriving (Show, Eq) instance Exception ClonePackageException where displayException (ClonePackageNoSourceRepos pkgid) = "Cannot fetch a source repository for package " ++ display pkgid ++ ". The package does not specify any source repositories." displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) = "Cannot fetch a source repository for package " ++ display pkgid ++ ". The package does not specify a source repository of the requested " ++ "kind" ++ maybe "." (\k -> " (kind " ++ display k ++ ").") repoKind displayException (ClonePackageNoRepoType pkgid _repo) = "Cannot fetch the source repository for package " ++ display 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 " ++ display pkgid ++ ". The repository type '" ++ display repoType ++ "' is not yet supported." displayException (ClonePackageNoRepoLocation pkgid _repo) = "Cannot fetch the source repository for package " ++ display 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 " ++ display 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 " ++ display pkgid ++ maybe "" (", repository location " ++) (PD.repoLocation 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, [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' <- mapM 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 repo (programName (vcsProgram vcs)) exitcode) | (pkgid, repo, vcs, destDir) <- pkgrepos' , let Just vcs' = Map.lookup (vcsRepoType vcs) vcss ] where preCloneChecks :: (PackageId, [SourceRepo]) -> IO (PackageId, SourceRepo, 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) vcs <- case validateSourceRepo repo of Right (_, _, _, vcs) -> return vcs Left SourceRepoRepoTypeUnspecified -> throwIO (ClonePackageNoRepoType pkgid repo) Left (SourceRepoRepoTypeUnsupported repoType) -> throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType) Left SourceRepoLocationUnspecified -> throwIO (ClonePackageNoRepoLocation pkgid repo) let destDir = destDirPrefix display (packageName pkgid) destDirExists <- doesDirectoryExist destDir destFileExists <- doesFileExist destDir when (destDirExists || destFileExists) $ throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) return (pkgid, repo, vcs, destDir) cabal-install-2.4.0.0/Distribution/Client/Glob.hs0000644000000000000000000002173200000000000017631 0ustar0000000000000000{-# 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 Prelude () import Distribution.Client.Compat.Prelude import Data.List (stripPrefix) import Control.Monad (mapM) import Distribution.Text import Distribution.Compat.ReadP (ReadP, (<++), (+++)) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import System.FilePath import System.Directory -- | A file path specified by globbing -- data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel deriving (Eq, Show, Generic) data FilePathGlobRel = GlobDir !Glob !FilePathGlobRel | GlobFile !Glob | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@ deriving (Eq, Show, Generic) -- | A single directory or file component of a globbed path type Glob = [GlobPiece] -- | A piece of a globbing pattern data GlobPiece = WildCard | Literal String | Union [Glob] deriving (Eq, Show, Generic) data FilePathRoot = FilePathRelative | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive' | FilePathHomeDir deriving (Eq, Show, Generic) instance Binary FilePathGlob instance Binary FilePathRoot instance Binary FilePathGlobRel instance Binary GlobPiece -- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and -- is in fact equivalent to a non-glob 'FilePath'. -- -- If it is trivial in this sense then the result is the equivalent constant -- 'FilePath'. On the other hand if it is not trivial (so could in principle -- match more than one file) then the result is @Nothing@. -- isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath isTrivialFilePathGlob (FilePathGlob root pathglob) = case root of FilePathRelative -> go [] pathglob FilePathRoot root' -> go [root'] pathglob FilePathHomeDir -> Nothing where go paths (GlobDir [Literal path] globs) = go (path:paths) globs go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths))) go paths GlobDirTrailing = Just (addTrailingPathSeparator (joinPath (reverse paths))) go _ _ = Nothing -- | Get the 'FilePath' corresponding to a 'FilePathRoot'. -- -- The 'FilePath' argument is required to supply the path for the -- 'FilePathRelative' case. -- getFilePathRootDirectory :: FilePathRoot -> FilePath -- ^ root for relative paths -> IO FilePath getFilePathRootDirectory FilePathRelative root = return root getFilePathRootDirectory (FilePathRoot root) _ = return root getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory ------------------------------------------------------------------------------ -- Matching -- -- | Match a 'FilePathGlob' against the file system, starting from a given -- root directory for relative paths. The results of relative globs are -- relative to the given root. Matches for absolute globs are absolute. -- matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath] matchFileGlob relroot (FilePathGlob globroot glob) = do root <- getFilePathRootDirectory globroot relroot matches <- matchFileGlobRel root glob case globroot of FilePathRelative -> return matches _ -> return (map (root ) matches) -- | Match a 'FilePathGlobRel' against the file system, starting from a -- given root directory. The results are all relative to the given root. -- matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath] matchFileGlobRel root glob0 = go glob0 "" where go (GlobFile glob) dir = do entries <- getDirectoryContents (root dir) let files = filter (matchGlob glob) entries return (map (dir ) files) go (GlobDir glob globPath) dir = do entries <- getDirectoryContents (root dir) subdirs <- filterM (\subdir -> doesDirectoryExist (root dir subdir)) $ filter (matchGlob glob) entries concat <$> mapM (\subdir -> go globPath (dir subdir)) subdirs go GlobDirTrailing dir = return [dir] -- | Match a globbing pattern against a file path component -- matchGlob :: Glob -> String -> Bool matchGlob = goStart where -- From the man page, glob(7): -- "If a filename starts with a '.', this character must be -- matched explicitly." go, goStart :: [GlobPiece] -> String -> Bool goStart (WildCard:_) ('.':_) = False goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs) globs goStart rest cs = go rest cs go [] "" = True go (Literal lit:rest) cs | Just cs' <- stripPrefix lit cs = go rest cs' | otherwise = False go [WildCard] "" = True go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs go [] (_:_) = False go (_:_) "" = False ------------------------------------------------------------------------------ -- Parsing & printing -- instance Text FilePathGlob where disp (FilePathGlob root pathglob) = disp root Disp.<> disp pathglob parse = parse >>= \root -> (FilePathGlob root <$> parse) <++ (when (root == FilePathRelative) Parse.pfail >> return (FilePathGlob root GlobDirTrailing)) instance Text FilePathRoot where disp FilePathRelative = Disp.empty disp (FilePathRoot root) = Disp.text root disp FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' parse = ( (Parse.char '/' >> return (FilePathRoot "/")) +++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir) +++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')) _ <- Parse.char ':' _ <- Parse.char '/' +++ Parse.char '\\' return (FilePathRoot (toUpper drive : ":\\"))) ) <++ return FilePathRelative instance Text FilePathGlobRel where disp (GlobDir glob pathglob) = dispGlob glob Disp.<> Disp.char '/' Disp.<> disp pathglob disp (GlobFile glob) = dispGlob glob disp GlobDirTrailing = Disp.empty parse = parsePath where parsePath :: ReadP r FilePathGlobRel parsePath = parseGlob >>= \globpieces -> asDir globpieces <++ asTDir globpieces <++ asFile globpieces asDir glob = do dirSep globs <- parsePath return (GlobDir glob globs) asTDir glob = do dirSep return (GlobDir glob GlobDirTrailing) asFile glob = return (GlobFile glob) dirSep = (Parse.char '/' >> return ()) +++ (do _ <- Parse.char '\\' -- check this isn't an escape code following <- Parse.look case following of (c:_) | isGlobEscapedChar c -> Parse.pfail _ -> return ()) dispGlob :: Glob -> Disp.Doc dispGlob = Disp.hcat . map dispPiece where dispPiece WildCard = Disp.char '*' dispPiece (Literal str) = Disp.text (escape str) dispPiece (Union globs) = Disp.braces (Disp.hcat (Disp.punctuate (Disp.char ',') (map dispGlob globs))) escape [] = [] escape (c:cs) | isGlobEscapedChar c = '\\' : c : escape cs | otherwise = c : escape cs parseGlob :: ReadP r Glob parseGlob = Parse.many1 parsePiece where parsePiece = literal +++ wildcard +++ union wildcard = Parse.char '*' >> return WildCard union = Parse.between (Parse.char '{') (Parse.char '}') $ fmap Union (Parse.sepBy1 parseGlob (Parse.char ',')) literal = Literal `fmap` litchars1 litchar = normal +++ escape normal = Parse.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') escape = Parse.char '\\' >> Parse.satisfy isGlobEscapedChar litchars1 :: ReadP r [Char] litchars1 = liftM2 (:) litchar litchars litchars :: ReadP r [Char] litchars = litchars1 <++ return [] isGlobEscapedChar :: Char -> Bool isGlobEscapedChar '*' = True isGlobEscapedChar '{' = True isGlobEscapedChar '}' = True isGlobEscapedChar ',' = True isGlobEscapedChar _ = False cabal-install-2.4.0.0/Distribution/Client/GlobalFlags.hs0000644000000000000000000002631400000000000021124 0ustar0000000000000000{-# 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(..), RemoteRepo(..) ) import Distribution.Simple.Setup ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList ( NubList, fromNubList ) import Distribution.Client.HttpUtils ( HttpTransport, configureTransport ) import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils ( info ) import Control.Concurrent ( MVar, newMVar, modifyMVar ) import Control.Exception ( throwIO ) 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 -- ------------------------------------------------------------ -- * Global flags -- ------------------------------------------------------------ -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags { globalVersion :: Flag Bool, globalNumericVersion :: Flag Bool, globalConfigFile :: Flag FilePath, globalSandboxConfigFile :: Flag FilePath, globalConstraintsFile :: Flag FilePath, globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. globalCacheDir :: Flag FilePath, globalLocalRepos :: NubList FilePath, globalLogsDir :: Flag FilePath, globalWorldFile :: Flag FilePath, globalRequireSandbox :: Flag Bool, globalIgnoreSandbox :: Flag Bool, globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates globalHttpTransport :: Flag String, 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, globalSandboxConfigFile = mempty, globalConstraintsFile = mempty, globalRemoteRepos = mempty, globalCacheDir = mempty, globalLocalRepos = mempty, globalLogsDir = mempty, globalWorldFile = mempty, globalRequireSandbox = Flag False, globalIgnoreSandbox = Flag False, globalIgnoreExpiry = Flag False, globalHttpTransport = mempty, 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 (globalLocalRepos globalFlags)) (fromFlag (globalCacheDir globalFlags)) (flagToMaybe (globalHttpTransport globalFlags)) (flagToMaybe (globalIgnoreExpiry globalFlags)) (fromNubList (globalProgPathExtra globalFlags)) withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] -> FilePath -> Maybe String -> Maybe Bool -> [FilePath] -> (RepoContext -> IO a) -> IO a withRepoContext' verbosity remoteRepos localRepos sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do transportRef <- newMVar Nothing let httpLib = Sec.HTTP.transportAdapter verbosity (getTransport transportRef) initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> callback RepoContext { repoContextRepos = allRemoteRepos ++ map RepoLocal localRepos , repoContextGetTransport = getTransport transportRef , repoContextWithSecureRepo = withSecureRepo secureRepos' , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry } where secureRemoteRepos = [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ] allRemoteRepos = [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir | remote <- remoteRepos , let cacheDir = sharedCacheDir remoteRepoName remote isSecure = remoteRepoSecure remote == Just True ] getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport getTransport transportRef = modifyMVar transportRef $ \mTransport -> do transport <- case mTransport of Just tr -> return tr Nothing -> configureTransport verbosity 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 cabal-install-2.4.0.0/Distribution/Client/Haddock.hs0000644000000000000000000000522200000000000020277 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 Data.List (maximumBy) import Data.Foldable (forM_) 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.Verbosity (Verbosity) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, allPackagesByName ) import Distribution.Simple.Utils ( comparing, 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] forM_ 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') ] cabal-install-2.4.0.0/Distribution/Client/HttpUtils.hs0000644000000000000000000010366200000000000020711 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | 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 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 Control.Exception ( evaluate ) import Control.DeepSeq ( force ) import Control.Monad ( guard ) import qualified Data.ByteString.Lazy.Char8 as BS import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils ( die', info, warn, debug, notice, writeFileAtomic , copyFileVerbose, withTempFile ) import Distribution.Client.Utils ( withTempFileName ) import Distribution.Client.Types ( RemoteRepo(..) ) import Distribution.System ( buildOS, buildArch ) import Distribution.Text ( display ) 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 System.Exit (ExitCode(..)) ------------------------------------------------------------------------------ -- Downloading a URI, given an HttpTransport -- data DownloadResult = FileAlreadyInCache | FileDownloaded FilePath 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 let etagPath = path <.> "etag" targetExists <- doesFileExist path etagPathExists <- doesFileExist etagPath -- In rare cases the target file doesn't exist, but the etag does. etag <- if targetExists && etagPathExists then Just <$> readFile etagPath else return Nothing -- 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 withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do result <- getHttp transport' verbosity uri etag tmpFile [] -- Only write the etag if we get a 200 response code. -- A 304 still sends us an etag header. case result of (200, Just newEtag) -> writeFile etagPath newEtag _ -> return () case fst result of 200 -> do info verbosity ("Downloaded to " ++ path) renameFile tmpFile path return (FileDownloaded path) 304 -> do notice verbosity "Skipping download: local and remote files match." return FileAlreadyInCache errCode -> die' verbosity $ "Failed to download " ++ show uri ++ " : HTTP code " ++ show errCode ------------------------------------------------------------------------------ -- 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 '" ++ 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 secifically selected a transport by name so we'll try and -- configure that one case find (\(name',_,_,_) -> name' == name) supportedTransports of Just (_, mprog, _tls, mkTrans) -> do 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 Just 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) ] -- there's always one because the plain one is last and never fails let (name, transport) = head availableTransports debug verbosity $ "Selected http transport implementation: " ++ name return transport { transportManuallySelected = False } ------------------------------------------------------------------------------ -- The HttpTransports based on external programs -- curlTransport :: ConfiguredProgram -> HttpTransport curlTransport prog = HttpTransport gethttp posthttp posthttpfile puthttpfile True False where gethttp verbosity uri etag destPath reqHeaders = do withTempFile (takeDirectory destPath) "curl-headers.txt" $ \tmpFile tmpHandle -> do hClose tmpHandle let args = [ show uri , "--output", destPath , "--location" , "--write-out", "%{http_code}" , "--user-agent", userAgent , "--silent", "--show-error" , "--dump-header", tmpFile ] ++ concat [ ["--header", "If-None-Match: " ++ t] | t <- maybeToList etag ] ++ concat [ ["--header", show name ++ ": " ++ value] | Header name value <- reqHeaders ] resp <- getProgramInvocationOutput verbosity (programInvocation prog args) 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 $ 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 BS.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 (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 BS.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 (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 break (== '-') 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 = BS.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 (BS.length body)) , Header HdrAccept ("text/plain") ] req = Request { rqURI = uri, rqMethod = POST, rqHeaders = headers, rqBody = body } (_, resp) <- cabalBrowse verbosity auth (request req) return (convertRspCode (rspCode resp), rspErrorString resp) puthttpfile verbosity uri path auth headers = do body <- BS.readFile path let req = Request { rqURI = uri, rqMethod = PUT, rqHeaders = Header HdrContentLength (show (BS.length body)) : Header HdrAccept "text/plain" : headers, rqBody = body } (_, resp) <- cabalBrowse verbosity auth (request req) return (convertRspCode (rspCode resp), rspErrorString resp) convertRspCode (a,b,c) = a*100 + b*10 + c rspErrorString resp = case lookupHeader HdrContentType (rspHeaders resp) of Just contenttype | takeWhile (/= ';') contenttype == "text/plain" -> BS.unpack (rspBody resp) _ -> rspReason resp cabalBrowse verbosity auth act = do p <- fixupEmptyProxy <$> fetchProxy True Exception.handleJust (guard . isDoesNotExistError) (const . die' 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/", display Paths_cabal_install.version , " (", display buildOS, "; ", display 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 (BS.ByteString, String) generateMultipartBody path = do content <- BS.readFile path boundary <- genBoundary let !body = formatBody content (BS.pack boundary) return (body, boundary) where formatBody content boundary = BS.concat $ [ crlf, dd, boundary, crlf ] ++ [ BS.pack (show header) | header <- headers ] ++ [ crlf , content , crlf, dd, boundary, dd, crlf ] headers = [ Header (HdrCustom "Content-disposition") ("form-data; name=package; " ++ "filename=\"" ++ takeFileName path ++ "\"") , Header HdrContentType "application/x-gzip" ] crlf = BS.pack "\r\n" dd = BS.pack "--" genBoundary :: IO String genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer return $ showHex i "" cabal-install-2.4.0.0/Distribution/Client/IndexUtils.hs0000644000000000000000000011672200000000000021042 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# 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, IndexState(..), getSourcePackagesAtIndexState, Index(..), PackageEntry(..), parsePackageIndex, updateRepoIndexCache, updatePackageIndexCacheFile, writeIndexTimestamp, currentIndexTimestamp, readCacheStrict, -- only used by soon-to-be-obsolete sandbox code BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType ) where import Prelude () import Distribution.Client.Compat.Prelude import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types import Distribution.Verbosity import Distribution.Package ( PackageId, PackageIdentifier(..), 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.Version ( Version, mkVersion, intersectVersionRanges ) import Distribution.Text ( display, simpleParse ) import Distribution.Simple.Utils ( die', warn, info ) 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 Control.DeepSeq import Control.Monad import Control.Exception import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath , tryFindAddSourcePackageDesc ) import Distribution.Compat.Binary import Distribution.Compat.Exception (catchIO) import Distribution.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath ( (), (<.>), takeExtension, replaceExtension, splitDirectories, normalise ) import System.FilePath.Posix as FilePath.Posix ( takeFileName ) import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) import 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" RepoLocal {} -> "00-index" ------------------------------------------------------------------------ -- Reading the source package index -- -- Note: 'data IndexState' is defined in -- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles -- | 'IndexStateInfo' contains meta-information about the resulting -- filtered 'Cache' 'after applying 'filterCache' according to a -- requested 'IndexState'. data IndexStateInfo = IndexStateInfo { isiMaxTime :: !Timestamp -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current -- filtered view of the cache. -- -- The following property holds -- -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi) -- , isiHeadTime :: !Timestamp -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to -- 'isiMaxTime'. } emptyStateInfo :: IndexStateInfo emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp -- | Filters a 'Cache' according to an 'IndexState' -- specification. Also returns 'IndexStateInfo' describing the -- resulting index cache. -- -- Note: 'filterCache' is idempotent in the 'Cache' value filterCache :: IndexState -> Cache -> (Cache, IndexStateInfo) filterCache IndexStateHead cache = (cache, IndexStateInfo{..}) where isiMaxTime = cacheHeadTs cache isiHeadTime = cacheHeadTs cache filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..}) where cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime } isiHeadTime = cacheHeadTs cache0 isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents) ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0) -- | Read a repository index from disk, from the local files specified by -- a list of 'Repo's. -- -- 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 = getSourcePackagesAtIndexState verbosity repoCtxt 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. -- -- TODO: Enhance to allow specifying per-repo 'IndexState's and also -- report back per-repo 'IndexStateInfo's (in order for @new-freeze@ -- to access it) getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState -> IO SourcePackageDb getSourcePackagesAtIndexState verbosity repoCtxt _ | null (repoContextRepos repoCtxt) = do -- In the test suite, we routinely don't have any remote package -- servers, so don't bleat about it warn (verboseUnmarkOutput verbosity) $ "No remote package servers have been specified. Usually " ++ "you would have one specified in the config file." return SourcePackageDb { packageIndex = mempty, packagePreferences = mempty } getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do let describeState IndexStateHead = "most recent state" describeState (IndexStateTime time) = "historical state as of " ++ display time pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do let rname = maybe "" remoteRepoName $ maybeRepoRemote r info verbosity ("Reading available packages of " ++ rname ++ "...") idxState <- case mb_idxState of Just idxState -> do 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 RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')") RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')") RepoSecure {} -> pure () let idxState' = case r of RepoSecure {} -> idxState _ -> IndexStateHead (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState' case idxState' of IndexStateHead -> do info verbosity ("index-state("++rname++") = " ++ display (isiHeadTime isi)) return () IndexStateTime ts0 -> do when (isiMaxTime isi /= ts0) $ if ts0 > isiMaxTime isi then warn verbosity $ "Requested index-state" ++ display ts0 ++ " is newer than '" ++ rname ++ "'!" ++ " Falling back to older state (" ++ display (isiMaxTime isi) ++ ")." else info verbosity $ "Requested index-state " ++ display ts0 ++ " does not exist in '"++rname++"'!" ++ " Falling back to older state (" ++ display (isiMaxTime isi) ++ ")." info verbosity ("index-state("++rname++") = " ++ display (isiMaxTime isi) ++ " (HEAD = " ++ display (isiHeadTime isi) ++ ")") pure (pis,deps) let (pkgs, prefs) = mconcat pkgss prefs' = Map.fromListWith intersectVersionRanges [ (name, range) | Dependency name range <- prefs ] _ <- evaluate pkgs _ <- evaluate prefs' return SourcePackageDb { packageIndex = pkgs, packagePreferences = prefs' } readCacheStrict :: NFData pkg => Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency]) readCacheStrict verbosity index mkPkg = do updateRepoIndexCache verbosity index cache <- readIndexCache verbosity index withFile (indexFile index) ReadMode $ \indexHnd -> evaluate . force =<< packageListFromCache verbosity mkPkg indexHnd cache -- | 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 -> IndexState -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) readRepoIndex verbosity repoCtxt repo idxState = handleNotFound $ do warnIfIndexIsOld =<< getIndexFileAge repo updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) readPackageIndexCacheFile verbosity mkAvailablePackage (RepoIndex repoCtxt repo) idxState where mkAvailablePackage pkgEntry = SourcePackage { packageInfoId = pkgid, packageDescription = packageDesc pkgEntry, packageSource = case pkgEntry of NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path, packageDescrOverride = case pkgEntry of NormalPackage _ _ pkgtxt _ -> Just pkgtxt _ -> Nothing } where 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 RepoLocal{..} -> warn verbosity $ "The package list for the local repo '" ++ repoLocalDir ++ "' is missing. The repo is invalid." 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 RepoLocal{..} -> return () errMissingPackageList repoRemote = "The package list for '" ++ remoteRepoName repoRemote ++ "' does not exist. Run 'cabal update' to download it." errOutdatedPackageList repoRemote dt = "The package list for '" ++ remoteRepoName repoRemote ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun " ++ "'cabal update' to get the latest list of available packages." -- | Return the age of the index file in days (as a Double). getIndexFileAge :: Repo -> IO Double getIndexFileAge repo = getFileAge $ 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 $ do updatePackageIndexCacheFile verbosity index whenCacheOutOfDate :: Index -> IO () -> IO () whenCacheOutOfDate index action = do exists <- doesFileExist $ cacheFile index if not exists then action else do indexTime <- getModTime $ indexFile index cacheTime <- getModTime $ cacheFile index when (indexTime > cacheTime) action ------------------------------------------------------------------------ -- 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,Generic) instance Binary 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 simpleParse 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 _ | takeFileName entrypath == "preferred-versions" -> Just prefs where entrypath = Tar.entryPath entry prefs = parsePreferredVersions content _ -> Nothing parsePreferredVersions :: ByteString -> [Dependency] parsePreferredVersions = mapMaybe simpleParse . filter (not . isPrefixOf "--") . lines . BS.Char8.unpack -- TODO: Are we sure no unicode? ------------------------------------------------------------------------ -- Reading and updating the index cache -- -- | 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 RepoLocal {} -> False is01Index (SandboxIndex _) = False updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") withIndexEntries verbosity index $ \entries -> do let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) cache = Cache { cacheHeadTs = maxTs , cacheEntries = entries } writeIndexCache index cache info verbosity ("Index cache updated to index-state " ++ display (cacheHeadTs cache)) -- | Read the index (for the purpose of building a cache) -- -- 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) -> 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 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 -> IndexState -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) readPackageIndexCacheFile verbosity mkPkg index idxState = do cache0 <- readIndexCache verbosity index indexHnd <- openFile (indexFile index) ReadMode let (cache,isi) = filterCache idxState cache0 (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache 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) -- | 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 { specVersionRaw = Left specVer , package = pkgid , synopsis = dummySynopsis } , 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) -- | Read the 'Index' cache from the filesystem without attempting to -- regenerate on parsing failures. readIndexCache' :: Index -> IO (Either String Cache) readIndexCache' index | is01Index index = decodeFileOrFail' (cacheFile index) | otherwise = liftM (Right .read00IndexCache) $ BSS.readFile (cacheFile index) -- | Write the 'Index' cache to the filesystem writeIndexCache :: Index -> Cache -> IO () writeIndexCache index cache | is01Index index = encodeFile (cacheFile index) cache | otherwise = writeFile (cacheFile index) (show00IndexCache cache) -- | Write the 'IndexState' to the filesystem writeIndexTimestamp :: Index -> IndexState -> IO () writeIndexTimestamp index st = writeFile (timestampFile index) (display 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 IndexState) readIndexTimestamp index = fmap simpleParse (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] } instance NFData Cache where rnf = rnf . cacheEntries -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. -- type BlockNo = Word32 -- Tar.TarEntryOffset data IndexCacheEntry = CachePackageId PackageId !BlockNo !Timestamp | CachePreference Dependency !BlockNo !Timestamp | CacheBuildTreeRef !BuildTreeRefType !BlockNo -- NB: CacheBuildTreeRef is irrelevant for 01-index & new-build deriving (Eq,Generic) instance NFData IndexCacheEntry where rnf (CachePackageId pkgid _ _) = rnf pkgid rnf (CachePreference dep _ _) = rnf dep rnf (CacheBuildTreeRef _ _) = () cacheEntryTimestamp :: IndexCacheEntry -> Timestamp cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp cacheEntryTimestamp (CachePreference _ _ ts) = ts cacheEntryTimestamp (CachePackageId _ _ ts) = ts ---------------------------------------------------------------------------- -- new binary 01-index.cache format instance Binary Cache where put (Cache headTs ents) = do -- magic / format version -- -- NB: this currently encodes word-size implicitly; when we -- switch to CBOR encoding, we will have a platform -- independent binary encoding put (0xcaba1002::Word) put headTs put ents get = do magic <- get when (magic /= (0xcaba1002::Word)) $ fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic) Cache <$> get <*> get instance Binary IndexCacheEntry ---------------------------------------------------------------------------- -- legacy 00-index.cache format packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String packageKey = "pkg:" blocknoKey = "b#" buildTreeRefKey = "build-tree-ref:" preferredVersionKey = "pref-ver:" -- 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 <- simpleParse (BSS.unpack (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 , display (packageName pkgid) , display (packageVersion pkgid) , blocknoKey , show b ] CacheBuildTreeRef tr b -> [ buildTreeRefKey , [typeCodeFromRefType tr] , show b ] CachePreference dep _ _ -> [ preferredVersionKey , display dep ] cabal-install-2.4.0.0/Distribution/Client/IndexUtils/0000755000000000000000000000000000000000000020475 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/IndexUtils/Timestamp.hs0000644000000000000000000001465700000000000023011 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.IndexUtils.Timestamp -- Copyright : (c) 2016 Herbert Valerio Riedel -- License : BSD3 -- -- Timestamp type used in package indexes module Distribution.Client.IndexUtils.Timestamp ( Timestamp , nullTimestamp , epochTimeToTimestamp , timestampToUTCTime , utcTimeToTimestamp , maximumTimestamp , IndexState(..) ) where import qualified Codec.Archive.Tar.Entry as Tar import Control.DeepSeq import Control.Monad import Data.Char (isDigit) import Data.Int (Int64) import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Distribution.Compat.Binary import qualified Distribution.Compat.ReadP as ReadP import Distribution.Text import qualified Text.PrettyPrint as Disp import GHC.Generics (Generic) -- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). newtype Timestamp = TS Int64 -- Tar.EpochTime deriving (Eq,Ord,Enum,NFData,Show) epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp epochTimeToTimestamp et | ts == nullTimestamp = Nothing | otherwise = Just ts where ts = TS et timestampToUTCTime :: Timestamp -> Maybe UTCTime timestampToUTCTime (TS t) | t == minBound = Nothing | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t) utcTimeToTimestamp :: UTCTime -> Maybe Timestamp utcTimeToTimestamp utct | minTime <= t, t <= maxTime = Just (TS (fromIntegral t)) | otherwise = Nothing where maxTime = toInteger (maxBound :: Int64) minTime = toInteger (succ minBound :: Int64) t :: Integer t = round . utcTimeToPOSIXSeconds $ utct -- | Compute the maximum 'Timestamp' value -- -- Returns 'nullTimestamp' for the empty list. Also note that -- 'nullTimestamp' compares as smaller to all non-'nullTimestamp' -- values. maximumTimestamp :: [Timestamp] -> Timestamp maximumTimestamp [] = nullTimestamp maximumTimestamp xs@(_:_) = maximum xs -- returns 'Nothing' if not representable as 'Timestamp' posixSecondsToTimestamp :: Integer -> Maybe Timestamp posixSecondsToTimestamp pt | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt)) | otherwise = Nothing where maxTs = toInteger (maxBound :: Int64) minTs = toInteger (succ minBound :: Int64) -- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format -- (e.g. @"2017-12-31T23:59:59Z"@) -- -- Returns empty string for 'nullTimestamp' in order for -- -- > null (display nullTimestamp) == True -- -- to hold. showTimestamp :: Timestamp -> String showTimestamp ts = case timestampToUTCTime ts of Nothing -> "" -- Note: we don't use 'formatTime' here to avoid incurring a -- dependency on 'old-locale' for older `time` libs Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z" where showTOD = show . timeToTimeOfDay instance Binary Timestamp where put (TS t) = put t get = TS `fmap` get instance Text Timestamp where disp = Disp.text . showTimestamp parse = parsePosix ReadP.+++ parseUTC where -- | Parses unix timestamps, e.g. @"\@1474626019"@ parsePosix = do _ <- ReadP.char '@' t <- parseInteger maybe ReadP.pfail return $ posixSecondsToTimestamp t -- | Parses ISO8601/RFC3339-style UTC timestamps, -- e.g. @"2017-12-31T23:59:59Z"@ -- -- TODO: support numeric tz offsets; allow to leave off seconds parseUTC = do -- Note: we don't use 'Data.Time.Format.parseTime' here since -- we want more control over the accepted formats. ye <- parseYear _ <- ReadP.char '-' mo <- parseTwoDigits _ <- ReadP.char '-' da <- parseTwoDigits _ <- ReadP.char 'T' utctDay <- maybe ReadP.pfail return $ fromGregorianValid ye mo da ho <- parseTwoDigits _ <- ReadP.char ':' mi <- parseTwoDigits _ <- ReadP.char ':' se <- parseTwoDigits _ <- ReadP.char 'Z' utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $ makeTimeOfDayValid ho mi (realToFrac (se::Int)) maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..}) parseTwoDigits = do d1 <- ReadP.satisfy isDigit d2 <- ReadP.satisfy isDigit return (read [d1,d2]) -- A year must have at least 4 digits; e.g. "0097" is fine, -- while "97" is not c.f. RFC3339 which -- deprecates 2-digit years parseYear = do sign <- ReadP.option ' ' (ReadP.char '-') ds <- ReadP.munch1 isDigit when (length ds < 4) ReadP.pfail return (read (sign:ds)) parseInteger = do sign <- ReadP.option ' ' (ReadP.char '-') ds <- ReadP.munch1 isDigit return (read (sign:ds) :: Integer) -- | Special timestamp value to be used when 'timestamp' is -- missing/unknown/invalid nullTimestamp :: Timestamp nullTimestamp = TS minBound ---------------------------------------------------------------------------- -- defined here for now to avoid import cycles -- | Specification of the state of a specific repo package index data IndexState = IndexStateHead -- ^ Use all available entries | IndexStateTime !Timestamp -- ^ Use all entries that existed at -- the specified time deriving (Eq,Generic,Show) instance Binary IndexState instance NFData IndexState instance Text IndexState where disp IndexStateHead = Disp.text "HEAD" disp (IndexStateTime ts) = disp ts parse = parseHead ReadP.+++ parseTime where parseHead = do _ <- ReadP.string "HEAD" return IndexStateHead parseTime = IndexStateTime `fmap` parse cabal-install-2.4.0.0/Distribution/Client/Init.hs0000644000000000000000000011215700000000000017653 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 , pvpize , incVersion ) where import Prelude () import Distribution.Client.Compat.Prelude hiding (empty) import System.IO ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile , getDirectoryContents, createDirectoryIfMissing ) import System.FilePath ( (), (<.>), takeBaseName, equalFilePath ) import Data.Time ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) import Data.List ( groupBy, (\\) ) import Data.Function ( on ) import qualified Data.Map as M import Control.Monad ( (>=>), join, forM_, mapM, mapM_ ) import Control.Arrow ( (&&&), (***) ) import Text.PrettyPrint hiding (mode, cat) import Distribution.Version ( Version, mkVersion, alterVersion , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity ( Verbosity ) import Distribution.ModuleName ( ModuleName ) -- And for the Text instance import Distribution.InstalledPackageInfo ( InstalledPackageInfo, exposed ) import qualified Distribution.Package as P import Language.Haskell.Extension ( Language(..) ) import Distribution.Client.Init.Types ( InitFlags(..), BuildType(..), PackageType(..), Category(..) , displayPackageType ) import Distribution.Client.Init.Licenses ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) import Distribution.Client.Init.Heuristics ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, SourceFileEntry(..), scanForModules, neededBuildPrograms ) import Distribution.License ( License(..), knownLicenses ) import Distribution.ReadE ( runReadE, readP_to_E ) import Distribution.Simple.Setup ( Flag(..), flagToMaybe ) import Distribution.Simple.Utils ( dropWhileEndLE ) import Distribution.Simple.Configure ( getInstalledPackages ) import Distribution.Simple.Compiler ( PackageDBStack, Compiler ) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, moduleNameIndex ) import Distribution.Text ( display, Text(..) ) 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 PublicDomain -> return () _ -> writeLicense initFlags' writeSetupFile initFlags' writeChangeLog initFlags' createSourceDirectories initFlags' createMainHs initFlags' success <- writeCabalFile initFlags' when success $ generateWarnings initFlags' --------------------------------------------------------------------------- -- Flag acquisition ----------------------------------------------------- --------------------------------------------------------------------------- -- | Fill in more details by guessing, discovering, or prompting the -- user. extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags extendFlags pkgIx sourcePkgDb = getPackageName sourcePkgDb >=> getVersion >=> getLicense >=> getAuthorInfo >=> getHomepage >=> getSynopsis >=> getCategory >=> getExtraSourceFiles >=> getLibOrExec >=> getSrcDir >=> 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 -- | Witness the isomorphism between Maybe and Flag. maybeToFlag :: Maybe a -> Flag a maybeToFlag = maybe NoFlag Flag -- | 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. getLicense :: InitFlags -> IO InitFlags getLicense flags = do lic <- return (flagToMaybe $ license flags) ?>> fmap (fmap (either UnknownLicense id)) (maybePrompt flags (promptList "Please choose a license" listedLicenses (Just BSD3) display True)) if isLicenseInvalid lic then putStrLn promptInvalidOtherLicenseMsg >> getLicense flags else return $ flags { license = maybeToFlag lic } where isLicenseInvalid (Just (UnknownLicense t)) = any (not . isAlphaNum) t isLicenseInvalid _ = False promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " ++ "If your license name has many words, " ++ "the convention is to use camel case (e.g. PublicDomain). " ++ "Please choose a different license." listedLicenses = knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing , Apache Nothing, OtherLicense] -- | 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. 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 Library) id `fmap` promptList "What does the package build" [Library, Executable, LibraryAndExecutable] Nothing displayPackageType False) ?>> return (Just Library) 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 for the 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) display 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 source root directory. getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do srcDirs <- return (sourceDirs flags) ?>> fmap (:[]) `fmap` guessSourceDir flags ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt flags (promptListOptional' "Source directory" ["src"] id)) return $ flags { sourceDirs = srcDirs } -- | 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) return $ flags { exposedModules = Just mods , buildTools = tools , dependencies = deps , otherExts = exts } 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 <$> mapM (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 " ++ display m ++ ".") >> return Nothing chooseDep flags (m, Just []) = message flags ("\nWarning: no package found providing " ++ display 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 " ++ display m ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps)) message flags "You will need to pick one and manually add it to the Build-depends: field." return Nothing where pkgGroups = groupBy ((==) `on` P.pkgName) (map P.packageId ps) -- Given a list of available versions of the same package, pick a dependency. toDep :: [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 . P.pkgVersion $ pid) -- Otherwise, choose the latest version and issue a warning. toDep pids = do message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") return $ P.Dependency (P.pkgName . head $ pids) (pvpize . maximum . map P.pkgVersion $ pids) -- | Given a version, return an API-compatible (according to PVP) version range. -- -- Example: @0.4.1@ produces the version range @>= 0.4 && < 0.5@ (which is the -- same as @0.4.*@). pvpize :: Version -> VersionRange pvpize v = orLaterVersion v' `intersectVersionRanges` earlierVersion (incVersion 1 v') where v' = 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 --------------------------------------------------------------------------- -- Prompting/user interaction ------------------------------------------- --------------------------------------------------------------------------- -- | Run a prompt or not based on the nonInteractive flag of the -- InitFlags structure. maybePrompt :: InitFlags -> IO t -> IO (Maybe t) maybePrompt flags p = case nonInteractive flags of Flag True -> return Nothing _ -> Just `fmap` p -- | 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 -> Maybe Bool -> 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 :: Text t => String -> Maybe t -> IO t prompt = promptDefault' (either (const Nothing) Just . runReadE (readP_to_E id parse)) display -- | 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 pretty pr def = do putStr $ mkDefPrompt pr (pretty `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 pretty 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 ++ "] " promptListOptional :: (Text t, Eq t) => String -- ^ prompt -> [t] -- ^ choices -> IO (Maybe (Either String t)) promptListOptional pr choices = promptListOptional' pr choices display 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]) mapM_ (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 --------------------------------------------------------------------------- -- File generation ------------------------------------------------------ --------------------------------------------------------------------------- writeLicense :: InitFlags -> IO () writeLicense flags = do message flags "\nGenerating LICENSE..." year <- show <$> getYear let authors = fromMaybe "???" . flagToMaybe . author $ flags let licenseFile = case license flags of Flag BSD2 -> Just $ bsd2 authors year Flag BSD3 -> Just $ bsd3 authors year Flag (GPL (Just v)) | v == mkVersion [2] -> Just gplv2 Flag (GPL (Just v)) | v == mkVersion [3] -> Just gplv3 Flag (LGPL (Just v)) | v == mkVersion [2,1] -> Just lgpl21 Flag (LGPL (Just v)) | v == mkVersion [3] -> Just lgpl3 Flag (AGPL (Just v)) | v == mkVersion [3] -> Just agplv3 Flag (Apache (Just v)) | v == mkVersion [2,0] -> Just apache20 Flag MIT -> Just $ mit authors year Flag (MPL v) | v == mkVersion [2,0] -> Just mpl20 Flag ISC -> Just $ isc authors year _ -> 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." getYear :: IO Integer getYear = do u <- getCurrentTime z <- getCurrentTimeZone let l = utcToLocalTime z u (y, _, _) = toGregorian $ localDay l return y writeSetupFile :: InitFlags -> IO () writeSetupFile flags = do message flags "Generating Setup.hs..." writeFileSafe flags "Setup.hs" setupFile where setupFile = unlines [ "import Distribution.Simple" , "main = defaultMain" ] 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 "" display $ flagToMaybe $ packageName flags pver = maybe "" display $ flagToMaybe $ version flags writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do message flags "Error: no package name provided." return False writeCabalFile flags@(InitFlags{packageName = Flag p}) = do let cabalFileName = display 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 source directories, if they were given. createSourceDirectories :: InitFlags -> IO () createSourceDirectories flags = case sourceDirs flags of Just dirs -> forM_ dirs (createDirectoryIfMissing True) Nothing -> return () -- | Create Main.hs, but only if we are init'ing an executable and -- the mainIs flag has been provided. createMainHs :: InitFlags -> IO () createMainHs flags = if hasMainHs flags then case sourceDirs flags of Just (srcPath:_) -> writeMainHs flags (srcPath mainFile) _ -> writeMainHs flags mainFile else return () where Flag mainFile = mainIs flags --- | 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 -- | Check that 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.hs file. Used when no Main.hs exists. mainHs :: String mainHs = unlines [ "module Main where" , "" , "main :: IO ()" , "main = putStrLn \"Hello, Haskell!\"" ] -- | Move an existing file, if there is one, and the overwrite flag is -- not set. moveExistingFile :: InitFlags -> FilePath -> IO () 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 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. NOTE: this -- is rather ad-hoc! What we would REALLY like is to have a -- standard low-level AST type representing .cabal files, which -- preserves things like comments, and to write an *inverse* -- parser/pretty-printer pair between .cabal files and this AST. -- Then instead of this ad-hoc code we could just map an InitFlags -- structure onto a low-level AST structure and use the existing -- pretty-printing code to generate the file. generateCabalFile :: String -> InitFlags -> String generateCabalFile fileName c = trimTrailingWS $ (++ "\n") . renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $ (if minimal c /= Flag True then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal " ++ "init. For further documentation, see " ++ "http://haskell.org/cabal/users-guide/") $$ text "" else empty) $$ vcat [ field "name" (packageName c) (Just "The name of the package.") True , field "version" (version c) (Just $ "The package version. See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://wiki.haskell.org/Package_versioning_policy\n" ++ "PVP summary: +-+------- breaking API changes\n" ++ " | | +----- non-breaking API additions\n" ++ " | | | +--- code changes with no API change") True , fieldS "synopsis" (synopsis c) (Just "A short (one-line) description of the package.") True , fieldS "description" NoFlag (Just "A longer description of the package.") True , fieldS "homepage" (homepage c) (Just "URL for the project homepage or repository.") False , fieldS "bug-reports" NoFlag (Just "A URL where users can report bugs.") False , field "license" (license c) (Just "The license under which the package is released.") True , case (license c) of Flag PublicDomain -> empty _ -> fieldS "license-file" (Flag "LICENSE") (Just "The file containing the license text.") True , fieldS "author" (author c) (Just "The package author(s).") True , fieldS "maintainer" (email c) (Just "An email address to which users can send suggestions, bug reports, and patches.") True , case (license c) of Flag PublicDomain -> empty _ -> fieldS "copyright" NoFlag (Just "A copyright notice.") True , fieldS "category" (either id display `fmap` category c) Nothing True , fieldS "build-type" (Flag "Simple") Nothing True , fieldS "extra-source-files" (listFieldS (extraSrc c)) (Just "Extra files to be distributed with the package, such as examples or a README.") True , field "cabal-version" (Flag $ orLaterVersion (mkVersion [1,10])) (Just "Constraint on the version of Cabal needed to build this package.") False , case packageType c of Flag Executable -> executableStanza Flag Library -> libraryStanza Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza _ -> empty ] where generateBuildInfo :: BuildType -> InitFlags -> Doc generateBuildInfo buildType c' = vcat [ fieldS "other-modules" (listField (otherModules c')) (Just $ case buildType of LibBuild -> "Modules included in this library but not exported." ExecBuild -> "Modules included in this executable, other than Main.") True , fieldS "other-extensions" (listField (otherExts c')) (Just "LANGUAGE extensions used by modules in this package.") True , fieldS "build-depends" (listField (dependencies c')) (Just "Other library packages from which modules are imported.") True , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) (Just "Directories containing source files.") True , fieldS "build-tools" (listFieldS (buildTools c')) (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") False , field "default-language" (language c') (Just "Base language which the package is written in.") True ] listField :: Text s => Maybe [s] -> Flag String listField = listFieldS . fmap (map display) listFieldS :: Maybe [String] -> Flag String listFieldS = Flag . maybe "" (intercalate ", ") field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc field s f = fieldS s (fmap display f) fieldS :: String -- ^ Name of the field -> Flag String -- ^ Field contents -> Maybe String -- ^ Comment to explain the field -> Bool -- ^ Should the field be included (commented out) even if blank? -> Doc fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty fieldS s f com _ = case (isJust com, noComments c, minimal c) of (_, _, Flag True) -> id (_, Flag True, _) -> id (True, _, _) -> (showComment com $$) . ($$ text "") (False, _, _) -> ($$ text "") $ comment f <<>> text s <<>> colon <<>> text (replicate (20 - length s) ' ') <<>> text (fromMaybe "" . flagToMaybe $ f) comment NoFlag = text "-- " comment (Flag "") = text "-- " comment _ = text "" showComment :: Maybe String -> Doc showComment (Just t) = vcat . map (text . ("-- "++)) . lines . renderStyle style { lineLength = 76, ribbonsPerLine = 1.05 } . vcat . map (fcat . map text . breakLine) . lines $ t showComment Nothing = text "" breakLine [] = [] breakLine cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs' breakLine' [] = [] breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs' trimTrailingWS :: String -> String trimTrailingWS = unlines . map (dropWhileEndLE isSpace) . lines executableStanza :: Doc executableStanza = text "\nexecutable" <+> text (maybe "" display . flagToMaybe $ packageName c) $$ nest 2 (vcat [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True , generateBuildInfo ExecBuild c ]) libraryStanza :: Doc libraryStanza = text "\nlibrary" $$ nest 2 (vcat [ fieldS "exposed-modules" (listField (exposedModules c)) (Just "Modules exported by the library.") True , generateBuildInfo LibBuild c ]) -- | 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." -- | 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 cabal-install-2.4.0.0/Distribution/Client/Init/0000755000000000000000000000000000000000000017310 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/Init/Heuristics.hs0000644000000000000000000003427100000000000021775 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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.Text (simpleParse) 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 ( packageDescription ) import Distribution.Client.Types ( SourcePackageDb(..) ) import Control.Monad ( mapM ) import Data.Char ( isNumber, isLower ) import Data.Either ( partitionEithers ) import Data.List ( isInfixOf ) import Data.Ord ( comparing ) 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 System.Exit ( ExitCode(..) ) -- | 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 . last . 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 isNumber 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 (mapM (tagIsDir dir) entries) let modules = catMaybes [ guessModuleName hierarchy file | file <- files , isUpper (head file) ] modules' <- mapM (findImportsAndExts projectRoot) modules recMods <- mapM (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 = simpleParse $ intercalate "." . reverse $ (unqualModName : hierarchy) ext = case takeExtension entry of '.':e -> e; e -> e scanRecursive parent hierarchy entry | isUpper (head entry) = scan (parent entry) (entry : hierarchy) | isLower (head 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 simpleParse . 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:_) = simpleParse 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 <- map head (allPackagesByName sourcePkgIndex) , let catList = (PD.category . PD.packageDescription . packageDescription) pkg , cat <- splitString ',' 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 (== '>') (tail 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 -} cabal-install-2.4.0.0/Distribution/Client/Init/Licenses.hs0000644000000000000000000053677500000000000021440 0ustar0000000000000000module Distribution.Client.Init.Licenses ( License , bsd2 , bsd3 , gplv2 , gplv3 , lgpl21 , lgpl3 , agplv3 , apache20 , mit , mpl20 , isc ) where 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." ] cabal-install-2.4.0.0/Distribution/Client/Init/Types.hs0000644000000000000000000000716100000000000020755 0ustar0000000000000000{-# 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.Simple.Setup ( Flag(..) ) import Distribution.Types.Dependency as P import Distribution.Compat.Semigroup import Distribution.Version import Distribution.Verbosity import qualified Distribution.Package as P import Distribution.License import Distribution.ModuleName import Language.Haskell.Extension ( Language(..), Extension ) import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse import Distribution.Text import GHC.Generics ( Generic ) -- | InitFlags is really just a simple type to represent certain -- portions of a .cabal file. Rather than have a flag for EVERY -- 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 { nonInteractive :: Flag Bool , quiet :: Flag Bool , packageDir :: Flag FilePath , noComments :: Flag Bool , minimal :: Flag Bool , packageName :: Flag P.PackageName , version :: Flag Version , cabalVersion :: Flag VersionRange , 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] , sourceDirs :: Maybe [String] , buildTools :: Maybe [String] , 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 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 -- | Some common package categories. 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 Text Category where disp = Disp.text . show parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -- TODO: eradicateNoParse cabal-install-2.4.0.0/Distribution/Client/Install.hs0000644000000000000000000020425600000000000020360 0ustar0000000000000000{-# 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 qualified Data.Map as Map import qualified Data.Set as S import Control.Exception as Exception ( Exception(toException), bracket, catches , Handler(Handler), handleJust, IOException, SomeException ) #ifndef mingw32_HOST_OS import Control.Exception as Exception ( Exception(fromException) ) #endif import System.Exit ( ExitCode(..) ) import Distribution.Compat.Exception ( catchIO, catchExit ) import Control.Monad ( forM_, mapM ) 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(..) ) import Distribution.Client.Config ( getCabalDir, defaultUserInstall ) import Distribution.Client.Sandbox.Timestamp ( withUpdateTimestamps ) import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..), UseSandbox(..), isUseSandbox , whenUsingSandbox ) 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 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 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 , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) , copyCommand, CopyFlags(..), emptyCopyFlags , registerCommand, RegisterFlags(..), emptyRegisterFlags , testCommand, TestFlags(..), emptyTestFlags ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, comparing , writeFileAtomic, withUTF8FileContents ) import Distribution.Simple.InstallDirs as InstallDirs ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Simple.Configure (interpretPackageDbFlags) import Distribution.Simple.Register (registerPackage, defaultRegisterOptions) import Distribution.Package ( PackageIdentifier(..), PackageId, packageName, packageVersion , Package(..), HasMungedPackageId(..), HasUnitId(..) , UnitId ) import Distribution.Types.Dependency ( Dependency(..), thisPackageVersion ) import Distribution.Types.MungedPackageId import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription ( PackageDescription, GenericPackageDescription(..), Flag(..) , FlagAssignment, mkFlagAssignment, unFlagAssignment , showFlagValue, diffFlagAssignment, nullFlagAssignment ) import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.ParseUtils ( showPWarning ) 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(..) , tryCanonicalizePath, ProgressPhase(..), progressMessage ) import Distribution.System ( Platform, OS(Windows), buildOS, buildPlatform ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity ( Verbosity, modifyVerbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension ) --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 -> UseSandbox -> Maybe SandboxPackageInfo -> GlobalFlags -> ConfigFlags -> ConfigExFlags -> InstallFlags -> HaddockFlags -> [UserTarget] -> IO () install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do unless (installRootCmd installFlags == Cabal.NoFlag) $ warn verbosity $ "--root-cmd is no longer supported, " ++ "see https://github.com/haskell/cabal/issues/3353" ++ " (if you didn't type --root-cmd, comment out root-cmd" ++ " in your ~/.cabal/config file)" let userOrSandbox = fromFlag (configUserInstall configFlags) || isUseSandbox useSandbox unless userOrSandbox $ warn verbosity $ "the --global flag is deprecated -- " ++ "it is generally considered a bad idea to install packages " ++ "into the global store" installContext <- makeInstallContext verbosity args (Just userTargets0) planResult <- foldProgress logMsg (return . Left) (return . Right) =<< makeInstallPlan verbosity args installContext 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, useSandbox, mSandboxPkgInfo, globalFlags, configFlags, configExFlags, installFlags, haddockFlags) die'' message = die' verbosity (message ++ if isUseSandbox useSandbox then installFailedInSandbox else []) -- TODO: use a better error message, remove duplication. installFailedInSandbox = "\nNote: when using a sandbox, all packages are required to have " ++ "consistent dependencies. " ++ "Try reinstalling/unregistering the offending packages or " ++ "recreating the sandbox." 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 , UseSandbox , Maybe SandboxPackageInfo , GlobalFlags , ConfigFlags , ConfigExFlags , InstallFlags , HaddockFlags ) -- | 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 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, _, _, mSandboxPkgInfo, _, 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 mSandboxPkgInfo 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 -> Maybe SandboxPackageInfo -> Solver -> ConfigFlags -> ConfigExFlags -> InstallFlags -> InstalledPackageIndex -> SourcePackageDb -> PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> Progress String String SolverInstallPlan planPackages verbosity comp platform mSandboxPkgInfo 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 . setAvoidReinstalls avoidReinstalls . setShadowPkgs shadowPkgs . setStrongFlags strongFlags . setAllowBootLibInstalls allowBootLibInstalls . 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 | Dependency 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 ] . maybe id applySandboxInstallPolicy mSandboxPkgInfo . (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) independentGoals = fromFlag (installIndependentGoals installFlags) avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) shadowPkgs = fromFlag (installShadowPkgs installFlags) strongFlags = fromFlag (installStrongFlags installFlags) maxBackjumps = fromFlag (installMaxBackjumps installFlags) allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) upgradeDeps = fromFlag (installUpgradeDeps installFlags) onlyDeps = fromFlag (installOnlyDeps installFlags) 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 " ++ display pkgid ++ " is " _ -> "the packages " ++ intercalate ", " (map display 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 (display . 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 (display . 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 packageInfoId) . filterM (fmap isNothing . checkFetched . packageSource) $ pkgs unless (null notFetched) $ die' verbosity $ "Can't download packages in offline mode. " ++ "Must download the following packages to proceed:\n" ++ intercalate ", " (map display notFetched) ++ "\nTry using 'cabal fetch'." where nothingToInstall = null (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, _) = display (packageId pkg) ++ showLatest (pkg) showPkgAndReason (ReadyPackage pkg', pr) = display (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: " ++ display latestVersion ++ ")") else "" Nothing -> "" where mLatestVersion :: Maybe Version mLatestVersion = case SourcePackageIndex.lookupPackageName (packageIndex sourcePkgDb) (packageName pkg) of [] -> Nothing x -> Just $ packageVersion $ last x toFlagAssignment :: [Flag] -> FlagAssignment toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment nonDefaultFlags cpkg = let defaultAssignment = toFlagAssignment (genPackageFlags (SourcePackage.packageDescription $ confPkgSource cpkg)) in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment showStanzas :: [OptionalStanza] -> String showStanzas = concatMap ((" *" ++) . showStanza) showFlagAssignment :: FlagAssignment -> String showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment change (OnlyInLeft pkgid) = display pkgid ++ " removed" change (InBoth pkgid pkgid') = display pkgid ++ " -> " ++ display (mungedVersion pkgid') change (OnlyInRight pkgid') = display pkgid' ++ " added" showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps = " (via: " ++ unwords (map display rdeps) ++ ")" | otherwise = "" revDepGraphEdges :: [(PackageId, PackageId)] revDepGraphEdges = [ (rpid, packageId cpkg) | (ReadyPackage cpkg, _) <- plan , ConfiguredId rpid (Just PackageDescription.CLibName) _ <- CD.flatDeps (confPkgDeps cpkg) ] revDeps :: Map.Map PackageId [PackageId] revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges) -- ------------------------------------------------------------ -- * 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 display pkgids) -- Save reports BuildReports.storeLocal (compilerInfo comp) (fromNubList $ installSummaryFile installFlags) buildReports platform -- Save solver log case logFile of Nothing -> return () Just template -> forM_ 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, useSandbox, mSandboxPkgInfo ,globalFlags, configFlags, _, installFlags, _) targets installPlan buildOutcomes = do updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo comp platform installPlan buildOutcomes unless oneShot $ World.insert verbosity worldFile --FIXME: does not handle flags [ World.WorldPkgInfo dep mempty | UserTargetNamed dep <- 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 useSandbox 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 = display (BuildReports.package report) <.> "log" logFile = logsDir logFileName reportsDir = dotCabal "reports" remoteRepoName remoteRepo reportFile = reportsDir logFileName handleMissingLogFile $ do buildLog <- readFile logFile createDirectoryIfMissing True reportsDir -- FIXME writeFile reportFile (show (BuildReports.show 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 -> UseSandbox -> ConfigFlags -> InstallFlags -> BuildOutcomes -> IO () regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox 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 = (isUseSandbox useSandbox || 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 configFlags installFlags plan buildOutcomes case failed of [] -> return () [(_, exe, path)] -> warn verbosity $ "could not create a symlink in " ++ bindir ++ " for " ++ display exe ++ " because the file exists there already but is not " ++ "managed by cabal. You can create a symlink for this executable " ++ "manually if you wish. The executable file has been installed at " ++ path exes -> warn verbosity $ "could not create symlinks in " ++ bindir ++ " for " ++ intercalate ", " [ display exe | (_, exe, _) <- exes ] ++ " because the files exist there already and are not " ++ "managed by cabal. You can create symlinks for these executables " ++ "manually if you wish. The executable files have been installed at " ++ 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:" : [ display pkgid ++ printFailureReason reason | (pkgid, reason) <- failed ] where printFailureReason reason = case reason of DependentFailed pkgid -> " depends on " ++ display 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 -- | If we're working inside a sandbox and some add-source deps were installed, -- update the timestamps of those deps. updateSandboxTimestampsFile :: Verbosity -> UseSandbox -> Maybe SandboxPackageInfo -> Compiler -> Platform -> InstallPlan -> BuildOutcomes -> IO () updateSandboxTimestampsFile verbosity (UseSandbox sandboxDir) (Just (SandboxPackageInfo _ _ _ allAddSourceDeps)) comp platform installPlan buildOutcomes = withUpdateTimestamps verbosity sandboxDir (compilerId comp) platform $ \_ -> do let allInstalled = [ pkg | InstallPlan.Configured pkg <- InstallPlan.toList installPlan , case InstallPlan.lookupBuildOutcome pkg buildOutcomes of Just (Right _success) -> True _ -> False ] allSrcPkgs = [ confPkgSource cpkg | cpkg <- allInstalled ] allPaths = [ pth | LocalUnpackedPackage pth <- map packageSource allSrcPkgs] allPathsCanonical <- mapM tryCanonicalizePath allPaths return $! filter (`S.member` allAddSourceDeps) allPathsCanonical updateSandboxTimestampsFile _ _ _ _ _ _ _ = return () -- ------------------------------------------------------------ -- * 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, useSandbox, _, globalFlags, configFlags, configExFlags, installFlags, haddockFlags) installedPkgIndex installPlan = do -- With 'install -j' it can be a bit hard to tell whether a sandbox is used. whenUsingSandbox useSandbox $ \sandboxDir -> when parallelInstall $ notice verbosity $ "Notice: installing into a sandbox located at " ++ sandboxDir info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." jobControl <- if parallelInstall then newParallelJobControl 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 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 (display pkgid) (Left _) -> do notice verbosity $ "Failed to install " ++ display 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 (display ipid), configConfigurationsFlags = flags, -- We generate the legacy constraints as well as the new style precise deps. -- In the end only one set gets passed to Setup.hs configure, depending on -- the Cabal version we are talking to. configConstraints = [ thisPackageVersion srcid | ConfiguredId srcid (Just PackageDescription.CLibName) _ipid <- CD.nonSetupDeps deps ], configDependencies = [ (packageName srcid, dep_ipid) | ConfiguredId srcid (Just PackageDescription.CLibName) dep_ipid <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, configBenchmarks = toFlag False, configTests = toFlag (TestStanzas `elem` stanzas) } source pkg pkgoverride where pkg = case 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 = display pkgid absUnpackedPath = tmpDirPath relUnpackedPath descFilePath = absUnpackedPath display (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 -> 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 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 display (packageName pkgid) <.> "cabal" info verbosity $ "Updating " ++ display (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) forM_ 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 = display 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 _ = Cabal.emptyTestFlags { 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 ++ "-" ++ display 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 mapM (readPkgConf pkgConfDest) . sort . filter notHidden =<< getDirectoryContents pkgConfDest else fmap (:[]) $ readPkgConf "." pkgConfDest else return [] readPkgConf :: FilePath -> FilePath -> IO Installed.InstalledPackageInfo readPkgConf pkgConfDir pkgConfFile = (withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfText -> case Installed.parseInstalledPackageInfo pkgConfText of Installed.ParseFailed perror -> pkgConfParseFailed perror Installed.ParseOk warns pkgConf -> do unless (null warns) $ warn verbosity $ unlines (map (showPWarning pkgConfFile) warns) return pkgConf) pkgConfParseFailed :: Installed.PError -> IO a pkgConfParseFailed perror = die' 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 ++ display (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 cabal-install-2.4.0.0/Distribution/Client/InstallPlan.hs0000644000000000000000000011372200000000000021170 0ustar0000000000000000{-# 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.Types hiding (BuildOutcomes) import qualified Distribution.PackageDescription as PD import qualified Distribution.Simple.Configure as Configure import qualified Distribution.Simple.Setup as Cabal import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Package ( Package(..), HasMungedPackageId(..) , HasUnitId(..), UnitId ) import Distribution.Solver.Types.SolverPackage import Distribution.Client.JobControl import Distribution.Text import Text.PrettyPrint import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.InstSolverPackage import Distribution.Utils.LogProgress -- TODO: Need this when we compute final UnitIds -- import qualified Distribution.Simple.Configure as Configure import Data.List ( foldl', intercalate ) import qualified Data.Foldable as Foldable (all) import Data.Maybe ( fromMaybe, mapMaybe ) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Compat.Binary (Binary(..)) import GHC.Generics import Data.Typeable import Control.Monad import Control.Exception ( assert ) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) import Prelude hiding (lookup) -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve. -- -- The Problem: -- -- In general we start with a set of installed packages and a set of source -- packages. -- -- Installed packages have fixed dependencies. They have already been built and -- we know exactly what packages they were built against, including their exact -- versions. -- -- Source package have somewhat flexible dependencies. They are specified as -- version ranges, though really they're predicates. To make matters worse they -- have conditional flexible dependencies. Configuration flags can affect which -- packages are required and can place additional constraints on their -- versions. -- -- These two sets of package can and usually do overlap. There can be installed -- packages that are also available as source packages which means they could -- be re-installed if required, though there will also be packages which are -- not available as source and cannot be re-installed. Very often there will be -- extra versions available than are installed. Sometimes we may like to prefer -- installed packages over source ones or perhaps always prefer the latest -- available version whether installed or not. -- -- The goal is to calculate an installation plan that is closed, acyclic and -- consistent and where every configured package is valid. -- -- An installation plan is a set of packages that are going to be used -- together. It will consist of a mixture of installed packages and source -- packages along with their exact version dependencies. An installation plan -- is closed if for every package in the set, all of its dependencies are -- also in the set. It is consistent if for every package in the set, all -- dependencies which target that package have the same version. -- Note that plans do not necessarily compose. You might have a valid plan for -- package A and a valid plan for package B. That does not mean the composition -- is simultaneously valid for A and B. In particular you're most likely to -- have problems with inconsistent dependencies. -- On the other hand it is true that every closed sub plan is valid. -- | Packages in an install plan -- -- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage' -- intentionally have no 'PackageInstalled' instance. `This is important: -- PackageInstalled returns only library dependencies, but for package that -- aren't yet installed we know many more kinds of dependencies (setup -- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on -- dependencies in cabal-install should consider what to do with these -- dependencies; if we give a 'PackageInstalled' instance it would be too easy -- to get this wrong (and, for instance, call graph traversal functions from -- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'. data GenericPlanPackage ipkg srcpkg = PreExisting ipkg | Configured srcpkg | Installed srcpkg deriving (Eq, Show, Generic) -- | Convenience combinator for destructing 'GenericPlanPackage'. -- This is handy because if you case manually, you have to handle -- 'Configured' and 'Installed' separately (where often you want -- them to be the same.) foldPlanPackage :: (ipkg -> a) -> (srcpkg -> a) -> GenericPlanPackage ipkg srcpkg -> a foldPlanPackage f _ (PreExisting ipkg) = f ipkg foldPlanPackage _ g (Configured srcpkg) = g srcpkg foldPlanPackage _ g (Installed srcpkg) = g srcpkg type IsUnit a = (IsNode a, Key a ~ UnitId) depends :: IsUnit a => a -> [UnitId] depends = nodeNeighbors -- NB: Expanded constraint synonym here to avoid undecidable -- instance errors in GHC 7.8 and earlier. instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) => IsNode (GenericPlanPackage ipkg srcpkg) where type Key (GenericPlanPackage ipkg srcpkg) = UnitId nodeKey (PreExisting ipkg) = nodeKey ipkg nodeKey (Configured spkg) = nodeKey spkg nodeKey (Installed spkg) = nodeKey spkg nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg nodeNeighbors (Configured spkg) = nodeNeighbors spkg nodeNeighbors (Installed spkg) = nodeNeighbors spkg instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) type PlanPackage = GenericPlanPackage InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) instance (Package ipkg, Package srcpkg) => Package (GenericPlanPackage ipkg srcpkg) where packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg packageId (Installed spkg) = packageId spkg instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) => HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where mungedId (PreExisting ipkg) = mungedId ipkg mungedId (Configured spkg) = mungedId spkg mungedId (Installed spkg) = mungedId spkg instance (HasUnitId ipkg, HasUnitId srcpkg) => HasUnitId (GenericPlanPackage ipkg srcpkg) where installedUnitId (PreExisting ipkg) = installedUnitId ipkg installedUnitId (Configured spkg) = installedUnitId spkg installedUnitId (Installed spkg) = installedUnitId spkg instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) => HasConfiguredId (GenericPlanPackage ipkg srcpkg) where configuredId (PreExisting ipkg) = configuredId ipkg configuredId (Configured spkg) = configuredId spkg configuredId (Installed spkg) = configuredId spkg data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)), planIndepGoals :: !IndependentGoals } deriving (Typeable) -- | 'GenericInstallPlan' specialised to most commonly used types. type InstallPlan = GenericInstallPlan InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) -- | Smart constructor that deals with caching the 'Graph' representation. -- mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg) => String -> Graph (GenericPlanPackage ipkg srcpkg) -> IndependentGoals -> GenericInstallPlan ipkg srcpkg mkInstallPlan loc graph indepGoals = assert (valid loc graph) GenericInstallPlan { planGraph = graph, planIndepGoals = indepGoals } internalError :: String -> String -> a internalError loc msg = error $ "internal error in InstallPlan." ++ loc ++ if null msg then "" else ": " ++ msg instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, Binary ipkg, Binary srcpkg) => Binary (GenericInstallPlan ipkg srcpkg) where put GenericInstallPlan { planGraph = graph, planIndepGoals = indepGoals } = put (graph, indepGoals) get = do (graph, indepGoals) <- get return $! mkInstallPlan "(instance Binary)" graph indepGoals showPlanGraph :: (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) => Graph (GenericPlanPackage ipkg srcpkg) -> String showPlanGraph graph = renderStyle defaultStyle $ vcat (map dispPlanPackage (Graph.toList graph)) where dispPlanPackage p = hang (hsep [ text (showPlanPackageTag p) , disp (packageId p) , parens (disp (nodeKey p))]) 2 (vcat (map disp (nodeNeighbors p))) showInstallPlan :: (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> String showInstallPlan = showPlanGraph . planGraph showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String showPlanPackageTag (PreExisting _) = "PreExisting" showPlanPackageTag (Configured _) = "Configured" showPlanPackageTag (Installed _) = "Installed" -- | Build an installation plan from a valid set of resolved packages. -- new :: (IsUnit ipkg, IsUnit srcpkg) => IndependentGoals -> Graph (GenericPlanPackage ipkg srcpkg) -> GenericInstallPlan ipkg srcpkg new indepGoals graph = mkInstallPlan "new" graph indepGoals toGraph :: GenericInstallPlan ipkg srcpkg -> Graph (GenericPlanPackage ipkg srcpkg) toGraph = planGraph toList :: GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] toList = Graph.toList . planGraph toMap :: GenericInstallPlan ipkg srcpkg -> Map UnitId (GenericPlanPackage ipkg srcpkg) toMap = Graph.toMap . planGraph keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] keys = Graph.keys . planGraph keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId keysSet = Graph.keysSet . planGraph -- | Remove packages from the install plan. This will result in an -- error if there are remaining packages that depend on any matching -- package. This is primarily useful for obtaining an install plan for -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. -- remove :: (IsUnit ipkg, IsUnit srcpkg) => (GenericPlanPackage ipkg srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg remove shouldRemove plan = mkInstallPlan "remove" newGraph (planIndepGoals plan) where newGraph = Graph.fromDistinctList $ filter (not . shouldRemove) (toList plan) -- | Change a number of packages in the 'Configured' state to the 'Installed' -- state. -- -- To preserve invariants, the package must have all of its dependencies -- already installed too (that is 'PreExisting' or 'Installed'). -- installed :: (IsUnit ipkg, IsUnit srcpkg) => (srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg installed shouldBeInstalled installPlan = foldl' markInstalled installPlan [ pkg | Configured pkg <- reverseTopologicalOrder installPlan , shouldBeInstalled pkg ] where markInstalled plan pkg = assert (all isInstalled (directDeps plan (nodeKey pkg))) $ plan { planGraph = Graph.insert (Installed pkg) (planGraph plan) } -- | Lookup a package in the plan. -- lookup :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> UnitId -> Maybe (GenericPlanPackage ipkg srcpkg) lookup plan pkgid = Graph.lookup pkgid (planGraph plan) -- | Find all the direct dependencies of the given package. -- -- Note that the package must exist in the plan or it is an error. -- directDeps :: GenericInstallPlan ipkg srcpkg -> UnitId -> [GenericPlanPackage ipkg srcpkg] directDeps plan pkgid = case Graph.neighbors (planGraph plan) pkgid of Just deps -> deps Nothing -> internalError "directDeps" "package not in graph" -- | Find all the direct reverse dependencies of the given package. -- -- Note that the package must exist in the plan or it is an error. -- revDirectDeps :: GenericInstallPlan ipkg srcpkg -> UnitId -> [GenericPlanPackage ipkg srcpkg] revDirectDeps plan pkgid = case Graph.revNeighbors (planGraph plan) pkgid of Just deps -> deps Nothing -> internalError "revDirectDeps" "package not in graph" -- | Return all the packages in the 'InstallPlan' in reverse topological order. -- That is, for each package, all dependencies of the package appear first. -- -- Compared to 'executionOrder', this function returns all the installed and -- source packages rather than just the source ones. Also, while both this -- and 'executionOrder' produce reverse topological orderings of the package -- dependency graph, it is not necessarily exactly the same order. -- reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) -- | Return the packages in the plan that 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 " ++ display uid) mapDep pidMap _ (PlannedId pid) | Just pkgs <- Map.lookup pid pidMap = pkgs | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid) -- This shouldn't happen, since mapDep should only be called -- on neighbor SolverId, which must have all been done already -- by the reverse top-sort (we assume the graph is not broken). fromSolverInstallPlanWithProgress :: (IsUnit ipkg, IsUnit srcpkg) => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage -> LogProgress [GenericPlanPackage ipkg srcpkg] ) -> SolverInstallPlan -> LogProgress (GenericInstallPlan ipkg srcpkg) fromSolverInstallPlanWithProgress f plan = do (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan) return $ mkInstallPlan "fromSolverInstallPlanWithProgress" (Graph.fromDistinctList pkgs'') (SolverInstallPlan.planIndepGoals plan) where f' (pidMap, ipiMap, pkgs) pkg = do pkgs' <- f (mapDep pidMap ipiMap) pkg let (pidMap', ipiMap') = case nodeKey pkg of PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) return (pidMap', ipiMap', pkgs' ++ pkgs) mapDep _ ipiMap (PreExistingId _pid uid) | Just pkgs <- Map.lookup uid ipiMap = pkgs | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid) mapDep pidMap _ (PlannedId pid) | Just pkgs <- Map.lookup pid pidMap = pkgs | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid) -- This shouldn't happen, since mapDep should only be called -- on neighbor SolverId, which must have all been done already -- by the reverse top-sort (we assume the graph is not broken). -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan configureInstallPlan configFlags solverPlan = flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> [case planpkg of SolverInstallPlan.PreExisting pkg -> PreExisting (instSolverPkgIPI pkg) SolverInstallPlan.Configured pkg -> Configured (configureSolverPackage mapDep pkg) ] where configureSolverPackage :: (SolverId -> [PlanPackage]) -> SolverPackage UnresolvedPkgLoc -> ConfiguredPackage UnresolvedPkgLoc configureSolverPackage mapDep spkg = ConfiguredPackage { confPkgId = Configure.computeComponentId (Cabal.fromFlagOrDefault False (Cabal.configDeterministic configFlags)) Cabal.NoFlag Cabal.NoFlag (packageId spkg) PD.CLibName (Just (map confInstId (CD.libraryDeps deps), solverPkgFlags spkg)), confPkgSource = solverPkgSource spkg, confPkgFlags = solverPkgFlags spkg, confPkgStanzas = solverPkgStanzas spkg, confPkgDeps = deps -- NB: no support for executable dependencies } where deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg) -- ------------------------------------------------------------ -- * Primitives for traversing plans -- ------------------------------------------------------------ -- $traversal -- -- Algorithms to traverse or execute an 'InstallPlan', especially in parallel, -- may make use of the 'Processing' type and the associated operations -- 'ready', 'completed' and 'failed'. -- -- The 'Processing' type is used to keep track of the state of a traversal and -- includes the set of packages that are in the processing state, e.g. in the -- process of being installed, plus those that have been completed and those -- where processing failed. -- -- Traversal algorithms start with an 'InstallPlan': -- -- * Initially there will be certain packages that can be processed immediately -- (since they are configured source packages and have all their dependencies -- installed already). The function 'ready' returns these packages plus a -- 'Processing' state that marks these same packages as being in the -- processing state. -- -- * The algorithm must now arrange for these packages to be processed -- (possibly in parallel). When a package has completed processing, the -- algorithm needs to know which other packages (if any) are now ready to -- process as a result. The 'completed' function marks a package as completed -- and returns any packages that are newly in the processing state (ie ready -- to process), along with the updated 'Processing' state. -- -- * If failure is possible then when processing a package fails, the algorithm -- needs to know which other packages have also failed as a result. The -- 'failed' function marks the given package as failed as well as all the -- other packages that depend on the failed package. In addition it returns -- the other failed packages. -- | The 'Processing' type is used to keep track of the state of a traversal -- and includes the set of packages that are in the processing state, e.g. in -- the process of being installed, plus those that have been completed and -- those where processing failed. -- data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) -- processing, completed, failed -- | The packages in the plan that are initially ready to be installed. -- That is they are in the configured state and have all their dependencies -- installed already. -- -- The result is both the packages that are now ready to be installed and also -- a 'Processing' state containing those same packages. The assumption is that -- all the packages that are ready will now be processed and so we can consider -- them to be in the processing state. -- ready :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> ([GenericReadyPackage srcpkg], Processing) ready plan = assert (processingInvariant plan processing) $ (readyPackages, processing) where !processing = Processing (Set.fromList [ nodeKey pkg | pkg <- readyPackages ]) (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ]) Set.empty readyPackages = [ ReadyPackage pkg | Configured pkg <- toList plan , all isInstalled (directDeps plan (nodeKey pkg)) ] isInstalled :: GenericPlanPackage a b -> Bool isInstalled (PreExisting {}) = True isInstalled (Installed {}) = True isInstalled _ = False -- | Given a package in the processing state, mark the package as completed -- and return any packages that are newly in the processing state (ie ready to -- process), along with the updated 'Processing' state. -- completed :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> Processing -> UnitId -> ([GenericReadyPackage srcpkg], Processing) completed plan (Processing processingSet completedSet failedSet) pkgid = assert (pkgid `Set.member` processingSet) $ assert (processingInvariant plan processing') $ ( map asReadyPackage newlyReady , processing' ) where completedSet' = Set.insert pkgid completedSet -- each direct reverse dep where all direct deps are completed newlyReady = [ dep | dep <- revDirectDeps plan pkgid , all ((`Set.member` completedSet') . nodeKey) (directDeps plan (nodeKey dep)) ] processingSet' = foldl' (flip Set.insert) (Set.delete pkgid processingSet) (map nodeKey newlyReady) processing' = Processing processingSet' completedSet' failedSet asReadyPackage (Configured pkg) = ReadyPackage pkg asReadyPackage _ = internalError "completed" "" failed :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> Processing -> UnitId -> ([srcpkg], Processing) failed plan (Processing processingSet completedSet failedSet) pkgid = assert (pkgid `Set.member` processingSet) $ assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $ assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ -- but note that some newlyFailed may already be in the failed set -- since one package can depend on two packages that both fail and -- so would be in the rev-dep closure for both. assert (processingInvariant plan processing') $ ( map asConfiguredPackage (tail newlyFailed) , processing' ) where processingSet' = Set.delete pkgid processingSet failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds newlyFailedIds = map nodeKey newlyFailed newlyFailed = fromMaybe (internalError "failed" "package not in graph") $ Graph.revClosure (planGraph plan) [pkgid] processing' = Processing processingSet' completedSet failedSet' asConfiguredPackage (Configured pkg) = pkg asConfiguredPackage _ = internalError "failed" "not in configured state" processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> Processing -> Bool processingInvariant plan (Processing processingSet completedSet failedSet) = -- All the packages in the three sets are actually in the graph assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $ assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $ assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $ -- The processing, completed and failed sets are disjoint from each other assert (noIntersection processingSet completedSet) $ assert (noIntersection processingSet failedSet) $ assert (noIntersection failedSet completedSet) $ -- Packages that depend on a package that's still processing cannot be -- completed assert (noIntersection (reverseClosure processingSet) completedSet) $ -- On the other hand, packages that depend on a package that's still -- processing /can/ have failed (since they may have depended on multiple -- packages that were processing, but it only takes one to fail to cause -- knock-on failures) so it is quite possible to have an -- intersection (reverseClosure processingSet) failedSet -- The failed set is upwards closed, i.e. equal to its own rev dep closure assert (failedSet == reverseClosure failedSet) $ -- All immediate reverse deps of packges that are currently processing -- are not currently being processed (ie not in the processing set). assert (and [ rdeppkgid `Set.notMember` processingSet | pkgid <- Set.toList processingSet , rdeppkgid <- maybe (internalError "processingInvariant" "") (map nodeKey) (Graph.revNeighbors (planGraph plan) pkgid) ]) $ -- Packages from the processing or failed sets are only ever in the -- configured state. assert (and [ case Graph.lookup pkgid (planGraph plan) of Just (Configured _) -> True Just (PreExisting _) -> False Just (Installed _) -> False Nothing -> False | pkgid <- Set.toList processingSet ++ Set.toList failedSet ]) -- We use asserts rather than returning False so that on failure we get -- better details on which bit of the invariant was violated. True where reverseClosure = Set.fromList . map nodeKey . fromMaybe (internalError "processingInvariant" "") . Graph.revClosure (planGraph plan) . Set.toList noIntersection a b = Set.null (Set.intersection a b) -- ------------------------------------------------------------ -- * Traversing plans -- ------------------------------------------------------------ -- | Flatten an 'InstallPlan', producing the sequence of source packages in -- the order in which they would be processed when the plan is executed. This -- can be used for simultations or presenting execution dry-runs. -- -- It is guaranteed to give the same order as using 'execute' (with a serial -- in-order 'JobControl'), which is a reverse topological orderings of the -- source packages in the dependency graph, albeit not necessarily exactly the -- same ordering as that produced by 'reverseTopologicalOrder'. -- executionOrder :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg] executionOrder plan = let (newpkgs, processing) = ready plan in tryNewTasks processing newpkgs where tryNewTasks _processing [] = [] tryNewTasks processing (p:todo) = waitForTasks processing p todo waitForTasks processing p todo = p : tryNewTasks processing' (todo++nextpkgs) where (nextpkgs, processing') = completed plan processing (nodeKey p) -- ------------------------------------------------------------ -- * Executing plans -- ------------------------------------------------------------ -- | The set of results we get from executing an install plan. -- type BuildOutcomes failure result = Map UnitId (Either failure result) -- | Lookup the build result for a single package. -- lookupBuildOutcome :: HasUnitId pkg => pkg -> BuildOutcomes failure result -> Maybe (Either failure result) lookupBuildOutcome = Map.lookup . installedUnitId -- | Execute an install plan. This traverses the plan in dependency order. -- -- Executing each individual package can fail and if so all dependents fail -- too. The result for each package is collected as a 'BuildOutcomes' map. -- -- Visiting each package happens with optional parallelism, as determined by -- the 'JobControl'. By default, after any failure we stop as soon as possible -- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour -- can be reversed to keep going and build as many packages as possible. -- -- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages -- in the plan. In particular in the default mode where we stop as soon as -- possible after a failure then there may be packages which are skipped and -- these will have no 'BuildOutcome'. -- execute :: forall m ipkg srcpkg result failure. (IsUnit ipkg, IsUnit srcpkg, Monad m) => JobControl m (UnitId, Either failure result) -> Bool -- ^ Keep going after failure -> (srcpkg -> failure) -- ^ Value for dependents of failed packages -> GenericInstallPlan ipkg srcpkg -> (GenericReadyPackage srcpkg -> m (Either failure result)) -> m (BuildOutcomes failure result) execute jobCtl keepGoing depFailure plan installPkg = let (newpkgs, processing) = ready plan in tryNewTasks Map.empty False False processing newpkgs where tryNewTasks :: BuildOutcomes failure result -> Bool -> Bool -> Processing -> [GenericReadyPackage srcpkg] -> m (BuildOutcomes failure result) tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs -- we were in the process of cancelling and now we're finished | tasksFailed && not keepGoing && not tasksRemaining = return results -- we are still in the process of cancelling, wait for remaining tasks | tasksFailed && not keepGoing && tasksRemaining = waitForTasks results tasksFailed processing -- no new tasks to do and all tasks are done so we're finished | null newpkgs && not tasksRemaining = return results -- no new tasks to do, remaining tasks to wait for | null newpkgs = waitForTasks results tasksFailed processing -- new tasks to do, spawn them, then wait for tasks to complete | otherwise = do sequence_ [ spawnJob jobCtl $ do result <- installPkg pkg return (nodeKey pkg, result) | pkg <- newpkgs ] waitForTasks results tasksFailed processing waitForTasks :: BuildOutcomes failure result -> Bool -> Processing -> m (BuildOutcomes failure result) waitForTasks !results tasksFailed !processing = do (pkgid, result) <- collectJob jobCtl case result of Right _success -> do tasksRemaining <- remainingJobs jobCtl tryNewTasks results' tasksFailed tasksRemaining processing' nextpkgs where results' = Map.insert pkgid result results (nextpkgs, processing') = completed plan processing pkgid Left _failure -> do -- if this is the first failure and we're not trying to keep going -- then try to cancel as many of the remaining jobs as possible when (not tasksFailed && not keepGoing) $ cancelJobs jobCtl tasksRemaining <- remainingJobs jobCtl tryNewTasks results' True tasksRemaining processing' [] where (depsfailed, processing') = failed plan processing pkgid results' = Map.insert pkgid result results `Map.union` depResults depResults = Map.fromList [ (nodeKey deppkg, Left (depFailure deppkg)) | deppkg <- depsfailed ] -- ------------------------------------------------------------ -- * Checking validity of plans -- ------------------------------------------------------------ -- | A valid installation plan is a set of packages that is closed, acyclic -- and respects the package state relation. -- -- * if the result is @False@ use 'problems' to get a detailed list. -- valid :: (IsUnit ipkg, IsUnit srcpkg) => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool valid loc graph = case problems graph of [] -> True ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) data PlanProblem ipkg srcpkg = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] | PackageCycle [GenericPlanPackage ipkg srcpkg] | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) (GenericPlanPackage ipkg srcpkg) showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg) => PlanProblem ipkg srcpkg -> String showPlanProblem (PackageMissingDeps pkg missingDeps) = "Package " ++ display (nodeKey pkg) ++ " depends on the following packages which are missing from the plan: " ++ intercalate ", " (map display missingDeps) showPlanProblem (PackageCycle cycleGroup) = "The following packages are involved in a dependency cycle " ++ intercalate ", " (map (display . nodeKey) cycleGroup) showPlanProblem (PackageStateInvalid pkg pkg') = "Package " ++ display (nodeKey pkg) ++ " is in the " ++ showPlanPackageTag pkg ++ " state but it depends on package " ++ display (nodeKey pkg') ++ " which is in the " ++ showPlanPackageTag pkg' ++ " state" -- | For an invalid plan, produce a detailed list of problems as human readable -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. -- problems :: (IsUnit ipkg, IsUnit srcpkg) => Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg] problems graph = [ PackageMissingDeps pkg (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 <- Graph.toList graph , Just pkg' <- map (flip Graph.lookup graph) (nodeNeighbors pkg) , not (stateDependencyRelation pkg pkg') ] -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on -- package @b@ we require that @stateDependencyRelation a b = True@. -- stateDependencyRelation :: GenericPlanPackage ipkg srcpkg -> GenericPlanPackage ipkg srcpkg -> Bool stateDependencyRelation PreExisting{} PreExisting{} = True stateDependencyRelation Installed{} PreExisting{} = True stateDependencyRelation Installed{} Installed{} = True stateDependencyRelation Configured{} PreExisting{} = True stateDependencyRelation Configured{} Installed{} = True stateDependencyRelation Configured{} Configured{} = True stateDependencyRelation _ _ = False cabal-install-2.4.0.0/Distribution/Client/InstallSymlink.hs0000644000000000000000000002647100000000000021730 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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, ) where #ifdef mingw32_HOST_OS import Distribution.Package (PackageIdentifier) import Distribution.Types.UnqualComponentName import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Types (BuildOutcomes) import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags) import Distribution.Simple.Compiler import Distribution.System symlinkBinaries :: Platform -> Compiler -> ConfigFlags -> InstallFlags -> InstallPlan -> BuildOutcomes -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] symlinkBinaries _ _ _ _ _ _ = return [] symlinkBinary :: FilePath -> FilePath -> UnqualComponentName -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" #else 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.Text ( display ) import System.Posix.Files ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink , removeLink ) import System.Directory ( canonicalizePath ) import System.FilePath ( (), splitPath, joinPath, isAbsolute ) import Prelude hiding (ioError) import System.IO.Error ( isDoesNotExistError, ioError ) import Distribution.Compat.Exception ( catchIO ) import Control.Exception ( assert ) import Data.Maybe ( catMaybes ) -- | 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 -> ConfigFlags -> InstallFlags -> InstallPlan -> BuildOutcomes -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] symlinkBinaries platform comp 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 $ sequence [ do privateBinDir <- pkgBinDir pkg ipid ok <- symlinkBinary publicBinDir privateBinDir 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 _ pkg _ _) flags stanzas _) = case finalizePD flags (enableStanzas stanzas) (const True) platform cinfo [] pkg of Left _ -> error "finalizePD ReadyPackage failed" Right (desc, _) -> desc -- This is sadly rather complicated. We're kind of re-doing part of the -- 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 symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir eg -- @/home/user/bin@ -> FilePath -- ^ The canonical path of the private bin dir eg -- @/home/user/.cabal/bin@ -> UnqualComponentName -- ^ The name of the executable to go in the public bin -- dir, eg @foo@ -> String -- ^ The name of the executable to in the private bin -- dir, eg @foo-1.0@ -> IO Bool -- ^ If creating the symlink was successful. @False@ if -- there was another file there already that we did -- not own. Other errors like permission errors just -- propagate as exceptions. symlinkBinary publicBindir privateBindir publicName privateName = do ok <- targetOkToOverwrite (publicBindir publicName') (privateBindir privateName) case ok of NotOurFile -> return False NotExists -> mkLink >> return True OkToOverwrite -> rmLink >> mkLink >> return True where publicName' = display publicName relativeBindir = makeRelative publicBindir privateBindir mkLink = createSymbolicLink (relativeBindir privateName) (publicBindir publicName') rmLink = removeLink (publicBindir publicName') -- | 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 status <- getSymbolicLinkStatus symlink if not (isSymbolicLink status) then return NotOurFile else do target' <- canonicalizePath symlink -- This 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 #endif cabal-install-2.4.0.0/Distribution/Client/JobControl.hs0000644000000000000000000001200200000000000021007 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 Control.Monad import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.STM (STM, atomically) import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TChan import Control.Exception (SomeException, bracket_, throwIO, try) import Distribution.Client.Compat.Semaphore -- | A simple concurrency abstraction. Jobs can be spawned and can complete -- in any order. This allows both serial and parallel implementations. -- data JobControl m a = JobControl { -- | Add a new job to the pool of jobs spawnJob :: m a -> m (), -- | 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 :: 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 cabal-install-2.4.0.0/Distribution/Client/List.hs0000644000000000000000000006053700000000000017667 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 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 ( Flag(..), unFlagName ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Pretty (pretty) import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Utils ( equating, comparing, die', notice ) import Distribution.Simple.Setup (fromFlag) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Version ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion , intersectVersionRanges, simplifyVersionRange ) import Distribution.Verbosity (Verbosity) import Distribution.Text ( Text(disp), display ) 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.List ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition ) import Data.Maybe ( listToMaybe, fromJust, fromMaybe, isJust, maybeToList ) import qualified Data.Map as Map import Data.Tree as Tree import Control.Monad ( MonadPlus(mplus), join ) import Control.Exception ( assert ) import Text.PrettyPrint as Disp import System.Directory ( doesDirectoryExist ) -- | Return a list of packages matching given search strings. getPkgList :: Verbosity -> PackageDBStack -> RepoContext -> Compiler -> ProgramDb -> ListFlags -> [String] -> IO [PackageDisplayInfo] getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt let sourcePkgIndex = packageIndex sourcePkgDb prefs name = fromMaybe anyVersion (Map.lookup name (packagePreferences sourcePkgDb)) pkgsInfo :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] pkgsInfo -- gather info for all packages | null pats = mergePackages (InstalledPackageIndex.allPackages installedPkgIndex) ( PackageIndex.allPackages sourcePkgIndex) -- gather info for packages matching search term | otherwise = pkgsInfoMatching pkgsInfoMatching :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] pkgsInfoMatching = let matchingInstalled = matchingPackages InstalledPackageIndex.searchByNameSubstring installedPkgIndex matchingSource = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchByNameSubstring idx n)) sourcePkgIndex in mergePackages matchingInstalled matchingSource 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 = fromFlag (listInstalled listFlags) matchingPackages search index = [ pkg | pat <- pats , pkg <- search index pat ] -- | Show information about packages. list :: Verbosity -> PackageDBStack -> RepoContext -> Compiler -> ProgramDb -> ListFlags -> [String] -> IO () list verbosity packageDBs repos comp progdb listFlags pats = do matches <- getPkgList verbosity packageDBs repos comp progdb listFlags pats if simpleOutput then putStr $ unlines [ display (pkgName pkg) ++ " " ++ display 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 <- sequence [ 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 " ++ display name ++ " that satisfies " ++ display (simplifyVersionRange verConstraint) | otherwise = Right $ mergePackageInfo pref installedPkgs sourcePkgs selectedSourcePkg' showPkgVersion where (pref, installedPkgs, sourcePkgs) = sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex (Dependency name verConstraint) selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex (Dependency 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 :: String, bugReports :: String, sourceRepo :: String, synopsis :: String, description :: String, category :: String, license :: Either SPDX.License License, author :: String, maintainer :: String, dependencies :: [ExtDependency], flags :: [Flag], 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 '*' <+> disp (pkgName pkginfo) $+$ (nest 4 $ vcat [ maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs , text "Default available version:" <+> case selectedSourcePkg pkginfo of Nothing -> text "[ Not available from any configured repository ]" Just pkg -> disp (packageVersion pkg) , text "Installed versions:" <+> case installedVersions pkginfo of [] | hasLib pkginfo -> text "[ Not installed ]" | otherwise -> text "[ Unknown ]" versions -> dispTopVersions 4 (preferredVersions pkginfo) versions , maybeShow (homepage pkginfo) "Homepage:" text , text "License: " <+> either pretty pretty (license pkginfo) ]) $+$ text "" where maybeShow [] _ _ = empty maybeShow l s f = text s <+> (f l) showPackageDetailedInfo :: PackageDisplayInfo -> String showPackageDetailedInfo pkginfo = renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ char '*' <+> disp (pkgName pkginfo) Disp.<> maybe empty (\v -> char '-' Disp.<> disp v) (selectedVersion pkginfo) <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ') Disp.<> parens pkgkind $+$ (nest 4 $ vcat [ entry "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)) , entry "Homepage" homepage orNotSpecified text , entry "Bug reports" bugReports orNotSpecified text , entry "Description" description hideIfNull reflowParagraphs , entry "Category" category hideIfNull text , entry "License" license alwaysShow (either pretty pretty) , entry "Author" author hideIfNull reflowLines , entry "Maintainer" maintainer hideIfNull reflowLines , entry "Source repo" sourceRepo orNotSpecified text , entry "Executables" executables hideIfNull (commaSep disp) , 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 empty else text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) ]) $+$ text "" where entry fname field cond format = case cond (field pkginfo) of Nothing -> label <+> format (field pkginfo) Just Nothing -> empty Just (Just other) -> label <+> text other where label = text fname Disp.<> char ':' Disp.<> padding padding = text (replicate (13 - length fname ) ' ') 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) = disp dep dispExtDep (InstalledDependency dep) = disp 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 = empty reflowParagraphs :: String -> Doc reflowParagraphs = vcat . intersperse (text "") -- re-insert blank lines . map (fsep . map text . concatMap words) -- reflow paragraphs . filter (/= [""]) . 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 "" Source.bugReports source, sourceRepo = fromMaybe "" . join . fmap (uncons Nothing Source.repoLocation . sortBy (comparing Source.repoKind) . Source.sourceRepos) $ source, --TODO: installed package info is missing synopsis synopsis = maybe "" 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 packageDescription 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 . packageSource) (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), 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 disp ver else parens (disp 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 versionNumbers where 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 xs = unfoldTree step (False, [], xs) where step (node,ns,vs) = ( (reverse ns, node) , [ (any null vs', n:ns, filter (not . null) vs') | (n, vs') <- groups vs ] ) groups = map (\g -> (head (head g), map tail g)) . groupBy (equating head) cabal-install-2.4.0.0/Distribution/Client/Manpage.hs0000644000000000000000000001305100000000000020311 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Manpage -- Copyright : (c) Maciek Makowski 2015 -- License : BSD-like -- -- Maintainer : cabal-devel@haskell.org -- Stability : provisional -- Portability : portable -- -- Functions for building the manual page. module Distribution.Client.Manpage ( -- * Manual page generation manpage ) where import Distribution.Simple.Command import Distribution.Client.Setup (globalCommand) import Data.Char (toUpper) import Data.List (intercalate) data FileInfo = FileInfo String String -- ^ path, description -- | A list of files that should be documented in the manual page. files :: [FileInfo] files = [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.") , (FileInfo "~/.cabal/world" "A list of all packages whose installation has been explicitly requested.") ] -- | Produces a manual page with @troff@ markup. manpage :: String -> [CommandSpec a] -> String manpage pname commands = unlines $ [ ".TH " ++ map toUpper pname ++ " 1" , ".SH NAME" , pname ++ " \\- a system for building and packaging Haskell libraries and programs" , ".SH SYNOPSIS" , ".B " ++ pname , ".I command" , ".RI < arguments |[ options ]>..." , "" , "Where the" , ".I commands" , "are" , "" ] ++ concatMap (commandSynopsisLines pname) commands ++ [ ".SH DESCRIPTION" , "Cabal is the standard package system for Haskell software. It helps people to configure, " , "build and install Haskell software and to distribute it easily to other users and developers." , "" , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with " , "installing existing packages and developing new packages. " , "It can be used to work with local packages or to install packages from online package archives, " , "including automatically installing dependencies. By default it is configured to use Hackage, " , "which is Haskell's central package archive that contains thousands of libraries and applications " , "in the Cabal package format." , ".SH OPTIONS" , "Global options:" , "" ] ++ optionsLines (globalCommand []) ++ [ ".SH COMMANDS" ] ++ concatMap (commandDetailsLines pname) commands ++ [ ".SH FILES" ] ++ concatMap fileLines files ++ [ ".SH BUGS" , "To browse the list of known issues or report a new one please see " , "https://github.com/haskell/cabal/labels/cabal-install." ] commandSynopsisLines :: String -> CommandSpec action -> [String] commandSynopsisLines pname (CommandSpec ui _ NormalCommand) = [ ".B " ++ pname ++ " " ++ (commandName ui) , ".R - " ++ commandSynopsis ui , ".br" ] commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = [] commandDetailsLines :: String -> CommandSpec action -> [String] commandDetailsLines pname (CommandSpec ui _ NormalCommand) = [ ".B " ++ pname ++ " " ++ (commandName ui) , "" , commandUsage ui pname , "" ] ++ optional commandDescription ++ optional commandNotes ++ [ "Flags:" , ".RS" ] ++ optionsLines ui ++ [ ".RE" , "" ] where optional field = case field ui of Just text -> [text pname, ""] Nothing -> [] commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = [] optionsLines :: CommandUI flags -> [String] optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs)) data ArgumentRequired = Optional | Required type OptionArg = (ArgumentRequired, ArgPlaceHolder) optionLines :: OptDescr flags -> [String] optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) = argOptionLines description optionChars optionStrings (Required, placeHolder) optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) = argOptionLines description optionChars optionStrings (Optional, placeHolder) optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) = optionLinesIfPresent trueChars trueStrings ++ optionLinesIfPresent falseChars falseStrings ++ optionDescriptionLines description optionLines (ChoiceOpt options) = concatMap choiceLines options where choiceLines (description, (optionChars, optionStrings), _, _) = [ optionsLine optionChars optionStrings ] ++ optionDescriptionLines description argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String] argOptionLines description optionChars optionStrings arg = [ optionsLine optionChars optionStrings , optionArgLine arg ] ++ optionDescriptionLines description optionLinesIfPresent :: [Char] -> [String] -> [String] optionLinesIfPresent optionChars optionStrings = if null optionChars && null optionStrings then [] else [ optionsLine optionChars optionStrings, ".br" ] optionDescriptionLines :: String -> [String] optionDescriptionLines description = [ ".RS" , description , ".RE" , "" ] optionsLine :: [Char] -> [String] -> String optionsLine optionChars optionStrings = intercalate ", " (shortOptions optionChars ++ longOptions optionStrings) shortOptions :: [Char] -> [String] shortOptions = map (\c -> "\\-" ++ [c]) longOptions :: [String] -> [String] longOptions = map (\s -> "\\-\\-" ++ s) optionArgLine :: OptionArg -> String optionArgLine (Required, placeHolder) = ".I " ++ placeHolder optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]" fileLines :: FileInfo -> [String] fileLines (FileInfo path description) = [ path , ".RS" , description , ".RE" , "" ] cabal-install-2.4.0.0/Distribution/Client/Nix.hs0000644000000000000000000001415400000000000017504 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} module Distribution.Client.Nix ( findNixExpr , inNixShell , nixInstantiate , nixShell , nixShellIfSandboxed ) where import Distribution.Client.Compat.Prelude import Control.Exception (bracket, catch) 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.Verbosity import Distribution.Simple.Program ( Program(..), ProgramDb , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput , runDbProgram, simpleProgram ) import Distribution.Simple.Setup (fromFlagOrDefault) import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan) import Distribution.Client.Config (SavedConfig(..)) import Distribution.Client.GlobalFlags (GlobalFlags(..)) import Distribution.Client.Sandbox.Types (UseSandbox(..)) configureOneProgram :: Verbosity -> Program -> IO ProgramDb configureOneProgram verb prog = configureProgram verb prog (addKnownProgram prog emptyProgramDb) touchFile :: FilePath -> IO () touchFile path = do catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ())) createDirectoryIfMissing True (takeDirectory path) openFile path WriteMode >>= hClose findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath) findNixExpr globalFlags config = do -- criteria for deciding to run nix-shell let nixEnabled = fromFlagOrDefault False (globalNix (savedGlobalFlags config) <> globalNix globalFlags) if nixEnabled then do let exprPaths = [ "shell.nix", "default.nix" ] filterM doesFileExist exprPaths >>= \case [] -> return Nothing (path : _) -> return (Just path) else return Nothing -- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell inFakeNixShell :: IO a -> IO a inFakeNixShell f = bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f) where fakeEnv var new = do old <- lookupEnv var setEnv var new return old resetEnv var = maybe (unsetEnv var) (setEnv var) nixInstantiate :: Verbosity -> FilePath -> Bool -> GlobalFlags -> SavedConfig -> IO () nixInstantiate verb dist force globalFlags config = findNixExpr globalFlags config >>= \case Nothing -> return () Just shellNix -> do alreadyInShell <- inNixShell shellDrv <- drvPath dist shellNix instantiated <- doesFileExist shellDrv -- an extra timestamp file is necessary because the derivation lives in -- the store so its mtime is always 1. let timestamp = timestampPath dist shellNix upToDate <- existsAndIsMoreRecentThan timestamp shellNix let ready = alreadyInShell || (instantiated && upToDate && not force) unless ready $ do let prog = simpleProgram "nix-instantiate" progdb <- configureOneProgram verb prog removeGCRoots verb dist touchFile timestamp _ <- inFakeNixShell (getDbProgramOutput verb prog progdb [ "--add-root", shellDrv, "--indirect", shellNix ]) return () nixShell :: Verbosity -> FilePath -> GlobalFlags -> SavedConfig -> IO () -- ^ The action to perform inside a nix-shell. This is also the action -- that will be performed immediately if Nix is disabled. -> IO () nixShell verb dist globalFlags config go = do alreadyInShell <- inNixShell if alreadyInShell then go else do findNixExpr globalFlags config >>= \case Nothing -> go Just shellNix -> do let prog = simpleProgram "nix-shell" progdb <- configureOneProgram verb prog cabal <- getExecutablePath -- alreadyInShell == True in child process setEnv "CABAL_IN_NIX_SHELL" "1" -- Run cabal with the same arguments inside nix-shell. -- When the child process reaches the top of nixShell, it will -- detect that it is running inside the shell and fall back -- automatically. shellDrv <- drvPath dist shellNix args <- getArgs runDbProgram verb prog progdb [ "--add-root", gcrootPath dist "result", "--indirect", shellDrv , "--run", showCommandForUser cabal args ] drvPath :: FilePath -> FilePath -> IO FilePath drvPath dist path = do -- We do not actually care about canonicity, but makeAbsolute is only -- available in newer versions of directory. -- We expect the path to be a symlink if it exists, so we do not canonicalize -- the entire path because that would dereference the symlink. distNix <- canonicalizePath (dist "nix") -- Nix garbage collector roots must be absolute paths return (distNix replaceExtension (takeFileName path) "drv") timestampPath :: FilePath -> FilePath -> FilePath timestampPath dist path = dist "nix" replaceExtension (takeFileName path) "drv.timestamp" gcrootPath :: FilePath -> FilePath gcrootPath dist = dist "nix" "gcroots" inNixShell :: IO Bool inNixShell = 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 nixShellIfSandboxed :: Verbosity -> FilePath -> GlobalFlags -> SavedConfig -> UseSandbox -> IO () -- ^ The action to perform inside a nix-shell. This is also the action -- that will be performed immediately if Nix is disabled. -> IO () nixShellIfSandboxed verb dist globalFlags config useSandbox go = case useSandbox of NoSandbox -> go UseSandbox _ -> nixShell verb dist globalFlags config go cabal-install-2.4.0.0/Distribution/Client/Outdated.hs0000644000000000000000000002231700000000000020517 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Outdated -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Implementation of the 'outdated' command. Checks for outdated -- dependencies in the package description file or freeze file. ----------------------------------------------------------------------------- module Distribution.Client.Outdated ( outdated , ListOutdatedSettings(..), listOutdated ) where import Prelude () import Distribution.Client.Config import Distribution.Client.IndexUtils as IndexUtils import Distribution.Client.Compat.Prelude import Distribution.Client.ProjectConfig import Distribution.Client.DistDirLayout import Distribution.Client.RebuildMonad import Distribution.Client.Setup hiding (quiet) import Distribution.Client.Targets import Distribution.Client.Types import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackageIndex import Distribution.Client.Sandbox.PackageEnvironment import Distribution.Package (PackageName, packageVersion) import Distribution.PackageDescription (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.Text (display) import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..)) import Distribution.Types.Dependency (Dependency(..), depPkgName, simplifyDependency) import Distribution.Verbosity (Verbosity, silent) import Distribution.Version (Version, LowerBound(..), UpperBound(..) ,asVersionIntervals, majorBoundVersion) import Distribution.PackageDescription.Parsec (readGenericPackageDescription) import qualified Data.Set as S import System.Directory (getCurrentDirectory) import System.Exit (exitFailure) import Control.Exception (throwIO) -- | Entry point for the 'outdated' command. outdated :: Verbosity -> OutdatedFlags -> RepoContext -> Compiler -> Platform -> IO () outdated verbosity0 outdatedFlags repoContext comp platform = do let freezeFile = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags) newFreezeFile = fromFlagOrDefault False (outdatedNewFreezeFile outdatedFlags) 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 --new-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 display deps) let outdatedDeps = listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) when (not quiet) $ showResult verbosity outdatedDeps simpleOutput if (exitCode && (not . null $ outdatedDeps)) then exitFailure else return () -- | Print either the list of all outdated dependencies, or a message -- that there are none. showResult :: Verbosity -> [(Dependency,Version)] -> Bool -> IO () showResult verbosity outdatedDeps simpleOutput = if (not . null $ outdatedDeps) then do when (not simpleOutput) $ notice verbosity "Outdated dependencies:" for_ outdatedDeps $ \(d@(Dependency pn _), v) -> let outdatedDep = if simpleOutput then display pn else display d ++ " (latest: " ++ display v ++ ")" in notice verbosity outdatedDep else notice verbosity "All dependencies are up to date." -- | Convert a list of 'UserConstraint's to a 'Dependency' list. userConstraintsToDependencies :: [UserConstraint] -> [Dependency] userConstraintsToDependencies ucnstrs = mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs -- | Read the list of dependencies from the freeze file. depsFromFreezeFile :: Verbosity -> IO [Dependency] depsFromFreezeFile verbosity = do cwd <- getCurrentDirectory userConfig <- loadUserConfig verbosity cwd Nothing let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ userConfig deps = userConstraintsToDependencies ucnstrs debug verbosity "Reading the list of dependencies from the freeze file" return deps -- | Read the list of dependencies from the new-style freeze file. depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [Dependency] 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 [Dependency] depsFromPkgDesc verbosity comp platform = do cwd <- getCurrentDirectory path <- tryFindPackageDesc 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 bd -- | Various knobs for customising the behaviour of 'listOutdated'. data ListOutdatedSettings = ListOutdatedSettings { -- | Should this package be ignored? listOutdatedIgnorePred :: PackageName -> Bool, -- | Should major version bumps should be ignored for this package? listOutdatedMinorPred :: PackageName -> Bool } -- | Find all outdated dependencies. listOutdated :: [Dependency] -> PackageIndex UnresolvedSourcePackage -> ListOutdatedSettings -> [(Dependency, Version)] listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) = mapMaybe isOutdated $ map simplifyDependency deps where isOutdated :: Dependency -> Maybe (Dependency, Version) isOutdated dep | ignorePred (depPkgName dep) = Nothing | otherwise = let this = map packageVersion $ lookupDependency pkgIndex dep latest = lookupLatest dep in (\v -> (dep, v)) `fmap` isOutdated' this latest isOutdated' :: [Version] -> [Version] -> Maybe Version isOutdated' [] _ = Nothing isOutdated' _ [] = Nothing isOutdated' this latest = let this' = maximum this latest' = maximum latest in if this' < latest' then Just latest' else Nothing lookupLatest :: Dependency -> [Version] lookupLatest dep | minorPred (depPkgName dep) = map packageVersion $ lookupDependency pkgIndex (relaxMinor dep) | otherwise = map packageVersion $ lookupPackageName pkgIndex (depPkgName dep) relaxMinor :: Dependency -> Dependency relaxMinor (Dependency pn vr) = (Dependency pn vr') where vr' = let vis = asVersionIntervals vr (LowerBound v0 _,upper) = last vis in case upper of NoUpperBound -> vr UpperBound _v1 _ -> majorBoundVersion v0 cabal-install-2.4.0.0/Distribution/Client/PackageHash.hs0000644000000000000000000004130200000000000021100 0ustar0000000000000000{-# 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, -- * Low level hash choice HashValue, hashValue, showHashValue, readFileHashValue, hashFromTUF, ) 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.PackageDescription ( FlagAssignment, unFlagAssignment, showFlagValue ) import Distribution.Simple.Compiler ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) , ProfDetailLevel(..), showProfDetailLevel ) import Distribution.Simple.InstallDirs ( PathTemplate, fromPathTemplate ) import Distribution.Text ( display ) import Distribution.Version import Distribution.Client.Types ( InstalledPackageId ) import qualified Distribution.Solver.Types.ComponentDeps as CD import qualified Hackage.Security.Client as Sec import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) import Data.Function (on) import Control.Exception (evaluate) import System.IO (withBinaryFile, IOMode(..)) ------------------------------- -- Calculating package hashes -- -- | Calculate a 'InstalledPackageId' for a package using our nix-style -- inputs hashing method. -- -- 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} = mkComponentId $ display pkgHashPkgId -- to be a bit user friendly ++ "-" ++ showHashValue (hashPackageHashInputs pkghashinputs) -- | 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 (display name) , truncateStr 8 (display version) , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs)) ] where PackageIdentifier name version = pkgHashPkgId -- Truncate a 32 byte SHA256 hash to 160bits, 20 bytes :-( -- It'll render as 40 hex chars. truncateHash (HashValue h) = HashValue (BS.take 20 h) -- 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") (display name) , display version , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs)) ] where PackageIdentifier name version = pkgHashPkgId truncateHash (HashValue h) = HashValue (BS.take 4 h) -- | 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 Version), pkgHashDirectDeps :: Set InstalledPackageId, pkgHashOtherConfig :: PackageHashConfigInputs } type PackageSourceHash = HashValue -- | Those parts of the package configuration that contribute to the -- package hash. -- data PackageHashConfigInputs = PackageHashConfigInputs { pkgHashCompilerId :: CompilerId, pkgHashPlatform :: Platform, pkgHashFlagAssignment :: FlagAssignment, -- complete not partial pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure pkgHashVanillaLib :: Bool, pkgHashSharedLib :: Bool, pkgHashDynExe :: Bool, pkgHashGHCiLib :: Bool, pkgHashProfLib :: Bool, pkgHashProfExe :: Bool, pkgHashProfLibDetail :: ProfDetailLevel, pkgHashProfExeDetail :: ProfDetailLevel, pkgHashCoverage :: Bool, pkgHashOptimization :: OptimisationLevel, pkgHashSplitObjs :: Bool, 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" display pkgHashPkgId , mentry "component" show pkgHashComponent , entry "src" showHashValue pkgHashSourceHash , entry "pkg-config-deps" (intercalate ", " . map (\(pn, mb_v) -> display pn ++ case mb_v of Nothing -> "" Just v -> " " ++ display v) . Set.toList) pkgHashPkgConfigDeps , entry "deps" (intercalate ", " . map display . Set.toList) pkgHashDirectDeps -- and then all the config , entry "compilerid" display pkgHashCompilerId , entry "platform" display pkgHashPlatform , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment , opt "configure-script" [] unwords pkgHashConfigureScriptArgs , opt "vanilla-lib" True display pkgHashVanillaLib , opt "shared-lib" False display pkgHashSharedLib , opt "dynamic-exe" False display pkgHashDynExe , opt "ghci-lib" False display pkgHashGHCiLib , opt "prof-lib" False display pkgHashProfLib , opt "prof-exe" False display pkgHashProfExe , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail , opt "hpc" False display pkgHashCoverage , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization , opt "split-objs" False display pkgHashSplitObjs , opt "split-sections" False display pkgHashSplitSections , opt "stripped-lib" False display pkgHashStripLibs , opt "stripped-exe" True display pkgHashStripExes , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix , opt "documentation" False display pkgHashDocumentation , opt "haddock-hoogle" False display pkgHashHaddockHoogle , opt "haddock-html" False display pkgHashHaddockHtml , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation , opt "haddock-foreign-libraries" False display pkgHashHaddockForeignLibs , opt "haddock-executables" False display pkgHashHaddockExecutables , opt "haddock-tests" False display pkgHashHaddockTestSuites , opt "haddock-benchmarks" False display pkgHashHaddockBenchmarks , opt "haddock-internal" False display pkgHashHaddockInternal , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss , opt "haddock-hyperlink-source" False display pkgHashHaddockLinkedSource , opt "haddock-quickjump" False display 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 showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment ----------------------------------------------- -- 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) instance Binary HashValue where put (HashValue digest) = put digest get = do digest <- get -- Cannot do any sensible validation here. Although we use SHA256 -- for stuff we hash ourselves, we can also get hashes from TUF -- and that can in principle use different hash functions in future. return (HashValue digest) -- | Hash some data. Currently uses SHA256. -- hashValue :: LBS.ByteString -> HashValue hashValue = HashValue . SHA256.hashlazy showHashValue :: HashValue -> String showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) -- | Hash the content of a file. Uses SHA256. -- readFileHashValue :: FilePath -> IO HashValue readFileHashValue tarball = withBinaryFile tarball ReadMode $ \hnd -> evaluate . hashValue =<< LBS.hGetContents hnd -- | Convert a hash from TUF metadata into a 'PackageSourceHash'. -- -- Note that TUF hashes don't neessarily have to be SHA256, since it can -- support new algorithms in future. -- hashFromTUF :: Sec.Hash -> HashValue hashFromTUF (Sec.Hash hashstr) = --TODO: [code cleanup] either we should get TUF to use raw bytestrings or -- perhaps we should also just use a base16 string as the internal rep. case Base16.decode (BS.pack hashstr) of (hash, trailing) | not (BS.null hash) && BS.null trailing -> HashValue hash _ -> error "hashFromTUF: cannot decode base16 hash" cabal-install-2.4.0.0/Distribution/Client/PackageUtils.hs0000644000000000000000000000314000000000000021313 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.PackageUtils -- Copyright : (c) Duncan Coutts 2010 -- License : BSD-like -- -- Maintainer : cabal-devel@gmail.com -- Stability : provisional -- Portability : portable -- -- Various package description utils that should be in the Cabal lib ----------------------------------------------------------------------------- module Distribution.Client.PackageUtils ( externalBuildDepends, ) where import Distribution.Package ( packageVersion, packageName ) import Distribution.Types.ComponentRequestedSpec ( ComponentRequestedSpec ) import Distribution.Types.Dependency import Distribution.Types.UnqualComponentName import Distribution.PackageDescription ( PackageDescription(..), libName, enabledBuildDepends ) import Distribution.Version ( withinRange, isAnyVersion ) -- | The list of dependencies that refer to external packages -- rather than internal package components. -- externalBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency] externalBuildDepends pkg spec = filter (not . internal) (enabledBuildDepends pkg spec) where -- True if this dependency is an internal one (depends on a library -- defined in the same package). internal (Dependency depName versionRange) = (depName == packageName pkg && packageVersion pkg `withinRange` versionRange) || (Just (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) && isAnyVersion versionRange) cabal-install-2.4.0.0/Distribution/Client/ParseUtils.hs0000644000000000000000000002264500000000000021045 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- 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, -- * Parsing and printing flat config parseFields, ppFields, ppSection, -- * Parsing and printing config with sections and subsections parseFieldsAndSections, ppFieldsAndSections, -- ** Top level of config files parseConfig, showConfig, ) where import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo , Field(..), liftField, readFieldsFlat ) import Distribution.Simple.Command ( OptionField, viewAsFieldDescr ) import Control.Monad ( foldM ) import Text.PrettyPrint ( (<+>), ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) ------------------------- -- FieldDescr utilities -- liftFields :: (b -> a) -> (a -> b -> b) -> [FieldDescr a] -> [FieldDescr b] liftFields get set = map (liftField get set) -- | Given a collection of field descriptions, keep only a given list of them, -- identified by name. -- filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a] filterFields includeFields = filter ((`elem` includeFields) . fieldName) -- | Apply a name mangling function to the field names of all the field -- descriptions. The typical use case is to apply some prefix. -- mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a] mapFieldNames mangleName = map (\descr -> descr { fieldName = mangleName (fieldName descr) }) -- | Reuse a command line 'OptionField' as a config file 'FieldDescr'. -- commandOptionToField :: OptionField a -> FieldDescr a commandOptionToField = viewAsFieldDescr -- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's. -- commandOptionsToFields :: [OptionField a] -> [FieldDescr a] commandOptionsToFields = map viewAsFieldDescr ------------------------------------------ -- SectionDescr definition and utilities -- -- | The description of a section in a config file. It can contain both -- fields and optionally further subsections. See also 'FieldDescr'. -- data SectionDescr a = forall b. SectionDescr { sectionName :: String, sectionFields :: [FieldDescr b], sectionSubsections :: [SectionDescr b], sectionGet :: a -> [(String, b)], sectionSet :: LineNo -> String -> b -> a -> ParseResult a, sectionEmpty :: b } -- | To help construction of config file descriptions in a modular way it is -- useful to define fields and sections on local types and then hoist them -- into the parent types when combining them in bigger descriptions. -- -- This is essentially a lens operation for 'SectionDescr' to help embedding -- one inside another. -- liftSection :: (b -> a) -> (a -> b -> b) -> SectionDescr a -> SectionDescr b liftSection get' set' (SectionDescr name fields sections get set empty) = let sectionGet' = get . get' sectionSet' lineno param x y = do x' <- set lineno param x (get' y) return (set' x' y) in SectionDescr name fields sections sectionGet' sectionSet' empty ------------------------------------- -- Parsing and printing flat config -- -- | Parse a bunch of semi-parsed 'Field's according to a set of field -- descriptions. It accumulates the result on top of a given initial value. -- -- This only covers the case of flat configuration without subsections. See -- also 'parseFieldsAndSections'. -- parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a parseFields fieldDescrs = foldM setField where fieldMap = Map.fromList [ (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.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] -> [SectionDescr a] -> a -> [Field] -> ParseResult a parseFieldsAndSections fieldDescrs sectionDescrs = foldM setField where fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ] setField a (F line name value) = case Map.lookup name fieldMap of Just (FieldDescr _ _ set) -> set line value a Nothing -> do warning $ "Unrecognized field '" ++ name ++ "' on line " ++ show line return a setField a (Section line name param fields) = case Map.lookup name sectionMap of Just (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty) -> do b <- parseFieldsAndSections fieldDescrs' sectionDescrs' sectionEmpty fields set line param b a Nothing -> do warning $ "Unrecognized section '" ++ name ++ "' on line " ++ show line return a setField accum (block@IfBlock {}) = do warning $ "Unrecognized stanza on line " ++ show (lineNo block) return accum -- | Much like 'ppFields' but also pretty prints any subsections. Subsection -- are only shown if they are non-empty. -- -- Note that unlike 'ppFields', at present it does not support printing -- default values. If needed, adding such support would be quite reasonable. -- ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc ppFieldsAndSections fieldDescrs sectionDescrs val = ppFields fieldDescrs Nothing val $+$ Disp.vcat [ Disp.text "" $+$ sectionDoc | SectionDescr { sectionName, sectionGet, sectionFields, sectionSubsections } <- sectionDescrs , (param, x) <- sectionGet val , let sectionDoc = ppSectionAndSubsections sectionName param sectionFields sectionSubsections x , not (Disp.isEmpty sectionDoc) ] -- | Unlike 'ppSection' which has to be called directly, this gets used via -- 'ppFieldsAndSections' and so does not need to be exported. -- ppSectionAndSubsections :: String -> String -> [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc ppSectionAndSubsections name arg fields sections cur | Disp.isEmpty fieldsDoc = Disp.empty | otherwise = Disp.text name <+> argDoc $+$ (Disp.nest 2 fieldsDoc) where fieldsDoc = showConfig fields sections cur argDoc | arg == "" = Disp.empty | otherwise = Disp.text arg ----------------------------------------------- -- Top level config file parsing and printing -- -- | Parse a string in the config file syntax into a value, based on a -- description of the configuration file in terms of its fields and sections. -- -- It accumulates the result on top of a given initial (typically empty) value. -- parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> String -> ParseResult a parseConfig fieldDescrs sectionDescrs empty str = parseFieldsAndSections fieldDescrs sectionDescrs empty =<< readFieldsFlat str -- | Render a value in the config file syntax, based on a description of the -- configuration file in terms of its fields and sections. -- showConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc showConfig = ppFieldsAndSections cabal-install-2.4.0.0/Distribution/Client/ProjectBuilding.hs0000644000000000000000000016724400000000000022043 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE ConstraintKinds #-} -- | -- module Distribution.Client.ProjectBuilding ( -- * Dry run phase -- | What bits of the plan will we execute? The dry run does not change -- anything but tells us what will need to be built. rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages, -- ** Build status -- | This is the detailed status information we get from the dry run. BuildStatusMap, BuildStatus(..), BuildStatusRebuild(..), BuildReason(..), MonitorChangedReason(..), buildStatusToString, -- * Build phase -- | Now we actually execute the plan. rebuildTargets, -- ** Build outcomes -- | This is the outcome for each package of executing the plan. -- For each package, did the build succeed or fail? BuildOutcomes, BuildOutcome, BuildResult(..), BuildFailure(..), BuildFailureReason(..), ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif 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 ) import Distribution.Client.SourceFiles import Distribution.Client.SrcDist (allPackageSourceFiles) import Distribution.Client.Utils ( ProgressPhase(..), progressMessage, removeExistingFile ) import Distribution.Compat.Lens import Distribution.Package hiding (InstalledPackageId, installedPackageId) 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(..)) import Distribution.Simple.Compiler ( Compiler, compilerId, PackageDB(..) ) import Distribution.Simple.Utils import Distribution.Version import Distribution.Verbosity import Distribution.Text import Distribution.ParseUtils ( showPWarning ) import Distribution.Compat.Graph (IsNode(..)) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as LBS import Data.List (isPrefixOf) import Control.Monad import Control.Exception import Data.Function (on) import Data.Maybe import System.FilePath import System.IO import System.Directory #if !MIN_VERSION_directory(1,2,5) listDirectory :: FilePath -> IO [FilePath] listDirectory path = (filter f) <$> (getDirectoryContents path) where f filename = filename /= "." && filename /= ".." #endif ------------------------------------------------------------------------------ -- * 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 Just (RemoteSourceRepoPackage _repo srcdir) -> -- At this point, source repos are essentially the same as local -- dirs, since we've already download them. dryRunLocalPkg pkg depsBuildStatus srcdir -- The three tarball cases are handled the same as each other, -- though depending on the build style. Just (LocalTarballPackage tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball Just (RemoteTarballPackage _ tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball Just (RepoTarballPackage _ _ tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball dryRunTarballPkg :: ElaboratedConfiguredPackage -> [BuildStatus] -> FilePath -> IO BuildStatus dryRunTarballPkg pkg depsBuildStatus tarball = case elabBuildStyle pkg of BuildAndInstall -> return (BuildStatusUnpack tarball) BuildInplaceOnly -> do -- TODO: [nice to have] use a proper file monitor rather than this dir exists test exists <- doesDirectoryExist srcdir if exists then dryRunLocalPkg pkg depsBuildStatus srcdir else return (BuildStatusUnpack tarball) where srcdir = distUnpackedSrcDirectory (packageId pkg) dryRunLocalPkg :: ElaboratedConfiguredPackage -> [BuildStatus] -> FilePath -> IO BuildStatus dryRunLocalPkg pkg depsBuildStatus srcdir = do -- Go and do lots of I/O, reading caches and probing files to work out -- if anything has changed change <- checkPackageFileMonitorChanged packageFileMonitor pkg srcdir depsBuildStatus case change of -- It did change, giving us 'BuildStatusRebuild' info on why Left rebuild -> return (BuildStatusRebuild srcdir rebuild) -- No changes, the package is up to date. Use the saved build results. Right buildResult -> return (BuildStatusUpToDate buildResult) where packageFileMonitor = newPackageFileMonitor 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 visting a package, the -- visiting function is passed the results for all the immediate package -- dependencies. This can be used to propagate information from dependencies. -- foldMInstallPlanDepOrder :: forall m ipkg srcpkg b. (Monad m, IsUnit ipkg, IsUnit srcpkg) => (GenericPlanPackage ipkg srcpkg -> [b] -> m b) -> GenericInstallPlan ipkg srcpkg -> m (Map UnitId b) foldMInstallPlanDepOrder visit = go Map.empty . InstallPlan.reverseTopologicalOrder where go :: Map UnitId b -> [GenericPlanPackage ipkg srcpkg] -> m (Map UnitId b) go !results [] = return results go !results (pkg : pkgs) = do -- we go in the right order so the results map has entries for all deps let depresults :: [b] depresults = map (\ipkgid -> let Just result = Map.lookup ipkgid results in result) (InstallPlan.depends pkg) result <- visit pkg depresults let results' = Map.insert (nodeKey pkg) result results go results' pkgs improveInstallPlanWithUpToDatePackages :: BuildStatusMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan improveInstallPlanWithUpToDatePackages pkgsBuildStatus = InstallPlan.installed canPackageBeImproved where canPackageBeImproved pkg = case Map.lookup (installedUnitId pkg) pkgsBuildStatus of Just BuildStatusUpToDate {} -> True Just _ -> False Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " ++ display (packageId pkg) ++ " not in status map" ----------------------------- -- Package change detection -- -- | As part of the dry run for local unpacked packages we have to check if the -- package config or files have changed. That is the purpose of -- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. -- -- When a package is (re)built, the monitor must be updated to reflect the new -- state of the package. Because we sometimes build without reconfiguring the -- state updates are split into two, one for package config changes and one -- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' -- and 'updatePackageBuildFileMonitor'. -- data PackageFileMonitor = PackageFileMonitor { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) } -- | This is all the components of the 'BuildResult' other than the -- @['InstalledPackageInfo']@. -- -- We have to split up the 'BuildResult' components since they get produced -- at different times (or rather, when different things change). -- type BuildResultMisc = (DocsResult, TestsResult) newPackageFileMonitor :: 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 mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse -- Before traversing the install plan, pre-emptively find all packages that -- will need to be downloaded and start downloading them. asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus $ \downloadMap -> -- For each package in the plan, in dependency order, but in parallel... InstallPlan.execute jobControl keepGoing (BuildFailure Nothing . DependentFailed . packageId) installPlan $ \pkg -> --TODO: review exception handling handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ let uid = installedUnitId pkg Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in rebuildTarget verbosity distDirLayout storeDirLayout buildSettings downloadMap registerLock cacheLock sharedPackageConfig installPlan pkg pkgBuildStatus where isParallelBuild = buildSettingNumJobs >= 2 keepGoing = buildSettingKeepGoing withRepoCtx = projectConfigWithBuilderRepoContext verbosity buildSettings packageDBsToUse = -- all the package dbs we may need to create (Set.toList . Set.fromList) [ pkgdb | InstallPlan.Configured elab <- InstallPlan.toList installPlan , pkgdb <- concat [ elabBuildPackageDBStack elab , elabRegisterPackageDBStack elab , elabSetupPackageDBStack elab ] ] -- | Create a package DB if it does not currently exist. Note that this action -- is /not/ safe to run concurrently. -- createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb -> PackageDB -> IO () createPackageDBIfMissing verbosity compiler progdb (SpecificPackageDB dbPath) = do exists <- Cabal.doesPackageDBExist dbPath unless exists $ do createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) Cabal.createPackageDB verbosity compiler progdb False dbPath createPackageDBIfMissing _ _ _ _ = return () -- | Given all the context and resources, (re)build an individual package. -- rebuildTarget :: Verbosity -> DistDirLayout -> StoreDirLayout -> BuildTimeSettings -> AsyncFetchMap -> Lock -> Lock -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> BuildStatus -> IO BuildResult rebuildTarget verbosity distDirLayout@DistDirLayout{distBuildDirectory} storeDirLayout buildSettings downloadMap registerLock cacheLock sharedPackageConfig plan rpkg@(ReadyPackage pkg) pkgBuildStatus = -- We rely on the 'BuildStatus' to decide which phase to start from: case pkgBuildStatus of BuildStatusDownload -> downloadPhase BuildStatusUnpack tarball -> unpackTarballPhase tarball BuildStatusRebuild srcdir status -> rebuildPhase status srcdir -- TODO: perhaps re-nest the types to make these impossible BuildStatusPreExisting {} -> unexpectedState BuildStatusInstalled {} -> unexpectedState BuildStatusUpToDate {} -> unexpectedState where unexpectedState = error "rebuildTarget: unexpected package status" downloadPhase = do downsrcloc <- annotateFailureNoLog DownloadFailed $ waitAsyncPackageDownload verbosity downloadMap pkg case downsrcloc of DownloadedTarball tarball -> unpackTarballPhase tarball --TODO: [nice to have] git/darcs repos etc unpackTarballPhase tarball = withTarballLocalDirectory verbosity distDirLayout tarball (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg) (elabPkgDescriptionOverride pkg) $ case elabBuildStyle pkg of BuildAndInstall -> buildAndInstall BuildInplaceOnly -> buildInplace buildStatus where buildStatus = BuildStatusConfigure MonitorFirstRun -- Note that this really is rebuild, not build. It can only happen for -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages -- would only start from download or unpack phases. -- rebuildPhase buildStatus srcdir = assert (elabBuildStyle pkg == BuildInplaceOnly) $ buildInplace buildStatus srcdir builddir where builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg) buildAndInstall srcdir builddir = buildAndInstallUnpackedPackage verbosity distDirLayout storeDirLayout buildSettings registerLock cacheLock sharedPackageConfig 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 Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus , BuildStatusDownload <- [pkgBuildStatus] ] -- | Check if a package needs downloading, and if so expect to find a download -- in progress in the given 'AsyncFetchMap' and wait on it to finish. -- waitAsyncPackageDownload :: Verbosity -> AsyncFetchMap -> ElaboratedConfiguredPackage -> IO DownloadedSourceLocation waitAsyncPackageDownload verbosity downloadMap elab = do pkgloc <- waitAsyncFetchPackage verbosity downloadMap (elabPkgSourceLocation elab) case downloadedSourceLocation pkgloc of Just loc -> return loc Nothing -> fail "waitAsyncPackageDownload: unexpected source location" data DownloadedSourceLocation = DownloadedTarball FilePath --TODO: [nice to have] git/darcs repos etc downloadedSourceLocation :: PackageLocation FilePath -> Maybe DownloadedSourceLocation downloadedSourceLocation pkgloc = case pkgloc of RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) _ -> Nothing -- | Ensure that the package is unpacked in an appropriate directory, either -- a temporary one or a persistent one under the shared dist directory. -- withTarballLocalDirectory :: Verbosity -> DistDirLayout -> FilePath -> PackageId -> DistDirParams -> BuildStyle -> Maybe CabalFileText -> (FilePath -> -- Source directory FilePath -> -- Build directory IO a) -> IO a withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} tarball pkgid dparams buildstyle pkgTextOverride buildPkg = case buildstyle of -- In this case we make a temp dir (e.g. tmp/src2345/), unpack -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for -- compatibility we put the dist dir within it -- (i.e. tmp/src2345/foo-1.0/dist/). -- -- Unfortunately, a few custom Setup.hs scripts do not respect -- the --builddir flag and always look for it at ./dist/ so -- this way we avoid breaking those packages BuildAndInstall -> let tmpdir = distTempDirectory in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do unpackPackageTarball verbosity tarball unpackdir pkgid pkgTextOverride let srcdir = unpackdir display pkgid builddir = srcdir "dist" buildPkg srcdir builddir -- In this case we make sure the tarball has been unpacked to the -- appropriate location under the shared dist dir, and then build it -- inplace there BuildInplaceOnly -> do let srcrootdir = distUnpackedSrcRootDirectory srcdir = distUnpackedSrcDirectory pkgid builddir = distBuildDirectory dparams -- TODO: [nice to have] use a proper file monitor rather than this dir exists test exists <- doesDirectoryExist srcdir unless exists $ do createDirectoryIfMissingVerbose verbosity True srcrootdir unpackPackageTarball verbosity tarball srcrootdir pkgid pkgTextOverride moveTarballShippedDistDirectory verbosity distDirLayout srcrootdir pkgid dparams buildPkg srcdir builddir unpackPackageTarball :: Verbosity -> FilePath -> FilePath -> PackageId -> Maybe CabalFileText -> IO () unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = --TODO: [nice to have] switch to tar package and catch tar exceptions annotateFailureNoLog UnpackFailed $ do -- Unpack the tarball -- info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." Tar.extractTarGzFile parentdir pkgsubdir tarball -- Sanity check -- exists <- doesFileExist cabalFile 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 " ++ display pkgname <.> "cabal" ++ " with the latest revision from the index." writeFileAtomic cabalFile pkgtxt where cabalFile = parentdir pkgsubdir display pkgname <.> "cabal" pkgsubdir = display pkgid pkgname = packageName pkgid -- | This is a bit of a hacky workaround. A number of packages ship -- pre-processed .hs files in a dist directory inside the tarball. We don't -- use the standard 'dist' location so unless we move this dist dir to the -- right place then we'll miss the shipped pre-procssed files. This hacky -- approach to shipped pre-procssed files ought to be replaced by a proper -- system, though we'll still need to keep this hack for older packages. -- moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout -> FilePath -> PackageId -> DistDirParams -> IO () moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} parentdir pkgid dparams = do distDirExists <- doesDirectoryExist tarballDistDir when distDirExists $ do debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" ++ targetDistDir ++ "'" --TODO: [nice to have] or perhaps better to copy, and use a file monitor renameDirectory tarballDistDir targetDistDir where tarballDistDir = parentdir display pkgid "dist" targetDistDir = distBuildDirectory dparams buildAndInstallUnpackedPackage :: Verbosity -> DistDirLayout -> StoreDirLayout -> BuildTimeSettings -> Lock -> Lock -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> FilePath -> FilePath -> IO BuildResult buildAndInstallUnpackedPackage verbosity DistDirLayout{distTempDirectory} storeDirLayout@StoreDirLayout { storePackageDBStack } BuildTimeSettings { buildSettingNumJobs, buildSettingLogFile } registerLock cacheLock pkgshared@ElaboratedSharedConfig { pkgConfigPlatform = platform, pkgConfigCompiler = compiler, pkgConfigCompilerProgs = progdb } plan rpkg@(ReadyPackage pkg) srcdir builddir = do createDirectoryIfMissingVerbose verbosity True builddir initLogFile --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like -- we do for ghc, with a proper options type and rendering step -- which will also let us call directly into the lib, rather than always -- going via the lib's command line interface, which would also allow -- passing data like installed packages, compiler, and program db for a -- quicker configure. --TODO: [required feature] docs and tests --TODO: [required feature] sudo re-exec -- 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 setup Cabal.copyCommand (copyFlags tmpDir) -- Note that the copy command has put the files into -- @$tmpDir/$prefix@ so we need to return this dir so -- the store knows which dir will be the final store entry. let prefix = dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) entryDir = tmpDir prefix LBS.writeFile (entryDir "cabal-hash.txt") (renderPackageHashInputs (packageHashInputs pkgshared pkg)) -- Ensure that there are no files in `tmpDir`, that are not in `entryDir` -- While this breaks the prefix-relocatable property of the lirbaries -- it is necessary on macOS to stay under the load command limit of the -- macOS mach-o linker. See also @PackageHash.hashedInstalledPackageIdVeryShort@. otherFiles <- filter (not . isPrefixOf entryDir) <$> listFilesRecursive tmpDir -- 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 <- forM 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 " ++ display uid | otherwise = do -- We register ourselves rather than via Setup.hs. We need to -- grab and modify the InstalledPackageInfo. We decide what -- the installed package id is, not the build system. ipkg0 <- generateInstalledPackageInfo let ipkg = ipkg0 { Installed.installedUnitId = uid } assert ( elabRegisterPackageDBStack pkg == storePackageDBStack compid) (return ()) criticalSection registerLock $ Cabal.registerPackage verbosity compiler progdb (storePackageDBStack compid) ipkg Cabal.defaultRegisterOptions { Cabal.registerMultiInstance = True, Cabal.registerSuppressFilesCheck = True } -- Actual installation void $ newStoreEntry verbosity storeDirLayout compid uid copyPkgFiles registerPkg --TODO: [nice to have] we currently rely on Setup.hs copy to do the right -- thing. Although we do copy into an image dir and do the move into the -- final location ourselves, perhaps we ought to do some sanity checks on -- the image dir first. -- TODO: [required eventually] note that for nix-style installations it is not necessary to do -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a -- shared bin dir. --TODO: [required feature] docs and test phases let docsResult = DocsNotTried testsResult = TestsNotTried 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 _ -> display pkgid ++ " (all, legacy fallback)" ElabComponent comp -> display pkgid ++ " (" ++ maybe "custom" display (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 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 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 -> hasHaddocks CSubLibName _ -> 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 scriptOptions 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 _ = 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 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 :: Installed.PError -> IO a pkgConfParseFailed perror = die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" ++ show perror readPkgConf pkgConfDir pkgConfFile = do (warns, ipkg) <- withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfStr -> case Installed.parseInstalledPackageInfo pkgConfStr of Installed.ParseFailed perror -> pkgConfParseFailed perror Installed.ParseOk warns ipkg -> return (warns, ipkg) unless (null warns) $ warn verbosity $ unlines (map (showPWarning pkgConfFile) warns) return ipkg ------------------------------------------------------------------------------ -- * Utilities ------------------------------------------------------------------------------ annotateFailureNoLog :: (SomeException -> BuildFailureReason) -> IO a -> IO a annotateFailureNoLog annotate action = annotateFailure Nothing annotate action annotateFailure :: Maybe FilePath -> (SomeException -> BuildFailureReason) -> IO a -> IO a annotateFailure mlogFile annotate action = action `catches` -- It's not just IOException and ExitCode we have to deal with, there's -- lots, including exceptions from the hackage-security and tar packages. -- So we take the strategy of catching everything except async exceptions. [ #if MIN_VERSION_base(4,7,0) Handler $ \async -> throwIO (async :: SomeAsyncException) #else Handler $ \async -> throwIO (async :: AsyncException) #endif , Handler $ \other -> handler (other :: SomeException) ] where handler :: Exception e => e -> IO a handler = throwIO . BuildFailure mlogFile . annotate . toException cabal-install-2.4.0.0/Distribution/Client/ProjectBuilding/0000755000000000000000000000000000000000000021471 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/ProjectBuilding/Types.hs0000644000000000000000000001670500000000000023142 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -- | Types for the "Distribution.Client.ProjectBuilding" -- -- Moved out to avoid module cycles. -- module Distribution.Client.ProjectBuilding.Types ( -- * Pre-build status BuildStatusMap, BuildStatus(..), buildStatusRequiresBuild, buildStatusToString, BuildStatusRebuild(..), BuildReason(..), MonitorChangedReason(..), -- * Build outcomes BuildOutcomes, BuildOutcome, BuildResult(..), BuildFailure(..), BuildFailureReason(..), ) where import Distribution.Client.Types (DocsResult, TestsResult) import Distribution.Client.FileMonitor (MonitorChangedReason(..)) import Distribution.Package (UnitId, PackageId) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.LocalBuildInfo (ComponentName) import Data.Map (Map) import Data.Set (Set) import Data.Typeable (Typeable) import Control.Exception (Exception, SomeException) ------------------------------------------------------------------------------ -- Pre-build status: result of the dry run -- -- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. -- -- This is used as the result of the dry-run of building an install plan. -- type BuildStatusMap = Map UnitId BuildStatus -- | The build status for an individual package is the state that the -- package is in /prior/ to initiating a (re)build. -- -- This should not be confused with a 'BuildResult' which is the result -- /after/ successfully building a package. -- -- It serves two purposes: -- -- * For dry-run output, it lets us explain to the user if and why a package -- is going to be (re)built. -- -- * It tell us what step to start or resume building from, and carries -- enough information for us to be able to do so. -- data BuildStatus = -- | The package is in the 'InstallPlan.PreExisting' state, so does not -- need building. BuildStatusPreExisting -- | The package is in the 'InstallPlan.Installed' state, so does not -- need building. | BuildStatusInstalled -- | The package has not been downloaded yet, so it will have to be -- downloaded, unpacked and built. | BuildStatusDownload -- | The package has not been unpacked yet, so it will have to be -- unpacked and built. | BuildStatusUnpack FilePath -- | The package exists in a local dir already, and just needs building -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style -- packages. | BuildStatusRebuild FilePath BuildStatusRebuild -- | The package exists in a local dir already, and is fully up to date. -- So this package can be put into the 'InstallPlan.Installed' state -- and it does not need to be built. | BuildStatusUpToDate BuildResult -- | Which 'BuildStatus' values indicate we'll have to do some build work of -- some sort. In particular we use this as part of checking if any of a -- package's deps have changed. -- buildStatusRequiresBuild :: BuildStatus -> Bool buildStatusRequiresBuild BuildStatusPreExisting = False buildStatusRequiresBuild BuildStatusInstalled = False buildStatusRequiresBuild BuildStatusUpToDate {} = False buildStatusRequiresBuild _ = True -- | This is primarily here for debugging. It's not actually used anywhere. -- buildStatusToString :: BuildStatus -> String buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" buildStatusToString BuildStatusInstalled = "BuildStatusInstalled" buildStatusToString BuildStatusDownload = "BuildStatusDownload" buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" -- | For a package that is going to be built or rebuilt, the state it's in now. -- -- So again, this tells us why a package needs to be rebuilt and what build -- phases need to be run. The 'MonitorChangedReason' gives us details like -- which file changed, which is mainly for high verbosity debug output. -- data BuildStatusRebuild = -- | The package configuration changed, so the configure and build phases -- needs to be (re)run. BuildStatusConfigure (MonitorChangedReason ()) -- | The configuration has not changed but the build phase needs to be -- rerun. We record the reason the (re)build is needed. -- -- The optional registration info here tells us if we've registered the -- package already, or if we still need to do that after building. -- @Just Nothing@ indicates that we know that no registration is -- necessary (e.g., executable.) -- | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason data BuildReason = -- | The dependencies of this package have been (re)built so the build -- phase needs to be rerun. -- BuildReasonDepsRebuilt -- | Changes in files within the package (or first run or corrupt cache) | BuildReasonFilesChanged (MonitorChangedReason ()) -- | An important special case is that no files have changed but the -- set of components the /user asked to build/ has changed. We track the -- set of components /we have built/, which of course only grows (until -- some other change resets it). -- -- The @Set 'ComponentName'@ is the set of components we have built -- previously. When we update the monitor we take the union of the ones -- we have built previously with the ones the user has asked for this -- time and save those. See 'updatePackageBuildFileMonitor'. -- | BuildReasonExtraTargets (Set ComponentName) -- | Although we're not going to build any additional targets as a whole, -- we're going to build some part of a component or run a repl or any -- other action that does not result in additional persistent artifacts. -- | BuildReasonEphemeralTargets ------------------------------------------------------------------------------ -- Build outcomes: result of the build -- -- | A summary of the outcome for building a whole set of packages. -- type BuildOutcomes = Map UnitId BuildOutcome -- | A summary of the outcome for building a single package: either success -- or failure. -- type BuildOutcome = Either BuildFailure BuildResult -- | Information arising from successfully building a single package. -- data BuildResult = BuildResult { buildResultDocs :: DocsResult, buildResultTests :: TestsResult, buildResultLogFile :: Maybe FilePath } deriving Show -- | Information arising from the failure to build a single package. -- data BuildFailure = BuildFailure { buildFailureLogFile :: Maybe FilePath, buildFailureReason :: BuildFailureReason } deriving (Show, Typeable) instance Exception BuildFailure -- | Detail on the reason that a package failed to build. -- data BuildFailureReason = DependentFailed PackageId | DownloadFailed SomeException | UnpackFailed SomeException | ConfigureFailed SomeException | BuildFailed SomeException | ReplFailed SomeException | HaddocksFailed SomeException | TestsFailed SomeException | BenchFailed SomeException | InstallFailed SomeException deriving Show cabal-install-2.4.0.0/Distribution/Client/ProjectConfig.hs0000644000000000000000000015626100000000000021510 0ustar0000000000000000{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveDataTypeable, LambdaCase #-} -- | 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.Solver.Types.SourcePackage import Distribution.Solver.Types.Settings import Distribution.Solver.Types.PackageConstraint ( PackageProperty(..) ) import Distribution.Package ( PackageName, PackageId, packageId, UnitId ) import Distribution.Types.Dependency import Distribution.System ( Platform ) import Distribution.Types.GenericPackageDescription ( GenericPackageDescription ) import Distribution.PackageDescription.Parsec ( parseGenericPackageDescription ) import Distribution.Parsec.ParseResult ( runParseResult ) import Distribution.Parsec.Common as NewParser ( PError, PWarning, showPWarning ) import Distribution.Types.SourceRepo ( SourceRepo(..), RepoType(..), ) 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 ( Verbosity, modifyVerbosity, verbose ) import Distribution.Version ( Version ) import Distribution.Text import Distribution.ParseUtils as OldParser ( ParseResult(..), locatedErrorMsg, showPWarning ) 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 import Control.Monad.Trans (liftIO) import Control.Exception import Data.Either import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map import Data.Set (Set) 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 buildSettingLocalRepos 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 projectConfigLocalRepos) (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 solverSettingLocalRepos = fromNubList projectConfigLocalRepos 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 solverSettingStrongFlags = fromFlag projectConfigStrongFlags solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls solverSettingIndexState = flagToMaybe projectConfigIndexState 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), projectConfigStrongFlags = Flag (StrongFlags False), projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), 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, projectConfigLocalRepos, 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 buildSettingLocalRepos = fromNubList projectConfigLocalRepos 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) --TODO: [nice to have] add compat support for old style sandboxes -- | Errors returned by 'findProjectRoot'. -- data BadProjectRoot = BadProjectRootExplicitFile FilePath #if MIN_VERSION_base(4,8,0) deriving (Show, Typeable) #else deriving (Typeable) instance Show BadProjectRoot where show = renderBadProjectRoot #endif instance Exception BadProjectRoot where #if MIN_VERSION_base(4,8,0) displayException = renderBadProjectRoot #endif renderBadProjectRoot :: BadProjectRoot -> String renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = "The given project file '" ++ projectFile ++ "' does not exist." 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" ], -- This is to automatically pick up deps that we unpack locally. projectPackagesOptional = [ "./*/*.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 -> 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 -> ParseResult a -> IO a reportParseResult verbosity _filetype filename (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 (ParseFailed err) = let (line, msg) = 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 SourceRepo | ProjectPackageNamed Dependency 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 <$> mapM (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 simpleParse pkglocstr of Nothing -> return Nothing Just glob -> liftM Just $ do matches <- matchFileGlob glob case matches of [] | isJust (isTrivialFilePathGlob glob) -> return (Left (BadPackageLocationFile (BadLocNonexistantFile pkglocstr))) [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) _ -> do (failures, pkglocs) <- partitionEithers <$> mapM checkFilePackageMatch matches 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 <- sequence [ readSourcePackageLocalDirectory verbosity dir cabalFile | location <- pkgLocations , (dir, cabalFile) <- projectPackageLocal location ] pkgsLocalTarball <- sequence [ readSourcePackageLocalTarball verbosity path | ProjectPackageLocalTarball path <- pkgLocations ] pkgsRemoteTarball <- do getTransport <- delayInitSharedResource $ configureTransport verbosity progPathExtra preferredHttpTransport sequence [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout getTransport uri | ProjectPackageRemoteTarball uri <- pkgLocations ] pkgsRemoteRepo <- syncAndReadSourcePackagesRemoteRepos verbosity distDirLayout projectConfigShared [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ] let pkgsNamed = [ NamedPackage pkgname [PackagePropertyVersion verrange] | ProjectPackageNamed (Dependency 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 -> [SourceRepo] -> 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) [(SourceRepo, 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 Just vcs = Map.lookup repoType knownVCSs in configureVCS verbosity {-progPathExtra-} vcs concat <$> sequence [ 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 [SourceRepo] [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] monitor = newFileMonitor (pathStem <.> "cache") ] where syncRepoGroupAndReadSourcePackages :: VCS ConfiguredProgram -> FilePath -> [SourceRepo] -> 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 ] -- But for reading we go through each 'SourceRepo' including its subdir -- value and have to know which path each one ended up in. sequence [ readPackageFromSourceRepo repoWithSubdir repoPath | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths , repoWithSubdir <- reposWithSubdir ] where -- So to do both things above, we pair them up here. repoGroupWithPaths = zipWith (\(x, y) z -> (x,y,z)) (Map.toList (Map.fromListWith (++) [ (repo { repoSubdir = Nothing }, [repo]) | repo <- repoGroup ])) repoPaths -- The repos in a group are given distinct names by simple enumeration -- foo, foo-2, foo-3 etc repoPaths = pathStem : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] readPackageFromSourceRepo repo repoPath = do let packageDir = maybe repoPath (repoPath ) (repoSubdir repo) entries <- liftIO $ getDirectoryContents packageDir --TODO: wrap exceptions case filter (\e -> takeExtension e == ".cabal") entries of [] -> liftIO $ throwIO NoCabalFileFound (_:_:_) -> liftIO $ throwIO MultipleCabalFilesFound [cabalFileName] -> do monitorFiles [monitorFileHashed cabalFilePath] liftIO $ fmap (mkSpecificSourcePackage location) . readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath where cabalFilePath = packageDir cabalFileName location = RemoteSourceRepoPackage repo packageDir reportSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> Rebuild a reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems renderSourceRepoProblems :: [(SourceRepo, 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 (PackageLocation (Maybe FilePath))) mkSpecificSourcePackage location pkg = SpecificSourcePackage SourcePackage { packageInfoId = packageId pkg, packageDescription = pkg, --TODO: it is silly that we still have to use a Maybe FilePath here packageSource = fmap Just location, packageDescrOverride = Nothing } -- | Errors reported upon failing to parse a @.cabal@ file. -- data CabalFileParseError = CabalFileParseError FilePath [PError] (Maybe Version) -- We might discover the spec version the package needs [PWarning] deriving (Show, Typeable) instance Exception CabalFileParseError -- | 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 errors mspecVersion warnings where formatWarnings warnings = "The package description file " ++ pkgfilename ++ " has warnings: " ++ unlines (map (NewParser.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 | MultipleCabalFilesFound 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 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 :: LBS.ByteString -> Either (Either Tar.FormatError CabalFileSearchFailure) (FilePath, LBS.ByteString) extractTarballPackageCabalFilePure = 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) [file] -> case Tar.entryContent file of Tar.NormalFile content _ -> Right (Tar.entryPath file, content) _ -> Left (Right NoCabalFileFound) _files -> Left (Right MultipleCabalFilesFound) 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 :: SourceRepo -> FilePath localFileNameForRemoteRepo SourceRepo{repoType, repoLocation, repoModule} = maybe "" ((++ "-") . mangleName) repoLocation ++ 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 repoType, repoLocation, repoModule)) -- | 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 '" ++ display pkgname ++ "'). All packages have to use the same compiler, so " ++ "specify the path in a global 'program-locations' section." --TODO: [nice to have] better format control so we can pretty-print the -- offending part of the project file. Currently the line wrapping breaks any -- formatting. renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" -- | The project configuration is not allowed to specify program locations for -- programs used by the compiler as these have to be the same for each set of -- packages. -- -- 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) cabal-install-2.4.0.0/Distribution/Client/ProjectConfig/0000755000000000000000000000000000000000000021141 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/ProjectConfig/Legacy.hs0000644000000000000000000015634600000000000022720 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric #-} -- | Project configuration, implementation in terms of legacy types. -- module Distribution.Client.ProjectConfig.Legacy ( -- * Project config in terms of legacy types LegacyProjectConfig, parseLegacyProjectConfig, showLegacyProjectConfig, -- * Conversion to and from legacy config types commandLineFlagsToProjectConfig, convertLegacyProjectConfig, convertLegacyGlobalConfig, convertToLegacyProjectConfig, -- * Internals, just for tests parsePackageLocationTokenQ, renderPackageLocationToken, ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types ( RemoteRepo(..), emptyRemoteRepo , AllowNewer(..), AllowOlder(..) ) import Distribution.Client.Config ( SavedConfig(..), remoteRepoFields ) import Distribution.Solver.Types.ConstraintSource import Distribution.Package import Distribution.PackageDescription ( SourceRepo(..), RepoKind(..) , dispFlagAssignment, parseFlagAssignment ) import Distribution.Client.SourceRepoParse ( sourceRepoFieldDescrs ) 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 , programDbPaths', splitArgs ) 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 Distribution.Text import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( ReadP, (+++), (<++) ) import qualified Text.Read as Read import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ( Doc, ($+$) ) import qualified Distribution.ParseUtils as ParseUtils (field) import Distribution.ParseUtils ( ParseResult(..), PError(..), syntaxError, PWarning(..), warning , simpleField, commaNewLineListField , showToken ) import Distribution.Client.ParseUtils import Distribution.Simple.Command ( CommandUI(commandOptions), ShowOrParseArgs(..) , OptionField, option, reqArg' ) import qualified Data.Map as Map ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types -- -- | We already have parsers\/pretty-printers for almost all the fields in the -- project config file, but they're in terms of the types used for the command -- line flags for Setup.hs or cabal commands. We don't want to redefine them -- all, at least not yet so for the moment we use the parsers at the old types -- and use conversion functions. -- -- Ultimately if\/when this project-based approach becomes the default then we -- can redefine the parsers directly for the new types. -- data LegacyProjectConfig = LegacyProjectConfig { legacyPackages :: [String], legacyPackagesOptional :: [String], legacyPackagesRepo :: [SourceRepo], legacyPackagesNamed :: [Dependency], legacySharedConfig :: LegacySharedConfig, 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 } deriving Generic instance Monoid LegacyPackageConfig where mempty = gmempty mappend = (<>) instance Semigroup LegacyPackageConfig where (<>) = gmappend data LegacySharedConfig = LegacySharedConfig { legacyGlobalFlags :: GlobalFlags, legacyConfigureShFlags :: ConfigFlags, legacyConfigureExFlags :: ConfigExFlags, legacyInstallFlags :: InstallFlags } deriving Generic instance Monoid LegacySharedConfig where mempty = gmempty mappend = (<>) instance Semigroup LegacySharedConfig where (<>) = gmappend ------------------------------------------------------------------ -- Converting from and to the legacy types -- -- | Convert configuration from the @cabal configure@ or @cabal build@ command -- line into a 'ProjectConfig' value that can combined with configuration from -- other sources. -- -- At the moment this uses the legacy command line flag types. See -- 'LegacyProjectConfig' for an explanation. -- commandLineFlagsToProjectConfig :: GlobalFlags -> ConfigFlags -> ConfigExFlags -> InstallFlags -> HaddockFlags -> ProjectConfig commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags = mempty { projectConfigBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags haddockFlags, projectConfigShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags, projectConfigLocalPackages = localConfig, projectConfigAllPackages = allConfig } where (localConfig, allConfig) = splitConfig (convertLegacyPerPackageFlags configFlags installFlags haddockFlags) -- 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, savedConfigureFlags = configFlags, savedConfigureExFlags = configExFlags, savedUserInstallDirs = _, savedGlobalInstallDirs = _, savedUploadFlags = _, savedReportFlags = _, savedHaddockFlags = haddockFlags } = 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 haddockFlags' = defaultHaddockFlags <> haddockFlags configAllPackages = convertLegacyPerPackageFlags configFlags installFlags' haddockFlags' configShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags' installFlags' configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags' haddockFlags' -- | Convert the project config from the legacy types to the 'ProjectConfig' -- and associated types. See 'LegacyProjectConfig' for an explanation of the -- approach. -- convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig convertLegacyProjectConfig LegacyProjectConfig { legacyPackages, legacyPackagesOptional, legacyPackagesRepo, legacyPackagesNamed, legacySharedConfig = LegacySharedConfig globalFlags configShFlags configExFlags installSharedFlags, legacyAllConfig, legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags haddockFlags, 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 where LegacyPackageConfig g i h = legacyAllConfig configLocalPackages = convertLegacyPerPackageFlags configFlags installPerPkgFlags haddockFlags configPackagesShared= convertLegacyAllPackageFlags globalFlags (configFlags <> configShFlags) configExFlags installSharedFlags configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configShFlags installSharedFlags haddockFlags perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags) = convertLegacyPerPackageFlags perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags -- | Helper used by other conversion functions that returns the -- 'ProjectConfigShared' subset of the 'ProjectConfig'. -- convertLegacyAllPackageFlags :: GlobalFlags -> ConfigFlags -> ConfigExFlags -> InstallFlags -> ProjectConfigShared convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags = ProjectConfigShared{..} where GlobalFlags { globalConfigFile = projectConfigConfigFile, globalSandboxConfigFile = _, -- ?? globalRemoteRepos = projectConfigRemoteRepos, globalLocalRepos = projectConfigLocalRepos, 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 } = configExFlags InstallFlags { installProjectFileName = projectConfigProjectFile, installHaddockIndex = projectConfigHaddockIndex, --installReinstall = projectConfigReinstall, --installAvoidReinstalls = projectConfigAvoidReinstalls, --installOverrideReinstall = projectConfigOverrideReinstall, installIndexState = projectConfigIndexState, installMaxBackjumps = projectConfigMaxBackjumps, --installUpgradeDeps = projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, installPerComponent = projectConfigPerComponent, installIndependentGoals = projectConfigIndependentGoals, --installShadowPkgs = projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, installAllowBootLibInstalls = projectConfigAllowBootLibInstalls } = installFlags -- | Helper used by other conversion functions that returns the -- 'PackageConfig' subset of the 'ProjectConfig'. -- convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags -> PackageConfig convertLegacyPerPackageFlags configFlags installFlags haddockFlags = PackageConfig{..} where ConfigFlags { configProgramPaths, configProgramArgs, configProgramPathExtra = packageConfigProgramPathExtra, configVanillaLib = packageConfigVanillaLib, configProfLib = packageConfigProfLib, configSharedLib = packageConfigSharedLib, configStaticLib = packageConfigStaticLib, configDynExe = packageConfigDynExe, 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 -- | Helper used by other conversion functions that returns the -- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'. -- convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags -> InstallFlags -> HaddockFlags -> ProjectConfigBuildOnly convertLegacyBuildOnlyFlags globalFlags configFlags installFlags haddockFlags = ProjectConfigBuildOnly{..} where GlobalFlags { globalCacheDir = projectConfigCacheDir, globalLogsDir = projectConfigLogsDir, globalWorldFile = _, 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 } where globalFlags = GlobalFlags { globalVersion = mempty, globalNumericVersion = mempty, globalConfigFile = projectConfigConfigFile, globalSandboxConfigFile = mempty, globalConstraintsFile = mempty, globalRemoteRepos = projectConfigRemoteRepos, globalCacheDir = projectConfigCacheDir, globalLocalRepos = projectConfigLocalRepos, globalLogsDir = projectConfigLogsDir, globalWorldFile = mempty, globalRequireSandbox = mempty, globalIgnoreSandbox = 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 } 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, installIndependentGoals = projectConfigIndependentGoals, installShadowPkgs = mempty, --projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, 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, installProjectFileName = projectConfigProjectFile } convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig convertToLegacyAllPackageConfig ProjectConfig { projectConfigBuildOnly = ProjectConfigBuildOnly {..}, projectConfigShared = ProjectConfigShared {..} } = LegacyPackageConfig { legacyConfigureFlags = configFlags, legacyInstallPkgFlags= mempty, legacyHaddockFlags = haddockFlags } 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, 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 } haddockFlags = mempty { haddockKeepTempFiles = projectConfigKeepTempFiles } convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig convertToLegacyPerPackageConfig PackageConfig {..} = LegacyPackageConfig { legacyConfigureFlags = configFlags, legacyInstallPkgFlags = installFlags, legacyHaddockFlags = haddockFlags } 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, 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 } 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 } ------------------------------------------------ -- Parsing and showing the project config file -- parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig parseLegacyProjectConfig = parseConfig legacyProjectConfigFieldDescrs legacyPackageConfigSectionDescrs mempty showLegacyProjectConfig :: LegacyProjectConfig -> String showLegacyProjectConfig config = Disp.render $ showConfig legacyProjectConfigFieldDescrs legacyPackageConfigSectionDescrs config $+$ Disp.text "" legacyProjectConfigFieldDescrs :: [FieldDescr LegacyProjectConfig] legacyProjectConfigFieldDescrs = [ newLineListField "packages" (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ legacyPackages (\v flags -> flags { legacyPackages = v }) , newLineListField "optional-packages" (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ legacyPackagesOptional (\v flags -> flags { legacyPackagesOptional = v }) , commaNewLineListField "extra-packages" disp parse legacyPackagesNamed (\v flags -> flags { legacyPackagesNamed = v }) ] ++ map (liftField legacySharedConfig (\flags conf -> conf { legacySharedConfig = flags })) legacySharedConfigFieldDescrs ++ map (liftField legacyLocalConfig (\flags conf -> conf { legacyLocalConfig = flags })) legacyPackageConfigFieldDescrs -- | This is a bit tricky since it has to cover globs which have embedded @,@ -- chars. But we don't just want to parse strictly as a glob since we want to -- allow http urls which don't parse as globs, and possibly some -- system-dependent file paths. So we parse fairly liberally as a token, but -- we allow @,@ inside matched @{}@ braces. -- parsePackageLocationTokenQ :: ReadP r String parsePackageLocationTokenQ = parseHaskellString Parse.<++ parsePackageLocationToken where parsePackageLocationToken :: ReadP r String parsePackageLocationToken = fmap fst (Parse.gather outerTerm) where outerTerm = alternateEither1 outerToken (braces innerTerm) innerTerm = alternateEither innerToken (braces innerTerm) outerToken = Parse.munch1 outerChar >> return () innerToken = Parse.munch1 innerChar >> return () outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',') innerChar c = not (isSpace c || c == '{' || c == '}') braces = Parse.between (Parse.char '{') (Parse.char '}') alternateEither, alternateEither1, alternatePQs, alternate1PQs, alternateQsP, alternate1QsP :: ReadP r () -> ReadP r () -> ReadP r () alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p alternateEither p q = alternateEither1 p q +++ return () alternate1PQs p q = p >> alternateQsP q p alternatePQs p q = alternate1PQs p q +++ return () alternate1QsP q p = Parse.many1 q >> alternatePQs p q alternateQsP q p = alternate1QsP q p +++ return () renderPackageLocationToken :: String -> String renderPackageLocationToken s | needsQuoting = show s | otherwise = s where needsQuoting = not (ok 0 s) || s == "." -- . on its own on a line has special meaning || take 2 s == "--" -- on its own line is comment syntax --TODO: [code cleanup] these "." and "--" escaping issues -- ought to be dealt with systematically in ParseUtils. ok :: Int -> String -> Bool ok n [] = n == 0 ok _ ('"':_) = False ok n ('{':cs) = ok (n+1) cs ok n ('}':cs) = ok (n-1) cs ok n (',':cs) = (n > 0) && ok n cs ok _ (c:_) | isSpace c = False ok n (_ :cs) = ok n cs legacySharedConfigFieldDescrs :: [FieldDescr LegacySharedConfig] legacySharedConfigFieldDescrs = ( liftFields legacyGlobalFlags (\flags conf -> conf { legacyGlobalFlags = flags }) . addFields [ newLineListField "local-repo" showTokenQ parseTokenQ (fromNubList . globalLocalRepos) (\v conf -> conf { globalLocalRepos = toNubList v }), 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" ] . 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 [ commaNewLineListField "constraints" (disp . fst) (fmap (\constraint -> (constraint, constraintSrc)) parse) configExConstraints (\v conf -> conf { configExConstraints = v }) , commaNewLineListField "preferences" disp parse configPreferences (\v conf -> conf { configPreferences = v }) , monoidField "allow-older" (maybe mempty disp) (fmap Just parse) (fmap unAllowOlder . configAllowOlder) (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) , monoidField "allow-newer" (maybe mempty disp) (fmap Just parse) (fmap unAllowNewer . configAllowNewer) (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) ] . filterFields [ "cabal-lib-version", "solver" -- not "constraint" or "preference", we use our own plural ones above ] . commandOptionsToFields ) (configureExOptions ParseArgs constraintSrc) ++ ( liftFields legacyInstallFlags (\flags conf -> conf { legacyInstallFlags = flags }) . addFields [ newLineListField "build-summary" (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) (fromNubList . installSummaryFile) (\v conf -> conf { installSummaryFile = toNubList v }) ] . filterFields [ "doc-index-file" , "root-cmd", "symlink-bindir" , "build-log" , "remote-build-reporting", "report-planning-failure" , "one-shot", "jobs", "keep-going", "offline", "per-component" -- solver flags: , "max-backjumps", "reorder-goals", "count-conflicts", "independent-goals" , "strong-flags" , "allow-boot-library-installs", "index-state" ] . commandOptionsToFields ) (installOptions ParseArgs) where constraintSrc = ConstraintSourceProjectConfig "TODO" legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] legacyPackageConfigFieldDescrs = ( liftFields legacyConfigureFlags (\flags conf -> conf { legacyConfigureFlags = flags }) . addFields [ newLineListField "extra-include-dirs" showTokenQ parseTokenQ configExtraIncludeDirs (\v conf -> conf { configExtraIncludeDirs = v }) , newLineListField "extra-lib-dirs" showTokenQ parseTokenQ configExtraLibDirs (\v conf -> conf { configExtraLibDirs = v }) , newLineListField "extra-framework-dirs" showTokenQ parseTokenQ configExtraFrameworkDirs (\v conf -> conf { configExtraFrameworkDirs = v }) , newLineListField "extra-prog-path" showTokenQ parseTokenQ (fromNubList . configProgramPathExtra) (\v conf -> conf { configProgramPathExtra = toNubList v }) , newLineListField "configure-options" showTokenQ parseTokenQ configConfigureArgs (\v conf -> conf { configConfigureArgs = v }) , simpleField "flags" dispFlagAssignment parseFlagAssignment configConfigurationsFlags (\v conf -> conf { configConfigurationsFlags = v }) ] . filterFields [ "with-compiler", "with-hc-pkg" , "program-prefix", "program-suffix" , "library-vanilla", "library-profiling" , "shared", "static", "executable-dynamic" , "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 [ simpleField "for-hackage" -- TODO: turn this into a library function (fromFlagOrDefault Disp.empty . fmap disp) (Parse.option mempty (fmap toFlag parse)) 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) where overrideFieldCompiler = simpleField "compiler" (fromFlagOrDefault Disp.empty . fmap disp) (Parse.option mempty (fmap toFlag parse)) configHcFlavor (\v flags -> flags { configHcFlavor = v }) -- TODO: [code cleanup] The following is a hack. The "optimization" and -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that. -- Instead of a hand-written parser and printer, we should handle this case -- properly in the library. overrideFieldOptimization = liftField configOptimization (\v flags -> flags { configOptimization = v }) $ let name = "optimization" in FieldDescr name (\f -> case f of Flag NoOptimisation -> Disp.text "False" Flag NormalOptimisation -> Disp.text "True" Flag MaximumOptimisation -> Disp.text "2" _ -> Disp.empty) (\line str _ -> case () of _ | str == "False" -> ParseOk [] (Flag NoOptimisation) | str == "True" -> ParseOk [] (Flag NormalOptimisation) | str == "0" -> ParseOk [] (Flag NoOptimisation) | str == "1" -> ParseOk [] (Flag NormalOptimisation) | str == "2" -> ParseOk [] (Flag MaximumOptimisation) | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation) | otherwise -> ParseFailed (NoParse name line) where lstr = lowercase str caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") overrideFieldDebugInfo = liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ let name = "debug-info" in FieldDescr name (\f -> case f of Flag NoDebugInfo -> Disp.text "False" Flag MinimalDebugInfo -> Disp.text "1" Flag NormalDebugInfo -> Disp.text "True" Flag MaximalDebugInfo -> Disp.text "3" _ -> Disp.empty) (\line str _ -> case () of _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) | str == "True" -> ParseOk [] (Flag NormalDebugInfo) | str == "0" -> ParseOk [] (Flag NoDebugInfo) | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) | str == "2" -> ParseOk [] (Flag NormalDebugInfo) | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) | otherwise -> ParseFailed (NoParse name line) where lstr = lowercase str caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] legacyPackageConfigSectionDescrs = [ packageRepoSectionDescr , packageSpecificOptionsSectionDescr , liftSection legacyLocalConfig (\flags conf -> conf { legacyLocalConfig = flags }) programOptionsSectionDescr , liftSection legacyLocalConfig (\flags conf -> conf { legacyLocalConfig = flags }) programLocationsSectionDescr , liftSection legacySharedConfig (\flags conf -> conf { legacySharedConfig = flags }) $ liftSection legacyGlobalFlags (\flags conf -> conf { legacyGlobalFlags = flags }) remoteRepoSectionDescr ] packageRepoSectionDescr :: SectionDescr LegacyProjectConfig packageRepoSectionDescr = SectionDescr { sectionName = "source-repository-package", sectionFields = sourceRepoFieldDescrs, sectionSubsections = [], sectionGet = map (\x->("", x)) . legacyPackagesRepo, sectionSet = \lineno unused pkgrepo projconf -> do unless (null unused) $ syntaxError lineno "the section 'source-repository-package' takes no arguments" return projconf { legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo] }, sectionEmpty = SourceRepo { repoKind = RepoThis, -- hopefully unused repoType = Nothing, repoLocation = Nothing, repoModule = Nothing, repoBranch = Nothing, repoTag = Nothing, repoSubdir = Nothing } } -- | 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 -> [ (display 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 simpleParse pkgnamestr of Just pkgname -> return pkgname Nothing -> syntaxError lineno $ "a 'package' section requires a package name " ++ "as an argument" return projconf { legacySpecificConfig = MapMappend $ Map.insertWith mappend pkgname pkgconf (getMapMappend $ legacySpecificConfig projconf) }, sectionEmpty = mempty } programOptionsFieldDescrs :: (a -> [(String, [String])]) -> ([(String, [String])] -> a -> a) -> [FieldDescr a] programOptionsFieldDescrs get' set = commandOptionsToFields $ 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 remoteRepoSectionDescr :: SectionDescr GlobalFlags remoteRepoSectionDescr = SectionDescr { sectionName = "repository", sectionFields = remoteRepoFields, sectionSubsections = [], sectionGet = map (\x->(remoteRepoName x, x)) . fromNubList . globalRemoteRepos, sectionSet = \lineno reponame repo0 conf -> do when (null reponame) $ syntaxError lineno $ "a 'repository' section requires the " ++ "repository name as an argument" let repo = repo0 { remoteRepoName = reponame } when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ warning $ "'key-threshold' for repository " ++ show (remoteRepoName repo) ++ " higher than number of keys" when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ warning $ "'root-keys' for repository " ++ show (remoteRepoName repo) ++ " non-empty, but 'secure' not set to True." return conf { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) }, sectionEmpty = emptyRemoteRepo "" } ------------------------------- -- Local field utils -- --TODO: [code cleanup] all these utils should move to Distribution.ParseUtils -- either augmenting or replacing the ones there --TODO: [code cleanup] this is a different definition from listField, like -- commaNewLineListField it pretty prints on multiple lines newLineListField :: String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b newLineListField = listFieldWithSep Disp.sep --TODO: [code cleanup] local copy purely so we can use the fixed version -- of parseOptCommaList below listFieldWithSep :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b listFieldWithSep separator name showF readF get' set = liftField get' set' $ ParseUtils.field name showF' (parseOptCommaList readF) where set' xs b = set (get' b ++ xs) b showF' = separator . map showF -- | Parser combinator for simple fields which uses the field type's -- 'Monoid' instance for combining multiple occurences of the field. monoidField :: Monoid a => String -> (a -> Doc) -> ReadP a a -> (b -> a) -> (a -> b -> b) -> FieldDescr b monoidField name showF readF get' set = liftField get' set' $ ParseUtils.field 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. This version avoid parse ambiguity for list element parsers -- that have multiple valid parses of prefixes. parseOptCommaList :: ReadP r a -> ReadP r [a] parseOptCommaList p = Parse.sepBy p sep where -- The separator must not be empty or it introduces ambiguity sep = (Parse.skipSpaces >> Parse.char ',' >> Parse.skipSpaces) +++ (Parse.satisfy isSpace >> Parse.skipSpaces) --TODO: [code cleanup] local redefinition that should replace the version in -- D.ParseUtils called showFilePath. This version escapes "." and "--" which -- otherwise are special syntax. showTokenQ :: String -> Doc showTokenQ "" = Disp.empty showTokenQ x@('-':'-':_) = Disp.text (show x) showTokenQ x@('.':[]) = Disp.text (show x) showTokenQ x = showToken x -- This is just a copy of parseTokenQ, using the fixed parseHaskellString parseTokenQ :: ReadP r String parseTokenQ = parseHaskellString <++ Parse.munch1 (\x -> not (isSpace x) && x /= ',') --TODO: [code cleanup] use this to replace the parseHaskellString in -- Distribution.ParseUtils. It turns out Read instance for String accepts -- the ['a', 'b'] syntax, which we do not want. In particular it messes -- up any token starting with []. parseHaskellString :: ReadP r String parseHaskellString = Parse.readS_to_P $ Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0 -- Handy util addFields :: [FieldDescr a] -> ([FieldDescr a] -> [FieldDescr a]) addFields = (++) cabal-install-2.4.0.0/Distribution/Client/ProjectConfig/Types.hs0000644000000000000000000004352600000000000022613 0ustar0000000000000000{-# 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.Types ( RemoteRepo, AllowNewer(..), AllowOlder(..) ) import Distribution.Client.Dependency.Types ( PreSolver ) import Distribution.Client.Targets ( UserConstraint ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.IndexUtils.Timestamp ( IndexState ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.ConstraintSource import Distribution.Package ( PackageName, PackageId, UnitId ) import Distribution.Types.Dependency import Distribution.Version ( Version ) import Distribution.System ( Platform ) import Distribution.PackageDescription ( FlagAssignment, SourceRepo(..) ) import Distribution.Simple.Compiler ( Compiler, CompilerFlavor , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup ( Flag, HaddockTarget(..) ) import Distribution.Simple.InstallDirs ( PathTemplate ) import Distribution.Utils.NubList ( NubList ) import Distribution.Verbosity ( Verbosity ) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import Distribution.Compat.Binary (Binary) import Distribution.Compat.Semigroup import GHC.Generics (Generic) import Data.Typeable ------------------------------- -- 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 :: [SourceRepo], -- | Packages in this project from hackage repositories. projectPackagesNamed :: [Dependency], -- See respective types for an explanation of what these -- values are about: projectConfigBuildOnly :: ProjectConfigBuildOnly, projectConfigShared :: ProjectConfigShared, projectConfigProvenance :: Set ProjectConfigProvenance, -- | Configuration to be applied to *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 } 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, projectConfigHcFlavor :: Flag CompilerFlavor, projectConfigHcPath :: Flag FilePath, projectConfigHcPkg :: Flag FilePath, projectConfigHaddockIndex :: Flag PathTemplate, -- Things that only make sense for manual mode, not --local mode -- too much control! --projectConfigUserInstall :: Flag Bool, --projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), --TODO: [required eventually] decide what to do with InstallDirs -- currently we don't allow it to be specified in the config file --projectConfigPackageDBs :: [Maybe PackageDB], -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. projectConfigLocalRepos :: NubList FilePath, projectConfigIndexState :: Flag IndexState, projectConfigStoreDir :: Flag FilePath, -- solver configuration projectConfigConstraints :: [(UserConstraint, ConstraintSource)], projectConfigPreferences :: [Dependency], projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused projectConfigSolver :: Flag PreSolver, projectConfigAllowOlder :: Maybe AllowOlder, projectConfigAllowNewer :: Maybe AllowNewer, projectConfigMaxBackjumps :: Flag Int, projectConfigReorderGoals :: Flag ReorderGoals, projectConfigCountConflicts :: Flag CountConflicts, projectConfigStrongFlags :: Flag StrongFlags, projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, 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, 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 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 } deriving (Eq, Show, Generic) instance Binary ProjectConfig instance Binary ProjectConfigBuildOnly instance Binary ProjectConfigShared instance Binary ProjectConfigProvenance instance Binary PackageConfig -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes -- the last value rather than the first value for overlapping keys. newtype MapLast k v = MapLast { getMapLast :: Map k v } deriving (Eq, Show, Functor, Generic, Binary, Typeable) 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 (Semigroup v, Ord k) => Monoid (MapMappend k v) where mempty = MapMappend Map.empty mappend = (<>) instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b) -- rather than Map.union which is the normal Map monoid instance instance Monoid ProjectConfig where mempty = gmempty mappend = (<>) instance Semigroup ProjectConfig where (<>) = gmappend instance Monoid ProjectConfigBuildOnly where mempty = gmempty mappend = (<>) instance Semigroup ProjectConfigBuildOnly where (<>) = gmappend instance Monoid ProjectConfigShared where mempty = gmempty mappend = (<>) instance Semigroup ProjectConfigShared where (<>) = gmappend instance Monoid PackageConfig where mempty = gmempty mappend = (<>) instance Semigroup PackageConfig where (<>) = gmappend ---------------------------------------- -- Resolving configuration to settings -- -- | Resolved configuration for the solver. The idea is that this is easier to -- use than the raw configuration because in the raw configuration everything -- is optional (monoidial). In the 'BuildTimeSettings' every field is filled -- in, if only with the defaults. -- -- Use 'resolveSolverSettings' to make one from the project config (by -- applying defaults etc). -- data SolverSettings = SolverSettings { solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. solverSettingLocalRepos :: [FilePath], solverSettingConstraints :: [(UserConstraint, ConstraintSource)], solverSettingPreferences :: [Dependency], solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages solverSettingFlagAssignments :: Map PackageName FlagAssignment, solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused solverSettingSolver :: PreSolver, solverSettingAllowOlder :: AllowOlder, solverSettingAllowNewer :: AllowNewer, solverSettingMaxBackjumps :: Maybe Int, solverSettingReorderGoals :: ReorderGoals, solverSettingCountConflicts :: CountConflicts, solverSettingStrongFlags :: StrongFlags, solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, solverSettingIndexState :: Maybe IndexState, 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 -- | 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], buildSettingLocalRepos :: [FilePath], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, buildSettingIgnoreExpiry :: Bool, buildSettingProgPathExtra :: [FilePath] } cabal-install-2.4.0.0/Distribution/Client/ProjectOrchestration.hs0000644000000000000000000013355100000000000023124 0ustar0000000000000000{-# 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? establishProjectBaseContext, 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(..), TargetProblemCommon(..), 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, -- * Shared CLI utils cmdCommonHelpTextNewBuildBeta, ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning hiding ( pruneInstallPlanToTargets ) import qualified Distribution.Client.ProjectPlanning as ProjectPlanning ( pruneInstallPlanToTargets ) import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding import Distribution.Client.ProjectPlanOutput import Distribution.Client.Types ( GenericReadyPackage(..), UnresolvedSourcePackage , PackageSpecifier(..) , SourcePackageDb(..) ) 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.Types.ComponentName ( componentNameString ) import Distribution.Types.UnqualComponentName ( UnqualComponentName, packageNameToUnqualComponentName ) import Distribution.Solver.Types.OptionalStanza import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.PackageDescription ( FlagAssignment, unFlagAssignment, showFlagValue , diffFlagAssignment ) import Distribution.Simple.LocalBuildInfo ( ComponentName(..), pkgComponents ) 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 ) import Distribution.Verbosity import Distribution.Text import Distribution.Simple.Compiler ( showCompilerId , OptimisationLevel(..)) import qualified Data.Monoid as Mon import qualified Data.Set as Set import qualified Data.Map as Map import Data.Either import Control.Exception (Exception(..), throwIO, assert) import System.Exit (ExitCode(..), exitFailure) #ifdef MIN_VERSION_unix import System.Posix.Signals (sigKILL, sigSEGV) #endif -- | 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 } establishProjectBaseContext :: Verbosity -> ProjectConfig -> IO ProjectBaseContext establishProjectBaseContext verbosity cliConfig = do cabalDir <- getCabalDir projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile 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 = Setup.flagToMaybe projectConfigStoreDir cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir buildSettings = resolveBuildTimeSettings verbosity cabalDirLayout projectConfig return ProjectBaseContext { distDirLayout, cabalDirLayout, projectConfig, localPackages, buildSettings } where mdistDirectory = Setup.flagToMaybe projectConfigDistDir mprojectFile = Setup.flagToMaybe projectConfigProjectFile ProjectConfigShared { projectConfigDistDir, projectConfigProjectFile } = projectConfigShared cliConfig -- | This holds the context between the pre-build, build and post-build phases. -- data ProjectBuildContext = ProjectBuildContext { -- | 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 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 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 err [k]) -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) -> ElaboratedInstallPlan -> Maybe (SourcePackageDb) -> [TargetSelector] -> Either [err] TargetsMap resolveTargets selectPackageTargets selectComponentTarget liftProblem installPlan mPkgDb = fmap mkTargetsMap . 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 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 (liftProblem (TargetProblemNoSuchPackage pkgid)) checkTarget (TargetPackage _ _ _) = error "TODO: add support for multiple packages in a directory" -- 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 (liftProblem (TargetProblemNoSuchComponent pkgid cname)) | otherwise = Left (liftProblem (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 (liftProblem (TargetProblemUnknownComponent pkgname ecname)) | otherwise = Left (liftProblem (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 (liftProblem (TargetAvailableInIndex pkgname)) | otherwise = Left (liftProblem (TargetNotInProject pkgname)) componentTargets :: SubComponentTarget -> [(b, ComponentName)] -> [(b, ComponentTarget)] componentTargets subtarget = map (fmap (\cname -> ComponentTarget cname subtarget)) selectComponentTargets :: SubComponentTarget -> [AvailableTarget k] -> Either err [k] selectComponentTargets subtarget = either (Left . head) Right . checkErrors . map (selectComponentTarget subtarget) checkErrors :: [Either e a] -> Either [e] [a] checkErrors = (\(es, xs) -> if null es then Right xs else Left 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 TargetProblemCommon 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 data TargetProblemCommon = 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) -- The target matching stuff only returns packages local to the project, -- so these lookups should never fail, but if 'resolveTargets' is called -- directly then of course it can. | TargetProblemNoSuchPackage PackageId | TargetProblemNoSuchComponent PackageId ComponentName deriving (Eq, Show) -- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts -- for the extra unneeded info in the 'TargetsMap'. -- pruneInstallPlanToTargets :: TargetAction -> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = assert (Map.size targetsMap > 0) $ ProjectPlanning.pruneInstallPlanToTargets targetActionType (Map.map (map fst) targetsMap) elaboratedPlan -- | Utility used by repl and run to check if the targets spans multiple -- components, since those commands do not support multiple components. -- distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) distinctTargetComponents targetsMap = Set.fromList [ (uid, cname) | (uid, cts) <- Map.toList targetsMap , (ComponentTarget cname _, _) <- cts ] ------------------------------------------------------------------------------ -- Displaying what we plan to do -- -- | 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) = " - " ++ (if verbosity >= deafening then display (installedUnitId elab) else display (packageId elab) ) ++ (case elabPkgOrComp elab of ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg) ElabComponent comp -> " (" ++ showComp elab comp ++ ")" ) ++ showFlagAssignment (nonDefaultFlags elab) ++ showConfigureFlags elab ++ let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in " (" ++ showBuildStatus buildStatus ++ ")" showComp elab comp = maybe "custom" display (compComponentName comp) ++ if Map.null (elabInstantiatedWith elab) then "" else " with " ++ intercalate ", " -- TODO: Abbreviate the UnitIds [ display k ++ "=" ++ display v | (k,v) <- Map.toList (elabInstantiatedWith elab) ] nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment nonDefaultFlags 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 ] ++ ")" showFlagAssignment :: FlagAssignment -> String showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment 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 = Mon.mempty { configProf = nubFlag False (configProf fullConfigureFlags), configProfExe = nubFlag tryExeProfiling (configProfExe fullConfigureFlags), configProfLib = nubFlag tryLibProfiling (configProfLib fullConfigureFlags) -- Maybe there are more we can add } -- Not necessary to "escape" it, it's just for user output in unwords . ("":) $ commandShowOptions (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) partialConfigureFlags showBuildStatus status = case status of BuildStatusPreExisting -> "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 -> ElaboratedInstallPlan -> BuildOutcomes -> IO () dieOnBuildFailures verbosity plan buildOutcomes | null failures = return () | isSimpleCase = exitFailure | otherwise = do -- For failures where we have a build log, print the log plus a header sequence_ [ do notice verbosity $ '\n' : renderFailureDetail False pkg reason ++ "\nBuild log ( " ++ logfile ++ " ):" readFile logfile >>= noticeNoWrap verbosity | (pkg, ShowBuildSummaryAndLog reason logfile) <- failuresClassification ] -- For all failures, print either a short summary (if we showed the -- build log) or all details 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 | 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 (ie a -- package with nothing else depending on it) -- - and that failure is of a kind that always reports enough detail -- itself (e.g. ghc reporting errors on stdout) -- - then we do not report additional error detail or context. -- isSimpleCase | [(pkgid, failure)] <- failures , [pkg] <- rootpkgs , installedUnitId pkg == pkgid , isFailureSelfExplanatory (buildFailureReason failure) = True | otherwise = False -- NB: if the Setup script segfaulted or was interrupted, -- we should give more detailed information. So only -- assume that exit code 1 is "pedestrian failure." isFailureSelfExplanatory (BuildFailed e) | Just (ExitFailure 1) <- fromException e = True isFailureSelfExplanatory (ConfigureFailed e) | Just (ExitFailure 1) <- fromException e = True isFailureSelfExplanatory _ = False rootpkgs = [ pkg | InstallPlan.Configured pkg <- InstallPlan.toList plan , hasNoDependents pkg ] ultimateDeps pkgid = filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) (InstallPlan.reverseDependencyClosure plan [pkgid]) hasNoDependents :: HasUnitId pkg => pkg -> Bool hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId renderFailureDetail mentionDepOf pkg reason = renderFailureSummary mentionDepOf pkg reason ++ "." ++ renderFailureExtraDetail reason ++ maybe "" showException (buildFailureException reason) renderFailureSummary mentionDepOf pkg reason = case reason of DownloadFailed _ -> "Failed to download " ++ pkgstr UnpackFailed _ -> "Failed to unpack " ++ pkgstr ConfigureFailed _ -> "Failed to build " ++ pkgstr BuildFailed _ -> "Failed to build " ++ pkgstr ReplFailed _ -> "repl failed for " ++ pkgstr HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr TestsFailed _ -> "Tests failed for " ++ pkgstr BenchFailed _ -> "Benchmarks failed for " ++ pkgstr InstallFailed _ -> "Failed to build " ++ pkgstr DependentFailed depid -> "Failed to build " ++ display (packageId pkg) ++ " because it depends on " ++ display depid ++ " which itself failed to build" where pkgstr = elabConfiguredName verbosity pkg ++ if mentionDepOf then renderDependencyOf (installedUnitId pkg) else "" renderFailureExtraDetail reason = case reason of ConfigureFailed _ -> " The failure occurred during the configure step." InstallFailed _ -> " The failure occurred during the final install step." _ -> "" renderDependencyOf pkgid = case ultimateDeps pkgid of [] -> "" (p1:[]) -> " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" (p1:p2:[]) -> " (which is required by " ++ elabPlanPackageName verbosity p1 ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" (p1:p2:_) -> " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ", " ++ elabPlanPackageName verbosity p2 ++ " and others)" showException e = case fromException e of Just (ExitFailure 1) -> "" #ifdef MIN_VERSION_unix -- Note [Positive "signal" exit code] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- What's the business with the test for negative and positive -- signal values? The API for process specifies that if the -- process died due to a signal, it returns a *negative* exit -- code. So that's the negative test. -- -- What about the positive test? Well, when we find out that -- a process died due to a signal, we ourselves exit with that -- exit code. However, we don't "kill ourselves" with the -- signal; we just exit with the same code as the signal: thus -- the caller sees a *positive* exit code. So that's what -- happens when we get a positive exit code. Just (ExitFailure n) | -n == fromIntegral sigSEGV -> " The build process segfaulted (i.e. SIGSEGV)." | n == fromIntegral sigSEGV -> " The build process terminated with exit code " ++ show n ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." | -n == fromIntegral sigKILL -> " The build process was killed (i.e. SIGKILL). " ++ explanation | n == fromIntegral sigKILL -> " The build process terminated with exit code " ++ show n ++ " which may be because some part of it was killed " ++ "(i.e. SIGKILL). " ++ explanation where 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 cmdCommonHelpTextNewBuildBeta :: String cmdCommonHelpTextNewBuildBeta = "Note: this command is part of the new project-based system (aka " ++ "nix-style\nlocal builds). These features are currently in beta. " ++ "Please see\n" ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " ++ "for\ndetails and advice on what you can expect to work. If you " ++ "encounter problems\nplease file issues at " ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " ++ "to get involved and help with testing, fixing bugs etc then\nthat " ++ "is very much appreciated.\n" cabal-install-2.4.0.0/Distribution/Client/ProjectPlanOutput.hs0000644000000000000000000012202100000000000022401 0ustar0000000000000000{-# 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(..), RemoteRepo(..), PackageLocation(..), confInstId) import Distribution.Client.PackageHash (showHashValue) 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.Text import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Binary as Binary import Distribution.Simple.Utils import Distribution.Verbosity import qualified Paths_cabal_install as Our (version) import Prelude () import Distribution.Client.Compat.Prelude import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as BB import System.FilePath import System.IO 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 Our.version , "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 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-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 RepoLocal{..} -> J.object [ "type" J..= J.String "local-repo" , "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 :: PD.SourceRepo -> J.Value sourceRepoToJ PD.SourceRepo{..} = J.object $ filter ((/= J.Null) . snd) $ [ "type" J..= fmap jdisplay repoType , "location" J..= fmap J.String repoLocation , "module" J..= fmap J.String repoModule , "branch" J..= fmap J.String repoBranch , "tag" J..= fmap J.String repoTag , "subdir" J..= fmap J.String repoSubdir ] 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 _ -> [] bin_file' s = ["bin-file" J..= J.String bin] where bin = if elabBuildStyle elab == BuildInplaceOnly then dist_dir "build" display s display s else InstallDirs.bindir (elabInstallDirs elab) display s -- TODO: maybe move this helper to "ComponentDeps" module? -- Or maybe define a 'Text' instance? comp2str :: ComponentDeps.Component -> String comp2str c = case c of ComponentDeps.ComponentLib -> "lib" ComponentDeps.ComponentSubLib s -> "lib:" <> display s ComponentDeps.ComponentFLib s -> "flib:" <> display s ComponentDeps.ComponentExe s -> "exe:" <> display s ComponentDeps.ComponentTest s -> "test:" <> display s ComponentDeps.ComponentBench s -> "bench:" <> display s ComponentDeps.ComponentSetup -> "setup" style2str :: Bool -> BuildStyle -> String style2str True _ = "local" style2str False BuildInplaceOnly = "inplace" style2str False BuildAndInstall = "global" jdisplay :: Text a => a -> J.Value jdisplay = J.String . display ----------------------------------------------------------------------------- -- Project status -- -- So, what is the status of a project after a build? That is, how do the -- inputs (package source files etc) compare to the output artefacts (build -- libs, exes etc)? Do the outputs reflect the current values of the inputs -- or are outputs out of date or invalid? -- -- First of all, what do we mean by out-of-date and what do we mean by -- invalid? We think of the build system as a morally pure function that -- computes the output artefacts given input values. We say an output artefact -- is out of date when its value is not the value that would be computed by a -- build given the current values of the inputs. An output artefact can be -- out-of-date but still be perfectly usable; it simply correspond to a -- previous state of the inputs. -- -- On the other hand there are cases where output artefacts cannot safely be -- used. For example libraries and dynamically linked executables cannot be -- used when the libs they depend on change without them being recompiled -- themselves. Whether an artefact is still usable depends on what it is, e.g. -- dynamically linked vs statically linked and on how it gets updated (e.g. -- only atomically on success or if failure can leave invalid states). We need -- a definition (or two) that is independent of the kind of artefact and can -- be computed just in terms of changes in package graphs, but are still -- useful for determining when particular kinds of artefacts are invalid. -- -- Note that when we talk about packages in this context we just mean nodes -- in the elaborated install plan, which can be components or packages. -- -- There's obviously a close connection between packages being out of date and -- their output artefacts being unusable: most of the time if a package -- remains out of date at the end of a build then some of its output artefacts -- will be unusable. That is true most of the time because a build will have -- attempted to build one of the out-of-date package's dependencies. If the -- build of the dependency succeeded then it changed output artefacts (like -- libs) and if it failed then it may have failed after already changing -- things (think failure after updating some but not all .hi files). -- -- There are a few reasons we may end up with still-usable output artefacts -- for a package even when it remains out of date at the end of a build. -- Firstly if executing a plan fails then packages can be skipped, and thus we -- may have packages where all their dependencies were skipped. Secondly we -- have artefacts like statically linked executables which are not affected by -- libs they depend on being recompiled. Furthermore, packages can be out of -- date due to changes in build tools or Setup.hs scripts they depend on, but -- again libraries or executables in those out-of-date packages remain usable. -- -- So we have two useful definitions of invalid. Both are useful, for -- different purposes, so we will compute both. The first corresponds to the -- invalid libraries and dynamic executables. We say a package is invalid by -- changed deps if any of the packages it depends on (via library dep edges) -- were rebuilt (successfully or unsuccessfully). The second definition -- corresponds to invalid static executables. We say a package is invalid by -- a failed build simply if the package was built but unsuccessfully. -- -- So how do we find out what packages are out of date or invalid? -- -- Obviously we know something for all the packages that were part of the plan -- that was executed, but that is just a subset since we prune the plan down -- to the targets and their dependencies. -- -- Recall the steps we go though: -- -- + starting with the initial improved plan (this is the full project); -- -- + prune the plan to the user's build targets; -- -- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap -- covering the pruned subset of the original plan; -- -- + execute the plan giving us BuildOutcomes which tell us success/failure -- for each package. -- -- So given that the BuildStatusMap and BuildOutcomes do not cover everything -- in the original plan, what can they tell us about the original plan? -- -- The BuildStatusMap tells us directly that some packages are up to date and -- others out of date (but only for the pruned subset). But we know that -- everything that is a reverse dependency of an out-of-date package is itself -- out-of-date (whether or not it is in the pruned subset). Of course after -- a build the BuildOutcomes may tell us that some of those out-of-date -- packages are now up to date (ie a successful build outcome). -- -- The difference is packages that are reverse dependencies of out-of-date -- packages but are not brought up-to-date by the build (i.e. did not have -- successful outcomes, either because they failed or were not in the pruned -- subset to be built). We also know which packages were rebuilt, so we can -- use this to find the now-invalid packages. -- -- Note that there are still packages for which we cannot discover full status -- information. There may be packages outside of the pruned plan that do not -- depend on packages within the pruned plan that were discovered to be -- out-of-date. For these packages we do not know if their build artefacts -- are out-of-date or not. We do know however that they are not invalid, as -- that's not possible given our definition of invalid. Intuitively it is -- because we have not disturbed anything that these packages depend on, e.g. -- we've not rebuilt any libs they depend on. Recall that our widest -- definition of invalid was only concerned about dependencies on libraries -- (to cover problems like shared libs or GHC seeing inconsistent .hi files). -- -- So our algorithm for out-of-date packages is relatively simple: take the -- reverse dependency closure in the original improved plan (pre-pruning) of -- the out-of-date packages (as determined by the BuildStatusMap from the dry -- run). That gives a set of packages that were definitely out of date after -- the dry run. Now we remove from this set the packages that the -- BuildOutcomes tells us are now up-to-date after the build. The remaining -- set is the out-of-date packages. -- -- As for packages that are invalid by changed deps, we start with the plan -- dependency graph but keep only those edges that point to libraries (so -- ignoring deps on exes and setup scripts). We take the packages for which a -- build was attempted (successfully or unsuccessfully, but not counting -- knock-on failures) and take the reverse dependency closure. We delete from -- this set all the packages that were built successfully. Note that we do not -- need to intersect with the out-of-date packages since this follows -- automatically: all rev deps of packages we attempted to build must have -- been out of date at the start of the build, and if they were not built -- successfully then they're still out of date -- meeting our definition of -- invalid. type PackageIdSet = Set UnitId type PackagesUpToDate = PackageIdSet data PostBuildProjectStatus = PostBuildProjectStatus { -- | Packages that are known to be up to date. These were found to be -- up to date before the build, or they have a successful build outcome -- afterwards. -- -- This does not include any packages outside of the subset of the plan -- that was executed because we did not check those and so don't know -- for sure that they're still up to date. -- packagesDefinitelyUpToDate :: PackageIdSet, -- | Packages that are probably still up to date (and at least not -- known to be out of date, and certainly not invalid). This includes -- 'packagesDefinitelyUpToDate' plus packages that were up to date -- previously and are outside of the subset of the plan that was -- executed. It excludes 'packagesOutOfDate'. -- packagesProbablyUpToDate :: PackageIdSet, -- | Packages that are known to be out of date. These are packages -- that were determined to be out of date before the build, and they -- do not have a successful build outcome afterwards. -- -- Note that this can sometimes include packages outside of the subset -- of the plan that was executed. For example suppose package A and B -- depend on C, and A is the target so only A and C are in the subset -- to be built. Now suppose C is found to have changed, then both A -- and B are out-of-date before the build and since B is outside the -- subset to be built then it will remain out of date. -- -- Note also that this is /not/ the inverse of -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. -- There are packages where we have no information (ones that were not -- in the subset of the plan that was executed). -- packagesOutOfDate :: PackageIdSet, -- | Packages that depend on libraries that have changed during the -- build (either build success or failure). -- -- This corresponds to the fact that libraries and dynamic executables -- are invalid once any of the libs they depend on change. -- -- This does include packages that themselves failed (i.e. it is a -- superset of 'packagesInvalidByFailedBuild'). It does not include -- changes in dependencies on executables (i.e. build tools). -- packagesInvalidByChangedLibDeps :: PackageIdSet, -- | Packages that themselves failed during the build (i.e. them -- directly not a dep). -- -- This corresponds to the fact that static executables are invalid -- in unlucky circumstances such as linking failing half way though, -- or data file generation failing. -- -- This is a subset of 'packagesInvalidByChangedLibDeps'. -- packagesInvalidByFailedBuild :: PackageIdSet, -- | A subset of the plan graph, including only dependency-on-library -- edges. That is, dependencies /on/ libraries, not dependencies /of/ -- libraries. This tells us all the libraries that packages link to. -- -- This is here as a convenience, as strictly speaking it's not status -- as it's just a function of the original 'ElaboratedInstallPlan'. -- packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage), -- | As a convenience for 'Set.intersection' with any of the other -- 'PackageIdSet's to select only packages that are part of the -- project locally (i.e. with a local source dir). -- packagesBuildLocal :: PackageIdSet, -- | As a convenience for 'Set.intersection' with any of the other -- 'PackageIdSet's to select only packages that are being built -- in-place within the project (i.e. not destined for the store). -- packagesBuildInplace :: PackageIdSet, -- | As a convenience for 'Set.intersection' or 'Set.difference' with -- any of the other 'PackageIdSet's to select only packages that were -- pre-installed or already in the store prior to the build. -- packagesAlreadyInStore :: PackageIdSet } -- | Work out which packages are out of date or invalid after a build. -- postBuildProjectStatus :: ElaboratedInstallPlan -> PackagesUpToDate -> BuildStatusMap -> BuildOutcomes -> PostBuildProjectStatus postBuildProjectStatus plan previousPackagesUpToDate pkgBuildStatus buildOutcomes = PostBuildProjectStatus { packagesDefinitelyUpToDate, packagesProbablyUpToDate, packagesOutOfDate, packagesInvalidByChangedLibDeps, packagesInvalidByFailedBuild, -- convenience stuff packagesLibDepGraph, packagesBuildLocal, packagesBuildInplace, packagesAlreadyInStore } where packagesDefinitelyUpToDate = packagesUpToDatePreBuild `Set.union` packagesSuccessfulPostBuild packagesProbablyUpToDate = packagesDefinitelyUpToDate `Set.union` (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) packagesOutOfDate = packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild packagesInvalidByChangedLibDeps = packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild packagesInvalidByFailedBuild = packagesFailurePostBuild -- Note: if any of the intermediate values below turn out to be useful in -- their own right then we can simply promote them to the result record -- The previous set of up-to-date packages will contain bogus package ids -- when the solver plan or config contributing to the hash changes. -- So keep only the ones where the package id (i.e. hash) is the same. previousPackagesUpToDate' = Set.intersection previousPackagesUpToDate (InstallPlan.keysSet plan) packagesUpToDatePreBuild = Set.filter (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) -- For packages not in the plan subset we did the dry-run on we don't -- know anything about their status, so not known to be /up to date/. (InstallPlan.keysSet plan) packagesOutOfDatePreBuild = Set.fromList . map installedUnitId $ InstallPlan.reverseDependencyClosure plan [ ipkgid | pkg <- InstallPlan.toList plan , let ipkgid = installedUnitId pkg , lookupBuildStatusRequiresBuild False ipkgid -- For packages not in the plan subset we did the dry-run on we don't -- know anything about their status, so not known to be /out of date/. ] packagesSuccessfulPostBuild = Set.fromList [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ] -- direct failures, not failures due to deps packagesFailurePostBuild = Set.fromList [ ikgid | (ikgid, Left failure) <- Map.toList buildOutcomes , case buildFailureReason failure of DependentFailed _ -> False _ -> True ] -- Packages that have a library dependency on a package for which a build -- was attempted packagesDepOnChangedLib = Set.fromList . map Graph.nodeKey $ fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ Graph.revClosure packagesLibDepGraph ( Map.keys . Map.filter (uncurry buildAttempted) $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes ) -- The plan graph but only counting dependency-on-library edges packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) packagesLibDepGraph = Graph.fromDistinctList [ Graph.N pkg (installedUnitId pkg) libdeps | pkg <- InstallPlan.toList plan , let libdeps = case pkg of InstallPlan.PreExisting ipkg -> installedDepends ipkg InstallPlan.Configured srcpkg -> elabLibDeps srcpkg InstallPlan.Installed srcpkg -> elabLibDeps srcpkg ] elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies -- Was a build was attempted for this package? -- If it doesn't have both a build status and outcome then the answer is no. buildAttempted :: BuildStatus -> BuildOutcome -> Bool -- And not if it didn't need rebuilding in the first place. buildAttempted buildStatus _buildOutcome | not (buildStatusRequiresBuild buildStatus) = False -- And not if it was skipped due to a dep failing first. buildAttempted _ (Left BuildFailure {buildFailureReason}) | DependentFailed _ <- buildFailureReason = False -- Otherwise, succeeded or failed, yes the build was tried. buildAttempted _ (Left BuildFailure {}) = True buildAttempted _ (Right _) = True lookupBuildStatusRequiresBuild def ipkgid = case Map.lookup ipkgid pkgBuildStatus of Nothing -> def -- Not in the plan subset we did the dry-run on Just buildStatus -> buildStatusRequiresBuild buildStatus packagesBuildLocal = selectPlanPackageIdSet $ \pkg -> case pkg of InstallPlan.PreExisting _ -> False InstallPlan.Installed _ -> False InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg packagesBuildInplace = selectPlanPackageIdSet $ \pkg -> case pkg of InstallPlan.PreExisting _ -> False InstallPlan.Installed _ -> False InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg == BuildInplaceOnly packagesAlreadyInStore = selectPlanPackageIdSet $ \pkg -> case pkg of InstallPlan.PreExisting _ -> True InstallPlan.Installed _ -> True InstallPlan.Configured _ -> False selectPlanPackageIdSet p = Map.keysSet . Map.filter p $ InstallPlan.toMap plan updatePostBuildProjectStatus :: Verbosity -> DistDirLayout -> ElaboratedInstallPlan -> BuildStatusMap -> BuildOutcomes -> IO PostBuildProjectStatus updatePostBuildProjectStatus verbosity distDirLayout elaboratedInstallPlan pkgsBuildStatus buildOutcomes = do -- Read the previous up-to-date set, update it and write it back previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout let currentBuildStatus@PostBuildProjectStatus{..} = postBuildProjectStatus elaboratedInstallPlan previousUpToDate pkgsBuildStatus buildOutcomes let currentUpToDate = packagesProbablyUpToDate writePackagesUpToDateCacheFile distDirLayout currentUpToDate -- Report various possibly interesting things -- We additionally intersect with the packagesBuildInplace so that -- we don't show huge numbers of boring packages from the store. debugNoWrap verbosity $ "packages definitely up to date: " ++ displayPackageIdSet (packagesDefinitelyUpToDate `Set.intersection` packagesBuildInplace) debugNoWrap verbosity $ "packages previously probably up to date: " ++ displayPackageIdSet (previousUpToDate `Set.intersection` packagesBuildInplace) debugNoWrap verbosity $ "packages now probably up to date: " ++ displayPackageIdSet (packagesProbablyUpToDate `Set.intersection` packagesBuildInplace) debugNoWrap verbosity $ "packages newly up to date: " ++ displayPackageIdSet (packagesDefinitelyUpToDate `Set.difference` previousUpToDate `Set.intersection` packagesBuildInplace) debugNoWrap verbosity $ "packages out to date: " ++ displayPackageIdSet (packagesOutOfDate `Set.intersection` packagesBuildInplace) debugNoWrap verbosity $ "packages invalid due to dep change: " ++ displayPackageIdSet packagesInvalidByChangedLibDeps debugNoWrap verbosity $ "packages invalid due to build failure: " ++ displayPackageIdSet packagesInvalidByFailedBuild return currentBuildStatus where displayPackageIdSet = intercalate ", " . map display . Set.toList -- | Helper for reading the cache file. -- -- This determines the type and format of the binary cache file. -- readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = handleDoesNotExist Set.empty $ handleDecodeFailure $ withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> Binary.decodeOrFailIO =<< BS.hGetContents hnd where handleDecodeFailure = fmap (either (const Set.empty) id) -- | Helper for writing the package up-to-date cache file. -- -- This determines the type and format of the binary cache file. -- writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = writeFileAtomic (distProjectCacheFile "up-to-date") $ Binary.encode upToDate -- | 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", display 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 cabal-install-2.4.0.0/Distribution/Client/ProjectPlanning.hs0000644000000000000000000051025300000000000022044 0ustar0000000000000000{-# 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 ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.ProjectPlanning.Types as Ty import Distribution.Client.PackageHash import Distribution.Client.RebuildMonad import Distribution.Client.Store import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanOutput import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Dependency import Distribution.Client.Dependency.Types import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Client.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.ModuleName import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.Types.AnnotatedId import Distribution.Types.ComponentName import Distribution.Types.PkgconfigDependency import Distribution.Types.UnqualComponentName import Distribution.System import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Compiler hiding (Flag) import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate import Distribution.Simple.Program import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault) import qualified Distribution.Simple.Configure as Cabal import qualified Distribution.Simple.LocalBuildInfo as Cabal import Distribution.Simple.LocalBuildInfo ( Component(..), pkgComponents, componentBuildInfo , componentName ) import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Backpack.ConfiguredComponent import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ModuleShape import Distribution.Backpack.FullUnitId import Distribution.Backpack import Distribution.Types.ComponentInclude import Distribution.Simple.Utils import Distribution.Version import Distribution.Verbosity import Distribution.Text import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph(IsNode(..)) import Text.PrettyPrint hiding ((<>)) import qualified Text.PrettyPrint as Disp import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Control.Monad import qualified Data.Traversable as T import Control.Monad.State as State import Control.Exception import Data.List (groupBy) import Data.Either import Data.Function import System.FilePath ------------------------------------------------------------------------------ -- * Elaborated install plan ------------------------------------------------------------------------------ -- "Elaborated" -- worked out with great care and nicety of detail; -- executed with great minuteness: elaborate preparations; -- elaborate care. -- -- So here's the idea: -- -- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc -- all passed in as separate args and which are then further selected, -- transformed etc during the execution of the build. Instead we construct -- an elaborated install plan that includes everything we will need, and then -- during the execution of the plan we do as little transformation of this -- info as possible. -- -- So we're trying to split the work into two phases: construction of the -- elaborated install plan (which as far as possible should be pure) and -- then simple execution of that plan without any smarts, just doing what the -- plan says to do. -- -- So that means we need a representation of this fully elaborated install -- plan. The representation consists of two parts: -- -- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a -- representation of source packages that includes a lot more detail about -- that package's individual configuration -- -- * A 'ElaboratedSharedConfig'. Some package configuration is the same for -- every package in a plan. Rather than duplicate that info every entry in -- the 'GenericInstallPlan' we keep that separately. -- -- The division between the shared and per-package config is /not set in stone -- for all time/. For example if we wanted to generalise the install plan to -- describe a situation where we want to build some packages with GHC and some -- with GHCJS then the platform and compiler would no longer be shared between -- all packages but would have to be per-package (probably with some sanity -- condition on the graph structure). -- -- Refer to ProjectPlanning.Types for details of these important types: -- type ElaboratedInstallPlan = ... -- type ElaboratedPlanPackage = ... -- data ElaboratedSharedConfig = ... -- data ElaboratedConfiguredPackage = ... -- data BuildStyle = -- | Check that an 'ElaboratedConfiguredPackage' actually makes -- sense under some 'ElaboratedSharedConfig'. sanityCheckElaboratedConfiguredPackage :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> a -> a sanityCheckElaboratedConfiguredPackage sharedConfig elab@ElaboratedConfiguredPackage{..} = (case elabPkgOrComp of ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg ElabComponent comp -> sanityCheckElaboratedComponent elab comp) -- either a package is being built inplace, or the -- 'installedPackageId' we assigned is consistent with -- the 'hashedInstalledPackageId' we would compute from -- the elaborated configured package . assert (elabBuildStyle == BuildInplaceOnly || elabComponentId == hashedInstalledPackageId (packageHashInputs sharedConfig elab)) -- the stanzas explicitly disabled should not be available . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested) `Set.intersection` elabStanzasAvailable)) -- either a package is built inplace, or we are not attempting to -- build any test suites or benchmarks (we never build these -- for remote packages!) . assert (elabBuildStyle == BuildInplaceOnly || Set.null elabStanzasAvailable) sanityCheckElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> a -> a sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} ElaboratedComponent{..} = -- Should not be building bench or test if not inplace. assert (elabBuildStyle == BuildInplaceOnly || case compComponentName of Nothing -> True Just CLibName -> True Just (CSubLibName _) -> True Just (CExeName _) -> True -- This is interesting: there's no way to declare a dependency -- on a foreign library at the moment, but you may still want -- to install these to the store Just (CFLibName _) -> True Just (CBenchName _) -> False Just (CTestName _) -> False) sanityCheckElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> a -> a sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} ElaboratedPackage{..} = -- we should only have enabled stanzas that actually can be built -- (according to the solver) assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable) -- the stanzas that the user explicitly requested should be -- enabled (by the previous test, they are also available) . assert (Map.keysSet (Map.filter id elabStanzasRequested) `Set.isSubsetOf` pkgStanzasEnabled) ------------------------------------------------------------------------------ -- * Deciding what to do: making an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------ -- | Return the up-to-date project config and information about the local -- packages within the project. -- rebuildProjectConfig :: Verbosity -> DistDirLayout -> ProjectConfig -> IO ( ProjectConfig , [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 ) -- ^ @(improvedPlan, elaboratedPlan, _, _)@ rebuildInstallPlan verbosity distDirLayout@DistDirLayout { distProjectRootDirectory, distProjectCacheFile } CabalDirLayout { cabalStoreDirLayout } = \projectConfig localPackages -> runRebuild distProjectRootDirectory $ do progsearchpath <- liftIO $ getSystemSearchPath let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } -- The overall improved plan is cached rerunIfChanged verbosity fileMonitorImprovedPlan -- react to changes in the project config, -- the package .cabal files and the path (projectConfigMonitored, localPackages, progsearchpath) $ do -- And so is the elaborated plan that the improved plan based on (elaboratedPlan, elaboratedShared) <- rerunIfChanged verbosity fileMonitorElaboratedPlan (projectConfigMonitored, localPackages, progsearchpath) $ do compilerEtc <- phaseConfigureCompiler projectConfig _ <- phaseConfigurePrograms projectConfig compilerEtc (solverPlan, pkgConfigDB) <- phaseRunSolver projectConfig compilerEtc localPackages (elaboratedPlan, elaboratedShared) <- phaseElaboratePlan projectConfig compilerEtc pkgConfigDB solverPlan localPackages phaseMaintainPlanOutputs elaboratedPlan elaboratedShared return (elaboratedPlan, elaboratedShared) -- The improved plan changes each time we install something, whereas -- the underlying elaborated plan only changes when input config -- changes, so it's worth caching them separately. improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared return (improvedPlan, elaboratedPlan, elaboratedShared) where fileMonitorCompiler = newFileMonitorInCacheDir "compiler" fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile -- Configure the compiler we're using. -- -- This is moderately expensive and doesn't change that often so we cache -- it independently. -- phaseConfigureCompiler :: ProjectConfig -> Rebuild (Compiler, Platform, ProgramDb) phaseConfigureCompiler ProjectConfig { projectConfigShared = ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg }, projectConfigLocalPackages = PackageConfig { packageConfigProgramPaths, packageConfigProgramArgs, packageConfigProgramPathExtra } } = do progsearchpath <- liftIO $ getSystemSearchPath rerunIfChanged verbosity fileMonitorCompiler (hcFlavor, hcPath, hcPkg, progsearchpath, packageConfigProgramPaths, packageConfigProgramArgs, packageConfigProgramPathExtra) $ do liftIO $ info verbosity "Compiler settings changed, reconfiguring..." result@(_, _, progdb') <- liftIO $ Cabal.configCompilerEx hcFlavor hcPath hcPkg progdb verbosity -- Note that we added the user-supplied program locations and args -- for /all/ programs, not just those for the compiler prog and -- compiler-related utils. In principle we don't know which programs -- the compiler will configure (and it does vary between compilers). -- We do know however that the compiler will only configure the -- programs it cares about, and those are the ones we monitor here. monitorFiles (programsMonitorFiles progdb') return result where hcFlavor = flagToMaybe projectConfigHcFlavor hcPath = flagToMaybe projectConfigHcPath hcPkg = flagToMaybe projectConfigHcPkg progdb = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) . modifyProgramSearchPath (++ [ ProgramSearchPathDir dir | dir <- fromNubList packageConfigProgramPathExtra ]) $ defaultProgramDb -- Configuring other programs. -- -- Having configred the compiler, now we configure all the remaining -- programs. This is to check we can find them, and to monitor them for -- changes. -- -- TODO: [required eventually] we don't actually do this yet. -- -- We rely on the fact that the previous phase added the program config for -- all local packages, but that all the programs configured so far are the -- compiler program or related util programs. -- phaseConfigurePrograms :: ProjectConfig -> (Compiler, Platform, ProgramDb) -> Rebuild () phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do -- Users are allowed to specify program locations independently for -- each package (e.g. to use a particular version of a pre-processor -- for some packages). However they cannot do this for the compiler -- itself as that's just not going to work. So we check for this. liftIO $ checkBadPerPackageCompilerPaths (configuredPrograms compilerprogdb) (getMapMappend (projectConfigSpecificPackage projectConfig)) --TODO: [required eventually] find/configure other programs that the -- user specifies. --TODO: [required eventually] find/configure all build-tools -- but note that some of them may be built as part of the plan. -- Run the solver to get the initial install plan. -- This is expensive so we cache it independently. -- phaseRunSolver :: ProjectConfig -> (Compiler, Platform, ProgramDb) -> [PackageSpecifier UnresolvedSourcePackage] -> Rebuild (SolverInstallPlan, PkgConfigDb) phaseRunSolver projectConfig@ProjectConfig { projectConfigShared, projectConfigBuildOnly } (compiler, platform, progdb) localPackages = rerunIfChanged verbosity fileMonitorSolverPlan (solverSettings, localPackages, localPackagesEnabledStanzas, compiler, platform, programDbSignature progdb) $ do installedPkgIndex <- getInstalledPackages verbosity compiler progdb platform corePackageDbs sourcePkgDb <- getSourcePackages verbosity withRepoCtx (solverSettingIndexState solverSettings) pkgConfigDB <- getPkgConfigDb verbosity progdb --TODO: [code cleanup] it'd be better if the Compiler contained the -- ConfiguredPrograms that it needs, rather than relying on the progdb -- since we don't need to depend on all the programs here, just the -- ones relevant for the compiler. liftIO $ do solver <- chooseSolver verbosity (solverSettingSolver solverSettings) (compilerInfo compiler) notice verbosity "Resolving dependencies..." plan <- foldProgress logMsg (die' verbosity) return $ planPackages verbosity compiler platform solver solverSettings installedPkgIndex sourcePkgDb pkgConfigDB localPackages localPackagesEnabledStanzas return (plan, pkgConfigDB) where corePackageDbs = [GlobalPackageDB] withRepoCtx = projectConfigWithSolverRepoContext verbosity projectConfigShared projectConfigBuildOnly solverSettings = resolveSolverSettings projectConfig logMsg message rest = debugNoWrap verbosity message >> rest localPackagesEnabledStanzas = Map.fromList [ (pkgname, stanzas) | pkg <- localPackages , let pkgname = pkgSpecifierTarget pkg testsEnabled = lookupLocalPackageConfig packageConfigTests projectConfig pkgname benchmarksEnabled = lookupLocalPackageConfig packageConfigBenchmarks projectConfig pkgname stanzas = Map.fromList $ [ (TestStanzas, enabled) | enabled <- flagToList testsEnabled ] ++ [ (BenchStanzas , enabled) | enabled <- flagToList benchmarksEnabled ] ] -- Elaborate the solver's install plan to get a fully detailed plan. This -- version of the plan has the final nix-style hashed ids. -- phaseElaboratePlan :: ProjectConfig -> (Compiler, Platform, ProgramDb) -> PkgConfigDb -> SolverInstallPlan -> [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 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.IndexState -> Rebuild SourcePackageDb getSourcePackages verbosity withRepoCtx idxState = do (sourcePkgDb, repos) <- liftIO $ withRepoCtx $ \repoctx -> do sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState return (sourcePkgDb, repoContextRepos repoctx) mapM_ needIfExists . IndexUtils.getSourcePackagesMonitorFiles $ repos return sourcePkgDb getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb getPkgConfigDb verbosity progdb = do dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb -- Just monitor the dirs so we'll notice new .pc files. -- Alternatively we could monitor all the .pc files too. mapM_ monitorDirectoryStatus dirs liftIO $ readPkgConfigDb verbosity progdb -- | Select the config values to monitor for changes package source hashes. packageLocationsSignature :: SolverInstallPlan -> [(PackageId, PackageLocation (Maybe FilePath))] packageLocationsSignature solverPlan = [ (packageId pkg, packageSource pkg) | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) <- SolverInstallPlan.toList solverPlan ] -- | Get the 'HashValue' for all the source packages where we use hashes, -- and download any packages required to do so. -- -- Note that we don't get hashes for local unpacked packages. -- getPackageSourceHashes :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a) -> SolverInstallPlan -> Rebuild (Map PackageId PackageSourceHash) getPackageSourceHashes verbosity withRepoCtx solverPlan = do -- Determine if and where to get the package's source hash from. -- let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] allPkgLocations = [ (packageId pkg, packageSource pkg) | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) <- SolverInstallPlan.toList solverPlan ] -- Tarballs that were local in the first place. -- We'll hash these tarball files directly. localTarballPkgs :: [(PackageId, FilePath)] localTarballPkgs = [ (pkgid, tarball) | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] -- Tarballs from remote URLs. We must have downloaded these already -- (since we extracted the .cabal file earlier) --TODO: [required eventually] finish remote tarball functionality -- allRemoteTarballPkgs = -- [ (pkgid, ) -- | (pkgid, RemoteTarballPackage ) <- allPkgLocations ] -- Tarballs from repositories, either where the repository provides -- hashes as part of the repo metadata, or where we will have to -- download and hash the tarball. repoTarballPkgsWithMetadata :: [(PackageId, Repo)] repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] (repoTarballPkgsWithMetadata, repoTarballPkgsWithoutMetadata) = partitionEithers [ case repo of RepoSecure{} -> Left (pkgid, repo) _ -> Right (pkgid, repo) | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] -- For tarballs from repos that do not have hashes available we now have -- to check if the packages were downloaded already. -- (repoTarballPkgsToDownload, repoTarballPkgsDownloaded) <- fmap partitionEithers $ liftIO $ sequence [ do mtarball <- checkRepoTarballFetched repo pkgid case mtarball of Nothing -> return (Left (pkgid, repo)) Just tarball -> return (Right (pkgid, tarball)) | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] (hashesFromRepoMetadata, repoTarballPkgsNewlyDownloaded) <- -- Avoid having to initialise the repository (ie 'withRepoCtx') if we -- don't have to. (The main cost is configuring the http client.) if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata then return (Map.empty, []) else liftIO $ withRepoCtx $ \repoctx -> do -- For tarballs from repos that do have hashes available as part of the -- repo metadata we now load up the index for each repo and retrieve -- the hashes for the packages -- hashesFromRepoMetadata <- Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions fmap (Map.fromList . concat) $ sequence -- Reading the repo index is expensive so we group the packages by repo [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> Sec.withIndex secureRepo $ \repoIndex -> sequence [ do hash <- Sec.trusted <$> -- strip off Trusted tag Sec.indexLookupHash repoIndex pkgid -- Note that hackage-security currently uses SHA256 -- but this API could in principle give us some other -- choice in future. return (pkgid, hashFromTUF hash) | pkgid <- pkgids ] | (repo, pkgids) <- map (\grp@((_,repo):_) -> (repo, map fst grp)) . groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) $ repoTarballPkgsWithMetadata ] -- For tarballs from repos that do not have hashes available, download -- the ones we previously determined we need. -- repoTarballPkgsNewlyDownloaded <- sequence [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid return (pkgid, tarball) | (pkgid, repo) <- repoTarballPkgsToDownload ] return (hashesFromRepoMetadata, repoTarballPkgsNewlyDownloaded) -- Hash tarball files for packages where we have to do that. This includes -- tarballs that were local in the first place, plus tarballs from repos, -- either previously cached or freshly downloaded. -- let allTarballFilePkgs :: [(PackageId, FilePath)] allTarballFilePkgs = localTarballPkgs ++ repoTarballPkgsDownloaded ++ repoTarballPkgsNewlyDownloaded hashesFromTarballFiles <- liftIO $ fmap Map.fromList $ sequence [ do srchash <- readFileHashValue tarball return (pkgid, srchash) | (pkgid, tarball) <- allTarballFilePkgs ] monitorFiles [ monitorFile tarball | (_pkgid, tarball) <- allTarballFilePkgs ] -- Return the combination return $! hashesFromRepoMetadata <> hashesFromTarballFiles -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------ planPackages :: Verbosity -> Compiler -> Platform -> Solver -> SolverSettings -> InstalledPackageIndex -> SourcePackageDb -> PkgConfigDb -> [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 --TODO: [required eventually] should only be configurable for custom installs -- . setAvoidReinstalls solverSettingAvoidReinstalls --TODO: [required eventually] should only be configurable for custom installs -- . setShadowPkgs solverSettingShadowPkgs . setStrongFlags solverSettingStrongFlags . setAllowBootLibInstalls solverSettingAllowBootLibInstalls . setSolverVerbosity verbosity --TODO: [required eventually] decide if we need to prefer installed for -- global packages, or prefer latest even for global packages. Perhaps -- should be configurable but with a different name than "upgrade-dependencies". . setPreferenceDefault PreferLatestForSelected {-(if solverSettingUpgradeDeps then PreferAllLatest else PreferLatestForSelected)-} . removeLowerBounds solverSettingAllowOlder . removeUpperBounds solverSettingAllowNewer . addDefaultSetupDependencies (defaultSetupDeps comp platform . PD.packageDescription . packageDescription) . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver | Dependency name ver <- solverSettingPreferences ] . addConstraints -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src | (pc, src) <- solverSettingConstraints ] . addPreferences -- enable stanza preference where the user did not specify [ PackageStanzasPreference pkgname stanzas | pkg <- localPackages , let pkgname = 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 compatiblity matrix as lower -- bounds on lib:Cabal here (effectively corresponding to the -- respective major Cabal version bundled with the respective GHC -- release). -- -- GHC 8.4 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 [8,6,1] = mkVersion [2,4] -- GHC 8.6alpha2 (GHC 8.6.0.20180714) still shipped with a -- devel snapshot of Cabal-2.3.0.0; the rule below can be -- dropped at some point | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,3] | 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 (disp (packageId pkg))) $ map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg -- NB: We don't INSTANTIATE packages at this point. That's -- a post-pass. This makes it simpler to compute dependencies. elaborateSolverToComponents :: (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) = case mkComponentsGraph (elabEnabledSpec elab0) pd of Right g -> do let src_comps = componentsGraphToList g infoProgress $ hang (text "Component graph for" <+> disp pkgid <<>> colon) 4 (dispComponentsWithDeps src_comps) (_, comps) <- mapAccumM buildComponent (Map.empty, Map.empty, Map.empty) (map fst src_comps) let not_per_component_reasons = why_not_per_component src_comps if null not_per_component_reasons then return comps else do checkPerPackageOk comps not_per_component_reasons return [elaborateSolverToPackage 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 >= mkVersion [1,8] = [] | otherwise = cuz "cabal-version is less than 1.8" -- In the odd corner case that a package has no components at all -- then keep it as a whole package, since otherwise it turns into -- 0 component graph nodes and effectively vanishes. We want to -- keep it around at least for error reporting purposes. cuz_length | length g > 0 = [] | otherwise = cuz "there are no buildable components" -- For ease of testing, we let per-component builds be toggled -- at the top level cuz_flag | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = [] | otherwise = cuz "you passed --disable-per-component" -- 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 (CSubLibName _) = True is_sublib _ = False when (any (matchElabPkg is_sublib) comps) $ dieProgress $ text "Internal libraries only supported with per-component builds." $$ text "Per-component builds were disabled because" <+> fsep (punctuate comma reasons) -- TODO: Maybe exclude Backpack too elab0 = elaborateSolverToCommon 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 path <- [Map.lookup (ann_id aid') exe_map1]] elab_comp = ElaboratedComponent {..} -- 3. Construct a preliminary ElaboratedConfiguredPackage, -- and use this to compute the component ID. Fix up cc_id -- correctly. let elab1 = elab0 { elabPkgOrComp = ElabComponent $ elab_comp } cid = case elabBuildStyle elab0 of BuildInplaceOnly -> mkComponentId $ display pkgid ++ "-inplace" ++ (case Cabal.componentNameString cname of Nothing -> "" Just s -> "-" ++ display s) BuildAndInstall -> hashedInstalledPackageId (packageHashInputs elaboratedSharedConfig elab1) -- knot tied cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) } infoProgress $ dispConfiguredComponent cc -- 4. Perform mix-in linking let lookup_uid def_uid = case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of Just full -> full Nothing -> error ("lookup_uid: " ++ display def_uid) lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) (Map.union external_lc_map lc_map) cc infoProgress $ dispLinkedComponent lc -- NB: elab is setup to be the correct form for an -- indefinite library, or a definite library with no holes. -- We will modify it in 'instantiateInstallPlan' to handle -- instantiated packages. -- 5. Construct the final ElaboratedConfiguredPackage let elab = elab1 { elabModuleShape = lc_shape lc, elabUnitId = abstractUnitId (lc_uid lc), elabComponentId = lc_cid lc, elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), elabPkgOrComp = ElabComponent $ elab_comp { compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)), compOrderLibDependencies = ordNub (map (abstractUnitId . ci_id) (lc_includes lc ++ lc_sig_includes lc)) }, elabInstallDirs = install_dirs cid } -- 6. Construct the updated local maps let cc_map' = extendConfiguredComponentMap cc cc_map lc_map' = extendLinkedComponentMap lc lc_map exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map return ((cc_map', lc_map', exe_map'), elab) where compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" cname = Cabal.componentName comp compComponentName = Just cname compSolverName = CD.componentNameToComponent cname -- NB: compLinkedLibDependencies and -- compOrderLibDependencies are defined when we define -- 'elab'. external_lib_dep_sids = CD.select (== compSolverName) deps0 external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 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, path) | pkg <- external_exe_dep_pkgs , Just path <- [planPackageExePath pkg] ] exe_map1 = Map.union external_exe_map 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! " ++ display pn ++ " from " ++ display (elabPkgSourceId elab0)) (pkgConfigDbPkgVersion pkgConfigDB pn)) | PkgconfigDependency pn _ <- PD.pkgconfigDepends (Cabal.componentBuildInfo comp) ] install_dirs cid | shouldBuildInplaceOnly spkg -- use the ordinary default install dirs = (InstallDirs.absoluteInstallDirs pkgid (newSimpleUnitId cid) (compilerInfo compiler) InstallDirs.NoCopyDest platform defaultInstallDirs) { -- absoluteInstallDirs sets these as 'undefined' but we have -- to use them as "Setup.hs configure" args InstallDirs.libsubdir = "", InstallDirs.libexecsubdir = "", InstallDirs.datasubdir = "" } | otherwise -- use special simplified install dirs = storePackageInstallDirs storeDirLayout (compilerId compiler) cid inplace_bin_dir elab = binDirectoryFor distDirLayout elaboratedSharedConfig elab $ case Cabal.componentNameString cname of Just n -> display 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)) . mapDep -- | Given an 'ElaboratedPlanPackage', return the path to where the -- executable that this package represents would be installed. planPackageExePath :: ElaboratedPlanPackage -> Maybe FilePath planPackageExePath = -- Pre-existing executables are assumed to be in PATH -- already. In fact, this should be impossible. InstallPlan.foldPlanPackage (const Nothing) $ \elab -> Just $ binDirectoryFor distDirLayout elaboratedSharedConfig elab $ case elabPkgOrComp elab of ElabPackage _ -> "" ElabComponent comp -> case fmap Cabal.componentNameString (compComponentName comp) of Just (Just n) -> display n _ -> "" elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc -> ComponentsGraph -> [ElaboratedConfiguredPackage] -> ElaboratedConfiguredPackage elaborateSolverToPackage pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride) _flags _stanzas _deps0 _exe_deps0) compGraph comps = -- Knot tying: the final elab includes the -- pkgInstalledId, which is calculated by hashing many -- of the other fields of the elaboratedPackage. elab where elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg elab = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId, elabComponentId = pkgInstalledId, elabLinkedInstantiatedWith = Map.empty, elabInstallDirs = install_dirs, elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, elabModuleShape = modShape } modShape = case find (matchElabPkg (== CLibName)) comps of Nothing -> emptyModuleShape Just e -> Ty.elabModuleShape e pkgInstalledId | shouldBuildInplaceOnly pkg = mkComponentId (display pkgid ++ "-inplace") | otherwise = assert (isJust elabPkgSourceHash) $ hashedInstalledPackageId (packageHashInputs elaboratedSharedConfig elab) -- recursive use of elab | otherwise = error $ "elaborateInstallPlan: non-inplace package " ++ " is missing a source hash: " ++ display pkgid -- Need to filter out internal dependencies, because they don't -- correspond to anything real anymore. isExt confid = confSrcId confid /= pkgid filterExt = filter isExt filterExt' = filter (isExt . fst) pkgLibDependencies = buildComponentDeps (filterExt . compLibDependencies) pkgExeDependencies = buildComponentDeps (filterExt . compExeDependencies) pkgExeDependencyPaths = buildComponentDeps (filterExt' . compExeDependencyPaths) -- TODO: Why is this flat? pkgPkgConfigDependencies = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies pkgDependsOnSelfLib = CD.fromList [ (CD.componentNameToComponent cn, [()]) | Graph.N _ cn _ <- fromMaybe [] mb_closure ] where mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ] is_lib CLibName = True -- NB: this case should not occur, because sub-libraries -- are not supported without per-component builds is_lib (CSubLibName _) = True is_lib _ = False buildComponentDeps f = CD.fromList [ (compSolverName comp, f comp) | ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent comp } <- comps ] -- 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) install_dirs | shouldBuildInplaceOnly pkg -- use the ordinary default install dirs = (InstallDirs.absoluteInstallDirs pkgid (newSimpleUnitId pkgInstalledId) (compilerInfo compiler) InstallDirs.NoCopyDest platform defaultInstallDirs) { -- absoluteInstallDirs sets these as 'undefined' but we have to -- use them as "Setup.hs configure" args InstallDirs.libsubdir = "", InstallDirs.libexecsubdir = "", InstallDirs.datasubdir = "" } | otherwise -- use special simplified install dirs = storePackageInstallDirs storeDirLayout (compilerId compiler) pkgInstalledId elaborateSolverToCommon :: 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 = let Right (desc, _) = PD.finalizePD flags elabEnabledSpec (const True) platform (compilerInfo compiler) [] gdesc in desc 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. 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 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 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! where shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId shouldBeLocal NamedPackage{} = Nothing shouldBeLocal (SpecificSourcePackage pkg) | LocalTarballPackage _ <- packageSource pkg = Nothing | otherwise = Just (packageId pkg) -- TODO: Is it only LocalTarballPackages we can know about without -- them being "local" in the sense meant here? -- -- Also, review use of SourcePackage's loc vs ProjectPackageLocation pkgsUseSharedLibrary :: Set PackageId pkgsUseSharedLibrary = packagesWithLibDepsDownwardClosedProperty needsSharedLib where needsSharedLib pkg = fromMaybe compilerShouldUseSharedLibByDefault (liftM2 (||) pkgSharedLib pkgDynExe) where pkgid = packageId pkg pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe --TODO: [code cleanup] move this into the Cabal lib. It's currently open -- coded in Distribution.Simple.Configure, but should be made a proper -- function of the Compiler or CompilerInfo. compilerShouldUseSharedLibByDefault = case compilerFlavor compiler of GHC -> GHC.isDynamic compiler GHCJS -> GHCJS.isDynamic compiler _ -> False pkgsUseProfilingLibrary :: Set PackageId pkgsUseProfilingLibrary = packagesWithLibDepsDownwardClosedProperty needsProfilingLib where needsProfilingLib pkg = fromFlagOrDefault False (profBothFlag <> profLibFlag) where pkgid = packageId pkg profBothFlag = lookupPerPkgOption pkgid packageConfigProf profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe libDepGraph = Graph.fromDistinctList $ map NonSetupLibDepSolverPlanPackage (SolverInstallPlan.toList solverPlan) packagesWithLibDepsDownwardClosedProperty property = Set.fromList . map packageId . fromMaybe [] $ Graph.closure libDepGraph [ Graph.nodeKey pkg | pkg <- SolverInstallPlan.toList solverPlan , property pkg ] -- just the packages that satisfy the property --TODO: [nice to have] this does not check the config consistency, -- e.g. a package explicitly turning off profiling, but something -- depending on it that needs profiling. This really needs a separate -- package config validation/resolution pass. --TODO: [nice to have] config consistency checking: -- + profiling libs & exes, exe needs lib, recursive -- + shared libs & exes, exe needs lib, recursive -- + vanilla libs & exes, exe needs lib, recursive -- + ghci or shared lib needed by TH, recursive, ghc version dependent -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) -- | Get the appropriate 'ComponentName' which identifies an installed -- component. ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName ipiComponentName ipkg = case IPI.sourceLibName ipkg of Nothing -> CLibName Just n -> (CSubLibName n) -- | Given a 'ElaboratedConfiguredPackage', report if it matches a -- 'ComponentName'. matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool matchElabPkg p elab = case elabPkgOrComp elab of ElabComponent comp -> maybe False p (compComponentName comp) ElabPackage _ -> -- So, what should we do here? One possibility is to -- unconditionally return 'True', because whatever it is -- that we're looking for, it better be in this package. -- But this is a bit dodgy if the package doesn't actually -- have, e.g., a library. Fortunately, it's not possible -- for the build of the library/executables to be toggled -- by 'pkgStanzasEnabled', so the only thing we have to -- test is if the component in question is *buildable.* any (p . componentName) (Cabal.pkgBuildableComponents (elabPkgDescription elab)) -- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' -- and 'ComponentName' to the 'ComponentId' that that should be used -- in this case. mkCCMapping :: ElaboratedPlanPackage -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) mkCCMapping = InstallPlan.foldPlanPackage (\ipkg -> (packageName ipkg, Map.singleton (ipiComponentName ipkg) -- TODO: libify (AnnotatedId { ann_id = IPI.installedComponentId ipkg, ann_pid = packageId ipkg, ann_cname = IPI.sourceComponentName ipkg }))) $ \elab -> let mk_aid cn = AnnotatedId { ann_id = elabComponentId elab, ann_pid = packageId elab, ann_cname = cn } in (packageName elab, case elabPkgOrComp elab of ElabComponent comp -> case compComponentName comp of Nothing -> Map.empty Just n -> Map.singleton n (mk_aid n) ElabPackage _ -> Map.fromList $ map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) (Cabal.pkgBuildableComponents (elabPkgDescription elab))) -- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' -- to the shape of this package, as per mix-in linking. mkShapeMapping :: ElaboratedPlanPackage -> (ComponentId, (OpenUnitId, ModuleShape)) mkShapeMapping dpkg = (getComponentId dpkg, (indef_uid, shape)) where (dcid, shape) = InstallPlan.foldPlanPackage -- Uses Monad (->) (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) (liftM2 (,) elabComponentId elabModuleShape) dpkg indef_uid = IndefFullUnitId dcid (Map.fromList [ (req, OpenModuleVar req) | req <- Set.toList (modShapeRequires shape)]) -- | 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 -> [display n] _ -> [] ElabPackage _ -> map (display . 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 :: ElaboratedInstallPlan -> ElaboratedInstallPlan instantiateInstallPlan plan = InstallPlan.new (IndependentGoals False) (Graph.fromDistinctList (Map.elems ready_map)) where pkgs = InstallPlan.toList plan cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] instantiateUnitId :: ComponentId -> Map ModuleName Module -> InstM DefUnitId instantiateUnitId cid insts = state $ \s -> case Map.lookup uid s of Nothing -> -- Knot tied let (r, s') = runState (instantiateComponent uid cid insts) (Map.insert uid r s) in (def_uid, Map.insert uid r s') Just _ -> (def_uid, s) where def_uid = mkDefUnitId cid insts uid = unDefUnitId def_uid instantiateComponent :: UnitId -> ComponentId -> Map ModuleName Module -> InstM ElaboratedPlanPackage instantiateComponent uid cid insts | Just planpkg <- Map.lookup cid cmap = case planpkg of InstallPlan.Configured (elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) -> do deps <- mapM (substUnitId insts) (compLinkedLibDependencies comp) let getDep (Module dep_uid _) = [dep_uid] return $ InstallPlan.Configured elab { elabUnitId = uid, elabComponentId = cid, elabInstantiatedWith = insts, elabIsCanonical = Map.null insts, elabPkgOrComp = ElabComponent comp { compOrderLibDependencies = (if Map.null insts then [] else [newSimpleUnitId cid]) ++ ordNub (map unDefUnitId (deps ++ concatMap getDep (Map.elems insts))) } } _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ display cid) substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId substUnitId _ (DefiniteUnitId uid) = return uid substUnitId subst (IndefFullUnitId cid insts) = do insts' <- substSubst subst insts instantiateUnitId cid insts' -- NB: NOT composition substSubst :: Map ModuleName Module -> Map ModuleName OpenModule -> InstM (Map ModuleName Module) substSubst subst insts = T.mapM (substModule subst) insts substModule :: Map ModuleName Module -> OpenModule -> InstM Module substModule subst (OpenModuleVar mod_name) | Just m <- Map.lookup mod_name subst = return m | otherwise = error "substModule: non-closing substitution" substModule subst (OpenModule uid mod_name) = do uid' <- substUnitId subst uid return (Module uid' mod_name) indefiniteUnitId :: ComponentId -> InstM UnitId indefiniteUnitId cid = do let uid = newSimpleUnitId cid r <- indefiniteComponent uid cid state $ \s -> (uid, Map.insert uid r s) indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage indefiniteComponent _uid cid | Just planpkg <- Map.lookup cid cmap = return planpkg | otherwise = error ("indefiniteComponent: " ++ display cid) ready_map = execState work Map.empty work = forM_ pkgs $ \pkg -> case pkg of InstallPlan.Configured elab | not (Map.null (elabLinkedInstantiatedWith elab)) -> indefiniteUnitId (elabComponentId elab) >> return () _ -> instantiateUnitId (getComponentId pkg) Map.empty >> return () --------------------------- -- Build targets -- -- Refer to ProjectPlanning.Types for details of these important types: -- data ComponentTarget = ... -- data SubComponentTarget = ... -- One step in the build system is to translate higher level intentions like -- "build this package", "test that package", or "repl that component" into -- a more detailed specification of exactly which components to build (or other -- actions like repl or build docs). This translation is somewhat different for -- different commands. For example "test" for a package will build a different -- set of components than "build". In addition, the translation of these -- intentions can fail. For example "run" for a package is only unambiguous -- when the package has a single executable. -- -- So we need a little bit of infrastructure to make it easy for the command -- implementations to select what component targets are meant when a user asks -- to do something with a package or component. To do this (and to be able to -- produce good error messages for mistakes and when targets are not available) -- we need to gather and summarise accurate information about all the possible -- targets, both available and unavailable. Then a command implementation can -- decide which of the available component targets should be selected. -- | An available target represents a component within a package that a user -- command could plausibly refer to. In this sense, all the components defined -- within the package are things the user could refer to, whether or not it -- would actually be possible to build that component. -- -- In particular the available target contains an 'AvailableTargetStatus' which -- informs us about whether it's actually possible to select this component to -- be built, and if not why not. This detail makes it possible for command -- implementations (like @build@, @test@ etc) to accurately report why a target -- cannot be used. -- -- Note that the type parameter is used to help enforce that command -- implementations can only select targets that can actually be built (by -- forcing them to return the @k@ value for the selected targets). -- In particular 'resolveTargets' makes use of this (with @k@ as -- @('UnitId', ComponentName')@) to identify the targets thus selected. -- data AvailableTarget k = AvailableTarget { availableTargetPackageId :: PackageId, availableTargetComponentName :: ComponentName, availableTargetStatus :: AvailableTargetStatus k, availableTargetLocalToProject :: Bool } deriving (Eq, Show, Functor) -- | The status of a an 'AvailableTarget' component. This tells us whether -- it's actually possible to select this component to be built, and if not -- why not. -- data AvailableTargetStatus k = TargetDisabledByUser -- ^ When the user does @tests: False@ | TargetDisabledBySolver -- ^ When the solver could not enable tests | TargetNotBuildable -- ^ When the component has @buildable: False@ | TargetNotLocal -- ^ When the component is non-core in a non-local package | TargetBuildable k TargetRequested -- ^ The target can or should be built deriving (Eq, Ord, Show, Functor) -- | This tells us whether a target ought to be built by default, or only if -- specifically requested. The policy is that components like libraries and -- executables are built by default by @build@, but test suites and benchmarks -- are not, unless this is overridden in the project configuration. -- data TargetRequested = TargetRequestedByDefault -- ^ To be built by default | TargetNotRequestedByDefault -- ^ Not to be built by default deriving (Eq, Ord, Show) -- | Given the install plan, produce the set of 'AvailableTarget's for each -- package-component pair. -- -- Typically there will only be one such target for each component, but for -- example if we have a plan with both normal and profiling variants of a -- component then we would get both as available targets, or similarly if we -- had a plan that contained two instances of the same version of a package. -- This approach makes it relatively easy to select all instances\/variants -- of a component. -- availableTargets :: ElaboratedInstallPlan -> Map (PackageId, ComponentName) [AvailableTarget (UnitId, ComponentName)] availableTargets installPlan = let rs = [ (pkgid, cname, fake, target) | pkg <- InstallPlan.toList installPlan , (pkgid, cname, fake, target) <- case pkg of InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg InstallPlan.Installed elab -> availableSourceTargets elab InstallPlan.Configured elab -> availableSourceTargets elab ] in Map.union (Map.fromListWith (++) [ ((pkgid, cname), [target]) | (pkgid, cname, fake, target) <- rs, not fake]) (Map.fromList [ ((pkgid, cname), [target]) | (pkgid, cname, fake, target) <- rs, fake]) -- The normal targets mask the fake ones. We get all instances of the -- normal ones and only one copy of the fake ones (as there are many -- duplicates of the fake ones). See 'availableSourceTargets' below for -- more details on this fake stuff is about. availableInstalledTargets :: IPI.InstalledPackageInfo -> [(PackageId, ComponentName, Bool, AvailableTarget (UnitId, ComponentName))] availableInstalledTargets ipkg = let unitid = installedUnitId ipkg cname = CLibName status = TargetBuildable (unitid, cname) TargetRequestedByDefault target = AvailableTarget (packageId ipkg) cname status False fake = False in [(packageId ipkg, cname, fake, target)] availableSourceTargets :: ElaboratedConfiguredPackage -> [(PackageId, ComponentName, Bool, AvailableTarget (UnitId, ComponentName))] availableSourceTargets elab = -- We have a somewhat awkward problem here. We need to know /all/ the -- components from /all/ the packages because these are the things that -- users could refer to. Unfortunately, at this stage the elaborated install -- plan does /not/ contain all components: some components have already -- been deleted because they cannot possibly be built. This is the case -- for components that are marked @buildable: False@ in their .cabal files. -- (It's not unreasonable that the unbuildable components have been pruned -- as the plan invariant is considerably simpler if all nodes can be built) -- -- We can recover the missing components but it's not exactly elegant. For -- a graph node corresponding to a component we still have the information -- about the package that it came from, and this includes the names of -- /all/ the other components in the package. So in principle this lets us -- find the names of all components, plus full details of the buildable -- components. -- -- Consider for example a package with 3 exe components: foo, bar and baz -- where foo and bar are buildable, but baz is not. So the plan contains -- nodes for the components foo and bar. Now we look at each of these two -- nodes and look at the package they come from and the names of the -- components in this package. This will give us the names foo, bar and -- baz, twice (once for each of the two buildable components foo and bar). -- -- We refer to these reconstructed missing components as fake targets. -- It is an invariant that they are not available to be built. -- -- To produce the final set of targets we put the fake targets in a finite -- map (thus eliminating the duplicates) and then we overlay that map with -- the normal buildable targets. (This is done above in 'availableTargets'.) -- [ (packageId elab, cname, fake, target) | component <- pkgComponents (elabPkgDescription elab) , let cname = componentName component status = componentAvailableTargetStatus component target = AvailableTarget { availableTargetPackageId = packageId elab, availableTargetComponentName = cname, availableTargetStatus = status, availableTargetLocalToProject = elabLocalToProject elab } fake = isFakeTarget cname -- TODO: The goal of this test is to exclude "instantiated" -- packages as available targets. This means that you can't -- ask for a particular instantiated component to be built; -- it will only get built by a dependency. Perhaps the -- correct way to implement this is to run selection -- prior to instantiating packages. If you refactor -- this, then you can delete this test. , elabIsCanonical elab -- Filter out some bogus parts of the cross product that are never needed , case status of TargetBuildable{} | fake -> False _ -> True ] where isFakeTarget cname = case elabPkgOrComp elab of ElabPackage _ -> False ElabComponent elabComponent -> compComponentName elabComponent /= Just cname componentAvailableTargetStatus :: Component -> AvailableTargetStatus (UnitId, ComponentName) componentAvailableTargetStatus component = case componentOptionalStanza (componentName component) of -- it is not an optional stanza, so a library, exe or foreign lib Nothing | not buildable -> TargetNotBuildable | otherwise -> TargetBuildable (elabUnitId elab, cname) TargetRequestedByDefault -- it is not an optional stanza, so a testsuite or benchmark Just stanza -> case (Map.lookup stanza (elabStanzasRequested elab), Set.member stanza (elabStanzasAvailable elab)) of _ | not withinPlan -> TargetNotLocal (Just False, _) -> TargetDisabledByUser (Nothing, False) -> TargetDisabledBySolver _ | not buildable -> TargetNotBuildable (Just True, True) -> TargetBuildable (elabUnitId elab, cname) TargetRequestedByDefault (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) TargetNotRequestedByDefault (Just True, False) -> error "componentAvailableTargetStatus: impossible" where cname = componentName component buildable = PD.buildable (componentBuildInfo component) withinPlan = elabLocalToProject elab || case elabPkgOrComp elab of ElabComponent elabComponent -> compComponentName elabComponent == Just cname ElabPackage _ -> case componentName component of CLibName -> True CExeName _ -> True --TODO: what about sub-libs and foreign libs? _ -> False -- | Merge component targets that overlap each other. Specially when we have -- multiple targets for the same component and one of them refers to the whole -- component (rather than a module or file within) then all the other targets -- for that component are subsumed. -- -- We also allow for information associated with each component target, and -- whenever we targets subsume each other we aggregate their associated info. -- nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])] nubComponentTargets = concatMap (wholeComponentOverrides . map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst) . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) . map compatSubComponentTargets where -- If we're building the whole component then that the only target all we -- need, otherwise we can have several targets within the component. wholeComponentOverrides :: [(ComponentTarget, a )] -> [(ComponentTarget, [a])] wholeComponentOverrides ts = case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of (t:_) -> [ (t, map snd ts) ] [] -> [ (t,[x]) | (t,x) <- ts ] -- Not all Cabal Setup.hs versions support sub-component targets, so switch -- them over to the whole component compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) | not setupHsSupportsSubComponentTargets = (ComponentTarget cname WholeComponent, x) | otherwise = target -- Actually the reality is that no current version of Cabal's Setup.hs -- build command actually support building specific files or modules. setupHsSupportsSubComponentTargets = False -- TODO: when that changes, adjust this test, e.g. -- | pkgSetupScriptCliVersion >= Version [x,y] [] pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool pkgHasEphemeralBuildTargets elab = isJust (elabReplTarget elab) || (not . null) (elabTestTargets elab) || (not . null) (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 = 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, 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 (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 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 Cabal.defaultLibName WholeComponent | installedUnitId elab `Set.member` hasReverseLibDeps ] exeTargetsRequiredForRevDeps = -- TODO: allow requesting executable with different name -- than package name [ ComponentTarget (Cabal.CExeName $ packageNameToUnqualComponentName $ packageName $ elabPkgSourceId elab) WholeComponent | installedUnitId elab `Set.member` hasReverseExeDeps ] availablePkgs :: Set UnitId availablePkgs = Set.fromList (map installedUnitId pkgs) hasReverseLibDeps :: Set UnitId hasReverseLibDeps = Set.fromList [ depid | InstallPlan.Configured pkg <- pkgs , depid <- elabOrderLibDependencies pkg ] hasReverseExeDeps :: Set UnitId hasReverseExeDeps = Set.fromList [ depid | InstallPlan.Configured pkg <- pkgs , depid <- elabOrderExeDependencies pkg ] mapConfiguredPackage :: (srcpkg -> srcpkg') -> InstallPlan.GenericPlanPackage ipkg srcpkg -> InstallPlan.GenericPlanPackage ipkg srcpkg' mapConfiguredPackage f (InstallPlan.Configured pkg) = InstallPlan.Configured (f pkg) mapConfiguredPackage f (InstallPlan.Installed pkg) = InstallPlan.Installed (f pkg) mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = InstallPlan.PreExisting pkg componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas componentOptionalStanza _ = Nothing ------------------------------------ -- Support for --only-dependencies -- -- | Try to remove the given targets from the install plan. -- -- This is not always possible. -- pruneInstallPlanToDependencies :: Set UnitId -> ElaboratedInstallPlan -> Either CannotPruneDependencies ElaboratedInstallPlan pruneInstallPlanToDependencies pkgTargets installPlan = assert (all (isJust . InstallPlan.lookup installPlan) (Set.toList pkgTargets)) $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) . checkBrokenDeps . Graph.fromDistinctList . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) . InstallPlan.toList $ installPlan where -- Our strategy is to remove the packages we don't want and then check -- if the remaining graph is broken or not, ie any packages with dangling -- dependencies. If there are then we cannot prune the given targets. checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage -> Either CannotPruneDependencies (Graph.Graph ElaboratedPlanPackage) checkBrokenDeps graph = case Graph.broken graph of [] -> Right graph brokenPackages -> Left $ CannotPruneDependencies [ (pkg, missingDeps) | (pkg, missingDepIds) <- brokenPackages , let missingDeps = 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. In case 3 we also have -- to build an external Setup.hs script because the package needs a later -- Cabal lib version than we can support internally. -- -- data SetupScriptStyle = ... -- see ProjectPlanning.Types -- | Work out the 'SetupScriptStyle' given the package description. -- packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle packageSetupScriptStyle pkg | buildType == PD.Custom , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza , not (PD.defaultSetupDepends setupbi) -- but not one we added internally = SetupCustomExplicitDeps | buildType == PD.Custom , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as , PD.defaultSetupDepends setupbi -- the solver fills in the deps = SetupCustomImplicitDeps | buildType == PD.Custom , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver = SetupCustomImplicitDeps | PD.specVersion pkg > cabalVersion -- one cabal-install is built against = SetupNonCustomExternalLib | otherwise = SetupNonCustomInternalLib where buildType = PD.buildType pkg -- | Part of our Setup.hs handling policy is implemented by getting the solver -- to work out setup dependencies for packages. The solver already handles -- packages that explicitly specify setup dependencies, but we can also tell -- the solver to treat other packages as if they had setup dependencies. -- That's what this function does, it gets called by the solver for all -- packages that don't already have setup dependencies. -- -- The dependencies we want to add is different for each 'SetupScriptStyle'. -- -- Note that adding default deps means these deps are actually /added/ to the -- packages that we get out of the solver in the 'SolverInstallPlan'. Making -- implicit setup deps explicit is a problem in the post-solver stages because -- we still need to distinguish the case of explicit and implict setup deps. -- See 'rememberImplicitSetupDeps'. -- -- Note in addition to adding default setup deps, we also use -- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require -- @Cabal >= 1.20@ for Setup scripts. -- defaultSetupDeps :: Compiler -> Platform -> PD.PackageDescription -> Maybe [Dependency] defaultSetupDeps compiler platform pkg = case packageSetupScriptStyle pkg of -- For packages with build type custom that do not specify explicit -- setup dependencies, we add a dependency on Cabal and a number -- of other packages. SetupCustomImplicitDeps -> Just $ [ Dependency depPkgname anyVersion | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ [ Dependency cabalPkgname cabalConstraint | packageName pkg /= cabalPkgname ] where -- The Cabal dep is slightly special: -- * We omit the dep for the Cabal lib itself, since it bootstraps. -- * We constrain it to be < 1.25 -- -- Note: we also add a global constraint to require Cabal >= 1.20 -- for Setup scripts (see use addSetupCabalMinVersionConstraint). -- cabalConstraint = orLaterVersion (PD.specVersion pkg) `intersectVersionRanges` earlierVersion cabalCompatMaxVer -- The idea here is that at some point we will make significant -- breaking changes to the Cabal API that Setup.hs scripts use. -- So for old custom Setup scripts that do not specify explicit -- constraints, we constrain them to use a compatible Cabal version. cabalCompatMaxVer = mkVersion [1,25] -- For other build types (like Simple) if we still need to compile an -- external Setup.hs, it'll be one of the simple ones that only depends -- on Cabal and base. SetupNonCustomExternalLib -> Just [ Dependency cabalPkgname cabalConstraint , Dependency basePkgname anyVersion ] where cabalConstraint = orLaterVersion (PD.specVersion pkg) -- The internal setup wrapper method has no deps at all. SetupNonCustomInternalLib -> Just [] -- This case gets ruled out by the caller, planPackages, see the note -- above in the SetupCustomImplicitDeps case. SetupCustomExplicitDeps -> error $ "defaultSetupDeps: called for a package with explicit " ++ "setup deps: " ++ display (packageId pkg) -- | Work out which version of the Cabal spec we will be using to talk to the -- Setup.hs interface for this package. -- -- This depends somewhat on the 'SetupScriptStyle' but most cases are a result -- of what the solver picked for us, based on the explicit setup deps or the -- ones added implicitly by 'defaultSetupDeps'. -- packageSetupScriptSpecVersion :: 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 -> 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", "old-time", "pretty" , "process", "time", "transformers" ] ++ [ "Win32" | os == Windows ] ++ [ "unix" | os /= Windows ] ++ [ "ghc-prim" | isGHC ] ++ [ "template-haskell" | isGHC ] where isGHC = compilerCompatFlavor GHC compiler -- The other aspects of our Setup.hs policy lives here where we decide on -- the 'SetupScriptOptions'. -- -- Our current policy for the 'SetupCustomImplicitDeps' case is that we -- try to make the implicit deps cover everything, and we don't allow the -- compiler to pick up other deps. This may or may not be sustainable, and -- we might have to allow the deps to be non-exclusive, but that itself would -- be tricky since we would have to allow the Setup access to all the packages -- in the store and local dbs. setupHsScriptOptions :: ElaboratedReadyPackage -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> FilePath -> FilePath -> Bool -> Lock -> SetupScriptOptions -- TODO: Fix this so custom is a separate component. Custom can ALWAYS -- be a separate component!!! setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) plan ElaboratedSharedConfig{..} srcdir builddir isParallelBuild cacheLock = SetupScriptOptions { useCabalVersion = thisVersion elabSetupScriptCliVersion, useCabalSpecVersion = Just elabSetupScriptCliVersion, useCompiler = Just pkgConfigCompiler, usePlatform = Just pkgConfigPlatform, usePackageDB = elabSetupPackageDBStack, usePackageIndex = Nothing, useDependencies = [ (uid, srcid) | ConfiguredId srcid (Just CLibName) uid <- elabSetupDependencies elab ], useDependenciesExclusive = True, useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, useProgramDb = pkgConfigCompilerProgs, useDistPref = builddir, useLoggingHandle = Nothing, -- this gets set later useWorkingDir = Just srcdir, useExtraPathEnv = elabExeDependencyPaths elab, useExtraEnvOverrides = dataDirsEnvironmentForPlan 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{ storePackageDirectory , storeDirectory } compid ipkgid = InstallDirs.InstallDirs {..} where store = storeDirectory compid prefix = storePackageDirectory compid (newSimpleUnitId ipkgid) 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" --TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, -- make the various Setup.hs {configure,build,copy} flags setupHsConfigureFlags :: ElaboratedReadyPackage -> ElaboratedSharedConfig -> Verbosity -> FilePath -> Cabal.ConfigFlags setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) sharedConfig@ElaboratedSharedConfig{..} verbosity builddir = sanityCheckElaboratedConfiguredPackage sharedConfig elab (Cabal.ConfigFlags {..}) where configArgs = mempty -- unused, passed via args configDistPref = toFlag builddir configCabalFilePath = mempty configVerbosity = toFlag verbosity configInstantiateWith = Map.toList elabInstantiatedWith configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese configIPID = case elabPkgOrComp of ElabPackage pkg -> toFlag (display (pkgInstalledId pkg)) ElabComponent _ -> mempty configCID = case elabPkgOrComp of ElabPackage _ -> mempty ElabComponent _ -> toFlag elabComponentId configProgramPaths = Map.toList elabProgramPaths configProgramArgs | {- 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 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 = [ (case mb_cn of -- Special case for internal libraries Just (CSubLibName uqn) | packageId elab == srcid -> mkPackageName (unUnqualComponentName uqn) _ -> packageName srcid, cid) | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab ] configConstraints = case elabPkgOrComp of ElabPackage _ -> [ thisPackageVersion srcid | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] ElabComponent _ -> [] -- explicitly clear, then our package db stack -- TODO: [required eventually] have to do this differently for older Cabal versions configPackageDBs = Nothing : map Just elabBuildPackageDBStack configTests = case elabPkgOrComp of ElabPackage pkg -> toFlag (TestStanzas `Set.member` pkgStanzasEnabled pkg) ElabComponent _ -> mempty configBenchmarks = case elabPkgOrComp of ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg) ElabComponent _ -> mempty configExactConfiguration = toFlag True configFlagError = mempty --TODO: [research required] appears not to be implemented configRelocatable = mempty --TODO: [research required] ??? configScratchDir = mempty -- never use configUserInstall = mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist configUseResponseFiles = mempty 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 _ _ verbosity builddir = Cabal.TestFlags { testDistPref = toFlag builddir , testVerbosity = toFlag verbosity , testMachineLog = mempty , testHumanLog = mempty , testShowDetails = toFlag Cabal.Always , testKeepTix = mempty , testOptions = mempty } setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] -- TODO: Does the issue #3335 affects test as well setupHsTestArgs elab = mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) setupHsBenchFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig -> Verbosity -> FilePath -> Cabal.BenchmarkFlags setupHsBenchFlags _ _ verbosity builddir = Cabal.BenchmarkFlags { benchmarkDistPref = toFlag builddir , benchmarkVerbosity = toFlag verbosity , benchmarkOptions = mempty } 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. " ++ display (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, 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" cabal-install-2.4.0.0/Distribution/Client/ProjectPlanning/0000755000000000000000000000000000000000000021502 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/ProjectPlanning/Types.hs0000644000000000000000000010004000000000000023135 0ustar0000000000000000{-# 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, -- * Setup script SetupScriptStyle(..), ) where 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 import Distribution.Text import Distribution.Types.ComponentRequestedSpec import Distribution.Types.PackageDescription (PackageDescription(..)) import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.System import qualified Distribution.PackageDescription as Cabal import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Compiler import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import qualified Distribution.Simple.BuildTarget as Cabal import Distribution.Simple.Program import Distribution.ModuleName (ModuleName) import Distribution.Simple.LocalBuildInfo (ComponentName(..)) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.InstallDirs (PathTemplate) import Distribution.Simple.Setup (HaddockTarget) import Distribution.Version import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import Distribution.Solver.Types.OptionalStanza import Distribution.Compat.Graph (IsNode(..)) import Distribution.Simple.Utils (ordNub) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes) import Data.Set (Set) import qualified Data.ByteString.Lazy as LBS import Distribution.Compat.Binary import GHC.Generics (Generic) import qualified Data.Monoid as Mon import Data.Typeable import Control.Monad 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 = display (packageName ipkg) | otherwise = display (installedUnitId ipkg) elabPlanPackageName verbosity (Configured elab) = elabConfiguredName verbosity elab elabPlanPackageName verbosity (Installed elab) = elabConfiguredName verbosity elab --TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things -- like a server + client with ghc + ghcjs 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 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, 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, -- 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. elabSetupScriptCliVersion :: Version, -- Build time related: 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. build_target || any (depends_on_lib pkg) (elabBuildTargets elab) where depends_on_lib pkg (ComponentTarget cn _) = not (null (CD.select (== CD.componentNameToComponent cn) (pkgDependsOnSelfLib pkg))) build_target = if not (null (elabBuildTargets elab)) then any is_lib_target (elabBuildTargets elab) -- Empty build targets mean we build /everything/; -- that means we have to look more carefully to see -- if there is anything to register else Cabal.hasLibs (elabPkgDescription elab) -- NB: this means we DO NOT reregister if you just built a -- single file is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn is_lib_target _ = False is_lib CLibName = True is_lib (CSubLibName _) = True is_lib _ = False -- | 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 :: ElaboratedInstallPlan -> [(String, Maybe FilePath)] dataDirsEnvironmentForPlan = catMaybes . fmap (InstallPlan.foldPlanPackage (const Nothing) dataDirEnvVarForPackage) . 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). -- * The other cases are not handled yet. See below. dataDirEnvVarForPackage :: ElaboratedConfiguredPackage -> Maybe (String, Maybe FilePath) dataDirEnvVarForPackage pkg = case (elabBuildStyle pkg, elabPkgSourceLocation pkg) of (BuildAndInstall, _) -> Nothing (BuildInplaceOnly, LocalUnpackedPackage path) -> Just (pkgPathEnvVar (elabPkgDescription pkg) "datadir", Just $ path dataDir (elabPkgDescription pkg)) -- TODO: handle the other cases for PackageLocation. -- We will only need this when we add support for -- remote/local tarballs. (BuildInplaceOnly, _) -> Nothing 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 data ElaboratedPackageOrComponent = ElabPackage ElaboratedPackage | ElabComponent ElaboratedComponent deriving (Eq, Show, Generic) instance Binary ElaboratedPackageOrComponent elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName elabComponentName elab = case elabPkgOrComp elab of ElabPackage _ -> Just CLibName -- there could be more, but default this ElabComponent comp -> compComponentName comp -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String elabConfiguredName verbosity elab | verbosity <= normal = (case elabPkgOrComp elab of ElabPackage _ -> "" ElabComponent comp -> case compComponentName comp of Nothing -> "setup from " Just CLibName -> "" Just cname -> display cname ++ " from ") ++ display (packageId elab) | otherwise = display (elabUnitId elab) elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams elabDistDirParams shared elab = DistDirParams { distParamUnitId = installedUnitId elab, distParamComponentId = elabComponentId elab, distParamPackageId = elabPkgSourceId elab, distParamComponentName = case elabPkgOrComp elab of ElabComponent comp -> compComponentName comp ElabPackage _ -> Nothing, distParamCompilerId = compilerId (pkgConfigCompiler shared), distParamPlatform = pkgConfigPlatform shared, distParamOptimization = elabOptimization elab } -- | The full set of dependencies which dictate what order we -- need to build things in the install plan: "order dependencies" -- balls everything together. This is mostly only useful for -- ordering; if you are, for example, trying to compute what -- @--dependency@ flags to pass to a Setup script, you need to -- use 'elabLibDependencies'. This method is the same as -- 'nodeNeighbors'. -- -- NB: this method DOES include setup deps. elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderDependencies elab = case elabPkgOrComp elab of -- Important not to have duplicates: otherwise InstallPlan gets -- confused. ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) ElabComponent comp -> compOrderDependencies comp -- | Like 'elabOrderDependencies', but only returns dependencies on -- libraries. elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderLibDependencies elab = case elabPkgOrComp elab of ElabPackage 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 Version)] elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } = pkgPkgConfigDependencies pkg elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = compPkgConfigDependencies comp -- | The cache files of all our inplace dependencies which, -- when updated, require us to rebuild. See #4202 for -- more details. Essentially, this is a list of filepaths -- that, if our dependencies get rebuilt, will themselves -- get updated. -- -- Note: the hash of these cache files gets built into -- the build cache ourselves, which means that we end -- up tracking transitive dependencies! -- -- Note: This tracks the "build" cache file, but not -- "registration" or "config" cache files. Why not? -- Arguably we should... -- -- Note: This is a bit of a hack, because it is not really -- the hashes of the SOURCES of our (transitive) dependencies -- that we should use to decide whether or not to rebuild, -- but the output BUILD PRODUCTS. The strategy we use -- here will never work if we want to implement unchanging -- rebuilds. elabInplaceDependencyBuildCacheFiles :: DistDirLayout -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedConfiguredPackage -> [FilePath] elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = go =<< InstallPlan.directDeps plan (nodeKey root_elab) where go = InstallPlan.foldPlanPackage (const []) $ \elab -> do guard (elabBuildStyle elab == BuildInplaceOnly) return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" -- | Some extra metadata associated with an -- 'ElaboratedConfiguredPackage' which indicates that the "package" -- in question is actually a single component to be built. Arguably -- it would be clearer if there were an ADT which branched into -- package work items and component work items, but I've structured -- it this way to minimize change to the existing code (which I -- don't feel qualified to rewrite.) data ElaboratedComponent = ElaboratedComponent { -- | The name of the component to be built according to the solver compSolverName :: CD.Component, -- | The name of the component to be built. Nothing if -- it's a setup dep. compComponentName :: Maybe ComponentName, -- | The *external* library dependencies of this component. We -- pass this to the configure script. compLibDependencies :: [ConfiguredId], -- | In a component prior to instantiation, this list specifies -- the 'OpenUnitId's which, after instantiation, are the -- actual dependencies of this package. Note that this does -- NOT include signature packages, which do not turn into real -- ordering dependencies when we instantiate. This is intended to be -- a purely temporary field, to carry some information to the -- instantiation phase. It's more precise than -- 'compLibDependencies', and also stores information about internal -- dependencies. compLinkedLibDependencies :: [OpenUnitId], -- | The executable dependencies of this component (including -- internal executables). compExeDependencies :: [ConfiguredId], -- | The @pkg-config@ dependencies of the component compPkgConfigDependencies :: [(PkgconfigName, Maybe Version)], -- | The paths all our executable dependencies will be installed -- to once they are installed. compExeDependencyPaths :: [(ConfiguredId, FilePath)], compOrderLibDependencies :: [UnitId] } deriving (Eq, Show, Generic) instance Binary ElaboratedComponent -- | See 'elabOrderDependencies'. compOrderDependencies :: ElaboratedComponent -> [UnitId] compOrderDependencies comp = compOrderLibDependencies comp ++ compOrderExeDependencies comp -- | See 'elabOrderExeDependencies'. compOrderExeDependencies :: ElaboratedComponent -> [UnitId] compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies data ElaboratedPackage = ElaboratedPackage { pkgInstalledId :: InstalledPackageId, -- | The exact dependencies (on other plan packages) -- pkgLibDependencies :: ComponentDeps [ConfiguredId], -- | Components which depend (transitively) on an internally -- defined library. These are used by 'elabRequiresRegistration', -- to determine if a user-requested build is going to need -- a library registration -- pkgDependsOnSelfLib :: ComponentDeps [()], -- | Dependencies on executable packages. -- pkgExeDependencies :: ComponentDeps [ConfiguredId], -- | Paths where executable dependencies live. -- pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], -- | Dependencies on @pkg-config@ packages. -- NB: this is NOT per-component (although it could be) -- because Cabal library does not track per-component -- pkg-config depends; it always does them all at once. -- pkgPkgConfigDependencies :: [(PkgconfigName, Maybe Version)], -- | Which optional stanzas (ie testsuites, benchmarks) will actually -- be enabled during the package configure step. pkgStanzasEnabled :: Set OptionalStanza } deriving (Eq, Show, Generic) instance Binary ElaboratedPackage -- | See 'elabOrderDependencies'. This gives the unflattened version, -- which can be useful in some circumstances. pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] pkgOrderDependencies pkg = fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) -- | This is used in the install plan to indicate how the package will be -- built. -- data BuildStyle = -- | The classic approach where the package is built, then the files -- installed into some location and the result registered in a package db. -- -- If the package came from a tarball then it's built in a temp dir and -- the results discarded. BuildAndInstall -- | The package is built, but the files are not installed anywhere, -- rather the build dir is kept and the package is registered inplace. -- -- Such packages can still subsequently be installed. -- -- Typically 'BuildAndInstall' packages will only depend on other -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones. -- | BuildInplaceOnly deriving (Eq, Show, Generic) instance Binary BuildStyle type CabalFileText = LBS.ByteString type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage --------------------------- -- 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 -- | Unambiguously render a 'ComponentTarget', e.g., to pass -- to a Cabal Setup script. showComponentTarget :: PackageId -> ComponentTarget -> String showComponentTarget pkgid = Cabal.showBuildTarget pkgid . toBuildTarget where toBuildTarget :: ComponentTarget -> Cabal.BuildTarget toBuildTarget (ComponentTarget cname subtarget) = case subtarget of WholeComponent -> Cabal.BuildTargetComponent cname ModuleTarget mname -> Cabal.BuildTargetModule cname mname FileTarget fname -> Cabal.BuildTargetFile cname fname showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ display n showTestComponentTarget _ _ = Nothing isTestComponentTarget :: ComponentTarget -> Bool isTestComponentTarget (ComponentTarget (CTestName _) _) = True isTestComponentTarget _ = False showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ display 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 (CSubLibName _) _) = True isSubLibComponentTarget _ = False --------------------------- -- 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 cabal-install-2.4.0.0/Distribution/Client/RebuildMonad.hs0000644000000000000000000002514600000000000021316 0ustar0000000000000000{-# 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 Distribution.Verbosity (Verbosity) 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, Binary b) => Verbosity -> FileMonitor a b -> a -> Rebuild b -> Rebuild b rerunIfChanged verbosity monitor key action = do rootDir <- askRoot changed <- liftIO $ checkFileMonitorChanged monitor rootDir key case changed of MonitorUnchanged result files -> do liftIO $ debug verbosity $ "File monitor '" ++ monitorName ++ "' unchanged." monitorFiles files return result MonitorChanged reason -> do liftIO $ debug verbosity $ "File monitor '" ++ monitorName ++ "' changed: " ++ showReason reason startTime <- liftIO $ beginUpdateFileMonitor (result, files) <- liftIO $ unRebuild rootDir action liftIO $ updateFileMonitor monitor rootDir (Just startTime) files key result monitorFiles files return result where monitorName = takeFileName (fileMonitorCacheFile monitor) showReason (MonitoredFileChanged file) = "file " ++ file showReason (MonitoredValueChanged _) = "monitor value changed" showReason MonitorFirstRun = "first run" showReason MonitorCorruptCache = "invalid cache file" -- | 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] cabal-install-2.4.0.0/Distribution/Client/Reconfigure.hs0000644000000000000000000002176600000000000021225 0ustar0000000000000000module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where import Distribution.Client.Compat.Prelude import Data.Monoid ( Any(..) ) import System.Directory ( doesFileExist ) import Distribution.Verbosity import Distribution.Simple.Configure ( localBuildInfoFile ) import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag ) import Distribution.Simple.Utils ( existsAndIsMoreRecentThan, defaultPackageDesc, info ) import Distribution.Client.Config ( SavedConfig(..) ) import Distribution.Client.Configure ( readConfigFlags ) import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate ) import Distribution.Client.Sandbox ( WereDepsReinstalled(..), findSavedDistPref, getSandboxConfigFilePath , maybeReinstallAddSourceDeps, updateInstallDirs ) import Distribution.Client.Sandbox.PackageEnvironment ( userPackageEnvironmentFile ) import Distribution.Client.Sandbox.Types ( UseSandbox(..) ) import Distribution.Client.Setup ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) , SkipAddSourceDepsCheck(..) ) -- | @Check@ represents a function to check some condition on type @a@. The -- returned 'Any' is 'True' if any part of the condition failed. newtype Check a = Check { runCheck :: Any -- Did any previous check fail? -> a -- value returned by previous checks -> IO (Any, a) -- Did this check fail? What value is returned? } instance Semigroup (Check a) where (<>) c d = Check $ \any0 a0 -> do (any1, a1) <- runCheck c any0 a0 (any2, a2) <- runCheck d (any0 <> any1) a1 return (any0 <> any1 <> any2, a2) instance Monoid (Check a) where mempty = Check $ \_ a -> return (mempty, a) mappend = (<>) -- | Re-configure the package in the current directory if needed. Deciding -- when to reconfigure and with which options is convoluted: -- -- If we are reconfiguring, we must always run @configure@ with the -- verbosity option we are given; however, that a previous configuration -- uses a different verbosity setting is not reason enough to reconfigure. -- -- The package should be configured to use the same \"dist\" prefix as -- given to the @build@ command, otherwise the build will probably -- fail. Not only does this determine the \"dist\" prefix setting if we -- need to reconfigure anyway, but an existing configuration should be -- invalidated if its \"dist\" prefix differs. -- -- If the package has never been configured (i.e., there is no -- LocalBuildInfo), we must configure first, using the default options. -- -- If the package has been configured, there will be a 'LocalBuildInfo'. -- If there no package description file, we assume that the -- 'PackageDescription' is up to date, though the configuration may need -- to be updated for other reasons (see above). If there is a package -- description file, and it has been modified since the 'LocalBuildInfo' -- was generated, then we need to reconfigure. -- -- The caller of this function may also have specific requirements -- regarding the flags the last configuration used. For example, -- 'testAction' requires that the package be configured with test suites -- enabled. The caller may pass the required settings to this function -- along with a function to check the validity of the saved 'ConfigFlags'; -- these required settings will be checked first upon determining that -- a previous configuration exists. reconfigure :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()) -- ^ configure action -> Verbosity -- ^ Verbosity setting -> FilePath -- ^ \"dist\" prefix -> UseSandbox -> SkipAddSourceDepsCheck -- ^ Should we skip the timestamp check for modified -- add-source dependencies? -> Flag (Maybe Int) -- ^ -j flag for reinstalling add-source deps. -> Check (ConfigFlags, ConfigExFlags) -- ^ Check that the required flags are set. -- If they are not set, provide a message explaining the -- reason for reconfiguration. -> [String] -- ^ Extra arguments -> GlobalFlags -- ^ Global flags -> SavedConfig -> IO SavedConfig reconfigure configureAction verbosity dist useSandbox skipAddSourceDepsCheck numJobsFlag check extraArgs globalFlags config = do savedFlags@(_, _) <- readConfigFlags dist useNix <- fmap isJust (findNixExpr globalFlags config) alreadyInNixShell <- inNixShell if useNix && not alreadyInNixShell then do -- If we are using Nix, we must reinstantiate the derivation outside -- the shell. Eventually, the caller will invoke 'nixShell' which will -- rerun cabal inside the shell. That will bring us back to 'reconfigure', -- but inside the shell we'll take the second branch, below. -- This seems to have a problem: won't 'configureAction' call 'nixShell' -- yet again, spawning an infinite tree of subprocesses? -- No, because 'nixShell' doesn't spawn a new process if it is already -- running in a Nix shell. nixInstantiate verbosity dist False globalFlags config return config else do let checks = checkVerb <> checkDist <> checkOutdated <> check <> checkAddSourceDeps (Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags let (_, config') = updateInstallDirs (configUserInstall configFlags) (useSandbox, config) when force $ configureAction flags extraArgs globalFlags return config' where -- Changing the verbosity does not require reconfiguration, but the new -- verbosity should be used if reconfiguring. checkVerb = Check $ \_ (configFlags, configExFlags) -> do let configFlags' = configFlags { configVerbosity = toFlag verbosity} return (mempty, (configFlags', configExFlags)) -- Reconfiguration is required if @--build-dir@ changes. checkDist = Check $ \_ (configFlags, configExFlags) -> do -- Always set the chosen @--build-dir@ before saving the flags, -- or bad things could happen. savedDist <- findSavedDistPref config (configDistPref configFlags) let distChanged = dist /= savedDist when distChanged $ info verbosity "build directory changed" let configFlags' = configFlags { configDistPref = toFlag dist } return (Any distChanged, (configFlags', configExFlags)) checkOutdated = Check $ \_ flags@(configFlags, _) -> do let buildConfig = localBuildInfoFile dist -- Has the package ever been configured? If not, reconfiguration is -- required. configured <- doesFileExist buildConfig unless configured $ info verbosity "package has never been configured" -- Is the configuration older than the sandbox configuration file? -- If so, reconfiguration is required. sandboxConfig <- getSandboxConfigFilePath globalFlags sandboxConfigNewer <- existsAndIsMoreRecentThan sandboxConfig buildConfig when sandboxConfigNewer $ info verbosity "sandbox was created after the package was configured" -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need -- to force reconfigure. Note that it's possible to use @cabal.config@ -- even without sandboxes. userPackageEnvironmentFileModified <- existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig when userPackageEnvironmentFileModified $ info verbosity ("user package environment file ('" ++ userPackageEnvironmentFile ++ "') was modified") -- Is the configuration older than the package description? descrFile <- maybe (defaultPackageDesc verbosity) return (flagToMaybe (configCabalFilePath configFlags)) outdated <- existsAndIsMoreRecentThan descrFile buildConfig when outdated $ info verbosity (descrFile ++ " was changed") let failed = Any outdated <> Any userPackageEnvironmentFileModified <> Any sandboxConfigNewer <> Any (not configured) return (failed, flags) checkAddSourceDeps = Check $ \(Any force') flags@(configFlags, _) -> do let (_, config') = updateInstallDirs (configUserInstall configFlags) (useSandbox, config) skipAddSourceDepsCheck' | force' = SkipAddSourceDepsCheck | otherwise = skipAddSourceDepsCheck when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $ info verbosity "skipping add-source deps check" -- Were any add-source dependencies reinstalled in the sandbox? depsReinstalled <- case skipAddSourceDepsCheck' of DontSkipAddSourceDepsCheck -> maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags globalFlags (useSandbox, config') SkipAddSourceDepsCheck -> do return NoDepsReinstalled case depsReinstalled of NoDepsReinstalled -> return (mempty, flags) ReinstalledSomeDeps -> do info verbosity "some add-source dependencies were reinstalled" return (Any True, flags) cabal-install-2.4.0.0/Distribution/Client/Run.hs0000644000000000000000000001504400000000000017511 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 Distribution.Verbosity (Verbosity) import Distribution.Text (display) 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 '" ++ display name ++ "' is disabled.") | e <- executables pkg_descr , not . buildable . buildInfo $ e, let name = exeName e] ++ [ (name, "There is a test-suite '" ++ display name ++ "'," ++ " but the `run` command is only for executables.") | t <- testSuites pkg_descr , let name = testName t] ++ [ (name, "There is a benchmark '" ++ display 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' = display $ 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 " ++ display (exeName exe) ++ "..." rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' cabal-install-2.4.0.0/Distribution/Client/Sandbox.hs0000644000000000000000000011727700000000000020356 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Sandbox -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- UI for the sandboxing functionality. ----------------------------------------------------------------------------- module Distribution.Client.Sandbox ( sandboxInit, sandboxDelete, sandboxAddSource, sandboxAddSourceSnapshot, sandboxDeleteSource, sandboxListSources, sandboxHcPkg, dumpPackageEnvironment, withSandboxBinDirOnSearchPath, getSandboxConfigFilePath, loadConfigOrSandboxConfig, findSavedDistPref, initPackageDBIfNeeded, maybeWithSandboxDirOnSearchPath, WereDepsReinstalled(..), reinstallAddSourceDeps, maybeReinstallAddSourceDeps, SandboxPackageInfo(..), maybeWithSandboxPackageInfo, tryGetIndexFilePath, sandboxBuildDir, getInstalledPackagesInSandbox, updateSandboxConfigFileFlag, updateInstallDirs, getPersistOrConfigCompiler ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.Setup ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..) , GlobalFlags(..), configCompilerAux', configPackageDB' , defaultConfigExFlags, defaultInstallFlags , defaultSandboxLocation, withRepoContext ) import Distribution.Client.Sandbox.Timestamp ( listModifiedDeps , maybeAddCompilerTimestampRecord , withAddTimestamps , removeTimestamps ) import Distribution.Client.Config ( SavedConfig(..), defaultUserInstall, loadConfig ) import Distribution.Client.Dependency ( foldProgress ) import Distribution.Client.IndexUtils ( BuildTreeRefType(..) ) import Distribution.Client.Install ( InstallArgs, makeInstallContext, makeInstallPlan, processInstallPlan ) import Distribution.Utils.NubList ( fromNubList ) import Distribution.Client.Sandbox.PackageEnvironment ( PackageEnvironment(..), PackageEnvironmentType(..) , createPackageEnvironmentFile, classifyPackageEnvironment , tryLoadSandboxPackageEnvironmentFile, loadUserConfig , commentPackageEnvironment, showPackageEnvironmentWithComments , sandboxPackageEnvironmentFile, userPackageEnvironmentFile , sandboxPackageDBPath ) import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) , UseSandbox(..) ) import Distribution.Client.SetupWrapper ( SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Types ( PackageLocation(..) ) import Distribution.Client.Utils ( inDir, tryCanonicalizePath , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) ) import Distribution.Simple.Configure ( configCompilerAuxEx , getPackageDBContents , maybeGetPersistBuildConfig , findDistPrefOrDefault , findDistPref ) import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) import Distribution.Simple.Utils ( die', debug, notice, info, warn , debugNoWrap, defaultPackageDesc , topHandlerWith , createDirectoryIfMissingVerbose ) import Distribution.Package ( Package(..) ) import Distribution.System ( Platform ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity ) import Distribution.Compat.Environment ( lookupEnv, setEnv ) import Distribution.Client.Compat.FilePerms ( setFileHidden ) import qualified Distribution.Client.Sandbox.Index as Index import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Simple.Register as Register import Distribution.Solver.Types.SourcePackage import qualified Data.Map as M import qualified Data.Set as S import Data.Either (partitionEithers) import Control.Exception ( assert, bracket_ ) import Control.Monad ( forM, mapM, mapM_ ) import Data.Bits ( shiftL, shiftR, xor ) import Data.IORef ( newIORef, writeIORef, readIORef ) import Data.List ( delete , groupBy ) import Data.Maybe ( fromJust ) import Numeric ( showHex ) import System.Directory ( canonicalizePath , createDirectory , doesDirectoryExist , doesFileExist , getCurrentDirectory , removeDirectoryRecursive , removeFile , renameDirectory ) import System.FilePath ( (), equalFilePath , getSearchPath , searchPathSeparator , splitSearchPath , takeDirectory ) -- -- * Constants -- -- | The name of the sandbox subdirectory where we keep snapshots of add-source -- dependencies. snapshotDirectoryName :: FilePath snapshotDirectoryName = "snapshots" -- | Non-standard build dir that is used for building add-source deps instead of -- "dist". Fixes surprising behaviour in some cases (see issue #1281). sandboxBuildDir :: FilePath -> FilePath sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash "" where sandboxDirHash = jenkins sandboxDir -- See http://en.wikipedia.org/wiki/Jenkins_hash_function jenkins :: String -> Word32 jenkins str = loop_finish $ foldl' loop 0 str where loop :: Word32 -> Char -> Word32 loop hash key_i' = hash''' where key_i = toEnum . ord $ key_i' hash' = hash + key_i hash'' = hash' + (shiftL hash' 10) hash''' = hash'' `xor` (shiftR hash'' 6) loop_finish :: Word32 -> Word32 loop_finish hash = hash''' where hash' = hash + (shiftL hash 3) hash'' = hash' `xor` (shiftR hash' 11) hash''' = hash'' + (shiftL hash'' 15) -- -- * Basic sandbox functions. -- -- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the -- value of the @CABAL_SANDBOX_CONFIG@ environment variable, or else to -- 'NoFlag'. updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags updateSandboxConfigFileFlag globalFlags = case globalSandboxConfigFile globalFlags of Flag _ -> return globalFlags NoFlag -> do f' <- fmap (maybe NoFlag Flag) . lookupEnv $ "CABAL_SANDBOX_CONFIG" return globalFlags { globalSandboxConfigFile = f' } -- | Return the path to the sandbox config file - either the default or the one -- specified with @--sandbox-config-file@. getSandboxConfigFilePath :: GlobalFlags -> IO FilePath getSandboxConfigFilePath globalFlags = do let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags case sandboxConfigFileFlag of NoFlag -> do pkgEnvDir <- getCurrentDirectory return (pkgEnvDir sandboxPackageEnvironmentFile) Flag path -> return path -- | Load the @cabal.sandbox.config@ file (and possibly the optional -- @cabal.config@). In addition to a @PackageEnvironment@, also return a -- canonical path to the sandbox. Exit with error if the sandbox directory or -- the package environment file do not exist. tryLoadSandboxConfig :: Verbosity -> GlobalFlags -> IO (FilePath, PackageEnvironment) tryLoadSandboxConfig verbosity globalFlags = do path <- getSandboxConfigFilePath globalFlags tryLoadSandboxPackageEnvironmentFile verbosity path (globalConfigFile globalFlags) -- | Return the name of the package index file for this package environment. tryGetIndexFilePath :: Verbosity -> SavedConfig -> IO FilePath tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config) -- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of -- 'SavedConfig'. tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath tryGetIndexFilePath' verbosity globalFlags = do let paths = fromNubList $ globalLocalRepos globalFlags case paths of [] -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ "no local repos found. " ++ checkConfiguration _ -> return $ (last paths) Index.defaultIndexFileName where checkConfiguration = "Please check your configuration ('" ++ userPackageEnvironmentFile ++ "')." -- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error -- message than just pattern-matching. getSandboxPackageDB :: Verbosity -> ConfigFlags -> IO PackageDB getSandboxPackageDB verbosity configFlags = do case configPackageDBs configFlags of [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB -- TODO: should we allow multiple package DBs (e.g. with 'inherit')? [] -> die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt [_] -> die' verbosity $ "Unexpected contents of the 'package-db' field. " ++ sandboxConfigCorrupt _ -> die' verbosity $ "Too many package DBs provided. " ++ sandboxConfigCorrupt where sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt." -- | Which packages are installed in the sandbox package DB? getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags -> Compiler -> ProgramDb -> IO InstalledPackageIndex getInstalledPackagesInSandbox verbosity configFlags comp progdb = do sandboxDB <- getSandboxPackageDB verbosity configFlags getPackageDBContents verbosity comp sandboxDB progdb -- | Temporarily add $SANDBOX_DIR/bin to $PATH. withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir where -- TODO: Instead of modifying the global process state, it'd be better to -- set the environment individually for each subprocess invocation. This -- will have to wait until the Shell monad is implemented; without it the -- required changes are too intrusive. addBinDir :: IO () addBinDir = do mbOldPath <- lookupEnv "PATH" let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator) mbOldPath setEnv "PATH" newPath rmBinDir :: IO () rmBinDir = do oldPath <- getSearchPath let newPath = intercalate [searchPathSeparator] (delete sandboxBin oldPath) setEnv "PATH" newPath sandboxBin = sandboxDir "bin" -- | Initialise a package DB for this compiler if it doesn't exist. initPackageDBIfNeeded :: Verbosity -> ConfigFlags -> Compiler -> ProgramDb -> IO () initPackageDBIfNeeded verbosity configFlags comp progdb = do SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags packageDBExists <- doesDirectoryExist dbPath unless packageDBExists $ Register.initPackageDB verbosity comp progdb dbPath when packageDBExists $ debug verbosity $ "The package database already exists: " ++ dbPath -- | Entry point for the 'cabal sandbox dump-pkgenv' command. dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags commentPkgEnv <- commentPackageEnvironment sandboxDir putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv -- | Entry point for the 'cabal sandbox init' command. sandboxInit :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () sandboxInit verbosity sandboxFlags globalFlags = do -- Warn if there's a 'cabal-dev' sandbox. isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev") (doesFileExist $ "cabal-dev" "cabal.config") when isCabalDevSandbox $ warn verbosity $ "You are apparently using a legacy (cabal-dev) sandbox. " ++ "Legacy sandboxes may interact badly with native Cabal sandboxes. " ++ "You may want to delete the 'cabal-dev' directory to prevent issues." -- Create the sandbox directory. let sandboxDir' = fromFlagOrDefault defaultSandboxLocation (sandboxLocation sandboxFlags) createDirectoryIfMissingVerbose verbosity True sandboxDir' sandboxDir <- tryCanonicalizePath sandboxDir' setFileHidden sandboxDir -- Determine which compiler to use (using the value from ~/.cabal/config). userConfig <- loadConfig verbosity (globalConfigFile globalFlags) (comp, platform, progdb) <- configCompilerAuxEx (savedConfigureFlags userConfig) -- Create the package environment file. pkgEnvFile <- getSandboxConfigFilePath globalFlags createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags let config = pkgEnvSavedConfig pkgEnv configFlags = savedConfigureFlags config -- Create the index file if it doesn't exist. indexFile <- tryGetIndexFilePath verbosity config indexFileExists <- doesFileExist indexFile if indexFileExists then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir Index.createEmpty verbosity indexFile -- Create the package DB for the default compiler. initPackageDBIfNeeded verbosity configFlags comp progdb maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile (compilerId comp) platform -- | Entry point for the 'cabal sandbox delete' command. sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () sandboxDelete verbosity _sandboxFlags globalFlags = do (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags { globalRequireSandbox = Flag False } case useSandbox of NoSandbox -> warn verbosity "Not in a sandbox." UseSandbox sandboxDir -> do curDir <- getCurrentDirectory pkgEnvFile <- getSandboxConfigFilePath globalFlags -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard -- location. let isNonDefaultConfigLocation = not $ equalFilePath pkgEnvFile $ curDir sandboxPackageEnvironmentFile if isNonDefaultConfigLocation then warn verbosity $ "Sandbox config file is in non-default location: '" ++ pkgEnvFile ++ "'.\n Please delete manually." else removeFile pkgEnvFile -- Remove the sandbox directory, unless we're using a shared sandbox. let isNonDefaultSandboxLocation = not $ equalFilePath sandboxDir $ curDir defaultSandboxLocation when isNonDefaultSandboxLocation $ die' verbosity $ "Non-default sandbox location used: '" ++ sandboxDir ++ "'.\nAssuming a shared sandbox. Please delete '" ++ sandboxDir ++ "' manually." absSandboxDir <- canonicalizePath sandboxDir notice verbosity $ "Deleting the sandbox located at " ++ absSandboxDir removeDirectoryRecursive absSandboxDir let pathInsideSandbox = isPrefixOf absSandboxDir -- Warn the user if deleting the sandbox deleted a package database -- referenced in the current environment. checkPackagePaths var = do let checkPath path = do absPath <- canonicalizePath path (when (pathInsideSandbox absPath) . warn verbosity) (var ++ " refers to package database " ++ path ++ " inside the deleted sandbox.") liftM (maybe [] splitSearchPath) (lookupEnv var) >>= mapM_ checkPath checkPackagePaths "CABAL_SANDBOX_PACKAGE_PATH" checkPackagePaths "GHC_PACKAGE_PATH" checkPackagePaths "GHCJS_PACKAGE_PATH" -- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'. doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment -> BuildTreeRefType -> IO () doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do let savedConfig = pkgEnvSavedConfig pkgEnv indexFile <- tryGetIndexFilePath verbosity savedConfig -- If we're running 'sandbox add-source' for the first time for this compiler, -- we need to create an initial timestamp record. (comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile (compilerId comp) platform withAddTimestamps verbosity sandboxDir $ do -- Path canonicalisation is done in addBuildTreeRefs, but we do it -- twice because of the timestamps file. buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType return buildTreeRefs' -- | Entry point for the 'cabal sandbox add-source' command. sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags -> IO () sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags if fromFlagOrDefault False (sandboxSnapshot sandboxFlags) then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef -- | Entry point for the 'cabal sandbox add-source --snapshot' command. sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment -> IO () sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do let snapshotDir = sandboxDir snapshotDirectoryName -- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private -- location. createDirectoryIfMissingVerbose verbosity True snapshotDir -- Collect the package descriptions first, so that if some path does not refer -- to a cabal package, we fail immediately. pkgs <- forM buildTreeRefs $ \buildTreeRef -> inDir (Just buildTreeRef) $ return . flattenPackageDescription =<< readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If -- 'prepareTree' throws an error at any point, the old snapshots will still be -- in consistent state. tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) -> inDir (Just buildTreeRef) $ do let targetDir = snapshotDir (display . packageId $ pkg) targetTmpDir = targetDir ++ "-tmp" dirExists <- doesDirectoryExist targetTmpDir when dirExists $ removeDirectoryRecursive targetDir createDirectory targetTmpDir prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers return (targetTmpDir, targetDir) -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to -- "snapshots/$PKGNAME-$VERSION". snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do dirExists <- doesDirectoryExist targetDir when dirExists $ removeDirectoryRecursive targetDir renameDirectory targetTmpDir targetDir return targetDir -- Once the packages are copied, just 'add-source' them as usual. doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef -- | Entry point for the 'cabal sandbox delete-source' command. sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags -> IO () sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) (results, convDict) <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs let (failedPaths, removedPaths) = partitionEithers results removedRefs = fmap convDict removedPaths unless (null removedPaths) $ do removeTimestamps verbosity sandboxDir removedPaths notice verbosity $ "Success deleting sources: " ++ showL removedRefs ++ "\n\n" unless (null failedPaths) $ do let groupedFailures = groupBy errorType failedPaths mapM_ handleErrors groupedFailures die' verbosity $ "The sources with the above errors were skipped. (" ++ showL (fmap getPath failedPaths) ++ ")" notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++ "source dependency, but does not remove the package " ++ "from the sandbox package DB.\n\n" ++ "Use 'sandbox hc-pkg -- unregister' to do that." where getPath (Index.ErrNonregisteredSource p) = p getPath (Index.ErrNonexistentSource p) = p showPaths f = concat . intersperse " " . fmap (show . f) showL = showPaths id showE [] = return ' ' showE errs = showPaths getPath errs errorType Index.ErrNonregisteredSource{} Index.ErrNonregisteredSource{} = True errorType Index.ErrNonexistentSource{} Index.ErrNonexistentSource{} = True errorType _ _ = False handleErrors [] = return () handleErrors errs@(Index.ErrNonregisteredSource{}:_) = warn verbosity ("Sources not registered: " ++ showE errs ++ "\n\n") handleErrors errs@(Index.ErrNonexistentSource{}:_) = warn verbosity ("Source directory not found for paths: " ++ showE errs ++ "\n" ++ "If you are trying to delete a reference to a removed directory, " ++ "please provide the full absolute path " ++ "(as given by `sandbox list-sources`).\n\n") -- | Entry point for the 'cabal sandbox list-sources' command. sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () sandboxListSources verbosity _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) refs <- Index.listBuildTreeRefs verbosity Index.ListIgnored Index.LinksAndSnapshots indexFile when (null refs) $ notice verbosity $ "Index file '" ++ indexFile ++ "' has no references to local build trees." when (not . null $ refs) $ do notice verbosity $ "Source dependencies registered " ++ "in the current sandbox ('" ++ sandboxDir ++ "'):\n\n" mapM_ putStrLn refs notice verbosity $ "\nTo unregister source dependencies, " ++ "use the 'sandbox delete-source' command." -- | Entry point for the 'cabal sandbox hc-pkg' command. Invokes the @hc-pkg@ -- tool with provided arguments, restricted to the sandbox. sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO () sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv -- Invoke hc-pkg for the most recently configured compiler (if any), -- using the right package-db for the compiler (see #1935). (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags let dir = sandboxPackageDBPath sandboxDir comp platform dbStack = [GlobalPackageDB, SpecificPackageDB dir] Register.invokeHcPkg verbosity comp progdb dbStack extraArgs updateInstallDirs :: Flag Bool -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig) updateInstallDirs userInstallFlag (useSandbox, savedConfig) = case useSandbox of NoSandbox -> let savedConfig' = savedConfig { savedConfigureFlags = configureFlags { configInstallDirs = installDirs } } in (useSandbox, savedConfig') _ -> (useSandbox, savedConfig) where configureFlags = savedConfigureFlags savedConfig userInstallDirs = savedUserInstallDirs savedConfig globalInstallDirs = savedGlobalInstallDirs savedConfig installDirs | userInstall = userInstallDirs | otherwise = globalInstallDirs userInstall = fromFlagOrDefault defaultUserInstall (configUserInstall configureFlags `mappend` userInstallFlag) -- | Check which type of package environment we're in and return a -- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates -- whether we're working in a sandbox. loadConfigOrSandboxConfig :: Verbosity -> GlobalFlags -- ^ For @--config-file@ and -- @--sandbox-config-file@. -> IO (UseSandbox, SavedConfig) loadConfigOrSandboxConfig verbosity globalFlags = do let configFileFlag = globalConfigFile globalFlags sandboxConfigFileFlag = globalSandboxConfigFile globalFlags ignoreSandboxFlag = globalIgnoreSandbox globalFlags pkgEnvDir <- getPkgEnvDir sandboxConfigFileFlag pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag ignoreSandboxFlag case pkgEnvType of -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present. SandboxPackageEnvironment -> do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags -- Prints an error message and exits on error. let config = pkgEnvSavedConfig pkgEnv return (UseSandbox sandboxDir, config) -- Only @cabal.config@ is present. UserPackageEnvironment -> do config <- loadConfig verbosity configFileFlag userConfig <- loadUserConfig verbosity pkgEnvDir Nothing let config' = config `mappend` userConfig dieIfSandboxRequired config' return (NoSandbox, config') -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present. AmbientPackageEnvironment -> do config <- loadConfig verbosity configFileFlag let globalConstraintsOpt = flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config globalConstraintConfig <- loadUserConfig verbosity pkgEnvDir globalConstraintsOpt let config' = config `mappend` globalConstraintConfig dieIfSandboxRequired config return (NoSandbox, config') where -- Return the path to the package environment directory - either the -- current directory or the one that @--sandbox-config-file@ resides in. getPkgEnvDir :: (Flag FilePath) -> IO FilePath getPkgEnvDir sandboxConfigFileFlag = do case sandboxConfigFileFlag of NoFlag -> getCurrentDirectory Flag path -> tryCanonicalizePath . takeDirectory $ path -- Die if @--require-sandbox@ was specified and we're not inside a sandbox. dieIfSandboxRequired :: SavedConfig -> IO () dieIfSandboxRequired config = checkFlag flag where flag = (globalRequireSandbox . savedGlobalFlags $ config) `mappend` (globalRequireSandbox globalFlags) checkFlag (Flag True) = die' verbosity $ "'require-sandbox' is set to True, but no sandbox is present. " ++ "Use '--no-require-sandbox' if you want to override " ++ "'require-sandbox' temporarily." checkFlag (Flag False) = return () checkFlag (NoFlag) = return () -- | Return the saved \"dist/\" prefix, or the default prefix. findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath findSavedDistPref config flagDistPref = do let defDistPref = useDistPref defaultSetupScriptOptions flagDistPref' = configDistPref (savedConfigureFlags config) `mappend` flagDistPref findDistPref defDistPref flagDistPref' -- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do -- nothing. maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a maybeWithSandboxDirOnSearchPath NoSandbox act = act maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act = withSandboxBinDirOnSearchPath sandboxDir $ act -- | Had reinstallAddSourceDeps actually reinstalled any dependencies? data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled -- | Reinstall those add-source dependencies that have been modified since -- we've last installed them. Assumes that we're working inside a sandbox. reinstallAddSourceDeps :: Verbosity -> ConfigFlags -> ConfigExFlags -> InstallFlags -> GlobalFlags -> FilePath -> IO WereDepsReinstalled reinstallAddSourceDeps verbosity configFlags' configExFlags installFlags globalFlags sandboxDir = topHandler' $ do let sandboxDistPref = sandboxBuildDir sandboxDir configFlags = configFlags' { configDistPref = Flag sandboxDistPref } haddockFlags = mempty { haddockDistPref = Flag sandboxDistPref } (comp, platform, progdb) <- configCompilerAux' configFlags retVal <- newIORef NoDepsReinstalled withSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb sandboxDir $ \sandboxPkgInfo -> unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do withRepoContext verbosity globalFlags $ \repoContext -> do let args :: InstallArgs args = ((configPackageDB' configFlags) ,repoContext ,comp, platform, progdb ,UseSandbox sandboxDir, Just sandboxPkgInfo ,globalFlags, configFlags, configExFlags, installFlags ,haddockFlags) -- This can actually be replaced by a call to 'install', but we use a -- lower-level API because of layer separation reasons. Additionally, we -- might want to use some lower-level features this in the future. withSandboxBinDirOnSearchPath sandboxDir $ do installContext <- makeInstallContext verbosity args Nothing installPlan <- foldProgress logMsg die'' return =<< makeInstallPlan verbosity args installContext processInstallPlan verbosity args installContext installPlan writeIORef retVal ReinstalledSomeDeps readIORef retVal where die'' message = die' verbosity (message ++ installFailedInSandbox) -- TODO: use a better error message, remove duplication. installFailedInSandbox = "Note: when using a sandbox, all packages are required to have " ++ "consistent dependencies. Try reinstalling/unregistering the " ++ "offending packages or recreating the sandbox." logMsg message rest = debugNoWrap verbosity message >> rest topHandler' = topHandlerWith $ \_ -> do warn verbosity "Couldn't reinstall some add-source dependencies." -- Here we can't know whether any deps have been reinstalled, so we have -- to be conservative. return ReinstalledSomeDeps -- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that -- we don't update the timestamp file here - this is done in -- 'postInstallActions'. withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags -> Compiler -> Platform -> ProgramDb -> FilePath -> (SandboxPackageInfo -> IO ()) -> IO () withSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb sandboxDir cont = do -- List all add-source deps. indexFile <- tryGetIndexFilePath' verbosity globalFlags buildTreeRefs <- Index.listBuildTreeRefs verbosity Index.DontListIgnored Index.OnlyLinks indexFile let allAddSourceDepsSet = S.fromList buildTreeRefs -- List all packages installed in the sandbox. installedPkgIndex <- getInstalledPackagesInSandbox verbosity configFlags comp progdb let err = "Error reading sandbox package information." -- Get the package descriptions for all add-source deps. depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs depsPkgDescs <- mapM (readGenericPackageDescription verbosity) depsCabalFiles let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs) isInstalled pkgid = not . null . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid installedDepsMap = M.filter (isInstalled . packageId) depsMap -- Get the package ids of modified (and installed) add-source deps. modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir (compilerId comp) platform installedDepsMap -- 'fromJust' here is safe because 'modifiedAddSourceDeps' are guaranteed to -- be a subset of the keys of 'depsMap'. let modifiedDeps = [ (modDepPath, fromJust $ M.lookup modDepPath depsMap) | modDepPath <- modifiedAddSourceDeps ] modifiedDepsMap = M.fromList modifiedDeps assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ()) if (null modifiedDeps) then info verbosity $ "Found no modified add-source deps." else notice verbosity $ "Some add-source dependencies have been modified. " ++ "They will be reinstalled..." -- Get the package ids of the remaining add-source deps (some are possibly not -- installed). let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap) -- Finally, assemble a 'SandboxPackageInfo'. cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps) (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet where toSourcePackage (path, pkgDesc) = SourcePackage (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing -- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the -- identity otherwise. maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags -> Compiler -> Platform -> ProgramDb -> UseSandbox -> (Maybe SandboxPackageInfo -> IO ()) -> IO () maybeWithSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb useSandbox cont = case useSandbox of NoSandbox -> cont Nothing UseSandbox sandboxDir -> withSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb sandboxDir (\spi -> cont (Just spi)) -- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that -- case. maybeReinstallAddSourceDeps :: Verbosity -> Flag (Maybe Int) -- ^ The '-j' flag -> ConfigFlags -- ^ Saved configure flags -- (from dist/setup-config) -> GlobalFlags -> (UseSandbox, SavedConfig) -> IO WereDepsReinstalled maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' (useSandbox, config) = do case useSandbox of NoSandbox -> return NoDepsReinstalled UseSandbox sandboxDir -> do -- Reinstall the modified add-source deps. let configFlags = savedConfigureFlags config `mappendSomeSavedFlags` configFlags' configExFlags = defaultConfigExFlags `mappend` savedConfigureExFlags config installFlags' = defaultInstallFlags `mappend` savedInstallFlags config installFlags = installFlags' { installNumJobs = installNumJobs installFlags' `mappend` numJobsFlag } globalFlags = savedGlobalFlags config -- This makes it possible to override things like 'remote-repo-cache' -- from the command line. These options are hidden, and are only -- useful for debugging, so this should be fine. `mappend` globalFlags' reinstallAddSourceDeps verbosity configFlags configExFlags installFlags globalFlags sandboxDir where -- NOTE: we can't simply do @sandboxConfigFlags `mappend` savedFlags@ -- because we don't want to auto-enable things like 'library-profiling' for -- all add-source dependencies even if the user has passed -- '--enable-library-profiling' to 'cabal configure'. These options are -- supposed to be set in 'cabal.config'. mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags mappendSomeSavedFlags sandboxConfigFlags savedFlags = sandboxConfigFlags { configHcFlavor = configHcFlavor sandboxConfigFlags `mappend` configHcFlavor savedFlags, configHcPath = configHcPath sandboxConfigFlags `mappend` configHcPath savedFlags, configHcPkg = configHcPkg sandboxConfigFlags `mappend` configHcPkg savedFlags, configProgramPaths = configProgramPaths sandboxConfigFlags `mappend` configProgramPaths savedFlags, configProgramArgs = configProgramArgs sandboxConfigFlags `mappend` configProgramArgs savedFlags, -- NOTE: Unconditionally choosing the value from -- 'dist/setup-config'. Sandbox package DB location may have been -- changed by 'configure -w'. configPackageDBs = configPackageDBs savedFlags -- FIXME: Is this compatible with the 'inherit' feature? } -- -- 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 ) cabal-install-2.4.0.0/Distribution/Client/Sandbox/0000755000000000000000000000000000000000000020003 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/Sandbox/Index.hs0000644000000000000000000003015300000000000021410 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Sandbox.Index -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Querying and modifying local build tree references in the package index. ----------------------------------------------------------------------------- module Distribution.Client.Sandbox.Index ( createEmpty, addBuildTreeRefs, removeBuildTreeRefs, ListIgnoredBuildTreeRefs(..), RefTypesToList(..), DeleteSourceError(..), listBuildTreeRefs, validateIndexPath, defaultIndexFileName ) where import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar import Distribution.Client.IndexUtils ( BuildTreeRefType(..) , refTypeFromTypeCode , typeCodeFromRefType , updatePackageIndexCacheFile , readCacheStrict , Index(..) ) import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString , makeAbsoluteToCwd, tryCanonicalizePath , tryFindAddSourcePackageDesc ) import Distribution.Simple.Utils ( die', debug ) import Distribution.Compat.Exception ( tryIO ) import Distribution.Verbosity ( Verbosity ) import qualified Data.ByteString.Lazy as BS import Control.DeepSeq ( NFData(rnf) ) import Control.Exception ( evaluate, throw, Exception ) import Control.Monad ( liftM, unless ) import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell) import Data.List ( (\\), intersect, nub, find ) import Data.Maybe ( catMaybes ) import Data.Either (partitionEithers) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist, renameFile, canonicalizePath) import System.FilePath ( (), (<.>), takeDirectory, takeExtension ) import System.IO ( IOMode(..), withBinaryFile ) -- | A reference to a local build tree. data BuildTreeRef = BuildTreeRef { buildTreeRefType :: !BuildTreeRefType, buildTreePath :: !FilePath } instance NFData BuildTreeRef where rnf (BuildTreeRef _ fp) = rnf fp defaultIndexFileName :: FilePath defaultIndexFileName = "00-index.tar" -- | Given a path, ensure that it refers to a local build tree. buildTreeRefFromPath :: Verbosity -> BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) buildTreeRefFromPath verbosity refType dir = do dirExists <- doesDirectoryExist dir unless dirExists $ die' verbosity $ "directory '" ++ dir ++ "' does not exist" _ <- tryFindAddSourcePackageDesc verbosity dir "Error adding source reference." return . Just $ BuildTreeRef refType dir -- | Given a tar archive entry, try to parse it as a local build tree reference. readBuildTreeRef :: Tar.Entry -> Maybe BuildTreeRef readBuildTreeRef entry = case Tar.entryContent entry of (Tar.OtherEntryType typeCode bs size) | (Tar.isBuildTreeRefTypeCode typeCode) && (size == BS.length bs) -> Just $! BuildTreeRef (refTypeFromTypeCode typeCode) (byteStringToFilePath bs) | otherwise -> Nothing _ -> Nothing -- | Given a sequence of tar archive entries, extract all references to local -- build trees. readBuildTreeRefs :: Exception e => Tar.Entries e -> [BuildTreeRef] readBuildTreeRefs = catMaybes . Tar.foldEntries (\e r -> readBuildTreeRef e : r) [] throw -- | Given a path to a tar archive, extract all references to local build trees. readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef] readBuildTreeRefsFromFile = liftM (readBuildTreeRefs . Tar.read) . BS.readFile -- | Read build tree references from an index cache readBuildTreeRefsFromCache :: Verbosity -> FilePath -> IO [BuildTreeRef] readBuildTreeRefsFromCache verbosity indexPath = do (mRefs, _prefs) <- readCacheStrict verbosity (SandboxIndex indexPath) buildTreeRef return (catMaybes mRefs) where buildTreeRef pkgEntry = case pkgEntry of IndexUtils.NormalPackage _ _ _ _ -> Nothing IndexUtils.BuildTreeRef typ _ _ path _ -> Just $ BuildTreeRef typ path -- | Given a local build tree ref, serialise it to a tar archive entry. writeBuildTreeRef :: BuildTreeRef -> Tar.Entry writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content where bs = filePathToByteString path -- Provide a filename for tools that treat custom entries as ordinary files. tarPath' = "local-build-tree-reference" -- fromRight can't fail because the path is shorter than 255 characters. tarPath = fromRight $ Tar.toTarPath True tarPath' content = Tar.OtherEntryType (typeCodeFromRefType refType) bs (BS.length bs) -- TODO: Move this to D.C.Utils? fromRight (Left err) = error err fromRight (Right a) = a -- | Check that the provided path is either an existing directory, or a tar -- archive in an existing directory. validateIndexPath :: Verbosity -> FilePath -> IO FilePath validateIndexPath verbosity path' = do path <- makeAbsoluteToCwd path' if (== ".tar") . takeExtension $ path then return path else do dirExists <- doesDirectoryExist path unless dirExists $ die' verbosity $ "directory does not exist: '" ++ path ++ "'" return $ path defaultIndexFileName -- | Create an empty index file. createEmpty :: Verbosity -> FilePath -> IO () createEmpty verbosity path = do indexExists <- doesFileExist path if indexExists then debug verbosity $ "Package index already exists: " ++ path else do debug verbosity $ "Creating the index file '" ++ path ++ "'" createDirectoryIfMissing True (takeDirectory path) -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'. let zeros = BS.replicate (512*20) 0 BS.writeFile path zeros -- | Add given local build tree references to the index. addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> BuildTreeRefType -> IO () addBuildTreeRefs _ _ [] _ = error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected" addBuildTreeRefs verbosity path l' refType = do checkIndexExists verbosity path l <- liftM nub . mapM tryCanonicalizePath $ l' treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path) -- Add only those paths that aren't already in the index. treesToAdd <- mapM (buildTreeRefFromPath verbosity refType) (l \\ treesInIndex) let entries = map writeBuildTreeRef (catMaybes treesToAdd) unless (null entries) $ do withBinaryFile path ReadWriteMode $ \h -> do block <- Tar.hSeekEndEntryOffset h Nothing debug verbosity $ "Writing at tar block: " ++ show block BS.hPut h (Tar.write entries) debug verbosity $ "Successfully appended to '" ++ path ++ "'" updatePackageIndexCacheFile verbosity $ SandboxIndex path data DeleteSourceError = ErrNonregisteredSource { nrPath :: FilePath } | ErrNonexistentSource { nePath :: FilePath } deriving Show -- | Remove given local build tree references from the index. -- -- Returns a tuple with either removed build tree refs or errors and a function -- that converts from a provided build tree ref to corresponding full directory path. removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO ([Either DeleteSourceError FilePath], (FilePath -> FilePath)) removeBuildTreeRefs _ _ [] = error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected" removeBuildTreeRefs verbosity indexPath l = do checkIndexExists verbosity indexPath let tmpFile = indexPath <.> "tmp" canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr return $ case res of Right pth -> Right (btr, pth) Left _ -> Left $ ErrNonexistentSource btr) l let (failures, convDict) = partitionEithers canonRes allRefs = fmap snd convDict -- Performance note: on my system, it takes 'index --remove-source' -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be -- much smaller. removedRefs <- doRemove convDict tmpFile renameFile tmpFile indexPath debug verbosity $ "Successfully renamed '" ++ tmpFile ++ "' to '" ++ indexPath ++ "'" unless (null removedRefs) $ updatePackageIndexCacheFile verbosity $ SandboxIndex indexPath let results = fmap Right removedRefs ++ fmap Left failures ++ fmap (Left . ErrNonregisteredSource) (fmap (convertWith convDict) (allRefs \\ removedRefs)) return (results, convertWith convDict) where doRemove :: [(FilePath, FilePath)] -> FilePath -> IO [FilePath] doRemove srcRefs tmpFile = do (newIdx, changedPaths) <- Tar.read `fmap` BS.readFile indexPath >>= runWriterT . Tar.filterEntriesM (p $ fmap snd srcRefs) BS.writeFile tmpFile . Tar.write . Tar.entriesToList $ newIdx return changedPaths p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool p refs entry = case readBuildTreeRef entry of Nothing -> return True -- FIXME: removing snapshot deps is done with `delete-source -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to -- support removing snapshots by providing the original path. (Just (BuildTreeRef _ pth)) -> if pth `elem` refs then tell [pth] >> return False else return True convertWith dict pth = maybe pth fst $ find ((==pth) . snd) dict -- | A build tree ref can become ignored if the user later adds a build tree ref -- with the same package ID. We display ignored build tree refs when the user -- runs 'cabal sandbox list-sources', but do not look at their timestamps in -- 'reinstallAddSourceDeps'. data ListIgnoredBuildTreeRefs = ListIgnored | DontListIgnored -- | Which types of build tree refs should be listed? data RefTypesToList = OnlySnapshots | OnlyLinks | LinksAndSnapshots -- | List the local build trees that are referred to from the index. listBuildTreeRefs :: Verbosity -> ListIgnoredBuildTreeRefs -> RefTypesToList -> FilePath -> IO [FilePath] listBuildTreeRefs verbosity listIgnored refTypesToList path = do checkIndexExists verbosity path buildTreeRefs <- case listIgnored of DontListIgnored -> do paths <- listWithoutIgnored case refTypesToList of LinksAndSnapshots -> return paths _ -> do allPathsFiltered <- fmap (map buildTreePath . filter predicate) listWithIgnored _ <- evaluate (length allPathsFiltered) return (paths `intersect` allPathsFiltered) ListIgnored -> fmap (map buildTreePath . filter predicate) listWithIgnored _ <- evaluate (length buildTreeRefs) return buildTreeRefs where predicate :: BuildTreeRef -> Bool predicate = case refTypesToList of OnlySnapshots -> (==) SnapshotRef . buildTreeRefType OnlyLinks -> (==) LinkRef . buildTreeRefType LinksAndSnapshots -> const True listWithIgnored :: IO [BuildTreeRef] listWithIgnored = readBuildTreeRefsFromFile path listWithoutIgnored :: IO [FilePath] listWithoutIgnored = fmap (map buildTreePath) $ readBuildTreeRefsFromCache verbosity path -- | Check that the package index file exists and exit with error if it does not. checkIndexExists :: Verbosity -> FilePath -> IO () checkIndexExists verbosity path = do indexExists <- doesFileExist path unless indexExists $ die' verbosity $ "index does not exist: '" ++ path ++ "'" cabal-install-2.4.0.0/Distribution/Client/Sandbox/PackageEnvironment.hs0000644000000000000000000006132000000000000024121 0ustar0000000000000000{-# 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 , createPackageEnvironmentFile , tryLoadSandboxPackageEnvironmentFile , readPackageEnvironmentFile , showPackageEnvironment , showPackageEnvironmentWithComments , setPackageDB , sandboxPackageDBPath , loadUserConfig , basePackageEnvironment , initialPackageEnvironment , commentPackageEnvironment , sandboxPackageEnvironmentFile , userPackageEnvironmentFile ) where import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig , loadConfig, configFieldDescriptions , haddockFlagsFields , installDirsFields, withProgramsFields , withProgramOptionsFields , defaultCompiler ) import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..) , InstallFlags(..) , defaultSandboxLocation ) import Distribution.Client.Targets ( userConstraintPackageName ) import Distribution.Utils.NubList ( toNubList ) import Distribution.Simple.Compiler ( Compiler, PackageDB(..) , compilerFlavor, showCompilerIdWithAbi ) import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate , defaultInstallDirs, combineInstallDirs , fromPathTemplate, toPathTemplate ) import Distribution.Simple.Setup ( Flag(..) , ConfigFlags(..), HaddockFlags(..) , fromFlagOrDefault, toFlag, flagToMaybe ) import Distribution.Simple.Utils ( die', info, notice, warn, debug ) import Distribution.Solver.Types.ConstraintSource import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..) , commaListField, commaNewLineListField , liftField, lineNo, locatedErrorMsg , parseFilePathQ, readFields , showPWarning, simpleField , syntaxError, warning ) import Distribution.System ( Platform ) import Distribution.Verbosity ( Verbosity, normal ) import Control.Monad ( foldM, liftM2, unless ) import Data.List ( partition, sortBy ) import Data.Maybe ( isJust ) import Data.Ord ( comparing ) import Distribution.Compat.Exception ( catchIO ) import Distribution.Compat.Semigroup import System.Directory ( doesDirectoryExist, doesFileExist , renameFile ) import System.FilePath ( (<.>), (), takeDirectory ) import System.IO.Error ( isDoesNotExistError ) import Text.PrettyPrint ( ($+$) ) import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) import qualified Distribution.Text as Text import GHC.Generics ( Generic ) -- -- * 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 { -- The 'inherit' feature is not used ATM, but could be useful in the future -- for constructing nested sandboxes (see discussion in #1196). pkgEnvInherit :: Flag FilePath, pkgEnvSavedConfig :: SavedConfig } deriving Generic instance Monoid PackageEnvironment where mempty = gmempty mappend = (<>) instance Semigroup PackageEnvironment where (<>) = gmappend -- | The automatically-created package environment file that should not be -- touched by the user. sandboxPackageEnvironmentFile :: FilePath sandboxPackageEnvironmentFile = "cabal.sandbox.config" -- | 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 = SandboxPackageEnvironment -- ^ './cabal.sandbox.config' | UserPackageEnvironment -- ^ './cabal.config' | AmbientPackageEnvironment -- ^ '~/.cabal/config' -- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this -- directory? classifyPackageEnvironment :: FilePath -> Flag FilePath -> Flag Bool -> IO PackageEnvironmentType classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag ignoreSandboxFlag = do isSandbox <- liftM2 (||) (return forceSandboxConfig) (configExists sandboxPackageEnvironmentFile) isUser <- configExists userPackageEnvironmentFile return (classify isSandbox isUser) where configExists fname = doesFileExist (pkgEnvDir fname) ignoreSandbox = fromFlagOrDefault False ignoreSandboxFlag forceSandboxConfig = isJust . flagToMaybe $ sandboxConfigFileFlag classify :: Bool -> Bool -> PackageEnvironmentType classify True _ | not ignoreSandbox = SandboxPackageEnvironment classify _ True = UserPackageEnvironment classify _ False = AmbientPackageEnvironment -- | Defaults common to 'initialPackageEnvironment' and -- 'commentPackageEnvironment'. commonPackageEnvironmentConfig :: FilePath -> SavedConfig commonPackageEnvironmentConfig sandboxDir = mempty { savedConfigureFlags = mempty { -- TODO: Currently, we follow cabal-dev and set 'user-install: False' in -- the config file. In the future we may want to distinguish between -- global, sandbox and user install types. configUserInstall = toFlag False, configInstallDirs = installDirs }, savedUserInstallDirs = installDirs, savedGlobalInstallDirs = installDirs, savedGlobalFlags = mempty { globalLogsDir = toFlag $ sandboxDir "logs", -- Is this right? cabal-dev uses the global world file. globalWorldFile = toFlag $ sandboxDir "world" } } where installDirs = sandboxInstallDirs sandboxDir -- | 'commonPackageEnvironmentConfig' wrapped inside a 'PackageEnvironment'. commonPackageEnvironment :: FilePath -> PackageEnvironment commonPackageEnvironment sandboxDir = mempty { pkgEnvSavedConfig = commonPackageEnvironmentConfig sandboxDir } -- | Given a path to a sandbox, return the corresponding InstallDirs record. sandboxInstallDirs :: FilePath -> InstallDirs (Flag PathTemplate) sandboxInstallDirs sandboxDir = mempty { prefix = toFlag (toPathTemplate sandboxDir) } -- | These are the absolute basic defaults, the fields that must be -- initialised. When we load the package environment from the file we layer the -- loaded values over these ones. basePackageEnvironment :: PackageEnvironment basePackageEnvironment = mempty { pkgEnvSavedConfig = mempty { savedConfigureFlags = mempty { configHcFlavor = toFlag defaultCompiler, configVerbosity = toFlag normal } } } -- | Initial configuration that we write out to the package environment file if -- it does not exist. When the package environment gets loaded this -- configuration gets layered on top of 'basePackageEnvironment'. initialPackageEnvironment :: FilePath -> Compiler -> Platform -> IO PackageEnvironment initialPackageEnvironment sandboxDir compiler platform = do defInstallDirs <- defaultInstallDirs (compilerFlavor compiler) {- userInstall= -} False {- _hasLibs= -} False let initialConfig = commonPackageEnvironmentConfig sandboxDir installDirs = combineInstallDirs (\d f -> Flag $ fromFlagOrDefault d f) defInstallDirs (savedUserInstallDirs initialConfig) return $ mempty { pkgEnvSavedConfig = initialConfig { savedUserInstallDirs = installDirs, savedGlobalInstallDirs = installDirs, savedGlobalFlags = (savedGlobalFlags initialConfig) { globalLocalRepos = toNubList [sandboxDir "packages"] }, savedConfigureFlags = setPackageDB sandboxDir compiler platform (savedConfigureFlags initialConfig), savedInstallFlags = (savedInstallFlags initialConfig) { installSummaryFile = toNubList [toPathTemplate (sandboxDir "logs" "build.log")] } } } -- | Return the path to the sandbox package database. sandboxPackageDBPath :: FilePath -> Compiler -> Platform -> String sandboxPackageDBPath sandboxDir compiler platform = sandboxDir (Text.display platform ++ "-" ++ showCompilerIdWithAbi compiler ++ "-packages.conf.d") -- The path in sandboxPackageDBPath should be kept in sync with the -- path in the bootstrap.sh which is used to bootstrap cabal-install -- into a sandbox. -- | Use the package DB location specific for this compiler. setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags setPackageDB sandboxDir compiler platform configFlags = configFlags { configPackageDBs = [Just (SpecificPackageDB $ sandboxPackageDBPath sandboxDir compiler platform)] } -- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are -- overridden instead of mappend'ed. overrideSandboxSettings :: PackageEnvironment -> PackageEnvironment -> PackageEnvironment overrideSandboxSettings pkgEnv0 pkgEnv = pkgEnv { pkgEnvSavedConfig = mappendedConf { savedConfigureFlags = (savedConfigureFlags mappendedConf) { configPackageDBs = configPackageDBs pkgEnvConfigureFlags } , savedInstallFlags = (savedInstallFlags mappendedConf) { installSummaryFile = installSummaryFile pkgEnvInstallFlags } }, pkgEnvInherit = pkgEnvInherit pkgEnv0 } where pkgEnvConf = pkgEnvSavedConfig pkgEnv mappendedConf = (pkgEnvSavedConfig pkgEnv0) `mappend` pkgEnvConf pkgEnvConfigureFlags = savedConfigureFlags pkgEnvConf pkgEnvInstallFlags = savedInstallFlags pkgEnvConf -- | Default values that get used if no value is given. Used here to include in -- comments when we write out the initial package environment. commentPackageEnvironment :: FilePath -> IO PackageEnvironment commentPackageEnvironment sandboxDir = do commentConf <- commentSavedConfig let baseConf = commonPackageEnvironmentConfig sandboxDir return $ mempty { pkgEnvSavedConfig = commentConf `mappend` baseConf } -- | If this package environment inherits from some other package environment, -- return that package environment; otherwise return mempty. inheritedPackageEnvironment :: Verbosity -> PackageEnvironment -> IO PackageEnvironment inheritedPackageEnvironment verbosity pkgEnv = do case (pkgEnvInherit pkgEnv) of NoFlag -> return mempty confPathFlag@(Flag _) -> do conf <- loadConfig verbosity confPathFlag return $ mempty { pkgEnvSavedConfig = conf } -- | 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 -- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and -- 'updatePackageEnvironment'. handleParseResult :: Verbosity -> FilePath -> Maybe (ParseResult PackageEnvironment) -> IO PackageEnvironment handleParseResult verbosity path minp = case minp of Nothing -> die' verbosity $ "The package environment file '" ++ path ++ "' doesn't exist" Just (ParseOk warns parseResult) -> do unless (null warns) $ warn verbosity $ unlines (map (showPWarning path) warns) return parseResult Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err die' verbosity $ "Error parsing package environment file " ++ path ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg -- | Try to load the given package environment file, exiting with error if it -- doesn't exist. Also returns the path to the sandbox directory. The path -- parameter should refer to an existing file. tryLoadSandboxPackageEnvironmentFile :: Verbosity -> FilePath -> (Flag FilePath) -> IO (FilePath, PackageEnvironment) tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do let pkgEnvDir = takeDirectory pkgEnvFile minp <- readPackageEnvironmentFile (ConstraintSourceSandboxConfig pkgEnvFile) mempty pkgEnvFile pkgEnv <- handleParseResult verbosity pkgEnvFile minp -- Get the saved sandbox directory. -- TODO: Use substPathTemplate with -- compilerTemplateEnv ++ platformTemplateEnv ++ abiTemplateEnv. let sandboxDir = fromFlagOrDefault defaultSandboxLocation . fmap fromPathTemplate . prefix . savedUserInstallDirs . pkgEnvSavedConfig $ pkgEnv -- Do some sanity checks dirExists <- doesDirectoryExist sandboxDir -- TODO: Also check for an initialised package DB? unless dirExists $ die' verbosity ("No sandbox exists at " ++ sandboxDir) info verbosity $ "Using a sandbox located at " ++ sandboxDir let base = basePackageEnvironment let common = commonPackageEnvironment sandboxDir user <- userPackageEnvironment verbosity pkgEnvDir Nothing --TODO inherited <- inheritedPackageEnvironment verbosity user -- Layer the package environment settings over settings from ~/.cabal/config. cabalConfig <- fmap unsetSymlinkBinDir $ loadConfig verbosity configFileFlag return (sandboxDir, updateInstallDirs $ (base `mappend` (toPkgEnv cabalConfig) `mappend` common `mappend` inherited `mappend` user) `overrideSandboxSettings` pkgEnv) where toPkgEnv config = mempty { pkgEnvSavedConfig = config } updateInstallDirs pkgEnv = let config = pkgEnvSavedConfig pkgEnv configureFlags = savedConfigureFlags config installDirs = savedUserInstallDirs config in pkgEnv { pkgEnvSavedConfig = config { savedConfigureFlags = configureFlags { configInstallDirs = installDirs } } } -- We don't want to inherit the value of 'symlink-bindir' from -- '~/.cabal/config'. See #1514. unsetSymlinkBinDir config = let installFlags = savedInstallFlags config in config { savedInstallFlags = installFlags { installSymlinkBinDir = NoFlag } } -- | Create a new package environment file, replacing the existing one if it -- exists. Note that the path parameters should point to existing directories. createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath -> Compiler -> Platform -> IO () createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile compiler platform = do notice verbosity $ "Writing a default package environment file to " ++ pkgEnvFile initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform writePackageEnvironmentFile pkgEnvFile initialPkgEnv -- | Descriptions of all fields in the package environment file. pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment] pkgEnvFieldDescrs src = [ simpleField "inherit" (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ) pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v }) , commaNewLineListField "constraints" (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse) (sortConstraints . configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig) (\v pkgEnv -> updateConfigureExFlags pkgEnv (\flags -> flags { configExConstraints = v })) , commaListField "preferences" Text.disp Text.parse (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) (\v pkgEnv -> updateConfigureExFlags pkgEnv (\flags -> flags { configPreferences = v })) ] ++ map toPkgEnv configFieldDescriptions' where optional = Parse.option mempty . fmap toFlag 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])]) -- | Write out the package environment file. writePackageEnvironmentFile :: FilePath -> PackageEnvironment -> IO () writePackageEnvironmentFile path pkgEnv = do let tmpPath = (path <.> "tmp") writeFile tmpPath $ explanation ++ pkgEnvStr ++ "\n" renameFile tmpPath path where pkgEnvStr = showPackageEnvironment pkgEnv explanation = unlines ["-- This is a Cabal package environment file." ,"-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY." ,"-- Please create a 'cabal.config' file in the same directory" ,"-- if you want to change the default settings for this sandbox." ,"","" ] -- | 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 cabal-install-2.4.0.0/Distribution/Client/Sandbox/Timestamp.hs0000644000000000000000000003043300000000000022305 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Sandbox.Timestamp -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Timestamp file handling (for add-source dependencies). ----------------------------------------------------------------------------- module Distribution.Client.Sandbox.Timestamp ( AddSourceTimestamp, withAddTimestamps, withUpdateTimestamps, maybeAddCompilerTimestampRecord, listModifiedDeps, removeTimestamps, -- * For testing TimestampFileRecord, readTimestampFile, writeTimestampFile ) where import Control.Monad (filterM, forM, when) import Data.Char (isSpace) import Data.List (partition) import System.Directory (renameFile) import System.FilePath ((<.>), ()) import qualified Data.Map as M import Distribution.Compiler (CompilerId) import Distribution.Simple.Utils (debug, die', warn) import Distribution.System (Platform) import Distribution.Text (display) import Distribution.Verbosity (Verbosity) import Distribution.Client.SrcDist (allPackageSourceFiles) import Distribution.Client.Sandbox.Index (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks) ,listBuildTreeRefs) import Distribution.Client.SetupWrapper import Distribution.Compat.Exception (catchIO) import Distribution.Compat.Time (ModTime, getCurTime, getModTime, posixSecondsToModTime) -- | Timestamp of an add-source dependency. type AddSourceTimestamp = (FilePath, ModTime) -- | Timestamp file record - a string identifying the compiler & platform plus a -- list of add-source timestamps. type TimestampFileRecord = (String, [AddSourceTimestamp]) timestampRecordKey :: CompilerId -> Platform -> String timestampRecordKey compId platform = display platform ++ "-" ++ display compId -- | The 'add-source-timestamps' file keeps the timestamps of all add-source -- dependencies. It is initially populated by 'sandbox add-source' and kept -- current by 'reinstallAddSourceDeps' and 'configure -w'. The user can install -- add-source deps manually with 'cabal install' after having edited them, so we -- can err on the side of caution sometimes. -- FIXME: We should keep this info in the index file, together with build tree -- refs. timestampFileName :: FilePath timestampFileName = "add-source-timestamps" -- | Read the timestamp file. Exits with error if the timestamp file is -- corrupted. Returns an empty list if the file doesn't exist. readTimestampFile :: Verbosity -> FilePath -> IO [TimestampFileRecord] readTimestampFile verbosity timestampFile = do timestampString <- readFile timestampFile `catchIO` \_ -> return "[]" case reads timestampString of [(version, s)] | version == (2::Int) -> case reads s of [(timestamps, s')] | all isSpace s' -> return timestamps _ -> dieCorrupted | otherwise -> dieWrongFormat -- Old format (timestamps are POSIX seconds). Convert to new format. [] -> case reads timestampString of [(timestamps, s)] | all isSpace s -> do let timestamps' = map (\(i, ts) -> (i, map (\(p, t) -> (p, posixSecondsToModTime t)) ts)) timestamps writeTimestampFile timestampFile timestamps' return timestamps' _ -> dieCorrupted _ -> dieCorrupted where dieWrongFormat = die' verbosity $ wrongFormat ++ deleteAndRecreate dieCorrupted = die' verbosity $ corrupted ++ deleteAndRecreate wrongFormat = "The timestamps file is in the wrong format." corrupted = "The timestamps file is corrupted." deleteAndRecreate = " Please delete and recreate the sandbox." -- | Write the timestamp file, atomically. writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO () writeTimestampFile timestampFile timestamps = do writeFile timestampTmpFile "2\n" -- version appendFile timestampTmpFile (show timestamps ++ "\n") renameFile timestampTmpFile timestampFile where timestampTmpFile = timestampFile <.> "tmp" -- | Read, process and write the timestamp file in one go. withTimestampFile :: Verbosity -> FilePath -> ([TimestampFileRecord] -> IO [TimestampFileRecord]) -> IO () withTimestampFile verbosity sandboxDir process = do let timestampFile = sandboxDir timestampFileName timestampRecords <- readTimestampFile verbosity timestampFile >>= process writeTimestampFile timestampFile timestampRecords -- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps -- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list -- for each path. If a timestamp for a given path already exists in the list, -- update it. addTimestamps :: ModTime -> [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp] addTimestamps initial timestamps newPaths = [ (p, initial) | p <- newPaths ] ++ oldTimestamps where (oldTimestamps, _toBeUpdated) = partition (\(path, _) -> path `notElem` newPaths) timestamps -- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps -- we've reinstalled and a new timestamp value, update the timestamp value for -- the deps in the list. If there are new paths in the list, ignore them. updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> ModTime -> [AddSourceTimestamp] updateTimestamps timestamps pathsToUpdate newTimestamp = foldr updateTimestamp [] timestamps where updateTimestamp t@(path, _oldTimestamp) rest | path `elem` pathsToUpdate = (path, newTimestamp) : rest | otherwise = t : rest -- | Given a list of 'TimestampFileRecord's and a list of paths to add-source -- deps we've removed, remove those deps from the list. removeTimestamps' :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp] removeTimestamps' l pathsToRemove = foldr removeTimestamp [] l where removeTimestamp t@(path, _oldTimestamp) rest = if path `elem` pathsToRemove then rest else t : rest -- | If a timestamp record for this compiler doesn't exist, add a new one. maybeAddCompilerTimestampRecord :: Verbosity -> FilePath -> FilePath -> CompilerId -> Platform -> IO () maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile compId platform = do let key = timestampRecordKey compId platform withTimestampFile verbosity sandboxDir $ \timestampRecords -> do case lookup key timestampRecords of Just _ -> return timestampRecords Nothing -> do buildTreeRefs <- listBuildTreeRefs verbosity ListIgnored OnlyLinks indexFile now <- getCurTime let timestamps = map (\p -> (p, now)) buildTreeRefs return $ (key, timestamps):timestampRecords -- | Given an IO action that returns a list of build tree refs, add those -- build tree refs to the timestamps file (for all compilers). withAddTimestamps :: Verbosity -> FilePath -> IO [FilePath] -> IO () withAddTimestamps verbosity sandboxDir act = do let initialTimestamp = minBound withActionOnAllTimestamps (addTimestamps initialTimestamp) verbosity sandboxDir act -- | Given a list of build tree refs, remove those -- build tree refs from the timestamps file (for all compilers). removeTimestamps :: Verbosity -> FilePath -> [FilePath] -> IO () removeTimestamps verbosity idxFile = withActionOnAllTimestamps removeTimestamps' verbosity idxFile . return -- | Given an IO action that returns a list of build tree refs, update the -- timestamps of the returned build tree refs to the current time (only for the -- given compiler & platform). withUpdateTimestamps :: Verbosity -> FilePath -> CompilerId -> Platform ->([AddSourceTimestamp] -> IO [FilePath]) -> IO () withUpdateTimestamps = withActionOnCompilerTimestamps updateTimestamps -- | Helper for implementing 'withAddTimestamps' and -- 'withRemoveTimestamps'. Runs a given action on the list of -- 'AddSourceTimestamp's for all compilers, applies 'f' to the result and then -- updates the timestamp file. The IO action is run only once. withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]) -> Verbosity -> FilePath -> IO [FilePath] -> IO () withActionOnAllTimestamps f verbosity sandboxDir act = withTimestampFile verbosity sandboxDir $ \timestampRecords -> do paths <- act return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords] -- | Helper for implementing 'withUpdateTimestamps'. Runs a given action on the -- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result -- and then updates the timestamp file record. The IO action is run only once. withActionOnCompilerTimestamps :: ([AddSourceTimestamp] -> [FilePath] -> ModTime -> [AddSourceTimestamp]) -> Verbosity -> FilePath -> CompilerId -> Platform -> ([AddSourceTimestamp] -> IO [FilePath]) -> IO () withActionOnCompilerTimestamps f verbosity sandboxDir compId platform act = do let needle = timestampRecordKey compId platform withTimestampFile verbosity sandboxDir $ \timestampRecords -> do timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) -> if key == needle then do paths <- act timestamps now <- getCurTime return (key, f timestamps paths now) else return r return timestampRecords' -- | Has this dependency been modified since we have last looked at it? isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool isDepModified verbosity now (packageDir, timestamp) = do debug verbosity ("Checking whether the dependency is modified: " ++ packageDir) -- TODO: we should properly plumb the correct options through -- instead of using defaultSetupScriptOptions depSources <- allPackageSourceFiles verbosity defaultSetupScriptOptions packageDir go depSources where go [] = return False go (dep0:rest) = do -- FIXME: What if the clock jumps backwards at any point? For now we only -- print a warning. let dep = packageDir dep0 modTime <- getModTime dep when (modTime > now) $ warn verbosity $ "File '" ++ dep ++ "' has a modification time that is in the future." if modTime >= timestamp then do debug verbosity ("Dependency has a modified source file: " ++ dep) return True else go rest -- | List all modified dependencies. listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform -> M.Map FilePath a -- ^ The set of all installed add-source deps. -> IO [FilePath] listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do timestampRecords <- readTimestampFile verbosity (sandboxDir timestampFileName) let needle = timestampRecordKey compId platform timestamps <- maybe noTimestampRecord return (lookup needle timestampRecords) now <- getCurTime fmap (map fst) . filterM (isDepModified verbosity now) . filter (\ts -> fst ts `M.member` installedDepsMap) $ timestamps where noTimestampRecord = die' verbosity $ "Сouldn't find a timestamp record for the given " ++ "compiler/platform pair. " ++ "Please report this on the Cabal bug tracker: " ++ "https://github.com/haskell/cabal/issues/new ." cabal-install-2.4.0.0/Distribution/Client/Sandbox/Types.hs0000644000000000000000000000453700000000000021454 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Sandbox.Types -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Helpers for writing code that works both inside and outside a sandbox. ----------------------------------------------------------------------------- module Distribution.Client.Sandbox.Types ( UseSandbox(..), isUseSandbox, whenUsingSandbox, SandboxPackageInfo(..) ) where import Prelude () import Distribution.Client.Compat.Prelude import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Client.Types (UnresolvedSourcePackage) import qualified Data.Set as S -- | Are we using a sandbox? data UseSandbox = UseSandbox FilePath | NoSandbox instance Monoid UseSandbox where mempty = NoSandbox mappend = (<>) instance Semigroup UseSandbox where NoSandbox <> s = s u0@(UseSandbox _) <> NoSandbox = u0 (UseSandbox _) <> u1@(UseSandbox _) = u1 -- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with -- @when@. isUseSandbox :: UseSandbox -> Bool isUseSandbox (UseSandbox _) = True isUseSandbox NoSandbox = False -- | Execute an action only if we're in a sandbox, feeding to it the path to the -- sandbox directory. whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO () whenUsingSandbox NoSandbox _ = return () whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir -- | Data about the packages installed in the sandbox that is passed from -- 'reinstallAddSourceDeps' to the solver. data SandboxPackageInfo = SandboxPackageInfo { modifiedAddSourceDependencies :: ![UnresolvedSourcePackage], -- ^ Modified add-source deps that we want to reinstall. These are guaranteed -- to be already installed in the sandbox. otherAddSourceDependencies :: ![UnresolvedSourcePackage], -- ^ Remaining add-source deps. Some of these may be not installed in the -- sandbox. otherInstalledSandboxPackages :: !InstalledPackageIndex.InstalledPackageIndex, -- ^ All packages installed in the sandbox. Intersection with -- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be -- non-empty. allAddSourceDependencies :: !(S.Set FilePath) -- ^ A set of paths to all add-source dependencies, for convenience. } cabal-install-2.4.0.0/Distribution/Client/SavedFlags.hs0000644000000000000000000000570700000000000020771 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags , readSavedArgs, writeSavedArgs ) where import Distribution.Simple.Command import Distribution.Simple.UserHooks ( Args ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, unintersperse ) import Distribution.Verbosity import Control.Exception ( Exception, throwIO ) import Control.Monad ( liftM ) import Data.List ( intercalate ) import Data.Maybe ( fromMaybe ) import Data.Typeable import System.Directory ( doesFileExist ) import System.FilePath ( takeDirectory ) writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () writeSavedArgs verbosity path args = do createDirectoryIfMissingVerbose (lessVerbose verbosity) True (takeDirectory path) writeFile path (intercalate "\0" args) -- | Write command-line flags to a file, separated by null characters. This -- format is also suitable for the @xargs -0@ command. Using the null -- character also avoids the problem of escaping newlines or spaces, -- because unlike other whitespace characters, the null character is -- not valid in command-line arguments. writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO () writeCommandFlags verbosity path command flags = writeSavedArgs verbosity path (commandShowOptions command flags) readSavedArgs :: FilePath -> IO (Maybe [String]) readSavedArgs path = do exists <- doesFileExist path if exists then liftM (Just . unintersperse '\0') (readFile path) else return Nothing -- | Read command-line arguments, separated by null characters, from a file. -- Returns the default flags if the file does not exist. readCommandFlags :: FilePath -> CommandUI flags -> IO flags readCommandFlags path command = do savedArgs <- liftM (fromMaybe []) (readSavedArgs path) case (commandParseArgs command True savedArgs) of CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs) CommandList _ -> throwIO (SavedArgsErrorList savedArgs) CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs) CommandReadyToGo (mkFlags, _) -> return (mkFlags (commandDefaultFlags command)) -- ----------------------------------------------------------------------------- -- * Exceptions -- ----------------------------------------------------------------------------- data SavedArgsError = SavedArgsErrorHelp Args | SavedArgsErrorList Args | SavedArgsErrorOther Args [String] deriving (Typeable) instance Show SavedArgsError where show (SavedArgsErrorHelp args) = "unexpected flag '--help', saved command line was:\n" ++ intercalate " " args show (SavedArgsErrorList args) = "unexpected flag '--list-options', saved command line was:\n" ++ intercalate " " args show (SavedArgsErrorOther args errs) = "saved command line was:\n" ++ intercalate " " args ++ "\n" ++ "encountered errors:\n" ++ intercalate "\n" errs instance Exception SavedArgsError cabal-install-2.4.0.0/Distribution/Client/Security/0000755000000000000000000000000000000000000020214 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/Security/DNS.hs0000644000000000000000000001677700000000000021216 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Client.Security.DNS ( queryBootstrapMirrors ) where import Prelude () import Distribution.Client.Compat.Prelude import Network.URI (URI(..), URIAuth(..), parseURI) import Distribution.Verbosity import Control.Monad import Control.DeepSeq (force) import Control.Exception (SomeException, evaluate, try) import Distribution.Simple.Utils import Distribution.Compat.Exception (displayException) #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 ++ " :") forM_ 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 ++ " :") forM_ mirrors $ \url -> info verbosity ("- " ++ show url) return mirrors | otherwise = return [] where nslookupProg = simpleProgram "nslookup" -- | Extract list of mirrors from @nslookup -query=TXT@ output. extractMirrors :: String -> String -> [URI] extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals where vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0 , h == hostname , e <- ents , Just (k,v) <- [splitRfc1464 e] , Just kn <- [isUrlBase k] ] -- | 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 cabal-install-2.4.0.0/Distribution/Client/Security/HTTP.hs0000644000000000000000000001577300000000000021344 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport' module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where -- stdlibs import Control.Exception ( Exception(..), IOException ) import Data.List ( intercalate ) import Data.Typeable ( Typeable ) import System.Directory ( getTemporaryDirectory ) import Network.URI ( URI ) import qualified Data.ByteString.Lazy as BS.L import qualified Network.HTTP as HTTP -- Cabal/cabal-install import Distribution.Verbosity ( Verbosity ) import Distribution.Client.HttpUtils ( HttpTransport(..), HttpCode ) import Distribution.Client.Utils ( withTempFileName ) -- hackage-security import Hackage.Security.Client import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked import Hackage.Security.Util.Pretty import qualified Hackage.Security.Util.Lens as Lens {------------------------------------------------------------------------------- 'HttpLib' implementation -------------------------------------------------------------------------------} -- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport' -- -- NOTE: The match between these two APIs is currently not perfect: -- -- * We don't get any response headers back from the 'HttpTransport', so we -- don't know if the server supports range requests. For now we optimistically -- assume that it does. -- * The 'HttpTransport' wants to know where to place the resulting file, -- whereas the 'HttpLib' expects an 'IO' action which streams the download; -- the security library then makes sure that the file gets written to a -- location which is suitable (in particular, to a temporary file in the -- directory where the file needs to end up, so that it can "finalize" the -- file simply by doing 'renameFile'). Right now we write the file to a -- temporary file in the system temp directory here and then read it again -- to pass it to the security library; this is a problem for two reasons: it -- is a source of inefficiency; and it means that the security library cannot -- insist on a minimum download rate (potential security attack). -- Fixing it however would require changing the 'HttpTransport'. transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib transportAdapter verbosity getTransport = HttpLib{ httpGet = \headers uri callback -> do transport <- getTransport get verbosity transport headers uri callback , httpGetRange = \headers uri range callback -> do transport <- getTransport getRange verbosity transport headers uri range callback } get :: Throws SomeRemoteError => Verbosity -> HttpTransport -> [HttpRequestHeader] -> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a get verbosity transport reqHeaders uri callback = wrapCustomEx $ do get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br -> case code of 200 -> callback respHeaders br _ -> throwChecked $ UnexpectedResponse uri code getRange :: Throws SomeRemoteError => Verbosity -> HttpTransport -> [HttpRequestHeader] -> URI -> (Int, Int) -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br -> case code of 200 -> callback HttpStatus200OK respHeaders br 206 -> callback HttpStatus206PartialContent respHeaders br _ -> throwChecked $ UnexpectedResponse uri code -- | Internal generalization of 'get' and 'getRange' get' :: Verbosity -> HttpTransport -> [HttpRequestHeader] -> URI -> Maybe (Int, Int) -> (HttpCode -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a get' verbosity transport reqHeaders uri mRange callback = do tempDir <- getTemporaryDirectory withTempFileName tempDir "transportAdapterGet" $ \temp -> do (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders' br <- bodyReaderFromBS =<< BS.L.readFile temp callback code [HttpResponseAcceptRangesBytes] br where reqHeaders' = mkReqHeaders reqHeaders mRange {------------------------------------------------------------------------------- Request headers -------------------------------------------------------------------------------} mkRangeHeader :: Int -> Int -> HTTP.Header mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader where -- Content-Range header uses inclusive rather than exclusive bounds -- See rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1) mkReqHeaders :: [HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header] mkReqHeaders reqHeaders mRange = concat [ tr [] reqHeaders , [mkRangeHeader fr to | Just (fr, to) <- [mRange]] ] where tr :: [(HTTP.HeaderName, [String])] -> [HttpRequestHeader] -> [HTTP.Header] tr acc [] = concatMap finalize acc tr acc (HttpRequestMaxAge0:os) = tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os tr acc (HttpRequestNoTransform:os) = tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os -- Some headers are comma-separated, others need multiple headers for -- multiple options. -- -- TODO: Right we we just comma-separate all of them. finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header] finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] insert x y = Lens.modify (Lens.lookupM x) (++ y) {------------------------------------------------------------------------------- Custom exceptions -------------------------------------------------------------------------------} data UnexpectedResponse = UnexpectedResponse URI Int deriving (Typeable) instance Pretty UnexpectedResponse where pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code ++ "for " ++ show uri #if MIN_VERSION_base(4,8,0) deriving instance Show UnexpectedResponse instance Exception UnexpectedResponse where displayException = pretty #else instance Show UnexpectedResponse where show = pretty instance Exception UnexpectedResponse #endif wrapCustomEx :: ( ( Throws UnexpectedResponse , Throws IOException ) => IO a) -> (Throws SomeRemoteError => IO a) wrapCustomEx act = handleChecked (\(ex :: UnexpectedResponse) -> go ex) $ handleChecked (\(ex :: IOException) -> go ex) $ act where go ex = throwChecked (SomeRemoteError ex) cabal-install-2.4.0.0/Distribution/Client/Setup.hs0000644000000000000000000034133400000000000020051 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- 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(..), filterConfigureFlags , configPackageDB', configCompilerAux' , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , replCommand, testCommand, benchmarkCommand , configureExOptions, reconfigureCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , filterHaddockArgs, filterHaddockFlags , defaultSolver, defaultMaxBackjumps , listCommand, ListFlags(..) , updateCommand, UpdateFlags(..), defaultUpdateFlags , upgradeCommand , uninstallCommand , infoCommand, InfoFlags(..) , fetchCommand, FetchFlags(..) , freezeCommand, FreezeFlags(..) , genBoundsCommand , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..) , getCommand, unpackCommand, GetFlags(..) , checkCommand , formatCommand , uploadCommand, UploadFlags(..), IsCandidate(..) , reportCommand, ReportFlags(..) , runCommand , initCommand, IT.InitFlags(..) , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) , actAsSetupCommand, ActAsSetupFlags(..) , sandboxCommand, defaultSandboxLocation, SandboxFlags(..) , execCommand, ExecFlags(..), defaultExecFlags , userConfigCommand, UserConfigFlags(..) , manpageCommand , haddockCommand , cleanCommand , doctestCommand , copyCommand , registerCommand , parsePackageArgs , liftOptions --TODO: stop exporting these: , showRepo , parseRepo , readRepo ) where import Prelude () import Distribution.Client.Compat.Prelude hiding (get) import Distribution.Client.Types ( Username(..), Password(..), RemoteRepo(..) , AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Dependency.Types ( PreSolver(..) ) import Distribution.Client.IndexUtils.Timestamp ( IndexState(..) ) import qualified Distribution.Client.Init.Types as IT ( InitFlags(..), PackageType(..) ) 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.Setup ( ConfigFlags(..), BuildFlags(..), ReplFlags , TestFlags(..), BenchmarkFlags(..) , SDistFlags(..), HaddockFlags(..) , CleanFlags(..), DoctestFlags(..) , CopyFlags(..), RegisterFlags(..) , readPackageDbList, showPackageDbList , Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag , BooleanFlag(..), optionVerbosity , boolOpt, boolOpt', trueArg, falseArg , optionNumJobs ) import Distribution.Simple.InstallDirs ( PathTemplate, InstallDirs(..) , toPathTemplate, fromPathTemplate, combinePathTemplate ) import Distribution.Version ( Version, mkVersion, nullVersion, anyVersion, thisVersion ) import Distribution.Package ( PackageIdentifier, PackageName, packageName, packageVersion ) import Distribution.Types.Dependency import Distribution.PackageDescription ( BuildType(..), RepoKind(..) ) import Distribution.System ( Platform ) import Distribution.Text ( Text(..), display ) import Distribution.ReadE ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse ( ReadP, char, munch1, pfail, sepBy1, (+++) ) import Distribution.ParseUtils ( readPToMaybe ) import Distribution.Verbosity ( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) import Distribution.Simple.Utils ( wrapText, wrapLine ) import Distribution.Client.GlobalFlags ( GlobalFlags(..), defaultGlobalFlags , RepoContext(..), withRepoContext ) import Data.List ( deleteFirstsBy ) import System.FilePath ( () ) import Network.URI ( parseAbsoluteURI, uriToString ) 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" , "reconfigure" , "build" , "clean" , "run" , "repl" , "test" , "bench" , "check" , "sdist" , "upload" , "report" , "freeze" , "gen-bounds" , "outdated" , "doctest" , "haddock" , "hscolour" , "copy" , "register" , "sandbox" , "exec" , "new-build" , "new-configure" , "new-repl" , "new-freeze" , "new-run" , "new-test" , "new-bench" , "new-haddock" , "new-exec" , "new-update" , "new-install" , "new-clean" , "new-sdist" -- 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" , "v1-sandbox" -- 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 addCmdCustom n d = case lookup n cmdDescs of -- make sure that the -- command still exists. Nothing -> "" Just _ -> " " ++ 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 "doctest" , addCmd "haddock" , addCmd "hscolour" , addCmd "copy" , addCmd "register" , addCmd "reconfigure" , par , startGroup "sandbox" , addCmd "sandbox" , addCmd "exec" , addCmdCustom "repl" "Open interpreter with access to sandbox packages." , par , startGroup "new-style projects (beta)" , addCmd "new-build" , addCmd "new-configure" , addCmd "new-repl" , addCmd "new-run" , addCmd "new-test" , addCmd "new-bench" , addCmd "new-freeze" , addCmd "new-haddock" , addCmd "new-exec" , addCmd "new-update" , addCmd "new-install" , addCmd "new-clean" , addCmd "new-sdist" , 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" , addCmd "v1-sandbox" ] ++ 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 [] ["sandbox-config-file"] "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')" globalSandboxConfigFile (\v flags -> flags { globalSandboxConfigFile = v }) (reqArgFlag "FILE") ,option [] ["default-user-config"] "Set a location for a cabal.config file for projects without their own cabal.config freeze file." globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v}) (reqArgFlag "FILE") ,option [] ["require-sandbox"] "requiring the presence of a sandbox for sandbox-aware commands" globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v }) (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"])) ,option [] ["ignore-sandbox"] "Ignore any existing sandbox" globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v }) trueArg ,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 . readRepo) (map showRepo . fromNubList)) ,option [] ["remote-repo-cache"] "The location where downloads from all remote repos are cached" globalCacheDir (\v flags -> flags { globalCacheDir = v }) (reqArgFlag "DIR") ,option [] ["local-repo"] "The location of a local repository" globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) (reqArg' "DIR" (\x -> toNubList [x]) fromNubList) ,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") ] -- ------------------------------------------------------------ -- * 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,1,0] = flags_latest -- The naming convention is that flags_version gives flags with -- all flags *introduced* in version eliminated. -- It is NOT the latest version of Cabal library that -- these flags work for; version of introduction is a more -- natural metric. | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10 | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0 | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0 | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0 | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0 | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1 | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2 | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1 | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 | otherwise = flags_latest where flags_latest = flags { -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. configConstraints = [] } flags_2_1_0 = flags_latest { -- 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 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 :: [Dependency], configSolver :: Flag PreSolver, configAllowNewer :: Maybe AllowNewer, configAllowOlder :: Maybe AllowOlder } deriving (Eq, 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" (readP_to_E ("Cannot parse cabal lib version: "++) (fmap toFlag parse)) (map display . 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 $ display . fst)) , option [] ["preference"] "Specify preferences (soft constraints) on the version of a package" configPreferences (\v flags -> flags { configPreferences = v }) (reqArg "CONSTRAINT" (readP_to_E (const "dependency expected") (fmap (\x -> [x]) parse)) (map display)) , 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" (readP_to_E ("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" (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) (Just RelaxDepsAll) relaxDepsPrinter) ] relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps) relaxDepsParser = (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',') relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] relaxDepsPrinter Nothing = [] relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ 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 -- ------------------------------------------------------------ data SkipAddSourceDepsCheck = SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck deriving Eq data BuildExFlags = BuildExFlags { buildOnly :: Flag SkipAddSourceDepsCheck } deriving Generic buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags] buildExOptions _showOrParseArgs = option [] ["only"] "Don't reinstall add-source dependencies (sandbox-only)" buildOnly (\v flags -> flags { buildOnly = v }) (noArg (Flag SkipAddSourceDepsCheck)) : [] buildCommand :: CommandUI (BuildFlags, BuildExFlags) 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, mempty), commandUsage = usageAlternatives "v1-build" $ [ "[FLAGS]", "COMPONENTS [FLAGS]" ], commandOptions = \showOrParseArgs -> liftOptions fst setFst (commandOptions parent showOrParseArgs) ++ liftOptions snd setSnd (buildExOptions showOrParseArgs) , 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 setFst a (_,b) = (a,b) setSnd b (a,_) = (a,b) parent = Cabal.buildCommand defaultProgramDb instance Monoid BuildExFlags where mempty = gmempty mappend = (<>) instance Semigroup BuildExFlags where (<>) = gmappend -- ------------------------------------------------------------ -- * Repl command -- ------------------------------------------------------------ replCommand :: CommandUI (ReplFlags, BuildExFlags) replCommand = parent { commandName = "repl", commandDescription = Just $ \pname -> wrapText $ "If the current directory contains no package, ignores COMPONENT " ++ "parameters and opens an interactive interpreter session; if a " ++ "sandbox is present, its package database will be used.\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, mempty), commandOptions = \showOrParseArgs -> liftOptions fst setFst (commandOptions parent showOrParseArgs) ++ liftOptions snd setSnd (buildExOptions showOrParseArgs), 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 setFst a (_,b) = (a,b) setSnd b (a,_) = (a,b) parent = Cabal.replCommand defaultProgramDb -- ------------------------------------------------------------ -- * Test command -- ------------------------------------------------------------ testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags) 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 = (commandDefaultFlags parent, Cabal.defaultBuildFlags, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 (commandOptions parent showOrParseArgs) ++ liftOptions get2 set2 (Cabal.buildOptions progDb showOrParseArgs) ++ liftOptions get3 set3 (buildExOptions showOrParseArgs) } where get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) parent = Cabal.testCommand progDb = defaultProgramDb -- ------------------------------------------------------------ -- * Bench command -- ------------------------------------------------------------ benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags) 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 = (commandDefaultFlags parent, Cabal.defaultBuildFlags, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 (commandOptions parent showOrParseArgs) ++ liftOptions get2 set2 (Cabal.buildOptions progDb showOrParseArgs) ++ liftOptions get3 set3 (buildExOptions showOrParseArgs) } where get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) 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, fetchIndependentGoals :: Flag IndependentGoals, fetchShadowPkgs :: Flag ShadowPkgs, fetchStrongFlags :: Flag StrongFlags, fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, 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), fetchIndependentGoals = Flag (IndependentGoals False), fetchShadowPkgs = Flag (ShadowPkgs False), fetchStrongFlags = Flag (StrongFlags False), fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), 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 }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = 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, freezeIndependentGoals :: Flag IndependentGoals, freezeShadowPkgs :: Flag ShadowPkgs, freezeStrongFlags :: Flag StrongFlags, freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, 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), freezeIndependentGoals = Flag (IndependentGoals False), freezeShadowPkgs = Flag (ShadowPkgs False), freezeStrongFlags = Flag (StrongFlags False), freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), 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 }) freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) } -- ------------------------------------------------------------ -- * 'gen-bounds' command -- ------------------------------------------------------------ genBoundsCommand :: CommandUI FreezeFlags genBoundsCommand = CommandUI { commandName = "gen-bounds", commandSynopsis = "Generate dependency bounds.", commandDescription = Just $ \_ -> wrapText $ "Generates bounds for all dependencies that do not currently have them. " ++ "Generated bounds are printed to stdout. " ++ "You can then paste them into your .cabal file.\n" ++ "\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 [] ["new-freeze-file", "v2-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 display)) ,option [] ["minor"] "Ignore major version bumps for these packages" outdatedMinor (\v flags -> flags { outdatedMinor = v }) (optArg "PKGS" ignoreMajorVersionBumpsParser (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter) ] } where ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps) -> [Maybe String] ignoreMajorVersionBumpsPrinter Nothing = [] ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = map (Just . display) $ pkgs ignoreMajorVersionBumpsParser = (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser pkgNameListParser = readP_to_E ("Couldn't parse the list of package names: " ++) (Parse.sepBy1 parse (Parse.char ',')) -- ------------------------------------------------------------ -- * Update command -- ------------------------------------------------------------ data UpdateFlags = UpdateFlags { updateVerbosity :: Flag Verbosity, updateIndexState :: Flag IndexState } deriving Generic defaultUpdateFlags :: UpdateFlags defaultUpdateFlags = UpdateFlags { updateVerbosity = toFlag normal, updateIndexState = toFlag IndexStateHead } 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" (readP_to_E (const $ "index-state must be a " ++ "unix-timestamps (e.g. '@1474732068'), " ++ "a ISO8601 UTC timestamp " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") (toFlag `fmap` parse)) (flagToList . fmap display)) ] } -- ------------------------------------------------------------ -- * Other commands -- ------------------------------------------------------------ upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) upgradeCommand = configureCommand { commandName = "upgrade", commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usageFlagsOrPackages "upgrade", commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } 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 = \_ -> [] } uninstallCommand :: CommandUI (Flag Verbosity) uninstallCommand = CommandUI { commandName = "uninstall", commandSynopsis = "Warn about 'uninstall' not being implemented.", commandDescription = Nothing, commandNotes = Nothing, commandUsage = usageAlternatives "uninstall" ["PACKAGES"], commandDefaultFlags = toFlag normal, commandOptions = \_ -> [] } manpageCommand :: CommandUI (Flag Verbosity) manpageCommand = CommandUI { commandName = "manpage", commandSynopsis = "Outputs manpage source.", commandDescription = Just $ \_ -> "Output manpage source to STDOUT.\n", commandNotes = Nothing, commandUsage = usageFlags "manpage", commandDefaultFlags = toFlag normal, commandOptions = \_ -> [optionVerbosity id const] } runCommand :: CommandUI (BuildFlags, BuildExFlags) runCommand = CommandUI { commandName = "run", commandSynopsis = "Builds and runs an executable.", commandDescription = Just $ \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 = \showOrParseArgs -> liftOptions fst setFst (commandOptions parent showOrParseArgs) ++ liftOptions snd setSnd (buildExOptions showOrParseArgs) } where setFst a (_,b) = (a,b) setSnd b (a,_) = (a,b) 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 IndexState, getSourceRepository :: Flag (Maybe RepoKind), getVerbosity :: Flag Verbosity } deriving Generic defaultGetFlags :: GetFlags defaultGetFlags = GetFlags { getDestDir = mempty, getPristine = mempty, getIndexState = 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|...]" (readP_to_E (const "invalid source-repository") (fmap (toFlag . Just) parse)) (Flag Nothing) (map (fmap show) . flagToList)) , option [] ["index-state"] ("Use source package index state as it existed at a previous time. " ++ "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++ "This determines which package versions are available as well as " ++ ".cabal file revision is selected (unless --pristine is used).") getIndexState (\v flags -> flags { getIndexState = v }) (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ "unix-timestamps (e.g. '@1474732068'), " ++ "a ISO8601 UTC timestamp " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") (toFlag `fmap` parse)) (flagToList . fmap display)) , option [] ["pristine"] ("Unpack the original pristine tarball, rather than updating the " ++ ".cabal file with the latest revision from the package archive.") 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, listVerbosity :: Flag Verbosity, listPackageDBs :: [Maybe PackageDB] } deriving Generic defaultListFlags :: ListFlags defaultListFlags = ListFlags { listInstalled = Flag False, listSimpleOutput = Flag False, listVerbosity = toFlag normal, listPackageDBs = [] } 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" ++ "If there is a sandbox in the current directory and " ++ "config:ignore-sandbox is False, use the sandbox package database. " ++ "Otherwise, use the package database specified with --package-db. " ++ "If not specified, use the user package database.\n", commandNotes = 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 = \_ -> [ 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 "" ["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'], or ['global', $sandbox]," ++ " depending on context. Use 'clear' to reset the list to empty." ++ " See the user guide for details.") listPackageDBs (\v flags -> flags { listPackageDBs = v }) (reqArg' "DB" readPackageDbList showPackageDbList) ] } 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 $ "If there is a sandbox in the current directory and " ++ "config:ignore-sandbox is False, use the sandbox package database. " ++ "Otherwise, use the package database specified with --package-db. " ++ "If not specified, use the user package database.\n", commandNotes = Nothing, 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'], or ['global', $sandbox]," ++ " depending on context. Use 'clear' to reset the list to empty." ++ " See the user guide for details.") infoPackageDBs (\v flags -> flags { infoPackageDBs = v }) (reqArg' "DB" readPackageDbList showPackageDbList) ] } 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, installIndependentGoals :: Flag IndependentGoals, installShadowPkgs :: Flag ShadowPkgs, installStrongFlags :: Flag StrongFlags, installAllowBootLibInstalls :: Flag AllowBootLibInstalls, installReinstall :: Flag Bool, installAvoidReinstalls :: Flag AvoidReinstalls, installOverrideReinstall :: Flag Bool, installUpgradeDeps :: Flag Bool, installOnly :: Flag Bool, installOnlyDeps :: Flag Bool, installIndexState :: Flag IndexState, installRootCmd :: Flag String, installSummaryFile :: NubList PathTemplate, installLogFile :: Flag PathTemplate, installBuildReports :: Flag ReportLevel, installReportPlanningFailure :: Flag Bool, installSymlinkBinDir :: Flag FilePath, installPerComponent :: Flag Bool, installOneShot :: Flag Bool, installNumJobs :: Flag (Maybe Int), installKeepGoing :: Flag Bool, installRunTests :: Flag Bool, installOfflineMode :: Flag Bool, -- | The cabal project file name; defaults to @cabal.project@. -- Th name itself denotes the cabal project file name, but it also -- is the base of auxiliary project files, such as -- @cabal.project.local@ and @cabal.project.freeze@ which are also -- read and written out in some cases. If the path is not found -- in the current working directory, we will successively probe -- relative to parent directories until this name is found. installProjectFileName :: Flag FilePath } deriving (Eq, Generic) 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), installIndependentGoals= Flag (IndependentGoals False), installShadowPkgs = Flag (ShadowPkgs False), installStrongFlags = Flag (StrongFlags False), installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), 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, installProjectFileName = mempty } where docIndexFile = toPathTemplate ("$datadir" "doc" "$arch-$os-$compiler" "index.html") defaultMaxBackjumps :: Int defaultMaxBackjumps = 2000 defaultSolver :: PreSolver defaultSolver = AlwaysModular allSolvers :: String allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver])) installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) 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 or, if a sandbox" ++ " is present in the current directory, inside the sandbox.\n" ++ "\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" ++ "When using a sandbox, the flags for `v1-install` only affect the" ++ " current command and have no effect on future commands. (To achieve" ++ " that, `v1-configure` must be used.)\n" ++ " In contrast, without a sandbox, 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 (and without a sandbox)" ++ " be put into `~/.cabal/bin/`." ++ " If you want installed executable to be available globally, make" ++ " sure that the PATH environment variable contains that directory.\n" ++ "When using a sandbox, executables will be put into" ++ " `$SANDBOX/bin/` (by default: `./.cabal-sandbox/bin/`).\n" ++ "\n" ++ "When specifying --bindir, consider also specifying --datadir;" ++ " this way the sandbox can be deleted and the executable should" ++ " continue working as long as bindir and datadir are left untouched.", commandNotes = Just $ \pname -> ( case commandNotes $ 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), 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) } where get1 (a,_,_,_) = a; set1 a (_,b,c,d) = (a,b,c,d) get2 (_,b,_,_) = b; set2 b (a,_,c,d) = (a,b,c,d) get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d) get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d) 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"] ] where 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 }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) installStrongFlags (\v flags -> flags { installStrongFlags = v }) installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) ++ [ option [] ["reinstall"] "Install even if it means installing the same version again." 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" (readP_to_E (const $ "index-state must be a " ++ "unix-timestamps (e.g. '@1474732068'), " ++ "a ISO8601 UTC timestamp " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") (toFlag `fmap` parse)) (flagToList . fmap display)) , option [] ["root-cmd"] "(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" (readP_to_E (const $ "report level must be 'none', " ++ "'anonymous' or 'detailed'") (toFlag `fmap` parse)) (flagToList . fmap display)) , 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) , option [] ["project-file"] "Set the name of the cabal.project file to search for in parent directories" installProjectFileName (\v flags -> flags {installProjectFileName = v}) (reqArgFlag "FILE") ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" -- avoids ParseArgs -> [ 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"], 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 -- ------------------------------------------------------------ emptyInitFlags :: IT.InitFlags emptyInitFlags = mempty defaultInitFlags :: IT.InitFlags defaultInitFlags = emptyInitFlags { IT.initVerbosity = toFlag normal } initCommand :: CommandUI IT.InitFlags initCommand = CommandUI { commandName = "init", commandSynopsis = "Create a new .cabal package file (interactively).", commandDescription = Just $ \_ -> wrapText $ "Cabalise a project by creating a .cabal, Setup.hs, and " ++ "optionally a LICENSE file.\n" ++ "\n" ++ "Calling init with no arguments (recommended) uses an " ++ "interactive mode, which will try to guess as much as " ++ "possible and prompt you for the rest. Command-line " ++ "arguments are provided for scripting purposes. " ++ "If you don't want interactive mode, be sure to pass " ++ "the -n flag.\n", commandNotes = Nothing, commandUsage = \pname -> "Usage: " ++ pname ++ " init [FLAGS]\n", commandDefaultFlags = defaultInitFlags, commandOptions = \_ -> [ option ['n'] ["non-interactive"] "Non-interactive mode." IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v }) trueArg , 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" (readP_to_E ("Cannot parse package name: "++) (toFlag `fmap` parse)) (flagToList . fmap display)) , option [] ["version"] "Initial version of the package." IT.version (\v flags -> flags { IT.version = v }) (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) (toFlag `fmap` parse)) (flagToList . fmap display)) , option [] ["cabal-version"] "Required version of the Cabal library." IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++) (toFlag `fmap` parse)) (flagToList . fmap display)) , option ['l'] ["license"] "Project license." IT.license (\v flags -> flags { IT.license = v }) (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) (toFlag `fmap` parse)) (flagToList . fmap display)) , 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 [] ["is-library"] "Build a library." IT.packageType (\v flags -> flags { IT.packageType = v }) (noArg (Flag IT.Library)) , option [] ["is-executable"] "Build an executable." IT.packageType (\v flags -> flags { IT.packageType = v }) (noArg (Flag IT.Executable)) , option [] ["is-libandexe"] "Build a library and an executable." IT.packageType (\v flags -> flags { IT.packageType = v }) (noArg (Flag IT.LibraryAndExecutable)) , 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" (readP_to_E ("Cannot parse language: "++) (toFlag `fmap` parse)) (flagToList . fmap display)) , option ['o'] ["expose-module"] "Export a module from the package." IT.exposedModules (\v flags -> flags { IT.exposedModules = v }) (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) ((Just . (:[])) `fmap` parse)) (maybe [] (fmap display))) , option [] ["extension"] "Use a LANGUAGE extension (in the other-extensions field)." IT.otherExts (\v flags -> flags { IT.otherExts = v }) (reqArg "EXTENSION" (readP_to_E ("Cannot parse extension: "++) ((Just . (:[])) `fmap` parse)) (maybe [] (fmap display))) , option ['d'] ["dependency"] "Package dependency." IT.dependencies (\v flags -> flags { IT.dependencies = v }) (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) ((Just . (:[])) `fmap` parse)) (maybe [] (fmap display))) , option [] ["source-dir", "sourcedir"] "Directory containing package 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 [])) , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) ] } -- ------------------------------------------------------------ -- * SDist flags -- ------------------------------------------------------------ -- | Extra flags to @sdist@ beyond runghc Setup sdist -- data SDistExFlags = SDistExFlags { sDistFormat :: Flag ArchiveFormat } deriving (Show, Generic) data ArchiveFormat = TargzFormat | ZipFormat -- ... deriving (Show, Eq) defaultSDistExFlags :: SDistExFlags defaultSDistExFlags = SDistExFlags { sDistFormat = Flag TargzFormat } sdistCommand :: CommandUI (SDistFlags, SDistExFlags) sdistCommand = Cabal.sdistCommand { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-sdist [FLAGS]\n", commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand, defaultSDistExFlags), commandOptions = \showOrParseArgs -> liftOptions fst setFst (commandOptions Cabal.sdistCommand showOrParseArgs) ++ liftOptions snd setSnd sdistExOptions } where setFst a (_,b) = (a,b) setSnd b (a,_) = (a,b) sdistExOptions = [option [] ["archive-format"] "archive-format" sDistFormat (\v flags -> flags { sDistFormat = v }) (choiceOpt [ (Flag TargzFormat, ([], ["targz"]), "Produce a '.tar.gz' format archive (default and required for uploading to hackage)") , (Flag ZipFormat, ([], ["zip"]), "Produce a '.zip' format archive") ]) ] instance Monoid SDistExFlags where mempty = gmempty mappend = (<>) instance Semigroup SDistExFlags where (<>) = gmappend -- 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" } -- ------------------------------------------------------------ -- * Win32SelfUpgrade flags -- ------------------------------------------------------------ data Win32SelfUpgradeFlags = Win32SelfUpgradeFlags { win32SelfUpgradeVerbosity :: Flag Verbosity } deriving Generic defaultWin32SelfUpgradeFlags :: Win32SelfUpgradeFlags defaultWin32SelfUpgradeFlags = Win32SelfUpgradeFlags { win32SelfUpgradeVerbosity = toFlag normal } win32SelfUpgradeCommand :: CommandUI Win32SelfUpgradeFlags win32SelfUpgradeCommand = CommandUI { commandName = "win32selfupgrade", commandSynopsis = "Self-upgrade the executable on Windows", commandDescription = Nothing, commandNotes = Nothing, commandUsage = \pname -> "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n", commandDefaultFlags = defaultWin32SelfUpgradeFlags, commandOptions = \_ -> [optionVerbosity win32SelfUpgradeVerbosity (\v flags -> flags { win32SelfUpgradeVerbosity = v}) ] } instance Monoid Win32SelfUpgradeFlags where mempty = gmempty mappend = (<>) instance Semigroup Win32SelfUpgradeFlags where (<>) = gmappend -- ------------------------------------------------------------ -- * ActAsSetup flags -- ------------------------------------------------------------ data ActAsSetupFlags = ActAsSetupFlags { actAsSetupBuildType :: Flag BuildType } deriving Generic defaultActAsSetupFlags :: ActAsSetupFlags defaultActAsSetupFlags = ActAsSetupFlags { actAsSetupBuildType = toFlag Simple } actAsSetupCommand :: CommandUI ActAsSetupFlags actAsSetupCommand = CommandUI { commandName = "act-as-setup", commandSynopsis = "Run as-if this was a Setup.hs", commandDescription = Nothing, commandNotes = Nothing, commandUsage = \pname -> "Usage: " ++ pname ++ " act-as-setup\n", commandDefaultFlags = defaultActAsSetupFlags, commandOptions = \_ -> [option "" ["build-type"] "Use the given build type." actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v }) (reqArg "BUILD-TYPE" (readP_to_E ("Cannot parse build type: "++) (fmap toFlag parse)) (map display . flagToList)) ] } instance Monoid ActAsSetupFlags where mempty = gmempty mappend = (<>) instance Semigroup ActAsSetupFlags where (<>) = gmappend -- ------------------------------------------------------------ -- * Sandbox-related flags -- ------------------------------------------------------------ data SandboxFlags = SandboxFlags { sandboxVerbosity :: Flag Verbosity, sandboxSnapshot :: Flag Bool, -- FIXME: this should be an 'add-source'-only -- flag. sandboxLocation :: Flag FilePath } deriving Generic defaultSandboxLocation :: FilePath defaultSandboxLocation = ".cabal-sandbox" defaultSandboxFlags :: SandboxFlags defaultSandboxFlags = SandboxFlags { sandboxVerbosity = toFlag normal, sandboxSnapshot = toFlag False, sandboxLocation = toFlag defaultSandboxLocation } sandboxCommand :: CommandUI SandboxFlags sandboxCommand = CommandUI { commandName = "sandbox", commandSynopsis = "Create/modify/delete a sandbox.", commandDescription = Just $ \pname -> concat [ paragraph $ "Sandboxes are isolated package databases that can be used" ++ " to prevent dependency conflicts that arise when many different" ++ " packages are installed in the same database (i.e. the user's" ++ " database in the home directory)." , paragraph $ "A sandbox in the current directory (created by" ++ " `v1-sandbox init`) will be used instead of the user's database for" ++ " commands such as `v1-install` and `v1-build`. Note that (a directly" ++ " invoked) GHC will not automatically be aware of sandboxes;" ++ " only if called via appropriate " ++ pname ++ " commands, e.g. `v1-repl`, `v1-build`, `v1-exec`." , paragraph $ "Currently, " ++ pname ++ " will not search for a sandbox" ++ " in folders above the current one, so cabal will not see the sandbox" ++ " if you are in a subfolder of a sandbox." , paragraph "Subcommands:" , headLine "init:" , indentParagraph $ "Initialize a sandbox in the current directory." ++ " An existing package database will not be modified, but settings" ++ " (such as the location of the database) can be modified this way." , headLine "delete:" , indentParagraph $ "Remove the sandbox; deleting all the packages" ++ " installed inside." , headLine "add-source:" , indentParagraph $ "Make one or more local packages available in the" ++ " sandbox. PATHS may be relative or absolute." ++ " Typical usecase is when you need" ++ " to make a (temporary) modification to a dependency: You download" ++ " the package into a different directory, make the modification," ++ " and add that directory to the sandbox with `add-source`." , indentParagraph $ "Unless given `--snapshot`, any add-source'd" ++ " dependency that was modified since the last build will be" ++ " re-installed automatically." , headLine "delete-source:" , indentParagraph $ "Remove an add-source dependency; however, this will" ++ " not delete the package(s) that have been installed in the sandbox" ++ " from this dependency. You can either unregister the package(s) via" ++ " `" ++ pname ++ " v1-sandbox hc-pkg unregister` or re-create the" ++ " sandbox (`v1-sandbox delete; v1-sandbox init`)." , headLine "list-sources:" , indentParagraph $ "List the directories of local packages made" ++ " available via `" ++ pname ++ " v1-sandbox add-source`." , headLine "hc-pkg:" , indentParagraph $ "Similar to `ghc-pkg`, but for the sandbox package" ++ " database. Can be used to list specific/all packages that are" ++ " installed in the sandbox. For subcommands, see the help for" ++ " ghc-pkg. Affected by the compiler version specified by `v1-configure`." ], commandNotes = Just $ \pname -> relevantConfigValuesText ["require-sandbox" ,"ignore-sandbox"] ++ "\n" ++ "Examples:\n" ++ " Set up a sandbox with one local dependency, located at ../foo:\n" ++ " " ++ pname ++ " v1-sandbox init\n" ++ " " ++ pname ++ " v1-sandbox add-source ../foo\n" ++ " " ++ pname ++ " v1-install --only-dependencies\n" ++ " Reset the sandbox:\n" ++ " " ++ pname ++ " v1-sandbox delete\n" ++ " " ++ pname ++ " v1-sandbox init\n" ++ " " ++ pname ++ " v1-install --only-dependencies\n" ++ " List the packages in the sandbox:\n" ++ " " ++ pname ++ " v1-sandbox hc-pkg list\n" ++ " Unregister the `broken` package from the sandbox:\n" ++ " " ++ pname ++ " v1-sandbox hc-pkg -- --force unregister broken\n", commandUsage = usageAlternatives "v1-sandbox" [ "init [FLAGS]" , "delete [FLAGS]" , "add-source [FLAGS] PATHS" , "delete-source [FLAGS] PATHS" , "list-sources [FLAGS]" , "hc-pkg [FLAGS] [--] COMMAND [--] [ARGS]" ], commandDefaultFlags = defaultSandboxFlags, commandOptions = \_ -> [ optionVerbosity sandboxVerbosity (\v flags -> flags { sandboxVerbosity = v }) , option [] ["snapshot"] "Take a snapshot instead of creating a link (only applies to 'add-source')" sandboxSnapshot (\v flags -> flags { sandboxSnapshot = v }) trueArg , option [] ["sandbox"] "Sandbox location (default: './.cabal-sandbox')." sandboxLocation (\v flags -> flags { sandboxLocation = v }) (reqArgFlag "DIR") ] } instance Monoid SandboxFlags where mempty = gmempty mappend = (<>) instance Semigroup SandboxFlags 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: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") get set (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers) (toFlag `fmap` parse)) (flagToList . fmap display)) 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 IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) -> [OptionField flags] optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc getig setig getsip setsip getstrfl setstrfl getib setib = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj (reqArg "NUM" (readP_to_E ("Cannot parse number: "++) (fmap toFlag parse)) (map show . flagToList)) , option [] ["reorder-goals"] "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." (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 [] ["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) ] usageFlagsOrPackages :: String -> String -> String usageFlagsOrPackages name pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" 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 [Dependency] parsePackageArgs = parsePkgArgs [] where parsePkgArgs ds [] = Right (reverse ds) parsePkgArgs ds (arg:args) = case readPToMaybe parseDependencyOrPackageId arg of Just dep -> parsePkgArgs (dep:ds) args Nothing -> Left $ show arg ++ " is not valid syntax for a package name or" ++ " package dependency." parseDependencyOrPackageId :: Parse.ReadP r Dependency parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse where pkgidToDependency :: PackageIdentifier -> Dependency pkgidToDependency p = case packageVersion p of v | v == nullVersion -> Dependency (packageName p) anyVersion | otherwise -> Dependency (packageName p) (thisVersion v) showRepo :: RemoteRepo -> String showRepo repo = remoteRepoName repo ++ ":" ++ uriToString id (remoteRepoURI repo) [] readRepo :: String -> Maybe RemoteRepo readRepo = readPToMaybe parseRepo parseRepo :: Parse.ReadP r RemoteRepo parseRepo = do name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") _ <- Parse.char ':' uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) return RemoteRepo { remoteRepoName = name, remoteRepoURI = uri, remoteRepoSecure = Nothing, remoteRepoRootKeys = [], remoteRepoKeyThreshold = 0, remoteRepoShouldTryHttps = False } -- ------------------------------------------------------------ -- * Helpers for Documentation -- ------------------------------------------------------------ headLine :: String -> String headLine = unlines . map unwords . wrapLine 79 . words paragraph :: String -> String paragraph = (++"\n") . unlines . map unwords . wrapLine 79 . words indentParagraph :: String -> String indentParagraph = unlines . (flip (++)) [""] . map ((" "++).unwords) . wrapLine 77 . words relevantConfigValuesText :: [String] -> String relevantConfigValuesText vs = "Relevant global configuration keys:\n" ++ concat [" " ++ v ++ "\n" |v <- vs] cabal-install-2.4.0.0/Distribution/Client/SetupWrapper.hs0000644000000000000000000012126300000000000021407 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- 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 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.Types.Dependency import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) , PackageDescription(..), specVersion, buildType , BuildType(..), 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.Simple.Utils ( die', debug, info, infoNoWrap , cabalVersion, tryFindPackageDesc, comparing , createDirectoryIfMissingVerbose, installExecutableFile , copyFileVerbose, rewriteFileEx ) 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.Text ( display ) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity import Distribution.Compat.Exception ( catchIO ) import Distribution.Compat.Stack import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) import System.IO ( Handle, hPutStr ) import System.Exit ( ExitCode(..), exitWith ) import System.Process ( createProcess, StdStream(..), proc, waitForProcess , ProcessHandle ) import qualified System.Process as Process import Data.List ( foldl1' ) import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) #ifdef mingw32_HOST_OS 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 (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 (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=" ++ display 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 " ++ display 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 _ = rewriteFileEx verbosity setupHs (buildTypeScript cabalLibVersion) buildTypeScript :: Version -> String buildTypeScript cabalLibVersion = case bt of Simple -> "import Distribution.Simple; main = defaultMain\n" Configure -> "import Distribution.Simple; main = defaultMainWithHooks " ++ if cabalLibVersion >= mkVersion [1,3,10] then "autoconfUserHooks\n" else "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 cabalDep = Dependency (mkPackageName "Cabal") (useCabalVersion options') options'' = options' { usePackageIndex = Just index } case PackageIndex.lookupDependency index cabalDep of [] -> die' verbosity $ "The package '" ++ display (packageName pkg) ++ "' requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed." pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs in return (packageVersion ipkginfo ,Just . 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-" ++ (display cabalLibVersion) compilerVersionString = display $ maybe buildCompilerId compilerId $ useCompiler options' platformString = display 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 (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" cabal-install-2.4.0.0/Distribution/Client/SolverInstallPlan.hs0000644000000000000000000004017100000000000022360 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.SolverInstallPlan -- Copyright : (c) Duncan Coutts 2008 -- License : BSD-like -- -- Maintainer : duncan@community.haskell.org -- Stability : provisional -- Portability : portable -- -- The 'SolverInstallPlan' is the graph of packages produced by the -- dependency solver, and specifies at the package-granularity what -- things are going to be installed. To put it another way: the -- dependency solver produces a 'SolverInstallPlan', which is then -- consumed by various other parts of Cabal. -- ----------------------------------------------------------------------------- module Distribution.Client.SolverInstallPlan( SolverInstallPlan(..), SolverPlanPackage, ResolverPackage(..), -- * Operations on 'SolverInstallPlan's new, toList, toMap, remove, showPlanIndex, showInstallPlan, -- * Checking validity of plans valid, closed, consistent, acyclic, -- ** Details on invalid plans SolverPlanProblem(..), showPlanProblem, problems, -- ** Querying the install plan dependencyClosure, reverseDependencyClosure, topologicalOrder, reverseTopologicalOrder, ) where import Distribution.Package ( PackageIdentifier(..), Package(..), PackageName , HasUnitId(..), PackageId, packageVersion, packageName ) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Text ( display ) import Distribution.Client.Types ( UnresolvedPkgLoc ) import Distribution.Version ( Version ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SolverId import Data.List ( intercalate ) import Data.Maybe ( fromMaybe, mapMaybe ) import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (Graph, IsNode(..)) import qualified Data.Graph as OldGraph import qualified Distribution.Compat.Graph as Graph import qualified Data.Map as Map import Data.Map (Map) import Data.Array ((!)) import Data.Typeable type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc type SolverPlanIndex = Graph SolverPlanPackage data SolverInstallPlan = SolverInstallPlan { planIndex :: !SolverPlanIndex, planIndepGoals :: !IndependentGoals } deriving (Typeable) {- -- | Much like 'planPkgIdOf', but mapping back to full packages. planPkgOf :: SolverInstallPlan -> Graph.Vertex -> SolverPlanPackage planPkgOf plan v = case Graph.lookupKey (planIndex plan) (planPkgIdOf plan v) of Just pkg -> pkg Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" -} mkInstallPlan :: SolverPlanIndex -> IndependentGoals -> SolverInstallPlan mkInstallPlan index indepGoals = SolverInstallPlan { planIndex = index, planIndepGoals = indepGoals } instance Binary SolverInstallPlan where put SolverInstallPlan { planIndex = index, planIndepGoals = indepGoals } = put (index, indepGoals) get = do (index, indepGoals) <- get return $! mkInstallPlan index indepGoals showPlanIndex :: [SolverPlanPackage] -> String showPlanIndex = intercalate "\n" . map showPlanPackage showInstallPlan :: SolverInstallPlan -> String showInstallPlan = showPlanIndex . toList showPlanPackage :: SolverPlanPackage -> String showPlanPackage (PreExisting ipkg) = "PreExisting " ++ display (packageId ipkg) ++ " (" ++ display (installedUnitId ipkg) ++ ")" showPlanPackage (Configured spkg) = "Configured " ++ display (packageId spkg) -- | Build an installation plan from a valid set of resolved packages. -- new :: IndependentGoals -> SolverPlanIndex -> Either [SolverPlanProblem] SolverInstallPlan new indepGoals index = case problems indepGoals index of [] -> Right (mkInstallPlan index indepGoals) probs -> Left probs toList :: SolverInstallPlan -> [SolverPlanPackage] toList = Graph.toList . planIndex toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage toMap = Graph.toMap . planIndex -- | Remove packages from the install plan. This will result in an -- error if there are remaining packages that depend on any matching -- package. This is primarily useful for obtaining an install plan for -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. -- remove :: (SolverPlanPackage -> Bool) -> SolverInstallPlan -> Either [SolverPlanProblem] (SolverInstallPlan) remove shouldRemove plan = new (planIndepGoals plan) newIndex where newIndex = Graph.fromDistinctList $ filter (not . shouldRemove) (toList plan) -- ------------------------------------------------------------ -- * Checking validity of plans -- ------------------------------------------------------------ -- | A valid installation plan is a set of packages that is 'acyclic', -- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the -- plan has to have a valid configuration (see 'configuredPackageValid'). -- -- * if the result is @False@ use 'problems' to get a detailed list. -- valid :: IndependentGoals -> SolverPlanIndex -> Bool valid indepGoals index = null $ problems indepGoals index data SolverPlanProblem = PackageMissingDeps SolverPlanPackage [PackageIdentifier] | PackageCycle [SolverPlanPackage] | PackageInconsistency PackageName [(PackageIdentifier, Version)] | PackageStateInvalid SolverPlanPackage SolverPlanPackage showPlanProblem :: SolverPlanProblem -> String showPlanProblem (PackageMissingDeps pkg missingDeps) = "Package " ++ display (packageId pkg) ++ " depends on the following packages which are missing from the plan: " ++ intercalate ", " (map display missingDeps) showPlanProblem (PackageCycle cycleGroup) = "The following packages are involved in a dependency cycle " ++ intercalate ", " (map (display.packageId) cycleGroup) showPlanProblem (PackageInconsistency name inconsistencies) = "Package " ++ display name ++ " is required by several packages," ++ " but they require inconsistent versions:\n" ++ unlines [ " package " ++ display pkg ++ " requires " ++ display (PackageIdentifier name ver) | (pkg, ver) <- inconsistencies ] showPlanProblem (PackageStateInvalid pkg pkg') = "Package " ++ display (packageId pkg) ++ " is in the " ++ showPlanState pkg ++ " state but it depends on package " ++ display (packageId pkg') ++ " which is in the " ++ showPlanState pkg' ++ " state" where showPlanState (PreExisting _) = "pre-existing" showPlanState (Configured _) = "configured" -- | For an invalid plan, produce a detailed list of problems as human readable -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. -- problems :: IndependentGoals -> SolverPlanIndex -> [SolverPlanProblem] problems indepGoals index = [ PackageMissingDeps pkg (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 <- Graph.toList index , Just pkg' <- map (flip Graph.lookup index) (nodeNeighbors pkg) , not (stateDependencyRelation pkg pkg') ] -- | Compute all roots of the install plan, and verify that the transitive -- plans from those roots are all consistent. -- -- NOTE: This does not check for dependency cycles. Moreover, dependency cycles -- may be absent from the subplans even if the larger plan contains a dependency -- cycle. Such cycles may or may not be an issue; either way, we don't check -- for them here. dependencyInconsistencies :: IndependentGoals -> SolverPlanIndex -> [(PackageName, [(PackageIdentifier, Version)])] dependencyInconsistencies indepGoals index = concatMap dependencyInconsistencies' subplans where subplans :: [SolverPlanIndex] subplans = -- Not Graph.closure!! map (nonSetupClosure index) (rootSets indepGoals index) -- NB: When we check for inconsistencies, packages from the setup -- scripts don't count as part of the closure (this way, we -- can build, e.g., Cabal-1.24.1 even if its setup script is -- built with Cabal-1.24.0). -- -- This is a best effort function that swallows any non-existent -- SolverIds. nonSetupClosure :: SolverPlanIndex -> [SolverId] -> SolverPlanIndex nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 where closure completed [] = completed closure completed (pkgid:pkgids) = case Graph.lookup pkgid index of Nothing -> closure completed pkgids Just pkg -> case Graph.lookup (nodeKey pkg) completed of Just _ -> closure completed pkgids Nothing -> closure completed' pkgids' where completed' = Graph.insert pkg completed pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids -- | Compute the root sets of a plan -- -- A root set is a set of packages whose dependency closure must be consistent. -- This is the set of all top-level library roots (taken together normally, or -- as singletons sets if we are considering them as independent goals), along -- with all setup dependencies of all packages. rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]] rootSets (IndependentGoals indepGoals) index = if indepGoals then map (:[]) libRoots else [libRoots] ++ setupRoots index where libRoots = libraryRoots index -- | Compute the library roots of a plan -- -- The library roots are the set of packages with no reverse dependencies -- (no reverse library dependencies but also no reverse setup dependencies). libraryRoots :: SolverPlanIndex -> [SolverId] libraryRoots index = map (nodeKey . toPkgId) roots where (graph, toPkgId, _) = Graph.toGraph index indegree = OldGraph.indegree graph roots = filter isRoot (OldGraph.vertices graph) isRoot v = indegree ! v == 0 -- | The setup dependencies of each package in the plan setupRoots :: SolverPlanIndex -> [[SolverId]] setupRoots = filter (not . null) . map (CD.setupDeps . resolverPackageLibDeps) . Graph.toList -- | Given a package index where we assume we want to use all the packages -- (use 'dependencyClosure' if you need to get such a index subset) find out -- if the dependencies within it use consistent versions of each package. -- Return all cases where multiple packages depend on different versions of -- some other package. -- -- Each element in the result is a package name along with the packages that -- depend on it and the versions they require. These are guaranteed to be -- distinct. -- dependencyInconsistencies' :: SolverPlanIndex -> [(PackageName, [(PackageIdentifier, Version)])] dependencyInconsistencies' index = [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids]) | (name, ipid_map) <- Map.toList inverseIndex , let uses = Map.elems ipid_map , reallyIsInconsistent (map fst uses) ] where -- For each package name (of a dependency, somewhere) -- and each installed ID of that that package -- the associated package instance -- and a list of reverse dependencies (as source IDs) inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId])) inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) | -- For each package @pkg@ pkg <- Graph.toList index -- Find out which @sid@ @pkg@ depends on , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) , Just dep <- [Graph.lookup sid index] ] -- If, in a single install plan, we depend on more than one version of a -- package, then this is ONLY okay in the (rather special) case that we -- depend on precisely two versions of that package, and one of them -- depends on the other. This is necessary for example for the base where -- we have base-3 depending on base-4. reallyIsInconsistent :: [SolverPlanPackage] -> Bool reallyIsInconsistent [] = False reallyIsInconsistent [_p] = False reallyIsInconsistent [p1, p2] = let pid1 = nodeKey p1 pid2 = nodeKey p2 in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) reallyIsInconsistent _ = True -- | The graph of packages (nodes) and dependencies (edges) must be acyclic. -- -- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out -- which packages are involved in dependency cycles. -- acyclic :: SolverPlanIndex -> Bool acyclic = null . Graph.cycles -- | An installation plan is closed if for every package in the set, all of -- its dependencies are also in the set. That is, the set is closed under the -- dependency relation. -- -- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out -- which packages depend on packages not in the index. -- closed :: SolverPlanIndex -> Bool closed = null . Graph.broken -- | An installation plan is consistent if all dependencies that target a -- single package name, target the same version. -- -- This is slightly subtle. It is not the same as requiring that there be at -- most one version of any package in the set. It only requires that of -- packages which have more than one other package depending on them. We could -- actually make the condition even more precise and say that different -- versions are OK so long as they are not both in the transitive closure of -- any other package (or equivalently that their inverse closures do not -- intersect). The point is we do not want to have any packages depending -- directly or indirectly on two different versions of the same package. The -- current definition is just a safe approximation of that. -- -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to -- find out which packages are. -- consistent :: SolverPlanIndex -> Bool consistent = null . dependencyInconsistencies (IndependentGoals False) -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on -- package @b@ we require that @dependencyStatesOk a b = True@. -- stateDependencyRelation :: SolverPlanPackage -> SolverPlanPackage -> Bool stateDependencyRelation PreExisting{} PreExisting{} = True stateDependencyRelation (Configured _) PreExisting{} = True stateDependencyRelation (Configured _) (Configured _) = True stateDependencyRelation _ _ = False -- | Compute the dependency closure of a package in a install plan -- dependencyClosure :: SolverInstallPlan -> [SolverId] -> [SolverPlanPackage] dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan) reverseDependencyClosure :: SolverInstallPlan -> [SolverId] -> [SolverPlanPackage] reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan) topologicalOrder :: SolverInstallPlan -> [SolverPlanPackage] topologicalOrder plan = Graph.topSort (planIndex plan) reverseTopologicalOrder :: SolverInstallPlan -> [SolverPlanPackage] reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan) cabal-install-2.4.0.0/Distribution/Client/SourceFiles.hs0000644000000000000000000001511000000000000021162 0ustar0000000000000000-- | Contains an @sdist@ like function which computes the source files -- that we should track to determine if a rebuild is necessary. -- Unlike @sdist@, we can operate directly on the true -- 'PackageDescription' (not flattened). -- -- The naming convention, roughly, is that to declare we need the -- source for some type T, you use the function needT; some functions -- need auxiliary information. -- -- We can only use this code for non-Custom scripts; Custom scripts -- may have arbitrary extra dependencies (esp. new preprocessors) which -- we cannot "see" easily. module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where import Distribution.Client.ProjectPlanning.Types import Distribution.Client.RebuildMonad import Distribution.Solver.Types.OptionalStanza import Distribution.Simple.PreProcess import Distribution.Types.PackageDescription import Distribution.Types.Component import Distribution.Types.ComponentRequestedSpec import Distribution.Types.Library import Distribution.Types.Executable import Distribution.Types.Benchmark import Distribution.Types.BenchmarkInterface import Distribution.Types.TestSuite import Distribution.Types.TestSuiteInterface import Distribution.Types.BuildInfo import Distribution.Types.ForeignLib import Distribution.ModuleName import Prelude () import Distribution.Client.Compat.Prelude import System.FilePath import Control.Monad import qualified Data.Set as Set needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild () needElaboratedConfiguredPackage elab = case elabPkgOrComp elab of ElabComponent ecomp -> needElaboratedComponent elab ecomp ElabPackage epkg -> needElaboratedPackage elab epkg needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () needElaboratedPackage elab epkg = mapM_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) where pkg_descr = elabPkgDescription elab enabled_stanzas = pkgStanzasEnabled epkg -- TODO: turn this into a helper function somewhere enabled = ComponentRequestedSpec { testsRequested = TestStanzas `Set.member` enabled_stanzas, benchmarksRequested = BenchStanzas `Set.member` enabled_stanzas } needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild () needElaboratedComponent elab ecomp = case mb_comp of Nothing -> needSetup Just comp -> needComponent pkg_descr comp where pkg_descr = elabPkgDescription elab mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) needComponent :: PackageDescription -> Component -> Rebuild () needComponent pkg_descr comp = case comp of CLib lib -> needLibrary pkg_descr lib CFLib flib -> needForeignLib pkg_descr flib CExe exe -> needExecutable pkg_descr exe CTest test -> needTestSuite pkg_descr test CBench bench -> needBenchmark pkg_descr bench needSetup :: Rebuild () needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () needLibrary :: PackageDescription -> Library -> Rebuild () needLibrary pkg_descr (Library { exposedModules = modules , signatures = sigs , libBuildInfo = bi }) = needBuildInfo pkg_descr bi (modules ++ sigs) needForeignLib :: PackageDescription -> ForeignLib -> Rebuild () needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs , foreignLibBuildInfo = bi }) = do mapM_ needIfExists fs needBuildInfo pkg_descr bi [] needExecutable :: PackageDescription -> Executable -> Rebuild () needExecutable pkg_descr (Executable { modulePath = mainPath , buildInfo = bi }) = do needBuildInfo pkg_descr bi [] needMainFile bi mainPath needTestSuite :: PackageDescription -> TestSuite -> Rebuild () needTestSuite pkg_descr t = case testInterface t of TestSuiteExeV10 _ mainPath -> do needBuildInfo pkg_descr bi [] needMainFile bi mainPath TestSuiteLibV09 _ m -> needBuildInfo pkg_descr bi [m] TestSuiteUnsupported _ -> return () -- soft fail where bi = testBuildInfo t needMainFile :: BuildInfo -> FilePath -> Rebuild () needMainFile bi mainPath = do -- The matter here is subtle. It might *seem* that we -- should just search for mainPath, but as per -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' -- will actually be the source file AFTER preprocessing, -- whereas we need to get the file *prior* to preprocessing. ppFile <- findFileWithExtensionMonitored (ppSuffixes knownSuffixHandlers) (hsSourceDirs bi) (dropExtension mainPath) case ppFile of -- But check the original path in the end, because -- maybe it's a non-preprocessed file with a non-traditional -- extension. Nothing -> findFileMonitored (hsSourceDirs bi) mainPath >>= maybe (return ()) need Just pp -> need pp needBenchmark :: PackageDescription -> Benchmark -> Rebuild () needBenchmark pkg_descr bm = case benchmarkInterface bm of BenchmarkExeV10 _ mainPath -> do needBuildInfo pkg_descr bi [] needMainFile bi mainPath BenchmarkUnsupported _ -> return () -- soft fail where bi = benchmarkBuildInfo bm needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild () needBuildInfo pkg_descr bi modules = do -- NB: These are separate because there may be both A.hs and -- A.hs-boot; need to track both. findNeededModules ["hs", "lhs", "hsig", "lhsig"] findNeededModules ["hs-boot", "lhs-boot"] mapM_ needIfExists (cSources bi ++ jsSources bi) -- A MASSIVE HACK to (1) make sure we rebuild when header -- files change, but (2) not have to rebuild when anything -- in extra-src-files changes (most of these won't affect -- compilation). It would be even better if we knew on a -- per-component basis which headers would be used but that -- seems to be too difficult. mapM_ needIfExists (filter ((==".h").takeExtension) (extraSrcFiles pkg_descr)) forM_ (installIncludes bi) $ \f -> findFileMonitored ("." : includeDirs bi) f >>= maybe (return ()) need where findNeededModules exts = mapM_ (findNeededModule exts) (modules ++ otherModules bi) findNeededModule exts m = findFileWithExtensionMonitored (ppSuffixes knownSuffixHandlers ++ exts) (hsSourceDirs bi) (toFilePath m) >>= maybe (return ()) need cabal-install-2.4.0.0/Distribution/Client/SourceRepoParse.hs0000644000000000000000000000163000000000000022022 0ustar0000000000000000module Distribution.Client.SourceRepoParse where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.FieldGrammar.FieldDescrs (fieldDescrsToList) import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar) import Distribution.Parsec.Class (explicitEitherParsec) import Distribution.ParseUtils (FieldDescr (..), syntaxError) import Distribution.Types.SourceRepo (SourceRepo, RepoKind (..)) sourceRepoFieldDescrs :: [FieldDescr SourceRepo] sourceRepoFieldDescrs = map toDescr . fieldDescrsToList $ sourceRepoFieldGrammar (RepoKindUnknown "unused") where toDescr (name, pretty, parse) = FieldDescr { fieldName = name , fieldGet = pretty , fieldSet = \lineNo str x -> either (syntaxError lineNo) return $ explicitEitherParsec (parse x) str } cabal-install-2.4.0.0/Distribution/Client/SrcDist.hs0000644000000000000000000002065600000000000020325 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} -- Implements the \"@.\/cabal sdist@\" command, which creates a source -- distribution for this package. That is, packs up the source code -- into a tarball, making use of the corresponding Cabal module. module Distribution.Client.SrcDist ( sdist, allPackageSourceFiles ) where import Distribution.Client.SetupWrapper ( SetupScriptOptions(..), defaultSetupScriptOptions, setupWrapper ) import Distribution.Client.Tar (createTarGzFile) import Distribution.Package ( Package(..), packageName ) import Distribution.PackageDescription ( PackageDescription ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, defaultPackageDesc , warn, die', notice, withTempDirectory ) import Distribution.Client.Setup ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault , defaultSDistFlags ) import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text ( display ) import Distribution.Verbosity (Verbosity, normal, lessVerbose) import Distribution.Version (mkVersion, orLaterVersion, intersectVersionRanges) import Distribution.Client.Utils (tryFindAddSourcePackageDesc) import Distribution.Compat.Exception (catchIO) import System.FilePath ((), (<.>)) import Control.Monad (when, unless, liftM) import System.Directory (doesFileExist, removeFile, canonicalizePath, getTemporaryDirectory) import System.Process (runProcess, waitForProcess) import System.Exit (ExitCode(..)) import Control.Exception (IOException, evaluate) -- |Create a source distribution. sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do pkg <- liftM flattenPackageDescription (readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity) let withDir :: (FilePath -> IO a) -> IO a withDir = if not needMakeArchive then \f -> f tmpTargetDir else withTempDirectory verbosity tmpTargetDir "sdist." -- 'withTempDir' fails if we don't create 'tmpTargetDir'... when needMakeArchive $ createDirectoryIfMissingVerbose verbosity True tmpTargetDir withDir $ \tmpDir -> do let outDir = if isOutDirectory then tmpDir else tmpDir tarBallName pkg flags' = (if not needMakeArchive then flags else flags { sDistDirectory = Flag outDir }) unless isListSources $ createDirectoryIfMissingVerbose verbosity True outDir -- Run 'setup sdist --output-directory=tmpDir' (or -- '--list-source'/'--output-directory=someOtherDir') in case we were passed -- those options. setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags') (const []) -- Unless we were given --list-sources or --output-directory ourselves, -- create an archive. when needMakeArchive $ createArchive verbosity pkg tmpDir distPref when isOutDirectory $ notice verbosity $ "Source directory created: " ++ tmpTargetDir when isListSources $ notice verbosity $ "List of package sources written to file '" ++ (fromFlag . sDistListSources $ flags) ++ "'" where flagEnabled f = not . null . flagToList . f $ flags isListSources = flagEnabled sDistListSources isOutDirectory = flagEnabled sDistDirectory needMakeArchive = not (isListSources || isOutDirectory) verbosity = fromFlag (sDistVerbosity flags) distPref = fromFlag (sDistDistPref flags) tmpTargetDir = fromFlagOrDefault (srcPref distPref) (sDistDirectory flags) setupOpts = defaultSetupScriptOptions { useDistPref = distPref, -- The '--output-directory' sdist flag was introduced in Cabal 1.12, and -- '--list-sources' in 1.17. useCabalVersion = if isListSources then orLaterVersion $ mkVersion [1,17,0] else orLaterVersion $ mkVersion [1,12,0] } format = fromFlag (sDistFormat exflags) createArchive = case format of TargzFormat -> createTarGzArchive ZipFormat -> createZipArchive tarBallName :: PackageDescription -> String tarBallName = display . packageId -- | Create a tar.gz archive from a tree of source files. createTarGzArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath -> IO () createTarGzArchive verbosity pkg tmpDir targetPref = do createTarGzFile tarBallFilePath tmpDir (tarBallName pkg) notice verbosity $ "Source tarball created: " ++ tarBallFilePath where tarBallFilePath = targetPref tarBallName pkg <.> "tar.gz" -- | Create a zip archive from a tree of source files. createZipArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath -> IO () createZipArchive verbosity pkg tmpDir targetPref = do let dir = tarBallName pkg zipfile = targetPref dir <.> "zip" (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb -- zip has an annoying habit of updating the target rather than creating -- it from scratch. While that might sound like an optimisation, it doesn't -- remove files already in the archive that are no longer present in the -- uncompressed tree. alreadyExists <- doesFileExist zipfile when alreadyExists $ removeFile zipfile -- We call zip with a different CWD, so have to make the path -- absolute. Can't just use 'canonicalizePath zipfile' since this function -- requires its argument to refer to an existing file. zipfileAbs <- fmap ( dir <.> "zip") . canonicalizePath $ targetPref --TODO: use runProgramInvocation, but has to be able to set CWD hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] (Just tmpDir) Nothing Nothing Nothing Nothing exitCode <- waitForProcess hnd unless (exitCode == ExitSuccess) $ die' verbosity $ "Generating the zip file failed " ++ "(zip returned exit code " ++ show exitCode ++ ")" notice verbosity $ "Source zip archive created: " ++ zipfile where zipProgram = simpleProgram "zip" -- | List all source files of a given add-source dependency. Exits with error if -- something is wrong (e.g. there is no .cabal file in the given directory). allPackageSourceFiles :: Verbosity -> SetupScriptOptions -> FilePath -> IO [FilePath] allPackageSourceFiles verbosity setupOpts0 packageDir = do pkg <- do let err = "Error reading source files of package." desc <- tryFindAddSourcePackageDesc verbosity packageDir err flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc globalTmp <- getTemporaryDirectory withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do let file = tempDir "cabal-sdist-list-sources" flags = defaultSDistFlags { sDistVerbosity = Flag $ if verbosity == normal then lessVerbose verbosity else verbosity, sDistListSources = Flag file } setupOpts = setupOpts0 { -- 'sdist --list-sources' was introduced in Cabal 1.18. useCabalVersion = intersectVersionRanges (orLaterVersion $ mkVersion [1,18,0]) (useCabalVersion setupOpts0), useWorkingDir = Just packageDir } doListSources :: IO [FilePath] doListSources = do setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) (const []) fmap lines . readFile $ file onFailedListSources :: IOException -> IO () onFailedListSources e = do warn verbosity $ "Could not list sources of the package '" ++ display (packageName pkg) ++ "'." warn verbosity $ "Exception was: " ++ show e -- Run setup sdist --list-sources=TMPFILE r <- doListSources `catchIO` (\e -> onFailedListSources e >> return []) -- Ensure that we've closed the 'readFile' handle before we exit the -- temporary directory. _ <- evaluate (length r) return r cabal-install-2.4.0.0/Distribution/Client/Store.hs0000644000000000000000000002413100000000000020036 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -- | Management for the installed package store. -- module Distribution.Client.Store ( -- * The store layout StoreDirLayout(..), defaultStoreDirLayout, -- * Reading store entries getStoreEntries, doesStoreEntryExist, -- * Creating store entries newStoreEntry, NewStoreEntryOutcome(..), -- * Concurrency strategy -- $concurrency ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.Compat.FileLock import Distribution.Client.DistDirLayout import Distribution.Client.RebuildMonad import Distribution.Package (UnitId, mkUnitId) import Distribution.Compiler (CompilerId) import Distribution.Simple.Utils ( withTempDirectory, debug, info ) import Distribution.Verbosity import Distribution.Text import Data.Set (Set) import qualified Data.Set as Set import Control.Exception import Control.Monad (forM_) import System.FilePath import System.Directory import System.IO -- $concurrency -- -- We access and update the store concurrently. Our strategy to do that safely -- is as follows. -- -- The store entries once created are immutable. This alone simplifies matters -- considerably. -- -- Additionally, the way 'UnitId' hashes are constructed means that if a store -- entry exists already then we can assume its content is ok to reuse, rather -- than having to re-recreate. This is the nix-style input hashing concept. -- -- A consequence of this is that with a little care it is /safe/ to race -- updates against each other. Consider two independent concurrent builds that -- both want to build a particular 'UnitId', where that entry does not yet -- exist in the store. It is safe for both to build and try to install this -- entry into the store provided that: -- -- * only one succeeds -- * the looser discovers that they lost, they abandon their own build and -- re-use the store entry installed by the winner. -- -- Note that because builds are not reproducible in general (nor even -- necessarily ABI compatible) then it is essential that the loser abandon -- their build and use the one installed by the winner, so that subsequent -- packages are built against the exact package from the store rather than some -- morally equivalent package that may not be ABI compatible. -- -- Our overriding goal is that store reads be simple, cheap and not require -- locking. We will derive our write-side protocol to make this possible. -- -- The read-side protocol is simply: -- -- * check for the existence of a directory entry named after the 'UnitId' in -- question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then -- the store entry can be assumed to be complete and immutable. -- -- Given our read-side protocol, the final step on the write side must be to -- atomically rename a fully-formed store entry directory into its final -- location. While this will indeed be the final step, the preparatory steps -- are more complicated. The tricky aspect is that the store also contains a -- number of shared package databases (one per compiler version). Our read -- strategy means that by the time we install the store dir entry the package -- db must already have been updated. We cannot do the package db update -- as part of atomically renaming the store entry directory however. Furthermore -- it is not safe to allow either package db update because the db entry -- contains the ABI hash and this is not guaranteed to be deterministic. So we -- must register the new package prior to the atomic dir rename. Since this -- combination of steps are not atomic then we need locking. -- -- The write-side protocol is: -- -- * Create a unique temp dir and write all store entry files into it. -- -- * Take a lock named after the 'UnitId' in question. -- -- * Once holding the lock, check again for the existence of the final store -- entry directory. If the entry exists then the process lost the race and it -- must abandon, unlock and re-use the existing store entry. If the entry -- does not exist then the process won the race and it can proceed. -- -- * Register the package into the package db. Note that the files are not in -- their final location at this stage so registration file checks may need -- to be disabled. -- -- * Atomically rename the temp dir to the final store entry location. -- -- * Release the previously-acquired lock. -- -- Obviously this means it is possible to fail after registering but before -- installing the store entry, leaving a dangling package db entry. This is not -- much of a problem because this entry does not determine package existence -- for cabal. It does mean however that the package db update should be insert -- or replace, i.e. not failing if the db entry already exists. -- | Check if a particular 'UnitId' exists in the store. -- doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = doesDirectoryExist (storePackageDirectory compid unitid) -- | Return the 'UnitId's of all packages\/components already installed in the -- store. -- getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) getStoreEntries StoreDirLayout{storeDirectory} compid = do paths <- getDirectoryContentsMonitored (storeDirectory compid) return $! mkEntries paths where mkEntries = Set.delete (mkUnitId "package.db") . Set.delete (mkUnitId "incoming") . Set.fromList . map mkUnitId . filter valid valid ('.':_) = False valid _ = True -- | The outcome of 'newStoreEntry': either the store entry was newly created -- or it existed already. The latter case happens if there was a race between -- two builds of the same store entry. -- data NewStoreEntryOutcome = UseNewStoreEntry | UseExistingStoreEntry deriving (Eq, Show) -- | Place a new entry into the store. See the concurrency strategy description -- for full details. -- -- In particular, it takes two actions: one to place files into a temporary -- location, and a second to perform any necessary registration. The first -- action is executed without any locks held (the temp dir is unique). The -- second action holds a lock that guarantees that only one cabal process is -- able to install this store entry. This means it is safe to register into -- the compiler package DB or do other similar actions. -- -- Note that if you need to use the registration information later then you -- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry' -- then you must read the existing registration information (unless your -- registration information is constructed fully deterministically). -- newStoreEntry :: Verbosity -> StoreDirLayout -> CompilerId -> UnitId -> (FilePath -> IO (FilePath, [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 " ++ display compid display unitid return UseExistingStoreEntry -- If the entry does not exist then we won the race and can proceed. else do -- Register the package into the package db (if appropriate). register -- Atomically rename the temp dir to the final store entry location. renameDirectory incomingEntryDir finalEntryDir forM_ 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 " ++ display compid display unitid return UseNewStoreEntry where finalEntryDir = storePackageDirectory compid unitid withTempIncomingDir :: StoreDirLayout -> CompilerId -> (FilePath -> IO a) -> IO a withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do createDirectoryIfMissing True incomingDir withTempDirectory silent incomingDir "new" action where incomingDir = storeIncomingDirectory compid withIncomingUnitIdLock :: Verbosity -> StoreDirLayout -> CompilerId -> UnitId -> IO a -> IO a withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} compid unitid action = bracket takeLock releaseLock (\_hnd -> action) where takeLock = do h <- openFile (storeIncomingLock compid unitid) ReadWriteMode -- First try non-blocking, but if we would have to wait then -- log an explanation and do it again in blocking mode. gotlock <- hTryLock h ExclusiveLock unless gotlock $ do info verbosity $ "Waiting for file lock on store entry " ++ display compid display unitid hLock h ExclusiveLock return h releaseLock = hClose cabal-install-2.4.0.0/Distribution/Client/Tar.hs0000644000000000000000000000666600000000000017505 0ustar0000000000000000{-# 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 qualified Data.ByteString.Lazy as BS import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Check as Tar import qualified Codec.Compression.GZip as GZip import qualified Distribution.Client.GZipUtils as GZipUtils import Control.Exception (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 cabal-install-2.4.0.0/Distribution/Client/TargetSelector.hs0000644000000000000000000026060000000000000021674 0ustar0000000000000000{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- 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.Verbosity import Distribution.PackageDescription ( PackageDescription , Executable(..) , TestSuite(..), TestSuiteInterface(..), testModules , Benchmark(..), BenchmarkInterface(..), benchmarkModules , BuildInfo(..), explicitLibModules, exeModules ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.ModuleName ( ModuleName, toFilePath ) import Distribution.Simple.LocalBuildInfo ( Component(..), ComponentName(..) , pkgComponents, componentName, componentBuildInfo ) import Distribution.Types.ForeignLib import Distribution.Text ( Text, display, simpleParse ) import Distribution.Simple.Utils ( die', lowercase, ordNub ) import Distribution.Client.Utils ( makeRelativeCanonical ) import Data.Either ( partitionEithers ) import Data.Function ( on ) import Data.List ( stripPrefix, partition, groupBy ) import Data.Ord ( comparing ) 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.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) import Distribution.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 ) -- ------------------------------------------------------------ -- * 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. | FileTarget FilePath deriving (Eq, Ord, Show, Generic) instance Binary SubComponentTarget -- ------------------------------------------------------------ -- * Top level, do everything -- ------------------------------------------------------------ -- | Parse a bunch of command line args as 'TargetSelector's, failing with an -- error if any are unrecognised. The possible target selectors are based on -- the available packages (and their locations). -- readTargetSelectors :: [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' <- mapM (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 -- ------------------------------------------------------------ -- * 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 | not (null expected) = let (things, got:_) = unzip expected in TargetSelectorExpected targetStr things got | not (null nosuch) = TargetSelectorNoSuch targetStr nosuch | otherwise = internalError $ "classifyMatchErrors: " ++ show errs where expected = [ (thing, got) | (_, MatchErrorExpected thing got) <- map (innerErr Nothing) errs ] -- Trim the list of alternatives by dropping duplicates and -- retaining only at most three most similar (by edit distance) ones. nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ [ ((inside, thing, got), Set.fromList alts) | (inside, MatchErrorNoSuch thing got alts) <- map (innerErr Nothing) errs ] genResults (inside, thing, got) alts acc = ( inside , thing , got , take maxResults $ map fst $ takeWhile distanceLow $ sortBy (comparing snd) $ map addLevDist $ Set.toList alts ) : acc where addLevDist = id &&& restrictedDamerauLevenshteinDistance defaultEditCosts got distanceLow (_, dist) = dist < length got `div` 2 maxResults = 3 innerErr _ (MatchErrorIn kind thing m) = innerErr (Just (kind,thing)) m innerErr c m = (c,m) 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 | CSubLibName _ <- 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) data QualLevel = QL1 | QL2 | QL3 | QLFull 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. matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])] matchResultsRenderings = [ (matchResult, matchRenderings) | matchResult <- matchResults , let matchRenderings = [ rendering | ql <- [QL1 .. QLFull] , rendering <- renderTargetSelector ql matchResult ] ] -- Of course the point is that we're looking for renderings that are -- unambiguous matches. So we build another memo table of all the matches -- for all of those renderings. So by looking up in this table we can see -- if we've got an unambiguous match. memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) 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 [ (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 = foldr1 AmbiguousAlternatives shadowingAlternatives = 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" (display (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" (display (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 (display 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" (display (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) (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" (display (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) (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" (display (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" (display (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" (display (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" (display (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" (display (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" (display (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 = display . packageName dispPN :: PackageName -> String dispPN = display dispC :: PackageId -> ComponentName -> String dispC = componentStringName . packageName dispC' :: PackageName -> ComponentName -> String dispC' = componentStringName dispCN :: UnqualComponentName -> String dispCN = display dispK :: ComponentKind -> String dispK = showComponentKindShort dispCK :: ComponentName -> String dispCK = dispK . componentKind dispF :: ComponentKind -> String dispF = showComponentKindFilterShort dispM :: ModuleName -> String dispM = display ------------------------------- -- 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 <- mapM (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 { packageDescription = pkg, packageSource = loc }) = do (pkgdir, pkgfile) <- case loc of --TODO: local tarballs, remote tarballs etc LocalUnpackedPackage dir -> do dirabs <- canonicalizePath dir dirrel <- makeRelativeToCwd dirActions dirabs --TODO: ought to get this earlier in project reading let fileabs = dirabs display (packageName pkg) <.> "cabal" filerel = dirrel display (packageName pkg) <.> "cabal" exists <- doesFileExist fileabs return ( Just (dirabs, dirrel) , if exists then Just (fileabs, filerel) else Nothing ) _ -> return (Nothing, Nothing) let pinfo = 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 = display pkgname componentStringName _ (CSubLibName name) = unUnqualComponentName name componentStringName _ (CFLibName name) = unUnqualComponentName name componentStringName _ (CExeName name) = unUnqualComponentName name componentStringName _ (CTestName name) = unUnqualComponentName name componentStringName _ (CBenchName name) = unUnqualComponentName name componentModules :: Component -> [ModuleName] -- I think it's unlikely users will ask to build a requirement -- which is not mentioned locally. componentModules (CLib lib) = explicitLibModules lib componentModules (CFLib flib) = foreignLibModules flib componentModules (CExe exe) = exeModules exe componentModules (CTest test) = testModules test componentModules (CBench bench) = benchmarkModules bench componentHsFiles :: Component -> [FilePath] componentHsFiles (CExe exe) = [modulePath exe] componentHsFiles (CTest TestSuite { testInterface = TestSuiteExeV10 _ mainfile }) = [mainfile] componentHsFiles (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainfile }) = [mainfile] componentHsFiles _ = [] ------------------------------ -- Matching meta targets -- guardNamespaceMeta :: String -> Match () guardNamespaceMeta = guardToken [""] "meta namespace" guardMetaAll :: String -> Match () guardMetaAll = guardToken ["all"] "meta-target 'all'" guardNamespacePackage :: String -> Match () guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace" guardNamespaceCwd :: String -> Match () guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace" guardNamespaceModule :: String -> Match () guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace" guardNamespaceFile :: String -> Match () guardNamespaceFile = guardToken ["file"] "'file' namespace" guardToken :: [String] -> String -> String -> Match () guardToken tokens msg s | caseFold s `elem` tokens = increaseConfidence | otherwise = matchErrorExpected msg s ------------------------------ -- Matching component kinds -- componentKind :: ComponentName -> ComponentKind componentKind CLibName = LibKind componentKind (CSubLibName _) = LibKind componentKind (CFLibName _) = FLibKind componentKind (CExeName _) = ExeKind componentKind (CTestName _) = TestKind componentKind (CBenchName _) = BenchKind cinfoKind :: 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 (display . knownPackageName) ps) $ increaseConfidenceFor $ matchInexactly caseFold (display . 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 simpleParse s :: Maybe ModuleName of Just _ -> increaseConfidence _ | all validModuleChar s && not (null s) -> return () | otherwise -> matchErrorExpected "module name" s where validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' matchModuleName :: [ModuleName] -> String -> Match ModuleName matchModuleName ms str = orNoSuchThing "module" str (map display ms) $ increaseConfidenceFor $ matchInexactly caseFold display ms str matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) matchModuleNameAnd ms str = orNoSuchThing "module" str (map (display . fst) ms) $ increaseConfidenceFor $ matchInexactly caseFold (display . fst) ms str 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 [ (file, c) | c <- cs , file <- cinfoHsFiles c ++ cinfoCFiles c ++ cinfoJsFiles c ] 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)) -- 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 :: Text a => String -> Match a matchParse = maybe mzero return . simpleParse ------------------------------ -- 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 | otherwise -> CSubLibName 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" -} cabal-install-2.4.0.0/Distribution/Client/Targets.hs0000644000000000000000000007216000000000000020360 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# 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 , PackageIdentifier(..), packageName, packageVersion ) 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.PackageDescription ( GenericPackageDescription, parseFlagAssignment, nullFlagAssignment ) import Distribution.Version ( nullVersion, thisVersion, anyVersion, isAnyVersion ) import Distribution.Text ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils ( die', warn, lowercase ) import Distribution.PackageDescription.Parsec ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) -- import Data.List ( find, nub ) import Data.Either ( partitionEithers ) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS import qualified Distribution.Client.GZipUtils as GZipUtils import Control.Monad (mapM) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) import Distribution.ParseUtils ( readPToMaybe ) 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 Dependency -- | 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 (mapM 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 testNamedTargets targetstr of Just (Dependency pkgn verrange) | pkgn == mkPackageName "world" -> return $ if verrange == anyVersion then Right UserTargetWorld else Left UserTargetBadWorldPkg Just dep -> return (Right (UserTargetNamed dep)) Nothing -> do fileTarget <- testFileTargets targetstr case fileTarget of Just target -> return target Nothing -> case testUriTargets targetstr of Just target -> return target Nothing -> return (Left (UserTargetUnrecognised targetstr)) where testNamedTargets = readPToMaybe parseDependencyOrPackageId 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" parseDependencyOrPackageId :: Parse.ReadP r Dependency parseDependencyOrPackageId = parse +++ liftM pkgidToDependency parse where pkgidToDependency :: PackageIdentifier -> Dependency pkgidToDependency p = case packageVersion p of v | v == nullVersion -> Dependency (packageName p) anyVersion | otherwise -> Dependency (packageName p) (thisVersion v) 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 <- mapM (readPackageTarget verbosity) =<< mapM (fetchPackageTarget verbosity repoCtxt) . concat =<< mapM (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 (Dependency 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 { packageInfoId = packageId pkg, packageDescription = pkg, packageSource = fmap Just location, packageDescrOverride = 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 { packageInfoId = packageId pkg, packageDescription = pkg, packageSource = fmap Just location, packageDescrOverride = 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 '" ++ display 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 '" ++ display name ++ "'. " ++ (if length matches > 1 then "However, the following package names exist: " else "However, the following package name exists: ") ++ intercalate ", " [ "'" ++ display 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 display 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 -- | Version of 'ConstraintScope' that a user may specify on the -- command line. data UserConstraintScope = -- | Scope that applies to the package when it has the specified qualifier. UserQualified UserQualifier PackageName -- | Scope that applies to the package when it has a setup qualifier. | UserAnySetupQualifier PackageName -- | Scope that applies to the package when it has any qualifier. | UserAnyQualifier PackageName deriving (Eq, Show, Generic) instance Binary UserConstraintScope fromUserQualifier :: UserQualifier -> Qualifier fromUserQualifier UserQualToplevel = QualToplevel fromUserQualifier (UserQualSetup name) = QualSetup name fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 fromUserConstraintScope :: UserConstraintScope -> ConstraintScope fromUserConstraintScope (UserQualified q pn) = ScopeQualified (fromUserQualifier q) pn fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn -- | Version of 'PackageConstraint' that the user can specify on -- the command line. data UserConstraint = UserConstraint UserConstraintScope PackageProperty deriving (Eq, Show, Generic) instance Binary UserConstraint userConstraintPackageName :: UserConstraint -> PackageName userConstraintPackageName (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 readPToMaybe parse str of Nothing -> Left msgCannotParse Just 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 Text UserConstraint where disp (UserConstraint scope prop) = dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop parse = let parseConstraintScope :: Parse.ReadP a UserConstraintScope parseConstraintScope = do _ <- Parse.string "any." pn <- parse return (UserAnyQualifier pn) +++ do _ <- Parse.string "setup." pn <- parse return (UserAnySetupQualifier pn) +++ do -- Qualified name pn <- parse (return (UserQualified UserQualToplevel pn) +++ do _ <- Parse.string ":setup." pn2 <- parse return (UserQualified (UserQualSetup pn) pn2)) -- -- TODO: Re-enable parsing of UserQualExe once we decide on a syntax. -- -- +++ -- do _ <- Parse.string ":" -- pn2 <- parse -- _ <- Parse.string ":exe." -- pn3 <- parse -- return (UserQualExe pn pn2, pn3) in do scope <- parseConstraintScope -- Package property let keyword str x = Parse.skipSpaces1 >> Parse.string str >> return x prop <- ((parse >>= return . PackagePropertyVersion) +++ keyword "installed" PackagePropertyInstalled +++ keyword "source" PackagePropertySource +++ keyword "test" (PackagePropertyStanzas [TestStanzas]) +++ keyword "bench" (PackagePropertyStanzas [BenchStanzas])) -- Note: the parser is left-biased here so that we -- don't get an ambiguous parse from 'installed', -- 'source', etc. being regarded as flags. <++ (Parse.skipSpaces1 >> parseFlagAssignment >>= return . PackagePropertyFlags) -- Result return (UserConstraint scope prop) cabal-install-2.4.0.0/Distribution/Client/Types.hs0000644000000000000000000005421500000000000020054 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- 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 where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) , PackageIdentifier(..), packageVersion, packageName , PackageInstalled(..), newSimpleUnitId ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo, installedComponentId, sourceComponentName ) import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Version ( VersionRange, nullVersion, thisVersion ) import Distribution.Types.ComponentId ( ComponentId ) import Distribution.Types.MungedPackageId ( computeCompatPackageId ) import Distribution.Types.PackageId ( PackageId ) import Distribution.Types.AnnotatedId import Distribution.Types.UnitId ( UnitId ) import Distribution.Types.PackageName ( PackageName, mkPackageName ) import Distribution.Types.ComponentName ( ComponentName(..) ) import Distribution.Types.SourceRepo ( SourceRepo ) import Distribution.Solver.Types.PackageIndex ( PackageIndex ) 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.PackageConstraint import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.SourcePackage import Distribution.Compat.Graph (IsNode(..)) import qualified Distribution.Compat.ReadP as Parse import Distribution.ParseUtils (parseOptCommaList) import Distribution.Simple.Utils (ordNub) import Distribution.Text (Text(..)) import Network.URI (URI(..), URIAuth(..), nullURI) import Control.Exception ( Exception, SomeException ) import qualified Text.PrettyPrint as Disp newtype Username = Username { unUsername :: String } newtype Password = Password { unPassword :: String } -- | 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 -- ------------------------------------------------------------ -- * Various kinds of information about packages -- ------------------------------------------------------------ -- | 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 -- | 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 -- @new-build@ codepath supports Backpack. -- data ConfiguredPackage loc = ConfiguredPackage { confPkgId :: InstalledPackageId, confPkgSource :: SourcePackage loc, -- package info, including repo confPkgFlags :: FlagAssignment, -- complete flag assignment for the package confPkgStanzas :: [OptionalStanza], -- list of enabled optional stanzas for the package confPkgDeps :: ComponentDeps [ConfiguredId] -- set of exact dependencies (installed or source). -- These must be consistent with the 'buildDepends' -- in the 'PackageDescription' that you'd get by -- applying the flag assignment and optional stanzas. } deriving (Eq, Show, Generic) -- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'. -- This type class is mostly used to conveniently finesse between -- 'ElaboratedPackage' and 'ElaboratedComponent'. -- instance HasConfiguredId (ConfiguredPackage loc) where configuredId pkg = ConfiguredId (packageId pkg) (Just CLibName) (confPkgId pkg) -- 'ConfiguredPackage' is the legacy codepath, we are guaranteed -- to never have a nontrivial 'UnitId' instance PackageFixedDeps (ConfiguredPackage loc) where depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps instance IsNode (ConfiguredPackage loc) where type Key (ConfiguredPackage loc) = UnitId nodeKey = newSimpleUnitId . confPkgId -- TODO: if we update ConfiguredPackage to support order-only -- dependencies, need to include those here. -- NB: have to deduplicate, otherwise the planner gets confused nodeNeighbors = ordNub . CD.flatDeps . depends instance (Binary loc) => Binary (ConfiguredPackage loc) -- | A ConfiguredId is a package ID for a configured package. -- -- Once we configure a source package we know 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 Show ConfiguredId where show cid = show (confInstId cid) instance Package ConfiguredId where packageId = confSrcId instance Package (ConfiguredPackage loc) where packageId cpkg = packageId (confPkgSource cpkg) instance HasMungedPackageId (ConfiguredPackage loc) where mungedId cpkg = computeCompatPackageId (packageId cpkg) Nothing -- Never has nontrivial UnitId instance HasUnitId (ConfiguredPackage loc) where installedUnitId = newSimpleUnitId . confPkgId instance PackageInstalled (ConfiguredPackage loc) where installedDepends = CD.flatDeps . depends 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) -- | 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) -- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc -- ------------------------------------------------------------ -- * Package specifier -- ------------------------------------------------------------ -- | 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) 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)) -- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------ type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) type ResolvedPkgLoc = PackageLocation FilePath data PackageLocation local = -- | An unpacked package in the given dir, or current dir 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 SourceRepo local deriving (Show, Functor, Eq, Ord, Generic, Typeable) instance Binary local => Binary (PackageLocation local) -- 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 Binary URIAuth where put (URIAuth a b c) = do put a; put b; put c get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) data RemoteRepo = RemoteRepo { remoteRepoName :: String, remoteRepoURI :: URI, -- | Enable secure access? -- -- 'Nothing' here represents "whatever the default is"; this is important -- to allow for a smooth transition from opt-in to opt-out security -- (once we switch to opt-out, all access to the central Hackage -- repository should be secure by default) remoteRepoSecure :: Maybe Bool, -- | Root key IDs (for bootstrapping) remoteRepoRootKeys :: [String], -- | Threshold for verification during bootstrapping remoteRepoKeyThreshold :: Int, -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a -- special case we may know a repo supports both and want to try HTTPS -- if we can, but still allow falling back to HTTP. -- -- This field is not currently stored in the config file, but is filled -- in automagically for known repos. remoteRepoShouldTryHttps :: Bool } deriving (Show, Eq, Ord, Generic) instance Binary RemoteRepo -- | Construct a partial 'RemoteRepo' value to fold the field parser list over. emptyRemoteRepo :: String -> RemoteRepo emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False -- | Different kinds of repositories -- -- NOTE: It is important that this type remains serializable. data Repo = -- | Local repositories RepoLocal { repoLocalDir :: FilePath } -- | Standard (unsecured) remote repositores | RepoRemote { repoRemote :: RemoteRepo , repoLocalDir :: FilePath } -- | Secure repositories -- -- Although this contains the same fields as 'RepoRemote', we use a separate -- constructor to avoid confusing the two. -- -- Not all access to a secure repo goes through the hackage-security -- library currently; code paths that do not still make use of the -- 'repoRemote' and 'repoLocalDir' fields directly. | RepoSecure { repoRemote :: RemoteRepo , repoLocalDir :: FilePath } deriving (Show, Eq, Ord, Generic) instance Binary Repo -- | Check if this is a remote repo isRepoRemote :: Repo -> Bool isRepoRemote RepoLocal{} = False isRepoRemote _ = True -- | Extract @RemoteRepo@ from @Repo@ if remote. maybeRepoRemote :: Repo -> Maybe RemoteRepo maybeRepoRemote (RepoLocal _localDir) = Nothing maybeRepoRemote (RepoRemote r _localDir) = Just r maybeRepoRemote (RepoSecure r _localDir) = Just r -- ------------------------------------------------------------ -- * Build results -- ------------------------------------------------------------ -- | 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 --FIXME: this is a total cheat instance Binary SomeException where put _ = return () get = fail "cannot serialise exceptions" -- ------------------------------------------------------------ -- * --allow-newer/--allow-older -- ------------------------------------------------------------ -- 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 Text RelaxedDep where disp (RelaxedDep scope rdmod subj) = case scope of RelaxDepScopeAll -> Disp.text "all:" Disp.<> modDep RelaxDepScopePackage p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep RelaxDepScopePackageId p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep where modDep = case rdmod of RelaxDepModNone -> disp subj RelaxDepModCaret -> Disp.char '^' Disp.<> disp subj parse = RelaxedDep <$> scopeP <*> modP <*> parse where -- "greedy" choices scopeP = (pure RelaxDepScopeAll <* Parse.char '*' <* Parse.char ':') Parse.<++ (pure RelaxDepScopeAll <* Parse.string "all:") Parse.<++ (RelaxDepScopePackageId <$> pidP <* Parse.char ':') Parse.<++ (RelaxDepScopePackage <$> parse <* Parse.char ':') Parse.<++ (pure RelaxDepScopeAll) modP = (pure RelaxDepModCaret <* Parse.char '^') Parse.<++ (pure RelaxDepModNone) -- | Stricter 'PackageId' parser which doesn't overlap with 'PackageName' parser pidP = do p0 <- parse when (pkgVersion p0 == nullVersion) Parse.pfail pure p0 instance Text RelaxDepSubject where disp RelaxDepSubjectAll = Disp.text "all" disp (RelaxDepSubjectPkg pn) = disp pn parse = (pure RelaxDepSubjectAll <* Parse.char '*') Parse.<++ pkgn where pkgn = do pn <- parse pure (if (pn == mkPackageName "all") then RelaxDepSubjectAll else RelaxDepSubjectPkg pn) instance Text RelaxDeps where disp rd | not (isRelaxDeps rd) = Disp.text "none" disp (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma . map disp $ pkgs disp RelaxDepsAll = Disp.text "all" parse = (const mempty <$> ((Parse.string "none" Parse.+++ Parse.string "None") <* Parse.eof)) Parse.<++ (const RelaxDepsAll <$> ((Parse.string "all" Parse.+++ Parse.string "All" Parse.+++ Parse.string "*") <* Parse.eof)) Parse.<++ ( RelaxDepsSome <$> parseOptCommaList parse) instance Binary RelaxDeps instance Binary RelaxDepMod instance Binary RelaxDepScope instance Binary RelaxDepSubject instance Binary RelaxedDep instance Binary AllowNewer instance Binary 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 -- | '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 = (<>) cabal-install-2.4.0.0/Distribution/Client/Update.hs0000644000000000000000000001123600000000000020166 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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.Simple.Setup ( fromFlag ) import Distribution.Client.Compat.Directory ( setModificationTime ) import Distribution.Client.Types ( Repo(..), RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils ( DownloadResult(..) ) import Distribution.Client.FetchUtils ( downloadIndex ) import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.IndexUtils ( updateRepoIndexCache, Index(..), writeIndexTimestamp , currentIndexTimestamp, indexBaseName ) import Distribution.Client.JobControl ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup ( RepoContext(..), UpdateFlags(..) ) import Distribution.Text ( display ) import Distribution.Verbosity 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.Maybe (mapMaybe) import Data.Time (getCurrentTime) import Control.Monad 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 " ++ remoteRepoName remoteRepo _ -> notice verbosity . unlines $ "Downloading the latest package lists from: " : map (("- " ++) . remoteRepoName) remoteRepos jobCtrl <- newParallelJobControl (length repos) mapM_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos mapM_ (\_ -> collectJob jobCtrl) repos updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO () updateRepo verbosity updateFlags repoCtxt repo = do transport <- repoContextGetTransport repoCtxt case repo of RepoLocal{..} -> 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{} -> 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 (fromFlag (updateIndexState updateFlags)) 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='" ++ display current_ts ++ "'\n" cabal-install-2.4.0.0/Distribution/Client/Upload.hs0000644000000000000000000002235500000000000020174 0ustar0000000000000000module Distribution.Client.Upload (upload, uploadDoc, report) where import Distribution.Client.Types ( Username(..), Password(..) , RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) import Distribution.Client.Setup ( IsCandidate(..), RepoContext(..) ) import Distribution.Simple.Utils (notice, warn, info, die') import Distribution.Verbosity (Verbosity) import Distribution.Text (display) import Distribution.Client.Config import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Upload as BuildReport import Network.URI (URI(uriPath)) import Network.HTTP (Header(..), HeaderName(..)) import System.IO (hFlush, stdout) import System.IO.Echo (withoutInputEcho) import System.Exit (exitFailure) import System.FilePath ((), takeExtension, takeFileName, dropExtension) import qualified System.FilePath.Posix as FilePath.Posix (()) import System.Directory import Control.Monad (forM_, when, foldM) import Data.Maybe (mapMaybe) import Data.Char (isSpace) 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." rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. case isCandidate of IsCandidate -> "packages/candidates" IsPublished -> "upload" } packageURI pkgid = targetRepoURI { uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. concat [ "package/", pkgid , case isCandidate of IsCandidate -> "/candidate" IsPublished -> "" ] } Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword let auth = Just (username,password) forM_ paths $ \path -> do notice verbosity $ "Uploading " ++ path ++ "... " 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." rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. 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 $ tail reversePkgid when (reverse reverseSuffix /= "docs.tar.gz" || null reversePkgid || head reversePkgid /= '-') $ die' verbosity "Expected a file name matching the pattern -docs.tar.gz" Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword let auth = Just (username,password) headers = [ Header HdrContentType "application/x-tar" , Header HdrContentEncoding "gzip" ] notice verbosity $ "Uploading documentation " ++ path ++ "... " resp <- putHttpFile transport verbosity uploadURI path auth headers case resp of -- 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 :: IO Username promptUsername = do putStr "Hackage username: " hFlush stdout fmap Username getLine promptPassword :: IO Password promptPassword = do putStr "Hackage 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 Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword let auth = (username, password) repos = repoContextRepos repoCtxt remoteRepos = mapMaybe maybeRepoRemote repos forM_ remoteRepos $ \remoteRepo -> do dotCabal <- getCabalDir let srcDir = dotCabal "reports" remoteRepoName remoteRepo -- We don't want to bomb out just because we haven't built any packages -- from this repo yet. srcExists <- doesDirectoryExist srcDir when srcExists $ do contents <- getDirectoryContents srcDir forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> do inp <- readFile (srcDir logFile) let (reportStr, buildLog) = read inp :: (String,String) -- TODO: eradicateNoParse case BuildReport.parse reportStr of Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME Right report' -> do info verbosity $ "Uploading report for " ++ display (BuildReport.package report') BuildReport.uploadReports verbosity repoCtxt auth (remoteRepoURI remoteRepo) [(report', Just buildLog)] return () 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 cabal-install-2.4.0.0/Distribution/Client/Utils.hs0000644000000000000000000003331000000000000020041 0ustar0000000000000000{-# 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) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Compat.Environment import Distribution.Compat.Exception ( catchIO ) import Distribution.Compat.Time ( getModTime ) import Distribution.Simple.Setup ( Flag(..) ) import Distribution.Verbosity 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 ( mapM, mapM_, 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 -- | 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 <- mapM lookupEnv envVars mapM_ (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 " cabal-install-2.4.0.0/Distribution/Client/Utils/0000755000000000000000000000000000000000000017505 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Client/Utils/Assertion.hs0000644000000000000000000000106500000000000022012 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Client.Utils.Assertion (expensiveAssert) where #ifdef DEBUG_EXPENSIVE_ASSERTIONS import Control.Exception (assert) import Distribution.Compat.Stack #endif -- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This -- function can be used for expensive assertions that should only be turned on -- during testing or debugging. #ifdef DEBUG_EXPENSIVE_ASSERTIONS expensiveAssert :: WithCallStack (Bool -> a -> a) expensiveAssert = assert #else expensiveAssert :: Bool -> a -> a expensiveAssert _ = id #endif cabal-install-2.4.0.0/Distribution/Client/Utils/Json.hs0000644000000000000000000001526500000000000020763 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Minimal JSON / RFC 7159 support -- -- The API is heavily inspired by @aeson@'s API but puts emphasis on -- simplicity rather than performance. The 'ToJSON' instances are -- intended to have an encoding compatible with @aeson@'s encoding. -- module Distribution.Client.Utils.Json ( Value(..) , Object, object, Pair, (.=) , encodeToString , encodeToBuilder , ToJSON(toJSON) ) where import Data.Char import Data.Int import Data.String import Data.Word import Data.List import Data.Monoid import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB -- TODO: We may want to replace 'String' with 'Text' or 'ByteString' -- | A JSON value represented as a Haskell value. data Value = Object !Object | Array [Value] | String String | Number !Double | Bool !Bool | Null deriving (Eq, Read, Show) -- | A key\/value pair for an 'Object' type Pair = (String, Value) -- | A JSON \"object\" (key/value map). type Object = [Pair] infixr 8 .= -- | A key-value pair for encoding a JSON object. (.=) :: ToJSON v => String -> v -> Pair k .= v = (k, toJSON v) -- | Create a 'Value' from a list of name\/value 'Pair's. object :: [Pair] -> Value object = Object instance IsString Value where fromString = String -- | A type that can be converted to JSON. class ToJSON a where -- | Convert a Haskell value to a JSON-friendly intermediate type. toJSON :: a -> Value instance ToJSON () where toJSON () = Array [] instance ToJSON Value where toJSON = id instance ToJSON Bool where toJSON = Bool instance ToJSON a => ToJSON [a] where toJSON = Array . map toJSON instance ToJSON a => ToJSON (Maybe a) where toJSON Nothing = Null toJSON (Just a) = toJSON a instance (ToJSON a,ToJSON b) => ToJSON (a,b) where toJSON (a,b) = Array [toJSON a, toJSON b] instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] instance ToJSON Float where toJSON = Number . realToFrac instance ToJSON Double where toJSON = Number instance ToJSON Int where toJSON = Number . realToFrac instance ToJSON Int8 where toJSON = Number . realToFrac instance ToJSON Int16 where toJSON = Number . realToFrac instance ToJSON Int32 where toJSON = Number . realToFrac instance ToJSON Word where toJSON = Number . realToFrac instance ToJSON Word8 where toJSON = Number . realToFrac instance ToJSON Word16 where toJSON = Number . realToFrac instance ToJSON Word32 where toJSON = Number . realToFrac -- | Possibly lossy due to conversion to 'Double' instance ToJSON Int64 where toJSON = Number . realToFrac -- | Possibly lossy due to conversion to 'Double' instance ToJSON Word64 where toJSON = Number . realToFrac -- | Possibly lossy due to conversion to 'Double' instance ToJSON Integer where toJSON = Number . fromInteger ------------------------------------------------------------------------------ -- 'BB.Builder'-based encoding -- | Serialise value as JSON/UTF8-encoded 'Builder' encodeToBuilder :: ToJSON a => a -> Builder encodeToBuilder = encodeValueBB . toJSON encodeValueBB :: Value -> Builder encodeValueBB jv = case jv of Bool True -> "true" Bool False -> "false" Null -> "null" Number n | isNaN n || isInfinite n -> encodeValueBB Null | Just i <- doubleToInt64 n -> BB.int64Dec i | otherwise -> BB.doubleDec n Array a -> encodeArrayBB a String s -> encodeStringBB s Object o -> encodeObjectBB o encodeArrayBB :: [Value] -> Builder encodeArrayBB [] = "[]" encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']' where go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB encodeObjectBB :: Object -> Builder encodeObjectBB [] = "{}" encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' where go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x encodeStringBB :: String -> Builder encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' where go = BB.stringUtf8 . escapeString ------------------------------------------------------------------------------ -- 'String'-based encoding -- | Serialise value as JSON-encoded Unicode 'String' encodeToString :: ToJSON a => a -> String encodeToString jv = encodeValue (toJSON jv) [] encodeValue :: Value -> ShowS encodeValue jv = case jv of Bool b -> showString (if b then "true" else "false") Null -> showString "null" Number n | isNaN n || isInfinite n -> encodeValue Null | Just i <- doubleToInt64 n -> shows i | otherwise -> shows n Array a -> encodeArray a String s -> encodeString s Object o -> encodeObject o encodeArray :: [Value] -> ShowS encodeArray [] = showString "[]" encodeArray jvs = ('[':) . go jvs . (']':) where go [] = id go [x] = encodeValue x go (x:xs) = encodeValue x . (',':) . go xs encodeObject :: Object -> ShowS encodeObject [] = showString "{}" encodeObject jvs = ('{':) . go jvs . ('}':) where go [] = id go [(l,x)] = encodeString l . (':':) . encodeValue x go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs encodeString :: String -> ShowS encodeString str = ('"':) . showString (escapeString str) . ('"':) ------------------------------------------------------------------------------ -- helpers -- | Try to convert 'Double' into 'Int64', return 'Nothing' if not -- representable loss-free as integral 'Int64' value. doubleToInt64 :: Double -> Maybe Int64 doubleToInt64 x | fromInteger x' == x , x' <= toInteger (maxBound :: Int64) , x' >= toInteger (minBound :: Int64) = Just (fromIntegral x') | otherwise = Nothing where x' = round x -- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings" escapeString :: String -> String escapeString s | not (any needsEscape s) = s | otherwise = escape s where escape [] = [] escape (x:xs) = case x of '\\' -> '\\':'\\':escape xs '"' -> '\\':'"':escape xs '\b' -> '\\':'b':escape xs '\f' -> '\\':'f':escape xs '\n' -> '\\':'n':escape xs '\r' -> '\\':'r':escape xs '\t' -> '\\':'t':escape xs c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs | otherwise -> c : escape xs -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] cabal-install-2.4.0.0/Distribution/Client/VCS.hs0000644000000000000000000004262700000000000017407 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} module Distribution.Client.VCS ( -- * VCS driver type VCS, vcsRepoType, vcsProgram, -- ** Type re-exports SourceRepo, RepoType, RepoKind, Program, ConfiguredProgram, -- * Selecting amongst source repos selectPackageSourceRepo, -- * Validating 'SourceRepo's and configuring VCS drivers validateSourceRepo, validateSourceRepos, SourceRepoProblem(..), configureVCS, configureVCSs, -- * Running the VCS driver cloneSourceRepo, syncSourceRepos, -- * The individual VCS drivers knownVCSs, vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn, ) where import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Types.SourceRepo ( SourceRepo(..), RepoType(..), RepoKind(..) ) import Distribution.Client.RebuildMonad ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) import Distribution.Verbosity as Verbosity ( Verbosity, normal ) import Distribution.Simple.Program ( Program(programFindVersion) , ConfiguredProgram(programVersion) , simpleProgram, findProgramVersion , ProgramInvocation(..), programInvocation, runProgramInvocation , emptyProgramDb, requireProgram ) import Distribution.Version ( mkVersion ) import Control.Monad ( mapM_ ) import Control.Monad.Trans ( liftIO ) import qualified Data.Char as Char import qualified Data.Map as Map import Data.Ord ( comparing ) import Data.Either ( partitionEithers ) 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 :: Verbosity -> ConfiguredProgram -> SourceRepo -> 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 :: Verbosity -> ConfiguredProgram -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath] } -- ------------------------------------------------------------ -- * Selecting repos and drivers -- ------------------------------------------------------------ -- | 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 -> [SourceRepo] -> Maybe 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 (repoKind repo ==) preferredRepoKind) where thisFirst :: SourceRepo -> Int thisFirst r = case repoKind r of RepoThis -> 0 RepoHead -> case 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 data SourceRepoProblem = SourceRepoRepoTypeUnspecified | SourceRepoRepoTypeUnsupported 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 :: SourceRepo -> Either SourceRepoProblem (SourceRepo, String, RepoType, VCS Program) validateSourceRepo = \repo -> do rtype <- repoType repo ?! SourceRepoRepoTypeUnspecified vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported rtype uri <- repoLocation repo ?! SourceRepoLocationUnspecified return (repo, uri, rtype, vcs) 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 :: [SourceRepo] -> Either [(SourceRepo, SourceRepoProblem)] [(SourceRepo, 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 -> SourceRepo -- ^ Must have 'repoLocation' filled. -> FilePath -- ^ Destination directory -> IO () cloneSourceRepo _ _ repo@SourceRepo{ repoLocation = Nothing } _ = error $ "cloneSourceRepo: precondition violation, missing repoLocation: \"" ++ show repo ++ "\". Validate using validateSourceRepo first." cloneSourceRepo verbosity vcs repo@SourceRepo{ repoLocation = Just srcuri } destdir = mapM_ (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 -> [(SourceRepo, 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 = Bazaar, vcsProgram = bzrProgram, vcsCloneRepo, vcsSyncRepos } where vcsCloneRepo :: Verbosity -> ConfiguredProgram -> SourceRepo -> 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 repoTag repo of Nothing -> [] Just tag -> ["-r", "tag:" ++ tag] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram -> [(SourceRepo, 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 = Darcs, vcsProgram = darcsProgram, vcsCloneRepo, vcsSyncRepos } where vcsCloneRepo :: Verbosity -> ConfiguredProgram -> SourceRepo -> 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 repoTag repo of Nothing -> [] Just tag -> ["-t", tag] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram -> [(SourceRepo, 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 = Git, vcsProgram = gitProgram, vcsCloneRepo, vcsSyncRepos } where vcsCloneRepo :: Verbosity -> ConfiguredProgram -> SourceRepo -> 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 (repoTag repo) ] where cloneArgs = ["clone", srcuri, destdir] ++ branchArgs ++ verboseArg branchArgs = case repoBranch repo of Just b -> ["--branch", b] Nothing -> [] checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram -> [(SourceRepo, 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 SourceRepo{..} 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 Just loc = repoLocation checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force" , checkoutTarget, "--" ] checkoutTarget = fromMaybe "HEAD" (repoBranch `mplus` repoTag) 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 = Mercurial, vcsProgram = hgProgram, vcsCloneRepo, vcsSyncRepos } where vcsCloneRepo :: Verbosity -> ConfiguredProgram -> SourceRepo -> FilePath -> FilePath -> [ProgramInvocation] vcsCloneRepo verbosity prog repo srcuri destdir = [ programInvocation prog cloneArgs ] where cloneArgs = ["clone", srcuri, destdir] ++ branchArgs ++ tagArgs ++ verboseArg branchArgs = case repoBranch repo of Just b -> ["--branch", b] Nothing -> [] tagArgs = case repoTag repo of Just t -> ["--rev", t] Nothing -> [] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram -> [(SourceRepo, 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 = SVN, vcsProgram = svnProgram, vcsCloneRepo, vcsSyncRepos } where vcsCloneRepo :: Verbosity -> ConfiguredProgram -> SourceRepo -> 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 -> [(SourceRepo, 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 _ -> "" } cabal-install-2.4.0.0/Distribution/Client/Win32SelfUpgrade.hs0000644000000000000000000001677600000000000022006 0ustar0000000000000000{-# 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 #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 (Verbosity, showForCabal) import Distribution.Simple.Utils (debug, info) import Prelude hiding (log) -- | 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' <- mapM 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.Verbosity (Verbosity) 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 cabal-install-2.4.0.0/Distribution/Client/World.hs0000644000000000000000000001460500000000000020036 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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.PackageDescription ( FlagAssignment, mkFlagAssignment, unFlagAssignment , mkFlagName, unFlagName ) import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils ( die', info, chattyTry, writeFileAtomic ) import Distribution.Text ( Text(..), display, simpleParse ) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.Exception ( catchIO ) import qualified Text.PrettyPrint as Disp import Data.Char as Char 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) -- | 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 [ (display 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 simpleParse (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 Text WorldPkgInfo where disp (WorldPkgInfo dep flags) = disp 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.empty) <<>> Disp.text (unFlagName fname) Disp.<+> flagAssDoc) Disp.empty parse = do dep <- parse Parse.skipSpaces flagAss <- Parse.option mempty parseFlagAssignment return $ WorldPkgInfo dep flagAss where parseFlagAssignment :: Parse.ReadP r FlagAssignment parseFlagAssignment = do _ <- Parse.string "--flags" Parse.skipSpaces _ <- Parse.char '=' Parse.skipSpaces mkFlagAssignment <$> (inDoubleQuotes $ Parse.many1 flag) where inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') flag = do Parse.skipSpaces val <- negative Parse.+++ positive name <- ident Parse.skipSpaces return (mkFlagName name,val) negative = do _ <- Parse.char '-' return False positive = return True ident :: Parse.ReadP r String ident = do -- First character must be a letter/digit to avoid flags -- like "+-debug": c <- Parse.satisfy Char.isAlphaNum cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_' || ch == '-') return (c:cs) cabal-install-2.4.0.0/Distribution/Solver/Compat/0000755000000000000000000000000000000000000017664 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Solver/Compat/Prelude.hs0000644000000000000000000000102700000000000021620 0ustar0000000000000000-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" {-# OPTIONS_GHC -fno-warn-deprecations #-} -- | This module does two things: -- -- * Acts as a compatiblity layer, like @base-compat@. -- -- * Provides commonly used imports. -- -- This module is a superset of "Distribution.Compat.Prelude" (which -- this module re-exports) -- module Distribution.Solver.Compat.Prelude ( module Distribution.Compat.Prelude.Internal , Prelude.IO ) where import Prelude (IO) import Distribution.Compat.Prelude.Internal hiding (IO) cabal-install-2.4.0.0/Distribution/Solver/0000755000000000000000000000000000000000000016441 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Solver/Modular.hs0000644000000000000000000001777100000000000020415 0ustar0000000000000000module 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 (Set) import Data.Ord 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(..), logToProgress ) import Distribution.Solver.Modular.Package ( PN ) 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.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. 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 = foldProgress Step (uncurry createErrorMsg) Done (runSolver printFullLog sc) where runSolver :: Bool -> SolverConfig -> Progress String (SolverFailure, String) (Assignment, RevDepMap) runSolver keepLog sc' = logToProgress keepLog (solverVerbosity sc') (maxBackjumps sc') $ solve sc' cinfo idx pkgConfigDB pprefs gcs pns createErrorMsg :: SolverFailure -> String -> Progress String String (Assignment, RevDepMap) createErrorMsg (ExhaustiveSearch cs _) msg = Fail $ rerunSolverForErrorMsg cs ++ msg createErrorMsg BackjumpLimitReached msg = Step ("Backjump limit reached. Rerunning dependency solver to generate " ++ "a final conflict set for the search tree containing the " ++ "first backjump.") $ foldProgress Step (f . fst) Done $ runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True } where f :: SolverFailure -> Progress String String (Assignment, RevDepMap) f (ExhaustiveSearch cs _) = Fail $ rerunSolverForErrorMsg cs ++ msg f BackjumpLimitReached = -- This case is possible when the number of goals involved in -- conflicts is greater than the backjump limit. Fail $ msg ++ "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 (runSolver True sc')) printFullLog = solverVerbosity sc >= verbose messages :: Progress step fail done -> [step] messages = foldProgress (:) (const []) (const []) -- | 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 where 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) cabal-install-2.4.0.0/Distribution/Solver/Modular/0000755000000000000000000000000000000000000020044 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Solver/Modular/Assignment.hs0000644000000000000000000000671700000000000022523 0ustar0000000000000000module Distribution.Solver.Modular.Assignment ( Assignment(..) , PAssignment , FAssignment , SAssignment , toCPs ) where import Prelude () import Distribution.Solver.Compat.Prelude hiding (pi) import Data.Array as A import Data.List as L import Data.Map as M import Data.Maybe 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) 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Builder.hs0000644000000000000000000003343400000000000021775 0ustar0000000000000000{-# 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 Data.List as L import Data.Map as M import Data.Set as S import Prelude hiding (sequence, mapM) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import 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 = 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) }) = -- If the package does not exist in the index, we construct an emty PChoiceF node for it -- After all, we have no choices here. Alternatively, we could immediately construct -- a Fail node here, but that would complicate the construction of conflict sets. -- We will probably want to give this case special treatment when generating error -- messages though. case M.lookup pn idx of Nothing -> PChoiceF qpn rdm gr (W.fromList []) Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> ([], POption i Nothing, bs { next = Instance qpn 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Configured.hs0000644000000000000000000000073500000000000022472 0ustar0000000000000000module 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]) cabal-install-2.4.0.0/Distribution/Solver/Modular/ConfiguredConversion.hs0000644000000000000000000000553300000000000024541 0ustar0000000000000000module Distribution.Solver.Modular.ConfiguredConversion ( convCP ) where import Data.Maybe import Prelude hiding (pi) import Data.Either (partitionEithers) import Distribution.Package (UnitId, packageId) import qualified Distribution.Simple.PackageIndex as SI import Distribution.Solver.Modular.Configured import Distribution.Solver.Modular.Package import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SourcePackage -- | Converts from the solver specific result @CP QPN@ into -- a 'ResolverPackage', which can then be converted into -- the install plan. convCP :: SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> CP QPN -> ResolverPackage loc convCP iidx sidx (CP qpi fa es ds) = case convPI qpi of Left pi -> PreExisting $ InstSolverPackage { instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, instSolverPkgLibDeps = fmap fst ds', instSolverPkgExeDeps = fmap snd ds' } Right pi -> Configured $ SolverPackage { solverPkgSource = srcpkg, solverPkgFlags = fa, solverPkgStanzas = es, solverPkgLibDeps = fmap fst ds', solverPkgExeDeps = fmap snd ds' } where Just srcpkg = CI.lookupPackageId sidx pi where ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) ds' = fmap (partitionEithers . map convConfId) ds convPI :: PI QPN -> Either UnitId PackageId convPI (PI _ (I _ (Inst pi))) = Left pi convPI pi = Right (packageId (either id id (convConfId pi))) convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = case loc of Inst pi -> Left (PreExistingId sourceId pi) _otherwise | QualExe _ pn' <- q -- NB: the dependencies of the executable are also -- qualified. So the way to tell if this is an executable -- dependency is to make sure the qualifier is pointing -- at the actual thing. Fortunately for us, I was -- silly and didn't allow arbitrarily nested build-tools -- dependencies, so a shallow check works. , pn == pn' -> Right (PlannedId sourceId) | otherwise -> Left (PlannedId sourceId) where sourceId = PackageIdentifier pn v cabal-install-2.4.0.0/Distribution/Solver/Modular/ConflictSet.hs0000644000000000000000000001166600000000000022627 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef DEBUG_CONFLICT_SETS {-# LANGUAGE ImplicitParams #-} #endif -- | Conflict sets -- -- Intended for double import -- -- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) -- > import qualified Distribution.Solver.Modular.ConflictSet as CS module Distribution.Solver.Modular.ConflictSet ( ConflictSet -- opaque , ConflictMap #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin #endif , showConflictSet , showCSSortedByFrequency , showCSWithFrequency -- Set-like operations , toList , union , unions , insert , empty , singleton , member , filter , fromList ) where import Prelude hiding (filter) import Data.List (intercalate, sortBy) import Data.Map (Map) import Data.Set (Set) import Data.Function (on) import qualified Data.Set as S import qualified Data.Map as M #ifdef DEBUG_CONFLICT_SETS import Data.Tree import GHC.Stack #endif import Distribution.Solver.Modular.Var import Distribution.Solver.Types.PackagePath -- | The set of variables involved in a solver conflict -- -- Since these variables should be preprocessed in some way, this type is -- kept abstract. data ConflictSet = CS { -- | The set of variables involved on the conflict conflictSetToSet :: !(Set (Var QPN)) #ifdef DEBUG_CONFLICT_SETS -- | The origin of the conflict set -- -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@, -- we record the origin of every conflict set. For new conflict sets -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations -- that construct new conflict sets from existing conflict sets ('union', -- 'filter', ..) we record the 'CallStack' to the call to the combinator -- as well as the 'CallStack's of the input conflict sets. -- -- Requires @GHC >= 7.10@. , conflictSetOrigin :: Tree CallStack #endif } deriving (Show) instance Eq ConflictSet where (==) = (==) `on` conflictSetToSet instance Ord ConflictSet where compare = compare `on` conflictSetToSet showConflictSet :: ConflictSet -> String showConflictSet = intercalate ", " . map showVar . toList showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String showCSSortedByFrequency = showCS False showCSWithFrequency :: ConflictMap -> ConflictSet -> String showCSWithFrequency = showCS True showCS :: Bool -> ConflictMap -> ConflictSet -> String showCS showCount cm = intercalate ", " . map showWithFrequency . indexByFrequency where indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of Just frequency | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" _ -> showVar conflict {------------------------------------------------------------------------------- Set-like operations -------------------------------------------------------------------------------} toList :: ConflictSet -> [Var QPN] toList = S.toList . conflictSetToSet union :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif ConflictSet -> ConflictSet -> ConflictSet union cs cs' = CS { conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs') #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) #endif } unions :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif [ConflictSet] -> ConflictSet unions css = CS { conflictSetToSet = S.unions (map conflictSetToSet css) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) #endif } insert :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif Var QPN -> ConflictSet -> ConflictSet insert var cs = CS { conflictSetToSet = S.insert var (conflictSetToSet cs) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] #endif } empty :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif ConflictSet empty = CS { conflictSetToSet = S.empty #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } singleton :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif Var QPN -> ConflictSet singleton var = CS { conflictSetToSet = S.singleton var #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } member :: Var QPN -> ConflictSet -> Bool member var = S.member var . conflictSetToSet filter :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif (Var QPN -> Bool) -> ConflictSet -> ConflictSet filter p cs = CS { conflictSetToSet = S.filter p (conflictSetToSet cs) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] #endif } fromList :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif [Var QPN] -> ConflictSet fromList vars = CS { conflictSetToSet = S.fromList vars #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } type ConflictMap = Map (Var QPN) Int cabal-install-2.4.0.0/Distribution/Solver/Modular/Cycles.hs0000644000000000000000000001165700000000000021634 0ustar0000000000000000{-# 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] cabal-install-2.4.0.0/Distribution/Solver/Modular/Dependency.hs0000644000000000000000000002713700000000000022470 0ustar0000000000000000{-# 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 , goalReasonToCS , dependencyReasonToCS ) 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.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 VR -- ^ 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 | 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) (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 goalReasonToCS :: GoalReason QPN -> ConflictSet goalReasonToCS UserGoal = CS.empty goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr -- | This function returns the solver variables responsible for the dependency. -- It drops the flag and stanza values, which are only needed for log messages. dependencyReasonToCS :: DependencyReason QPN -> ConflictSet dependencyReasonToCS (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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Explore.hs0000644000000000000000000002340700000000000022024 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.Explore ( backjump , backjumpAndExplore ) where import qualified Distribution.Solver.Types.Progress as P import Data.Foldable as F import Data.List as L (foldl') import Data.Map.Strict as M import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Log import Distribution.Solver.Modular.Message import qualified Distribution.Solver.Modular.PSQ as P import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..)) -- | This function takes the variable we're currently considering, 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'. -- backjump :: Maybe Int -> EnableBackjumping -> Var QPN -> ConflictSet -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) -> ExploreState -> ConflictSetLog a backjump mbj (EnableBackjumping enableBj) var lastCS xs = F.foldr combine avoidGoal xs CS.empty where combine :: forall a . (ExploreState -> ConflictSetLog a) -> (ConflictSet -> ExploreState -> ConflictSetLog a) -> ConflictSet -> ExploreState -> ConflictSetLog a combine x f csAcc es = retry (x es) next where next :: IntermediateFailure -> ConflictSetLog a next BackjumpLimit = fromProgress (P.Fail BackjumpLimit) next (NoSolution !cs es') | enableBj && not (var `CS.member` cs) = skipLoggingBackjump cs es' | otherwise = f (csAcc `CS.union` cs) es' -- This function represents the option to not choose a value for this goal. avoidGoal :: ConflictSet -> ExploreState -> ConflictSetLog a avoidGoal cs !es = logBackjump (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) } logBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a logBackjump 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) -- 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) -- | 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 -> CountConflicts -> Tree Assignment QGoalReason -> ConflictSetLog (Assignment, RevDepMap) exploreLog mbj enableBj (CountConflicts countConflicts) t = cata go t initES where getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) getBestGoal' | countConflicts = \ ts cm -> getBestGoal cm ts | otherwise = \ ts _ -> getFirstGoal ts go :: TreeF Assignment QGoalReason (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) -> (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 (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryP qpn k) (r es)) ts go (FChoiceF qfn _ gr _ _ _ ts) = backjump mbj enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryF qfn k) (r es)) ts go (SChoiceF qsn _ gr _ ts) = backjump mbj enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryS qsn k) (r es)) ts go (GoalChoiceF _ ts) = \ es -> let (k, v) = getBestGoal' ts (esConflictMap es) in continueWith (Next k) (v es) initES = ES { esConflictMap = M.empty , esBackjumps = 0 } -- | 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 gr = CS.union (CS.singleton var) (goalReasonToCS 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 -> CountConflicts -> Tree d QGoalReason -> RetryLog Message SolverFailure (Assignment, RevDepMap) backjumpAndExplore mbj enableBj countConflicts = mapFailure convertFailure . exploreLog mbj enableBj countConflicts . assign where convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) convertFailure BackjumpLimit = BackjumpLimitReached cabal-install-2.4.0.0/Distribution/Solver/Modular/Flag.hs0000644000000000000000000000615400000000000021257 0ustar0000000000000000{-# 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Index.hs0000644000000000000000000000432500000000000021453 0ustar0000000000000000module Distribution.Solver.Modular.Index ( Index , PInfo(..) , IsBuildable(..) , defaultQualifyOptions , mkIndex ) where import Data.List as L import Data.Map as M import Prelude hiding (pi) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree -- | 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 IsBuildable) FlagInfo (Maybe FailReason) -- | Whether a component is made unbuildable by a "buildable: False" field. newtype IsBuildable = IsBuildable Bool 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" cabal-install-2.4.0.0/Distribution/Solver/Modular/IndexConversion.hs0000644000000000000000000006742200000000000023530 0ustar0000000000000000module Distribution.Solver.Modular.IndexConversion ( convPIs ) where import Data.List as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid as Mon import Data.Set as S import Distribution.Compiler import Distribution.InstalledPackageInfo as IPI import Distribution.Package -- from Cabal import Distribution.Simple.BuildToolDepends -- from Cabal import Distribution.Simple.Utils (cabalVersion) -- from Cabal import Distribution.Types.ExeDependency -- from Cabal import Distribution.Types.PkgconfigDependency -- from Cabal import Distribution.Types.ComponentName -- from Cabal import Distribution.Types.UnqualComponentName -- from Cabal import Distribution.Types.CondTree -- from Cabal import Distribution.Types.MungedPackageId -- from Cabal import Distribution.Types.MungedPackageName -- from Cabal import Distribution.PackageDescription as PD -- from Cabal import Distribution.PackageDescription.Configuration as PDC import qualified Distribution.Simple.PackageIndex as SI import Distribution.System import Distribution.Types.ForeignLib import Distribution.Solver.Types.ComponentDeps ( Component(..), componentNameToComponent ) import Distribution.Solver.Types.Flag import Distribution.Solver.Types.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 the package ID from an installed package info, and convert it to a solver's I. convId :: InstalledPackageInfo -> (PN, I) convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) where MungedPackageId mpn ver = mungedId ipi -- HACK. See Note [Index conversion with internal libraries] pn = mkPackageName (unMungedPackageName mpn) -- | Convert a single installed package into the solver-specific format. convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of Nothing -> (pn, i, PInfo [] M.empty M.empty (Just Broken)) Just fds -> ( pn , i , PInfo fds (M.singleton ExposedLib (IsBuildable True)) M.empty Nothing) where (pn, i) = convId ipi -- 'sourceLibName' is unreliable, but for now we only really use this for -- primary libs anyways comp = componentNameToComponent $ libraryComponentName $ sourceLibName ipi -- TODO: Installed packages should also store their encapsulations! -- Note [Index conversion with internal libraries] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Something very interesting happens when we have internal libraries -- in our index. In this case, we maybe have p-0.1, which itself -- depends on the internal library p-internal ALSO from p-0.1. -- Here's the danger: -- -- - If we treat both of these packages as having PN "p", -- then the solver will try to pick one or the other, -- but never both. -- -- - If we drop the internal packages, now p-0.1 has a -- dangling dependency on an "installed" package we know -- nothing about. Oops. -- -- An expedient hack is to put p-internal into cabal-install's -- index as a MUNGED package name, so that it doesn't conflict -- with anyone else (except other instances of itself). But -- yet, we ought NOT to say that PNs in the solver are munged -- package names, because they're not; for source packages, -- we really will never see munged package names. -- -- The tension here is that the installed package index is actually -- per library, but the solver is per package. We need to smooth -- it over, and munging the package names is a pretty good way to -- do it. -- | Convert dependencies specified by an installed package id into -- flagged dependencies of the solver. -- -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored. convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep PN) convIPId dr comp idx ipid = case SI.lookupUnitId idx ipid of Nothing -> Nothing Just ipi -> let (pn, i) = convId ipi in Just (D.Simple (LDep dr (Dep (PkgComponent pn ExposedLib) (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 flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags -- | We have to be careful to filter out dependencies on -- internal libraries, since they don't refer to real packages -- and thus cannot actually be solved over. We'll do this -- by creating a set of package names which are "internal" -- and dropping them as we convert. ipns = S.fromList $ [ unqualComponentNameToPackageName nm | (nm, _) <- sub_libs ] conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN -> CondTree ConfVar [Dependency] a -> FlaggedDeps PN conv comp getInfo dr = convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo ipns solveExes . PDC.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) -- | We infer the maximally supported spec-version from @lib:Cabal@'s version -- -- As we cannot predict the future, we can only properly support -- spec-versions predating (and including) the @lib:Cabal@ version -- used by @cabal-install@. -- -- This relies on 'cabalVersion' having always at least 3 components to avoid -- comparisons like @2.0.0 > 2.0@ which would result in confusing results. -- -- NOTE: Before we can switch to a /normalised/ spec-version -- comparison (e.g. by truncating to 3 components, and removing -- trailing zeroes) we'd have to make sure all other places where -- the spec-version is compared against a bound do it -- consistently. maxSpecVer = cabalVersion -- | Required/declared spec-version of the package -- -- We don't truncate patch-levels, as specifying a patch-level -- spec-version is discouraged and not supported anymore starting -- with spec-version 2.2. reqSpecVer = specVersion pkg -- | 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 | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer) | otherwise = Nothing components :: Map ExposedComponent IsBuildable components = M.fromList $ libComps ++ exeComps where libComps = [ (ExposedLib, IsBuildable $ isBuildable libBuildInfo lib) | lib <- maybeToList mlib ] exeComps = [ (ExposedExe name, IsBuildable $ isBuildable buildInfo exe) | (name, exe) <- exes ] isBuildable = isBuildableComponent os arch cinfo constraints in PInfo flagged_deps components fds fr -- | Returns true if the component is buildable in the given environment. -- This function can give false-positives. For example, it only considers flags -- that are set by unqualified flag constraints, and it doesn't check whether -- the intra-package dependencies of a component are buildable. It is also -- possible for the solver to later assign a value to an automatic flag that -- makes the component unbuildable. isBuildableComponent :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> (a -> BuildInfo) -> CondTree ConfVar [Dependency] a -> Bool isBuildableComponent os arch cinfo constraints getInfo tree = case simplifyCondition $ extractCondition (buildable . getInfo) tree of Lit False -> False _ -> True 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. simplifyCondition :: Condition ConfVar -> Condition ConfVar simplifyCondition (Var (OS os')) = Lit (os == os') simplifyCondition (Var (Arch arch')) = Lit (arch == arch') simplifyCondition (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 simplifyCondition (Var (Flag f)) | Just b <- L.lookup f flagAssignment = Lit b simplifyCondition (Var v) = Var v simplifyCondition (Lit b) = Lit b simplifyCondition (CNot c) = case simplifyCondition c of Lit True -> Lit False Lit False -> Lit True c' -> CNot c' simplifyCondition (COr c d) = case (simplifyCondition c, simplifyCondition d) of (Lit False, d') -> d' (Lit True, _) -> Lit True (c', Lit False) -> c' (_, Lit True) -> Lit True (c', d') -> COr c' d' simplifyCondition (CAnd c d) = case (simplifyCondition c, simplifyCondition 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 -> [PD.Flag] -> FlagInfo flagInfo (StrongFlags strfl) = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) where weak m = WeakOrTrivial $ not (strfl || m) flagType m = if m then Manual else Automatic -- | Internal package names, which should not be interpreted as true -- dependencies. type IPNs = Set PN -- | Convenience function to delete a 'Dependency' if it's -- for a 'PN' that isn't actually real. filterIPNs :: IPNs -> Dependency -> Maybe Dependency filterIPNs ipns d@(Dependency pn _) | S.notMember pn ipns = Just d | otherwise = Nothing -- | Convert condition trees to flagged dependencies. Mutually -- recursive with 'convBranch'. See 'convBranch' for an explanation -- of all arguments preceeding the input 'CondTree'. convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> Component -> (a -> BuildInfo) -> IPNs -> SolveExecutables -> CondTree ConfVar [Dependency] a -> FlaggedDeps PN convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns 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 $ L.map (\d -> D.Simple (convLibDep dr d) comp) (mapMaybe (filterIPNs ipns) ds) -- unconditional package dependencies ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (PD.allExtensions bi) -- unconditional extension dependencies ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (PD.allLanguages bi) -- unconditional language dependencies ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns 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) -> IPNs -> SolveExecutables -> CondBranch ConfVar [Dependency] a -> FlaggedDeps PN convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c' t' mf') = go c' (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes t') (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns 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 (Flag 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 library to a solver-specific dependency. convLibDep :: DependencyReason PN -> Dependency -> LDep PN convLibDep dr (Dependency pn vr) = LDep dr $ Dep (PkgComponent pn ExposedLib) (Constrained vr) -- | 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 = L.map (\d -> D.Simple (convLibDep (DependencyReason pn M.empty S.empty) d) ComponentSetup) (PD.setupDepends nfo) cabal-install-2.4.0.0/Distribution/Solver/Modular/LabeledGraph.hs0000644000000000000000000000716500000000000022723 0ustar0000000000000000-- | Wrapper around Data.Graph with support for edge labels {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.LabeledGraph ( -- * Graphs Graph , Vertex -- ** Building graphs , graphFromEdges , graphFromEdges' , buildG , transposeG -- ** Graph properties , vertices , edges -- ** Operations on the underlying unlabeled graph , forgetLabels , topSort ) where import Data.Array import Data.Graph (Vertex, Bounds) import Data.List (sortBy) import Data.Maybe (mapMaybe) import qualified Data.Graph as G {------------------------------------------------------------------------------- Types -------------------------------------------------------------------------------} type Graph e = Array Vertex [(e, Vertex)] type Edge e = (Vertex, e, Vertex) {------------------------------------------------------------------------------- Building graphs -------------------------------------------------------------------------------} -- | Construct an edge-labeled graph -- -- This is a simple adaptation of the definition in Data.Graph graphFromEdges :: forall key node edge. Ord key => [ (node, key, [(edge, key)]) ] -> ( Graph edge , Vertex -> (node, key, [(edge, key)]) , key -> Maybe Vertex ) graphFromEdges edges0 = (graph, \v -> vertex_map ! v, key_vertex) where max_v = length edges0 - 1 bounds0 = (0, max_v) :: (Vertex, Vertex) sorted_edges = sortBy lt edges0 edges1 = 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Linking.hs0000644000000000000000000005076000000000000022003 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} 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.Function (on) import Data.Map ((!)) import Data.Set (Set) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Traversable as T import Distribution.Client.Utils.Assertion import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import Distribution.Types.GenericPackageDescription (unFlagName) {------------------------------------------------------------------------------- Validation Validation of links is a separate pass that's performed after normal validation. Validation of links checks that if the tree indicates that a package is linked, then everything underneath that choice really matches the package we have linked to. This is interesting because it isn't unidirectional. Consider that we've chosen a.foo to be version 1 and later decide that b.foo should link to a.foo. Now foo depends on bar. Because a.foo and b.foo are linked, it's required that a.bar and b.bar are also linked. However, it's not required that we actually choose a.bar before b.bar. Goal choice order is relatively free. It's possible that we choose a.bar first, but also possible that we choose b.bar first. In both cases, we have to recognize that we have freedom of choice for the first of the two, but no freedom of choice for the second. This is what LinkGroups are all about. Using LinkGroup, we can record (in the situation above) that a.bar and b.bar need to be linked even if we haven't chosen either of them yet. -------------------------------------------------------------------------------} data ValidateState = VS { vsIndex :: Index , vsLinks :: Map QPN LinkGroup , vsFlags :: FAssignment , vsStanzas :: SAssignment , vsQualifyOptions :: QualifyOptions -- 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` dependencyReasonToCS) 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 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) cabal-install-2.4.0.0/Distribution/Solver/Modular/Log.hs0000644000000000000000000000413300000000000021122 0ustar0000000000000000module Distribution.Solver.Modular.Log ( logToProgress , 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 qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.RetryLog import Distribution.Verbosity -- | Information about a dependency solver failure. data SolverFailure = ExhaustiveSearch ConflictSet ConflictMap | BackjumpLimitReached -- | Postprocesses a log file. When the dependency solver fails to find a -- solution, the log ends with a SolverFailure and a message describing the -- failure. This function discards all log messages and avoids calling -- 'showMessages' if the log isn't needed (specified by 'keepLog'), for -- efficiency. logToProgress :: Bool -> Verbosity -> Maybe Int -> RetryLog Message SolverFailure a -> Progress String (SolverFailure, String) a logToProgress keepLog verbosity mbj lg = if keepLog then showMessages progress else foldProgress (const id) Fail Done progress where progress = -- Convert the RetryLog to a Progress (with toProgress) as late as -- possible, to take advantage of efficient updates at failures. toProgress $ mapFailure (\failure -> (failure, finalErrorMsg failure)) lg finalErrorMsg :: SolverFailure -> String finalErrorMsg (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 where showCS = if verbosity > normal then CS.showCSWithFrequency else CS.showCSSortedByFrequency finalErrorMsg BackjumpLimitReached = "Backjump limit reached (" ++ currlimit mbj ++ "change with --max-backjumps or try to run with --reorder-goals).\n" where currlimit (Just n) = "currently " ++ show n ++ ", " currlimit Nothing = "" cabal-install-2.4.0.0/Distribution/Solver/Modular/Message.hs0000644000000000000000000002142300000000000021766 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Distribution.Solver.Modular.Message ( Message(..), showMessages ) where import qualified Data.List as L import Prelude hiding (pi) import Distribution.Text -- from Cabal import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree ( FailReason(..), POption(..), ConflictingDep(..) ) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress 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) | 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 (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)) ms@(Step (Failure _c Backjump) _)) = (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) = (atLevel l $ showPackageGoal qpn gr) $ (atLevel l $ showFailure c fr) (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 (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) -- 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 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 " ++ display ext ++ ")" showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ display lang ++ ")" showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ display pn ++ display 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 _ (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 _ (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 _ Shadowed = " (shadowed by another installed package with same version)" showFR _ Broken = " (package is broken)" showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ display vr ++ ")" showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" showFR _ ManualFlag = " (manual flag can only be changed explicitly)" showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" showFR _ MultipleInstances = " (multiple instances)" showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ display 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 = "library" 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 -> "" 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/PSQ.hs0000644000000000000000000001011200000000000021036 0ustar0000000000000000{-# 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) cabal-install-2.4.0.0/Distribution/Solver/Modular/Package.hs0000644000000000000000000000615000000000000021735 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Modular.Package ( I(..) , Loc(..) , PackageId , PackageIdentifier(..) , PackageName, mkPackageName, unPackageName , PkgconfigName, mkPkgconfigName, unPkgconfigName , PI(..) , PN , QPV , instI , makeIndependent , primaryPP , setupPP , showI , showPI , unPN ) where import Data.List as L import Distribution.Package -- from Cabal import Distribution.Text (display) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath -- | A package name. type PN = PackageName -- | Unpacking a package name. unPN :: PN -> String unPN = unPackageName -- | Package version. A package name plus a version number. type PV = PackageId -- | Qualified package version. type QPV = Qualified PV -- | Package id. Currently just a black-box string. type PId = UnitId -- | Location. Info about whether a package is installed or not, and where -- exactly it is located. For installed packages, uniquely identifies the -- package instance via its 'PId'. -- -- TODO: More information is needed about the repo. data Loc = Inst PId | InRepo deriving (Eq, Ord, Show) -- | Instance. A version number and a location. data I = I Ver Loc deriving (Eq, Ord, Show) -- | String representation of an instance. showI :: I -> String showI (I v InRepo) = showVer v showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid where -- A hack to extract the beginning of the package ABI hash shortId = snip (splitAt 4) (++ "...") . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':) . display snip p f xs = case p xs of (ys, zs) -> (if L.null zs then id else f) ys -- | Package instance. A package name and an instance. data PI qpn = PI qpn I deriving (Eq, Ord, Show, Functor) -- | String representation of a package instance. showPI :: PI QPN -> String showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i instI :: I -> Bool instI (I _ (Inst _)) = True instI _ = False -- | Is the package in the primary group of packages. This is used to -- determine (1) if we should try to establish stanza preferences -- for this goal, and (2) whether or not a user specified @--constraint@ -- should apply to this dependency (grep 'primaryPP' to see the -- use sites). In particular this does not include packages pulled in -- as setup deps. -- primaryPP :: PackagePath -> Bool primaryPP (PackagePath _ns q) = go q where go QualToplevel = True go (QualBase _) = True go (QualSetup _) = False go (QualExe _ _) = False -- | Is the package a dependency of a setup script. This is used to -- establish whether or not certain constraints should apply to this -- dependency (grep 'setupPP' to see the use sites). -- setupPP :: PackagePath -> Bool setupPP (PackagePath _ns (QualSetup _)) = True setupPP (PackagePath _ns _) = False -- | 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Preference.hs0000644000000000000000000005034200000000000022462 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | Reordering or pruning the tree in order to prefer or make certain choices. module Distribution.Solver.Modular.Preference ( avoidReinstalls , deferSetupChoices , deferWeakFlagChoices , enforceManualFlags , enforcePackageConstraints , enforceSingleInstanceRestriction , firstGoal , preferBaseGoalChoice , preferLinked , preferPackagePreferences , preferReallyEasyGoalChoices , requireInstalled , sortGoals , pruneAfterFirstSuccess ) where import Prelude () import Distribution.Solver.Compat.Prelude import Data.Function (on) import qualified Data.List as L import qualified Data.Map as M import Control.Monad.Reader hiding (sequence) import Data.Traversable (sequence) import Distribution.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 -- | 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 <$> sequence (W.mapWithKey (goP qpn) cs) go _otherwise = innM _otherwise -- The check proper goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c) goP qpn@(Q _ pn) (POption i linkedTo) r = do let inst = PI pn i env <- ask case (linkedTo, M.lookup inst env) of (Just _, _) -> -- For linked nodes we don't check anything r (Nothing, Nothing) -> -- Not linked, not already used local (M.insert inst qpn) r (Nothing, Just qpn') -> do -- Not linked, already used. This is an error return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances cabal-install-2.4.0.0/Distribution/Solver/Modular/RetryLog.hs0000644000000000000000000000462100000000000022152 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} module Distribution.Solver.Modular.RetryLog ( RetryLog , toProgress , fromProgress , mapFailure , retry , failWith , succeedWith , continueWith , tryWith ) where import Distribution.Solver.Modular.Message import Distribution.Solver.Types.Progress -- | 'Progress' as a difference list that allows efficient appends at failures. newtype RetryLog step fail done = RetryLog { unRetryLog :: forall fail2 . (fail -> Progress step fail2 done) -> Progress step fail2 done } -- | /O(1)/. Convert a 'RetryLog' to a 'Progress'. toProgress :: RetryLog step fail done -> Progress step fail done toProgress (RetryLog f) = f Fail -- | /O(N)/. Convert a 'Progress' to a 'RetryLog'. fromProgress :: Progress step fail done -> RetryLog step fail done fromProgress l = RetryLog $ \f -> go f l where go :: (fail1 -> Progress step fail2 done) -> Progress step fail1 done -> Progress step fail2 done go _ (Done d) = Done d go f (Fail failure) = f failure go f (Step m ms) = Step m (go f ms) -- | /O(1)/. Apply a function to the failure value in a log. mapFailure :: (fail1 -> fail2) -> RetryLog step fail1 done -> RetryLog step fail2 done mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure) -- | /O(1)/. If the first log leads to failure, continue with the second. retry :: RetryLog step fail1 done -> (fail1 -> RetryLog step fail2 done) -> RetryLog step fail2 done retry (RetryLog f) g = RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog -- | /O(1)/. Create a log with one message before a failure. failWith :: step -> fail -> RetryLog step fail done failWith m failure = RetryLog $ \f -> Step m (f failure) -- | /O(1)/. Create a log with one message before a success. succeedWith :: step -> done -> RetryLog step fail done succeedWith m d = RetryLog $ const $ Step m (Done d) -- | /O(1)/. Prepend a message to a log. continueWith :: step -> RetryLog step fail done -> RetryLog step fail done continueWith m (RetryLog f) = RetryLog $ Step m . f -- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert -- 'Leave' before the failure if the log fails. tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done tryWith m f = RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave)) cabal-install-2.4.0.0/Distribution/Solver/Modular/Solver.hs0000644000000000000000000002367200000000000021664 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef DEBUG_TRACETREE {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #endif module Distribution.Solver.Modular.Solver ( SolverConfig(..) , solve , PruneAfterFirstSuccess(..) ) where import Data.Map as M import Data.List as L import 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.Text as T import Debug.Trace.Tree (gtraceJson) import Debug.Trace.Tree.Simple import Debug.Trace.Tree.Generic import Debug.Trace.Tree.Assoc (Assoc(..)) #endif -- | Various options for the modular solver. data SolverConfig = SolverConfig { reorderGoals :: ReorderGoals, countConflicts :: CountConflicts, independentGoals :: IndependentGoals, avoidReinstalls :: AvoidReinstalls, shadowPkgs :: ShadowPkgs, strongFlags :: StrongFlags, allowBootLibInstalls :: AllowBootLibInstalls, maxBackjumps :: Maybe Int, enableBackjumping :: EnableBackjumping, solveExecutables :: SolveExecutables, goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), solverVerbosity :: Verbosity, 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 -> Map PN [LabeledPackageConstraint] -- ^ global constraints -> 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) (countConflicts sc) 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)) buildPhase = traceTree "build.json" id $ buildTree idx (independentGoals sc) (S.toList userGoals) -- packages that can never be installed or upgraded -- If you change this enumeration, make sure to update the list in -- "Distribution.Client.Dependency" as well nonInstallable :: [PackageName] nonInstallable = L.map mkPackageName [ "base" , "ghc-prim" , "integer-gmp" , "integer-simple" , "template-haskell" ] -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which -- prefers (keeps) goals only if the have 0 or 1 enabled choice. -- -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes -- to just a single option. This was a way to work around a space leak that was -- unnecessary and is now fixed, so we no longer do it. -- -- If --count-conflicts is active, it will then choose among the remaining goals -- the one that has been responsible for the most conflicts so far. -- -- Otherwise, we simply choose the first remaining goal. -- goalChoiceHeuristics | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices | otherwise = id {- P.firstGoal -} -- | Dump solver tree to a file (in debugging mode) -- -- This only does something if the @debug-tracetree@ configure argument was -- given; otherwise this is just the identity function. traceTree :: #ifdef DEBUG_TRACETREE GSimpleTree a => #endif FilePath -- ^ Output file -> (a -> a) -- ^ Function to summarize the tree before dumping -> a -> a #ifdef DEBUG_TRACETREE traceTree = gtraceJson #else traceTree _ _ = id #endif #ifdef DEBUG_TRACETREE instance GSimpleTree (Tree d c) where fromGeneric = go where go :: Tree d c -> SimpleTree go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq go (Done _rdm _s) = Node "D" $ Assoc [] go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] psqToList :: W.WeightedPSQ w k v -> [(k, v)] psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList -- Show package choice goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) -- Show flag or stanza choice goFS :: Bool -> Tree d c -> (String, SimpleTree) goFS val subtree = (show val, go subtree) -- Show goal choice goG :: Goal QPN -> Tree d c -> (String, SimpleTree) goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) -- Variation on 'showGR' that produces shorter strings -- (Actually, QGoalReason records more info than necessary: we only need -- to know the variable that introduced the goal, not the value assigned -- to that variable) shortGR :: QGoalReason -> String shortGR UserGoal = "user" shortGR (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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Tree.hs0000644000000000000000000002034300000000000021301 0ustar0000000000000000{-# 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 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 VR | NewPackageDoesNotMatchExistingConstraint ConflictingDep | ConflictingConstraints ConflictingDep ConflictingDep | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) | PackageRequiresMissingComponent QPN ExposedComponent | PackageRequiresUnbuildableComponent QPN ExposedComponent | CannotInstall | CannotReinstall | Shadowed | Broken | 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Validate.hs0000644000000000000000000006413300000000000022140 0ustar0000000000000000{-# 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.Function (on) import Data.List as L import Data.Set as S import Data.Traversable import Prelude hiding (sequence) 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) #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 the current choice is -- a new active constraint, fixing the choice. -- -- If a test fails, we have detected an inconsistent state. We can -- disable the current subtree and do not have to traverse it any further. -- -- We need a good way to represent the current state, i.e., the current -- set of active constraints. Since the main situation where we have to -- search in it is (1), it seems best to store the state by package: for -- every package, we store which versions are still allowed. If for any -- package, we have inconsistent active constraints, we can also stop. -- This is a particular way to read task (2): -- -- (2, weak) We only check if the new constraints are consistent with -- the choices we've already made, and add them to the active set. -- -- (2, strong) We check if the new constraints are consistent with the -- choices we've already made, and the constraints we already have. -- -- It currently seems as if we're implementing the weak variant. However, -- when used together with 'preferEasyGoalChoices', we will find an -- inconsistent state in the very next step. -- -- What do we do about flags? -- -- Like for packages, we store the flag choices we have already made. -- Now, regarding (1), we only have to test whether we've decided the -- current flag before. Regarding (2), the interesting bit is in discovering -- the new active constraints. To this end, we look up the constraints for -- the package the flag belongs to, and traverse its flagged dependencies. -- Wherever we find the flag in question, we start recording dependencies -- underneath as new active dependencies. If we encounter other flags, we -- check if we've chosen them already and either proceed or stop. -- | The state needed during validation. data ValidateState = VS { supportedExt :: Extension -> Bool, supportedLang :: Language -> Bool, presentPkgs :: PkgconfigName -> VR -> Bool, index :: Index, -- Saved, 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 buildable. availableComponents :: Map QPN (Map ExposedComponent IsBuildable), -- 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 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 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 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 buildable. checkComponentsInNewPackage :: ComponentDependencyReasons -> QPN -> Map ExposedComponent IsBuildable -> Either Conflict () checkComponentsInNewPackage required qpn providedComps = case M.toList $ deleteKeys (M.keys providedComps) required of (missingComp, dr) : _ -> Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent [] -> case M.toList $ deleteKeys buildableProvidedComps required of (unbuildableComp, dr) : _ -> Left $ mkConflict unbuildableComp dr NewPackageHasUnbuildableRequiredComponent [] -> Right () where mkConflict :: ExposedComponent -> DependencyReason QPN -> (ExposedComponent -> DependencyReason QPN -> FailReason) -> Conflict mkConflict comp dr mkFailure = (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure comp dr) buildableProvidedComps :: [ExposedComponent] buildableProvidedComps = [comp | (comp, IsBuildable True) <- M.toList providedComps] 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 -> VR -> 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 (dependencyReasonToCS dr, UnsupportedExtension ext) extendSingle a (LDep dr (Lang lang)) = if langSupported lang then Right a else Left (dependencyReasonToCS dr, UnsupportedLanguage lang) extendSingle a (LDep dr (Pkg pn vr)) = if pkgPresent pn vr then Right a else Left (dependencyReasonToCS 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 -- 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) (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` dependencyReasonToCS) 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 ( (CS.union `on` dependencyReasonToCS) vs1 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 ( (CS.union `on` dependencyReasonToCS) vs1 vs2 , ( 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)]) -- | 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 or unbuildable in a previously chosen -- packages. extendRequiredComponents :: Map QPN (Map ExposedComponent IsBuildable) -> Map QPN ComponentDependencyReasons -> [LDep QPN] -> Either Conflict (Map QPN ComponentDependencyReasons) extendRequiredComponents 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 in -- Only check for the existence of the component if its package has -- already been chosen. case M.lookup qpn available of Just comps | M.notMember comp comps -> Left $ mkConflict qpn comp dr PackageRequiresMissingComponent | L.notElem comp (buildableComps comps) -> Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent _ -> Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required extendSingle required _ = Right required mkConflict :: QPN -> ExposedComponent -> DependencyReason QPN -> (QPN -> ExposedComponent -> FailReason) -> Conflict mkConflict qpn comp dr mkFailure = (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure qpn comp) buildableComps :: Map comp IsBuildable -> [comp] buildableComps comps = [comp | (comp, IsBuildable True) <- M.toList comps] -- | 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 } cabal-install-2.4.0.0/Distribution/Solver/Modular/Var.hs0000644000000000000000000000203300000000000021126 0ustar0000000000000000{-# 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/Version.hs0000644000000000000000000000223700000000000022031 0ustar0000000000000000module Distribution.Solver.Modular.Version ( Ver , VR , anyVR , checkVR , eqVR , showVer , showVR , simplifyVR , (.&&.) , (.||.) ) where import qualified Distribution.Version as CV -- from Cabal import Distribution.Text -- from Cabal -- | Preliminary type for versions. type Ver = CV.Version -- | String representation of a version. showVer :: Ver -> String showVer = display -- | Version range. Consists of a lower and upper bound. type VR = CV.VersionRange -- | String representation of a version range. showVR :: VR -> String showVR = display -- | Unconstrained version range. anyVR :: VR anyVR = CV.anyVersion -- | Version range fixing a single version. eqVR :: Ver -> VR eqVR = CV.thisVersion -- | Intersect two version ranges. (.&&.) :: VR -> VR -> VR 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 cabal-install-2.4.0.0/Distribution/Solver/Modular/WeightedPSQ.hs0000644000000000000000000000637100000000000022533 0ustar0000000000000000{-# 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 cabal-install-2.4.0.0/Distribution/Solver/Types/0000755000000000000000000000000000000000000017545 5ustar0000000000000000cabal-install-2.4.0.0/Distribution/Solver/Types/ComponentDeps.hs0000644000000000000000000001442000000000000022660 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -- | Fine-grained package dependencies -- -- Like many others, this module is meant to be "double-imported": -- -- > import Distribution.Solver.Types.ComponentDeps ( -- > Component -- > , ComponentDep -- > , ComponentDeps -- > ) -- > import qualified Distribution.Solver.Types.ComponentDeps as CD module Distribution.Solver.Types.ComponentDeps ( -- * Fine-grained package dependencies Component(..) , componentNameToComponent , ComponentDep , ComponentDeps -- opaque -- ** Constructing ComponentDeps , empty , fromList , singleton , insert , zip , filterDeps , fromLibraryDeps , fromSetupDeps , fromInstalled -- ** Deconstructing ComponentDeps , toList , flatDeps , nonSetupDeps , libraryDeps , setupDeps , select ) where import Prelude () import Distribution.Types.UnqualComponentName import Distribution.Solver.Compat.Prelude hiding (empty,zip) import qualified Data.Map as Map import Data.Foldable (fold) import qualified Distribution.Types.ComponentName as CN {------------------------------------------------------------------------------- Types -------------------------------------------------------------------------------} -- | Component of a package. data Component = ComponentLib | ComponentSubLib UnqualComponentName | ComponentFLib UnqualComponentName | ComponentExe UnqualComponentName | ComponentTest UnqualComponentName | ComponentBench UnqualComponentName | ComponentSetup deriving (Show, Eq, Ord, Generic) instance Binary Component -- | Dependency for a single component. type ComponentDep a = (Component, a) -- | Fine-grained dependencies for a package. -- -- Typically used as @ComponentDeps [Dependency]@, to represent the list of -- dependencies for each named component within a package. -- newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } deriving (Show, Functor, Eq, Ord, Generic) instance Semigroup a => Monoid (ComponentDeps a) where mempty = ComponentDeps Map.empty mappend = (<>) instance Semigroup a => Semigroup (ComponentDeps a) where ComponentDeps d <> ComponentDeps d' = ComponentDeps (Map.unionWith (<>) d d') instance Foldable ComponentDeps where foldMap f = foldMap f . unComponentDeps instance Traversable ComponentDeps where traverse f = fmap ComponentDeps . traverse f . unComponentDeps instance Binary a => Binary (ComponentDeps a) componentNameToComponent :: CN.ComponentName -> Component componentNameToComponent (CN.CLibName) = ComponentLib componentNameToComponent (CN.CSubLibName s) = ComponentSubLib s componentNameToComponent (CN.CFLibName s) = ComponentFLib s componentNameToComponent (CN.CExeName s) = ComponentExe s componentNameToComponent (CN.CTestName s) = ComponentTest s componentNameToComponent (CN.CBenchName s) = ComponentBench s {------------------------------------------------------------------------------- Construction -------------------------------------------------------------------------------} empty :: ComponentDeps a empty = ComponentDeps $ Map.empty fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a fromList = ComponentDeps . Map.fromListWith mappend singleton :: Component -> a -> ComponentDeps a singleton comp = ComponentDeps . Map.singleton comp insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps where aux Nothing = Just a aux (Just a') = Just $ a `mappend` a' -- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' -- as the neutral element when a 'Component' is present only in one. zip :: (Monoid a, Monoid b) => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) {- TODO/FIXME: Once we can expect containers>=0.5, switch to the more efficient version below: zip (ComponentDeps d1) (ComponentDeps d2) = ComponentDeps $ Map.mergeWithKey (\_ a b -> Just (a,b)) (fmap (\a -> (a, mempty))) (fmap (\b -> (mempty, b))) d1 d2 -} zip (ComponentDeps d1) (ComponentDeps d2) = ComponentDeps $ Map.unionWith mappend (Map.map (\a -> (a, mempty)) d1) (Map.map (\b -> (mempty, b)) d2) -- | Keep only selected components (and their associated deps info). filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps -- | ComponentDeps containing library dependencies only fromLibraryDeps :: a -> ComponentDeps a fromLibraryDeps = singleton ComponentLib -- | ComponentDeps containing setup dependencies only. fromSetupDeps :: a -> ComponentDeps a fromSetupDeps = singleton ComponentSetup -- | ComponentDeps for installed packages. -- -- We assume that installed packages only record their library dependencies. fromInstalled :: a -> ComponentDeps a fromInstalled = fromLibraryDeps {------------------------------------------------------------------------------- Deconstruction -------------------------------------------------------------------------------} toList :: ComponentDeps a -> [ComponentDep a] toList = Map.toList . unComponentDeps -- | All dependencies of a package. -- -- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more -- obvious than a use of 'fold', and moreover this avoids introducing lots of -- @#ifdef@s for 7.10 just for the use of 'fold'. flatDeps :: Monoid a => ComponentDeps a -> a flatDeps = fold -- | All dependencies except the setup dependencies. -- -- Prior to the introduction of setup dependencies in version 1.24 this -- would have been _all_ dependencies. nonSetupDeps :: Monoid a => ComponentDeps a -> a nonSetupDeps = select (/= ComponentSetup) -- | Library dependencies proper only. (Includes dependencies -- of internal libraries.) libraryDeps :: Monoid a => ComponentDeps a -> a libraryDeps = select (\c -> case c of ComponentSubLib _ -> True ComponentLib -> True _ -> False) -- | Setup dependencies. setupDeps :: Monoid a => ComponentDeps a -> a setupDeps = select (== ComponentSetup) -- | Select dependencies satisfying a given predicate. select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a select p = foldMap snd . filter (p . fst) . toList cabal-install-2.4.0.0/Distribution/Solver/Types/ConstraintSource.hs0000644000000000000000000000613700000000000023415 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) , showConstraintSource ) where import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) -- | Source of a 'PackageConstraint'. data ConstraintSource = -- | Main config file, which is ~/.cabal/config by default. ConstraintSourceMainConfig FilePath -- | Local cabal.project file | ConstraintSourceProjectConfig FilePath -- | Sandbox config file, which is ./cabal.sandbox.config by default. | ConstraintSourceSandboxConfig FilePath -- | User config file, which is ./cabal.config by default. | ConstraintSourceUserConfig FilePath -- | Flag specified on the command line. | ConstraintSourceCommandlineFlag -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ -- implies @package==0.1.0.0@. | ConstraintSourceUserTarget -- | Internal requirement to use installed versions of packages like ghc-prim. | ConstraintSourceNonUpgradeablePackage -- | Internal requirement to use the add-source version of a package when that -- version is installed and the source is modified. | ConstraintSourceModifiedAddSourceDep -- | Internal constraint used by @cabal freeze@. | ConstraintSourceFreeze -- | Constraint specified by a config file, a command line flag, or a user -- target, when a more specific source is not known. | ConstraintSourceConfigFlagOrTarget -- | The source of the constraint is not specified. | ConstraintSourceUnknown -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a minimum lower bound on Cabal | ConstraintSetupCabalMinVersion -- | 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 -- | 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" cabal-install-2.4.0.0/Distribution/Solver/Types/DependencyResolver.hs0000644000000000000000000000275100000000000023706 0ustar0000000000000000module Distribution.Solver.Types.DependencyResolver ( DependencyResolver ) where import Data.Set (Set) import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) import Distribution.Solver.Types.PackagePreferences import Distribution.Solver.Types.PackageIndex ( PackageIndex ) import Distribution.Solver.Types.Progress import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SourcePackage import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import Distribution.Package ( PackageName ) import Distribution.Compiler ( CompilerInfo ) import Distribution.System ( Platform ) -- | A dependency resolver is a function that works out an installation plan -- given the set of installed and available packages and a set of deps to -- solve for. -- -- The reason for this interface is because there are dozens of approaches to -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. -- type DependencyResolver loc = Platform -> CompilerInfo -> InstalledPackageIndex -> PackageIndex (SourcePackage loc) -> PkgConfigDb -> (PackageName -> PackagePreferences) -> [LabeledPackageConstraint] -> Set PackageName -> Progress String String [ResolverPackage loc] cabal-install-2.4.0.0/Distribution/Solver/Types/Flag.hs0000644000000000000000000000017700000000000020757 0ustar0000000000000000module Distribution.Solver.Types.Flag ( FlagType(..) ) where data FlagType = Manual | Automatic deriving (Eq, Show) cabal-install-2.4.0.0/Distribution/Solver/Types/InstSolverPackage.hs0000644000000000000000000000264100000000000023470 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.InstSolverPackage ( InstSolverPackage(..) ) where import Distribution.Compat.Binary (Binary(..)) import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.SolverId import Distribution.Types.MungedPackageId import Distribution.Types.PackageId import Distribution.Types.PackageName import Distribution.Types.MungedPackageName import Distribution.InstalledPackageInfo (InstalledPackageInfo) import GHC.Generics (Generic) -- | An 'InstSolverPackage' is a pre-existing installed pacakge -- specified by the dependency solver. data InstSolverPackage = InstSolverPackage { instSolverPkgIPI :: InstalledPackageInfo, instSolverPkgLibDeps :: ComponentDeps [SolverId], instSolverPkgExeDeps :: ComponentDeps [SolverId] } deriving (Eq, Show, Generic) instance Binary InstSolverPackage instance Package InstSolverPackage where packageId i = -- HACK! See Note [Index conversion with internal libraries] let MungedPackageId mpn v = mungedId i in PackageIdentifier (mkPackageName (unMungedPackageName mpn)) v instance HasMungedPackageId InstSolverPackage where mungedId = mungedId . instSolverPkgIPI instance HasUnitId InstSolverPackage where installedUnitId = installedUnitId . instSolverPkgIPI cabal-install-2.4.0.0/Distribution/Solver/Types/InstalledPreference.hs0000644000000000000000000000041000000000000024012 0ustar0000000000000000module Distribution.Solver.Types.InstalledPreference ( InstalledPreference(..), ) where -- | Whether we prefer an installed version of a package or simply the latest -- version. -- data InstalledPreference = PreferInstalled | PreferLatest deriving Show cabal-install-2.4.0.0/Distribution/Solver/Types/LabeledPackageConstraint.hs0000644000000000000000000000101100000000000024743 0ustar0000000000000000module 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 cabal-install-2.4.0.0/Distribution/Solver/Types/OptionalStanza.hs0000644000000000000000000000220300000000000023044 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} module Distribution.Solver.Types.OptionalStanza ( OptionalStanza(..) , showStanza , enableStanzas ) where import GHC.Generics (Generic) import Data.Typeable import Distribution.Compat.Binary (Binary(..)) import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..), defaultComponentRequestedSpec) import Data.List (foldl') data OptionalStanza = TestStanzas | BenchStanzas deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) -- | String representation of an OptionalStanza. showStanza :: OptionalStanza -> String showStanza TestStanzas = "test" showStanza BenchStanzas = "bench" -- | Convert a list of 'OptionalStanza' into the corresponding -- 'ComponentRequestedSpec' which records what components are enabled. enableStanzas :: [OptionalStanza] -> ComponentRequestedSpec enableStanzas = foldl' addStanza defaultComponentRequestedSpec where addStanza enabled TestStanzas = enabled { testsRequested = True } addStanza enabled BenchStanzas = enabled { benchmarksRequested = True } instance Binary OptionalStanza cabal-install-2.4.0.0/Distribution/Solver/Types/PackageConstraint.hs0000644000000000000000000001450700000000000023510 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Per-package constraints. Package constraints must be respected by the -- solver. Multiple constraints for each package can be given, though obviously -- it is possible to construct conflicting constraints (eg impossible version -- range or inconsistent flag assignment). -- module Distribution.Solver.Types.PackageConstraint ( ConstraintScope(..), scopeToplevel, scopeToPackageName, constraintScopeMatches, PackageProperty(..), dispPackageProperty, PackageConstraint(..), dispPackageConstraint, showPackageConstraint, packageConstraintToDependency ) where import Distribution.Compat.Binary (Binary(..)) import Distribution.Package (PackageName) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) import Distribution.Types.Dependency (Dependency(..)) import Distribution.Version (VersionRange, simplifyVersionRange) import Distribution.Solver.Compat.Prelude ((<<>>)) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import Distribution.Text (disp, flatStyle) import GHC.Generics (Generic) import Text.PrettyPrint ((<+>)) import qualified Text.PrettyPrint as Disp -- | Determines to what packages and in what contexts a -- constraint applies. data ConstraintScope -- | 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) = disp pn <<>> Disp.text "." <<>> disp pn dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> disp pn dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> disp pn dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> disp pn -- | A package property is a logical predicate on packages. data PackageProperty = PackagePropertyVersion VersionRange | PackagePropertyInstalled | PackagePropertySource | PackagePropertyFlags FlagAssignment | PackagePropertyStanzas [OptionalStanza] deriving (Eq, Show, Generic) instance Binary PackageProperty -- | Pretty-prints a package property. dispPackageProperty :: PackageProperty -> Disp.Doc dispPackageProperty (PackagePropertyVersion verrange) = disp verrange dispPackageProperty PackagePropertyInstalled = Disp.text "installed" dispPackageProperty PackagePropertySource = Disp.text "source" dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags dispPackageProperty (PackagePropertyStanzas stanzas) = Disp.hsep $ map (Disp.text . showStanza) stanzas -- | A package constraint consists of a scope plus a property -- that must hold for all packages within that scope. data PackageConstraint = PackageConstraint ConstraintScope PackageProperty deriving (Eq, Show) -- | Pretty-prints a package constraint. dispPackageConstraint :: PackageConstraint -> Disp.Doc dispPackageConstraint (PackageConstraint scope prop) = dispConstraintScope scope <+> dispPackageProperty prop -- | Alternative textual representation of a package constraint -- for debugging purposes (slightly more verbose than that -- produced by 'dispPackageConstraint'). -- showPackageConstraint :: PackageConstraint -> String showPackageConstraint pc@(PackageConstraint scope prop) = Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 where pc2 = case prop of PackagePropertyVersion vr -> PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr) _ -> pc postprocess = case prop of PackagePropertyFlags _ -> (Disp.text "flags" <+>) PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) _ -> id -- | Lossily convert a 'PackageConstraint' to a 'Dependency'. packageConstraintToDependency :: PackageConstraint -> Maybe Dependency packageConstraintToDependency (PackageConstraint scope prop) = toDep prop where toDep (PackagePropertyVersion vr) = Just $ Dependency (scopeToPackageName scope) vr toDep (PackagePropertyInstalled) = Nothing toDep (PackagePropertySource) = Nothing toDep (PackagePropertyFlags _) = Nothing toDep (PackagePropertyStanzas _) = Nothing cabal-install-2.4.0.0/Distribution/Solver/Types/PackageFixedDeps.hs0000644000000000000000000000172300000000000023233 0ustar0000000000000000module 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) cabal-install-2.4.0.0/Distribution/Solver/Types/PackageIndex.hs0000644000000000000000000002360200000000000022427 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Solver.Types.PackageIndex -- Copyright : (c) David Himmelstrup 2005, -- Bjorn Bringert 2007, -- Duncan Coutts 2008 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- An index of packages. -- module Distribution.Solver.Types.PackageIndex ( -- * Package index data type PackageIndex, -- * Creating an index fromList, -- * Updates merge, insert, deletePackageName, deletePackageId, deleteDependency, -- * Queries -- ** Precise lookups elemByPackageId, elemByPackageName, lookupPackageName, lookupPackageId, lookupDependency, -- ** Case-insensitive searches searchByName, SearchResult(..), searchByNameSubstring, -- ** Bulk queries allPackages, allPackagesByName, ) where import Prelude () import Distribution.Solver.Compat.Prelude hiding (lookup) import Control.Exception (assert) import qualified Data.Map as Map import Data.List (groupBy, isInfixOf) import Distribution.Package ( PackageName, unPackageName, PackageIdentifier(..) , Package(..), packageName, packageVersion ) import Distribution.Types.Dependency import Distribution.Version ( withinRange ) import Distribution.Simple.Utils ( lowercase, comparing ) -- | The collection of information about packages from one or more 'PackageDB's. -- -- It can be searched efficiently by package name and version. -- newtype PackageIndex pkg = PackageIndex -- This index package names to all the package records matching that package -- name case-sensitively. It includes all versions. -- -- This allows us to find all versions satisfying a dependency. -- Most queries are a map lookup followed by a linear scan of the bucket. -- (Map PackageName [pkg]) deriving (Eq, Show, Read, Functor, Generic) --FIXME: the Functor instance here relies on no package id changes instance Package pkg => Semigroup (PackageIndex pkg) where (<>) = merge instance Package pkg => Monoid (PackageIndex pkg) where mempty = PackageIndex Map.empty mappend = (<>) --save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = foldr1 mappend xs instance Binary pkg => Binary (PackageIndex pkg) invariant :: Package pkg => PackageIndex pkg -> Bool invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) where goodBucket _ [] = False goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 where check pkgid [] = packageName pkgid == name check pkgid (pkg':pkgs) = packageName pkgid == name && pkgid < pkgid' && check pkgid' pkgs where pkgid' = packageId pkg' -- -- * Internal helpers -- mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg mkPackageIndex index = assert (invariant (PackageIndex index)) (PackageIndex index) internalError :: String -> a internalError name = error ("PackageIndex." ++ name ++ ": internal error") -- | Lookup a name in the index to get all packages that match that name -- case-sensitively. -- lookup :: PackageIndex pkg -> PackageName -> [pkg] lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m -- -- * Construction -- -- | Build an index out of a bunch of packages. -- -- If there are duplicates, later ones mask earlier ones. -- fromList :: Package pkg => [pkg] -> PackageIndex pkg fromList pkgs = mkPackageIndex . Map.map fixBucket . Map.fromListWith (++) $ [ (packageName pkg, [pkg]) | pkg <- pkgs ] where fixBucket = -- out of groups of duplicates, later ones mask earlier ones -- but Map.fromListWith (++) constructs groups in reverse order map head -- Eq instance for PackageIdentifier is wrong, so use Ord: . groupBy (\a b -> EQ == comparing packageId a b) -- relies on sortBy being a stable sort so we -- can pick consistently among duplicates . sortBy (comparing packageId) -- -- * Updates -- -- | Merge two indexes. -- -- Packages from the second mask packages of the same exact name -- (case-sensitively) from the first. -- merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg merge i1@(PackageIndex m1) i2@(PackageIndex m2) = assert (invariant i1 && invariant i2) $ mkPackageIndex (Map.unionWith mergeBuckets m1 m2) -- | Elements in the second list mask those in the first. mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] mergeBuckets [] ys = ys mergeBuckets xs [] = xs mergeBuckets xs@(x:xs') ys@(y:ys') = case packageId x `compare` packageId y of GT -> y : mergeBuckets xs ys' EQ -> y : mergeBuckets xs' ys' LT -> x : mergeBuckets xs' ys -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. -- insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg insert pkg (PackageIndex index) = mkPackageIndex $ Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index where pkgid = packageId pkg insertNoDup [] = [pkg] insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of LT -> pkg : pkgs EQ -> pkg : pkgs' GT -> pkg' : insertNoDup pkgs' -- | Internal delete helper. -- delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg delete name p (PackageIndex index) = mkPackageIndex $ Map.update filterBucket name index where filterBucket = deleteEmptyBucket . filter (not . p) deleteEmptyBucket [] = Nothing deleteEmptyBucket remaining = Just remaining -- | Removes a single package from the index. -- deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg deletePackageId pkgid = delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) -- | Removes all packages with this (case-sensitive) name from the index. -- deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg deletePackageName name = delete name (\pkg -> packageName pkg == name) -- | Removes all packages satisfying this dependency from the index. -- deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg deleteDependency (Dependency name verstionRange) = delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) -- -- * Bulk queries -- -- | Get all the packages from the index. -- allPackages :: PackageIndex pkg -> [pkg] allPackages (PackageIndex m) = concat (Map.elems m) -- | Get all the packages from the index. -- -- They are grouped by package name, case-sensitively. -- allPackagesByName :: PackageIndex pkg -> [[pkg]] allPackagesByName (PackageIndex m) = Map.elems m -- -- * Lookups -- elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool elemByPackageId index = isJust . lookupPackageId index elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool elemByPackageName index = not . null . lookupPackageName index -- | Does a lookup by package id (name & version). -- -- Since multiple package DBs mask each other case-sensitively by package name, -- then we get back at most one package. -- lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg lookupPackageId index pkgid = case [ pkg | pkg <- lookup index (packageName pkgid) , packageId pkg == pkgid ] of [] -> Nothing [pkg] -> Just pkg _ -> internalError "lookupPackageIdentifier" -- | Does a case-sensitive search by package name. -- lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] lookupPackageName index name = [ pkg | pkg <- lookup index name , packageName pkg == name ] -- | Does a case-sensitive search by package name and a range of versions. -- -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. -- lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] lookupDependency index (Dependency name versionRange) = [ pkg | pkg <- lookup index name , packageName pkg == name , packageVersion pkg `withinRange` versionRange ] -- -- * Case insensitive name lookups -- -- | Does a case-insensitive search by package name. -- -- If there is only one package that compares case-insensitively to this name -- then the search is unambiguous and we get back all versions of that package. -- If several match case-insensitively but one matches exactly then it is also -- unambiguous. -- -- If however several match case-insensitively and none match exactly then we -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. -- searchByName :: PackageIndex pkg -> String -> [(PackageName, [pkg])] searchByName (PackageIndex m) name = [ pkgs | pkgs@(pname,_) <- Map.toList m , lowercase (unPackageName pname) == lname ] where lname = lowercase name data SearchResult a = None | Unambiguous a | Ambiguous [a] -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name. -- searchByNameSubstring :: PackageIndex pkg -> String -> [(PackageName, [pkg])] searchByNameSubstring (PackageIndex m) searchterm = [ pkgs | pkgs@(pname, _) <- Map.toList m , lsearchterm `isInfixOf` lowercase (unPackageName pname) ] where lsearchterm = lowercase searchterm cabal-install-2.4.0.0/Distribution/Solver/Types/PackagePath.hs0000644000000000000000000000733100000000000022255 0ustar0000000000000000module Distribution.Solver.Types.PackagePath ( PackagePath(..) , Namespace(..) , Qualifier(..) , dispQualifier , Qualified(..) , QPN , dispQPN , showQPN ) where import Distribution.Package import Distribution.Text import qualified Text.PrettyPrint as Disp import Distribution.Solver.Compat.Prelude ((<<>>)) -- | A package path consists of a namespace and a package path inside that -- namespace. data PackagePath = PackagePath Namespace Qualifier deriving (Eq, Ord, Show) -- | Top-level namespace -- -- Package choices in different namespaces are considered completely independent -- by the solver. data Namespace = -- | The default namespace DefaultNamespace -- | 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) = disp i <<>> Disp.text "." -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = -- | Top-level dependency in this namespace QualToplevel -- | Any dependency on base is considered independent -- -- This makes it possible to have base shims. | QualBase PackageName -- | Setup dependency -- -- By rights setup dependencies ought to be nestable; after all, the setup -- dependencies of a package might themselves have setup dependencies, which -- are independent from everything else. However, this very quickly leads to -- infinite search trees in the solver. Therefore we limit ourselves to -- a single qualifier (within a given namespace). | QualSetup PackageName -- | If we depend on an executable from a package (via -- @build-tools@), we should solve for the dependencies of that -- package separately (since we're not going to actually try to -- link it.) We qualify for EACH package separately; e.g., -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on -- @pn2@ from package @pn1@. (If we tracked only @pn1@, that -- would require a consistent dependency resolution for all -- of the depended upon executables from a package; if we -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) | QualExe PackageName PackageName deriving (Eq, Ord, Show) -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. -- -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is -- there to make sure different dependencies on base are all independent. -- So we want to print something like @"A.base"@, where the @"A."@ part -- is the qualifier and @"base"@ is the actual dependency (which, for the -- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc dispQualifier QualToplevel = Disp.empty dispQualifier (QualSetup pn) = disp pn <<>> Disp.text ":setup." dispQualifier (QualExe pn pn2) = disp pn <<>> Disp.text ":" <<>> disp pn2 <<>> Disp.text ":exe." dispQualifier (QualBase pn) = disp pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a deriving (Eq, Ord, Show) -- | Qualified package name. type QPN = Qualified PackageName -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc dispQPN (Q (PackagePath ns qual) pn) = dispNamespace ns <<>> dispQualifier qual <<>> disp pn -- | String representation of a qualified package name. showQPN :: QPN -> String showQPN = Disp.renderStyle flatStyle . dispQPN cabal-install-2.4.0.0/Distribution/Solver/Types/PackagePreferences.hs0000644000000000000000000000177700000000000023632 0ustar0000000000000000module 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] cabal-install-2.4.0.0/Distribution/Solver/Types/PkgConfigDb.hs0000644000000000000000000001463100000000000022223 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Solver.Types.PkgConfigDb -- Copyright : (c) Iñaki García Etxebarria 2016 -- License : BSD-like -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Read the list of packages available to pkg-config. ----------------------------------------------------------------------------- module Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb , readPkgConfigDb , pkgConfigDbFromList , pkgConfigPkgIsPresent , pkgConfigDbPkgVersion , getPkgConfigDbDirs ) where import Prelude () import Distribution.Solver.Compat.Prelude import Control.Exception (IOException, handle) import qualified Data.Map as M import Data.Version (parseVersion) import Text.ParserCombinators.ReadP (readP_to_S) import System.FilePath (splitSearchPath) import Distribution.Package ( PkgconfigName, mkPkgconfigName ) import Distribution.Verbosity ( Verbosity ) import Distribution.Version ( Version, mkVersion', VersionRange, withinRange ) import Distribution.Compat.Environment ( lookupEnv ) import Distribution.Simple.Program ( ProgramDb, pkgConfigProgram, getProgramOutput, requireProgram ) import Distribution.Simple.Utils ( info ) -- | The list of packages installed in the system visible to -- @pkg-config@. This is an opaque datatype, to be constructed with -- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe Version)) -- ^ If an entry is `Nothing`, this means that the -- package seems to be present, but we don't know the -- exact version (because parsing of the version -- number failed). | NoPkgConfigDb -- ^ For when we could not run pkg-config successfully. deriving (Show, Generic, Typeable) instance Binary PkgConfigDb -- | Query pkg-config for the list of installed packages, together -- with their versions. Return a `PkgConfigDb` encapsulating this -- information. readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] -- The output of @pkg-config --list-all@ also includes a description -- for each package, which we do not need. let pkgNames = map (takeWhile (not . isSpace)) pkgList pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig ("--modversion" : pkgNames) (return . pkgConfigDbFromList . zip pkgNames) pkgVersions where -- For when pkg-config invocation fails (possibly because of a -- too long command line). ioErrorHandler :: IOException -> IO PkgConfigDb ioErrorHandler e = do info verbosity ("Failed to query pkg-config, Cabal will continue" ++ " without solving for pkg-config constraints: " ++ show e) return NoPkgConfigDb -- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs where convert :: (String, String) -> (PkgconfigName, Maybe Version) convert (n,vs) = (mkPkgconfigName n, case (reverse . readP_to_S parseVersion) vs of (v, "") : _ -> Just (mkVersion' v) _ -> Nothing -- Version not (fully) -- understood. ) -- | Check whether a given package range is satisfiable in the given -- @pkg-config@ database. pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> VersionRange -> Bool pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = case M.lookup pn db of Nothing -> False -- Package not present in the DB. Just Nothing -> True -- Package present, but version unknown. Just (Just v) -> withinRange v vr -- If we could not read the pkg-config database successfully we allow -- the check to succeed. The plan found by the solver may fail to be -- executed later on, but we have no grounds for rejecting the plan at -- this stage. pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True -- | Query the version of a package in the @pkg-config@ database. -- @Nothing@ indicates the package is not in the database, while -- @Just Nothing@ indicates that the package is in the database, -- but its version is not known. pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe Version) pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db -- NB: Since the solver allows solving to succeed if there is -- NoPkgConfigDb, we should report that we *guess* that there -- is a matching pkg-config configuration, but that we just -- don't know about it. pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing -- | Query pkg-config for the locations of pkg-config's package files. Use this -- to monitor for changes in the pkg-config DB. -- getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath] getPkgConfigDbDirs verbosity progdb = (++) <$> getEnvPath <*> getDefPath where -- According to @man pkg-config@: -- -- PKG_CONFIG_PATH -- A colon-separated (on Windows, semicolon-separated) list of directories -- to search for .pc files. The default directory will always be searched -- after searching the path -- getEnvPath = maybe [] parseSearchPath <$> lookupEnv "PKG_CONFIG_PATH" -- Again according to @man pkg-config@: -- -- pkg-config can be used to query itself for the default search path, -- version number and other information, for instance using: -- -- > pkg-config --variable pc_path pkg-config -- getDefPath = handle ioErrorHandler $ do (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb parseSearchPath <$> getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] parseSearchPath str = case lines str of [p] | not (null p) -> splitSearchPath p _ -> [] ioErrorHandler :: IOException -> IO [FilePath] ioErrorHandler _e = return [] cabal-install-2.4.0.0/Distribution/Solver/Types/Progress.hs0000644000000000000000000000327400000000000021713 0ustar0000000000000000module 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://ghc.haskell.org/trac/ghc/ticket/7436#comment:6. -- The derived functor instance caused a space leak in the solver. instance Functor (Progress step fail) where fmap f (Step s p) = Step s (fmap f p) fmap _ (Fail x) = Fail x fmap f (Done r) = Done (f r) -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two -- base cases, one for a final result and one for failure. -- -- Eg to convert into a simple 'Either' result use: -- -- > foldProgress (flip const) Left Right -- foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) -> Progress step fail done -> a foldProgress step fail done = fold where fold (Step s p) = step s (fold p) fold (Fail f) = fail f fold (Done r) = done r instance Monad (Progress step fail) where return = pure p >>= f = foldProgress Step Fail f p instance Applicative (Progress step fail) where pure a = Done a p <*> x = foldProgress Step Fail (flip fmap x) p instance Monoid fail => Alternative (Progress step fail) where empty = Fail mempty p <|> q = foldProgress Step (const q) Done p cabal-install-2.4.0.0/Distribution/Solver/Types/ResolverPackage.hs0000644000000000000000000000375400000000000023167 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.ResolverPackage ( ResolverPackage(..) , resolverPackageLibDeps , resolverPackageExeDeps ) where import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (IsNode(..)) import Distribution.Package (Package(..), HasUnitId(..)) import Distribution.Simple.Utils (ordNub) import GHC.Generics (Generic) -- | The dependency resolver picks either pre-existing installed packages -- or it picks source packages along with package configuration. -- -- This is like the 'InstallPlan.PlanPackage' but with fewer cases. -- data ResolverPackage loc = PreExisting InstSolverPackage | Configured (SolverPackage loc) deriving (Eq, Show, Generic) instance Binary loc => Binary (ResolverPackage loc) instance Package (ResolverPackage loc) where packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg instance IsNode (ResolverPackage loc) where type Key (ResolverPackage loc) = SolverId nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) nodeKey (Configured spkg) = PlannedId (packageId spkg) -- Use dependencies for ALL components nodeNeighbors pkg = ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ CD.flatDeps (resolverPackageExeDeps pkg) cabal-install-2.4.0.0/Distribution/Solver/Types/Settings.hs0000644000000000000000000000303100000000000021676 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Solver.Types.Settings ( ReorderGoals(..) , IndependentGoals(..) , AvoidReinstalls(..) , ShadowPkgs(..) , StrongFlags(..) , AllowBootLibInstalls(..) , EnableBackjumping(..) , CountConflicts(..) , SolveExecutables(..) ) where import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Compat.Binary (Binary(..)) import GHC.Generics (Generic) newtype ReorderGoals = ReorderGoals Bool deriving (BooleanFlag, Eq, Generic, Show) newtype CountConflicts = CountConflicts Bool deriving (BooleanFlag, Eq, Generic, Show) newtype IndependentGoals = IndependentGoals Bool deriving (BooleanFlag, Eq, Generic, Show) newtype AvoidReinstalls = AvoidReinstalls Bool deriving (BooleanFlag, Eq, Generic, Show) newtype ShadowPkgs = ShadowPkgs Bool deriving (BooleanFlag, Eq, Generic, Show) newtype StrongFlags = StrongFlags Bool deriving (BooleanFlag, Eq, Generic, Show) newtype AllowBootLibInstalls = AllowBootLibInstalls Bool deriving (BooleanFlag, Eq, Generic, Show) newtype EnableBackjumping = EnableBackjumping Bool deriving (BooleanFlag, Eq, Generic, Show) newtype SolveExecutables = SolveExecutables Bool deriving (BooleanFlag, Eq, Generic, Show) instance Binary ReorderGoals instance Binary CountConflicts instance Binary IndependentGoals instance Binary AvoidReinstalls instance Binary ShadowPkgs instance Binary StrongFlags instance Binary AllowBootLibInstalls instance Binary SolveExecutables cabal-install-2.4.0.0/Distribution/Solver/Types/SolverId.hs0000644000000000000000000000143100000000000021627 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.SolverId ( SolverId(..) ) where import Distribution.Compat.Binary (Binary(..)) import Distribution.Package (PackageId, Package(..), UnitId) import GHC.Generics (Generic) -- | The solver can produce references to existing packages or -- packages we plan to install. Unlike 'ConfiguredId' we don't -- yet know the 'UnitId' for planned packages, because it's -- not the solver's job to compute them. -- data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } | PlannedId { solverSrcId :: PackageId } deriving (Eq, Ord, Generic) instance Binary SolverId instance Show SolverId where show = show . solverSrcId instance Package SolverId where packageId = solverSrcId cabal-install-2.4.0.0/Distribution/Solver/Types/SolverPackage.hs0000644000000000000000000000237300000000000022634 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.SolverPackage ( SolverPackage(..) ) where import Distribution.Compat.Binary (Binary(..)) import Distribution.Package ( Package(..) ) import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SourcePackage import GHC.Generics (Generic) -- | A 'SolverPackage' is a package specified by the dependency solver. -- It will get elaborated into a 'ConfiguredPackage' or even an -- 'ElaboratedConfiguredPackage'. -- -- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc', -- but for symmetry we have the parameter. (Maybe it can be removed.) -- data SolverPackage loc = SolverPackage { solverPkgSource :: SourcePackage loc, solverPkgFlags :: FlagAssignment, solverPkgStanzas :: [OptionalStanza], solverPkgLibDeps :: ComponentDeps [SolverId], solverPkgExeDeps :: ComponentDeps [SolverId] } deriving (Eq, Show, Generic) instance Binary loc => Binary (SolverPackage loc) instance Package (SolverPackage loc) where packageId = packageId . solverPkgSource cabal-install-2.4.0.0/Distribution/Solver/Types/SourcePackage.hs0000644000000000000000000000211600000000000022615 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} module Distribution.Solver.Types.SourcePackage ( PackageDescriptionOverride , SourcePackage(..) ) where import Distribution.Package ( PackageId, Package(..) ) import Distribution.PackageDescription ( GenericPackageDescription(..) ) import Data.ByteString.Lazy (ByteString) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) import Data.Typeable -- | A package description along with the location of the package sources. -- data SourcePackage loc = SourcePackage { packageInfoId :: PackageId, packageDescription :: GenericPackageDescription, packageSource :: loc, packageDescrOverride :: PackageDescriptionOverride } deriving (Eq, Show, Generic, Typeable) instance (Binary loc) => Binary (SourcePackage loc) instance Package (SourcePackage a) where packageId = packageInfoId -- | We sometimes need to override the .cabal file in the tarball with -- the newer one from the package index. type PackageDescriptionOverride = Maybe ByteString cabal-install-2.4.0.0/Distribution/Solver/Types/Variable.hs0000644000000000000000000000055600000000000021634 0ustar0000000000000000module Distribution.Solver.Types.Variable where import Distribution.Solver.Types.OptionalStanza import Distribution.PackageDescription (FlagName) -- | Variables used by the dependency solver. This type is similar to the -- internal 'Var' type. data Variable qpn = PackageVar qpn | FlagVar qpn FlagName | StanzaVar qpn OptionalStanza deriving (Eq, Show) cabal-install-2.4.0.0/LICENSE0000644000000000000000000000307500000000000013522 0ustar0000000000000000Copyright (c) 2003-2017, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. All rights reserved. Redistribution and use in source and binary forms, with or without 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 Isaac Jones 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. cabal-install-2.4.0.0/README.md0000755000000000000000000001256600000000000014004 0ustar0000000000000000The cabal-install package ========================= See the [Cabal web site] for more information. The `cabal-install` package provides a command line tool named `cabal`. It uses the [Cabal] library and provides a user interface to the Cabal/[Hackage] build automation and package management system. It can build and install both local and remote packages, including dependencies. [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: symlink-bindir: $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 cabal-install-2.4.0.0/Setup.hs0000644000000000000000000000543700000000000014155 0ustar0000000000000000import Distribution.PackageDescription ( PackageDescription ) import Distribution.Simple ( defaultMainWithHooks , simpleUserHooks , postBuild , postCopy , postInst ) import Distribution.Simple.InstallDirs ( mandir , CopyDest (NoCopyDest) ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) , absoluteInstallDirs ) import Distribution.Simple.Utils ( installOrdinaryFiles , notice ) import Distribution.Simple.Setup ( buildVerbosity , copyDest , copyVerbosity , fromFlag , installVerbosity ) import Distribution.Verbosity ( Verbosity ) import System.IO ( openFile , IOMode (WriteMode) ) import System.Process ( runProcess ) import System.FilePath ( () ) -- WARNING to editors of this file: -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- At this moment (Cabal 1.23), whatever you write here must be -- compatible with ALL Cabal libraries which we support bootstrapping -- with. This is because pre-setup-depends versions of cabal-install will -- build Setup.hs against the version of Cabal which MATCHES the library -- that cabal-install was built against. There is no way of overriding -- this behavior without bumping the required 'cabal-version' in our -- Cabal file. Travis will let you know if we fail to install from -- tarball! main :: IO () main = defaultMainWithHooks $ simpleUserHooks { postBuild = \ _ flags _ lbi -> buildManpage lbi (fromFlag $ buildVerbosity flags) , postCopy = \ _ flags pkg lbi -> installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags) , postInst = \ _ flags pkg lbi -> installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest } buildManpage :: LocalBuildInfo -> Verbosity -> IO () buildManpage lbi verbosity = do let cabal = buildDir lbi "cabal/cabal" manpage = buildDir lbi "cabal/cabal.1" manpageHandle <- openFile manpage WriteMode notice verbosity ("Generating manual page " ++ manpage ++ " ...") _ <- runProcess cabal ["manpage"] Nothing Nothing Nothing (Just manpageHandle) Nothing return () installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO () installManpage pkg lbi verbosity copy = do let destDir = mandir (absoluteInstallDirs pkg lbi copy) "man1" installOrdinaryFiles verbosity destDir [(buildDir lbi "cabal", "cabal.1")] cabal-install-2.4.0.0/bash-completion/0000755000000000000000000000000000000000000015574 5ustar0000000000000000cabal-install-2.4.0.0/bash-completion/cabal0000755000000000000000000000601200000000000016563 0ustar0000000000000000# cabal command line completion # Copyright 2007-2008 "Lennart Kolmodin" # "Duncan Coutts" # # List cabal targets by type, pass: # - test-suite for test suites # - benchmark for benchmarks # - executable for executables # - executable|test-suite|benchmark for the three _cabal_list() { for f in ./*.cabal; do grep -Ei "^[[:space:]]*($1)[[:space:]]" "$f" | sed -e "s/.* \([^ ]*\).*/\1/" done } # List possible targets depending on the command supplied as parameter. The # ideal option would be to implement this via --list-options on cabal directly. # This is a temporary workaround. _cabal_targets() { # If command ($*) contains build, repl, test or bench completes with # targets of according type. local comp for comp in "$@"; do [ "$comp" == new-build ] && _cabal_list "executable|test-suite|benchmark" && break [ "$comp" == build ] && _cabal_list "executable|test-suite|benchmark" && break [ "$comp" == repl ] && _cabal_list "executable|test-suite|benchmark" && break [ "$comp" == run ] && _cabal_list "executable" && break [ "$comp" == test ] && _cabal_list "test-suite" && break [ "$comp" == bench ] && _cabal_list "benchmark" && break done } # List possible subcommands of a cabal subcommand. # # In example "sandbox" is a cabal subcommand that itself has subcommands. Since # "cabal --list-options" doesn't work in such cases we have to get the list # using other means. _cabal_subcommands() { local word for word in "$@"; do case "$word" in sandbox) # Get list of "cabal sandbox" subcommands from its help message. "$1" help sandbox | sed -n '1,/^Subcommands:$/d;/^Flags for sandbox:$/,$d;/^ /d;s/^\(.*\):/\1/p' break # Terminate for loop. ;; esac done } __cabal_has_doubledash () { local c=1 # Ignore the last word, because it is replaced anyways. # This allows expansion for flags on "cabal foo --", # but does not try to complete after "cabal foo -- ". local n=$((${#COMP_WORDS[@]} - 1)) while [ $c -lt $n ]; do if [ "--" = "${COMP_WORDS[c]}" ]; then return 0 fi ((c++)) done return 1 } _cabal() { # no completion past cabal arguments. __cabal_has_doubledash && return # get the word currently being completed local cur cur=${COMP_WORDS[$COMP_CWORD]} # create a command line to run local cmd # copy all words the user has entered cmd=( ${COMP_WORDS[@]} ) # replace the current word with --list-options cmd[${COMP_CWORD}]="--list-options" # the resulting completions should be put into this array COMPREPLY=( $( compgen -W "$( eval "${cmd[@]}" 2>/dev/null ) $( _cabal_targets "${cmd[@]}" ) $( _cabal_subcommands "${COMP_WORDS[@]}" )" -- "$cur" ) ) } complete -F _cabal -o default cabal cabal-install-2.4.0.0/bootstrap.sh0000755000000000000000000004637600000000000015104 0ustar0000000000000000#!/bin/sh set -e # A script to bootstrap cabal-install. # It works by downloading and installing the Cabal, zlib and # HTTP packages. It then installs cabal-install itself. # It expects to be run inside the cabal-install directory. # Install settings, you can override these by setting environment vars. E.g. if # you don't want profiling and dynamic versions of libraries to be installed in # addition to vanilla, run 'EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh' #VERBOSE DEFAULT_CONFIGURE_OPTS="--enable-library-profiling --enable-shared" EXTRA_CONFIGURE_OPTS=${EXTRA_CONFIGURE_OPTS-$DEFAULT_CONFIGURE_OPTS} #EXTRA_BUILD_OPTS #EXTRA_INSTALL_OPTS die() { printf "\nError during cabal-install bootstrap:\n%s\n" "$1" >&2 exit 2 } # programs, you can override these by setting environment vars GHC="${GHC:-ghc}" GHC_PKG="${GHC_PKG:-ghc-pkg}" GHC_VER="$(${GHC} --numeric-version)" HADDOCK=${HADDOCK:-haddock} WGET="${WGET:-wget}" CURL="${CURL:-curl}" FETCH="${FETCH:-fetch}" TAR="${TAR:-tar}" GZIP_PROGRAM="${GZIP_PROGRAM:-gzip}" # The variable SCOPE_OF_INSTALLATION can be set on the command line to # use/install the libaries needed to build cabal-install to a custom package # database instead of the user or global package database. # # Example: # # $ ghc-pkg init /my/package/database # $ SCOPE_OF_INSTALLATION='--package-db=/my/package/database' ./bootstrap.sh # # You can also combine SCOPE_OF_INSTALLATION with PREFIX: # # $ ghc-pkg init /my/prefix/packages.conf.d # $ SCOPE_OF_INSTALLATION='--package-db=/my/prefix/packages.conf.d' \ # PREFIX=/my/prefix ./bootstrap.sh # # If you use the --global,--user or --sandbox arguments, this will # override the SCOPE_OF_INSTALLATION setting and not use the package # database you pass in the SCOPE_OF_INSTALLATION variable. SCOPE_OF_INSTALLATION="${SCOPE_OF_INSTALLATION:---user}" DEFAULT_PREFIX="${HOME}/.cabal" TMPDIR=$(mktemp -d -p /tmp -t cabal-XXXXXXX || mktemp -d -t cabal-XXXXXXX) export TMPDIR # Check for a C compiler, using user-set $CC, if any, first. for c in $CC gcc clang cc icc; do $c --version 1>/dev/null 2>&1 && CC=$c && echo "Using $c for C compiler. If this is not what you want, set CC." >&2 && break done # None found. [ -"$CC"- = -""- ] && die 'C compiler not found (or could not be run). If a C compiler is installed make sure it is on your PATH, or set $CC.' # Find the correct linker/linker-wrapper. # # See https://github.com/haskell/cabal/pull/4187#issuecomment-269074153. LINK="$(for link in collect2 ld; do if [ $($CC -print-prog-name=$link) = $link ] then continue else $CC -print-prog-name=$link && break fi done)" # Fall back to "ld"... might work. [ -$LINK- = -""- ] && LINK=ld # And finally, see if we can compile and link something. echo 'int main(){}' | $CC -xc - -o /dev/null || die "C compiler and linker could not compile a simple test program. Please check your toolchain." # Warn that were's overriding $LD if set (if you want). [ -"$LD"- != -""- ] && [ -"$LD"- != -"$LINK"- ] && echo "Warning: value set in $LD is not the same as C compiler's $LINK." >&2 echo "Using $LINK instead." >&2 # Set LD, overriding environment if necessary. export LD=$LINK # Check we're in the right directory, etc. grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 || die "The bootstrap.sh script must be run in the cabal-install directory" ${GHC} --numeric-version > /dev/null 2>&1 || die "${GHC} not found (or could not be run). If ghc is installed, make sure it is on your PATH, or set the GHC and GHC_PKG vars." ${GHC_PKG} --version > /dev/null 2>&1 || die "${GHC_PKG} not found." GHC_PKG_VER="$(${GHC_PKG} --version | cut -d' ' -f 5)" [ ${GHC_VER} = ${GHC_PKG_VER} ] || die "Version mismatch between ${GHC} and ${GHC_PKG}. If you set the GHC variable then set GHC_PKG too." JOBS="-j1" while [ "$#" -gt 0 ]; do case "${1}" in "--user") SCOPE_OF_INSTALLATION="${1}" shift;; "--global") SCOPE_OF_INSTALLATION="${1}" DEFAULT_PREFIX="/usr/local" shift;; "--sandbox") shift # check if there is another argument which doesn't start with -- if [ "$#" -le 0 ] || [ ! -z $(echo "${1}" | grep "^--") ] then SANDBOX=".cabal-sandbox" else SANDBOX="${1}" shift fi;; "--no-doc") NO_DOCUMENTATION=1 shift;; "-j"|"--jobs") shift # check if there is another argument which doesn't start with - or -- if [ "$#" -le 0 ] \ || [ ! -z $(echo "${1}" | grep "^-") ] \ || [ ! -z $(echo "${1}" | grep "^--") ] then JOBS="-j" else JOBS="-j${1}" shift fi;; *) echo "Unknown argument or option, quitting: ${1}" echo "usage: bootstrap.sh [OPTION]" echo echo "options:" echo " -j/--jobs Number of concurrent workers to use (Default: 1)" echo " -j without an argument will use all available cores" echo " --user Install for the local user (default)" echo " --global Install systemwide (must be run as root)" echo " --no-doc Do not generate documentation for installed"\ "packages" echo " --sandbox Install to a sandbox in the default location"\ "(.cabal-sandbox)" echo " --sandbox path Install to a sandbox located at path" exit;; esac done # Do not try to use -j with GHC 7.8 or older case $GHC_VER in 7.4*|7.6*|7.8*) JOBS="" ;; *) ;; esac abspath () { case "$1" in /*)printf "%s\n" "$1";; *)printf "%s\n" "$PWD/$1";; esac; } if [ ! -z "$SANDBOX" ] then # set up variables for sandbox bootstrap # Make the sandbox path absolute since it will be used from # different working directories when the dependency packages are # installed. SANDBOX=$(abspath "$SANDBOX") # Get the name of the package database which cabal sandbox would use. GHC_ARCH=$(ghc --info | sed -n 's/.*"Target platform".*"\([^-]\+\)-[^-]\+-\([^"]\+\)".*/\1-\2/p') PACKAGEDB="$SANDBOX/${GHC_ARCH}-ghc-${GHC_VER}-packages.conf.d" # Assume that if the directory is already there, it is already a # package database. We will get an error immediately below if it # isn't. Uses -r to try to be compatible with Solaris, and allow # symlinks as well as a normal dir/file. [ ! -r "$PACKAGEDB" ] && ghc-pkg init "$PACKAGEDB" PREFIX="$SANDBOX" SCOPE_OF_INSTALLATION="--package-db=$PACKAGEDB" echo Bootstrapping in sandbox at \'$SANDBOX\'. fi # Check for haddock unless no documentation should be generated. if [ ! ${NO_DOCUMENTATION} ] then ${HADDOCK} --version > /dev/null 2>&1 || die "${HADDOCK} not found." fi PREFIX=${PREFIX:-${DEFAULT_PREFIX}} # Versions of the packages to install. # The version regex says what existing installed versions are ok. PARSEC_VER="3.1.13.0"; PARSEC_VER_REGEXP="[3]\.[1]\." # >= 3.1 && < 3.2 DEEPSEQ_VER="1.4.3.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 BINARY_VER="0.8.5.1"; BINARY_VER_REGEXP="[0]\.[78]\." # >= 0.7 && < 0.9 TEXT_VER="1.2.3.0"; TEXT_VER_REGEXP="[1]\.[2]\." # >= 1.2 && < 1.3 NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\.(0\.[2-9]|[1-9])" # >= 2.6.0.2 && < 2.7 NETWORK_VER="2.7.0.0"; NETWORK_VER_REGEXP="2\.[0-7]\." # >= 2.0 && < 2.7 CABAL_VER="2.4.0.1"; CABAL_VER_REGEXP="2\.4\.[0-9]" # >= 2.4 && < 2.5 TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.2"; MTL_VER_REGEXP="[2]\." # >= 2.0 && < 3 HTTP_VER="4000.3.12"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" # >= 4000.2.5 < 4000.4 ZLIB_VER="0.6.2"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" # >= 0.5.3 && <= 0.7 TIME_VER="1.9.1" TIME_VER_REGEXP="1\.[1-9]\.?" # >= 1.1 && < 1.10 RANDOM_VER="1.1" RANDOM_VER_REGEXP="1\.[01]\.?" # >= 1 && < 1.2 STM_VER="2.4.5.0"; STM_VER_REGEXP="2\." # == 2.* HASHABLE_VER="1.2.7.0"; HASHABLE_VER_REGEXP="1\." # 1.* ASYNC_VER="2.2.1"; ASYNC_VER_REGEXP="2\." # 2.* BASE16_BYTESTRING_VER="0.1.1.6"; BASE16_BYTESTRING_VER_REGEXP="0\.1" # 0.1.* BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\." # >=1.0 CRYPTOHASH_SHA256_VER="0.11.101.0"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" # 0.11.* RESOLV_VER="0.1.1.1"; RESOLV_VER_REGEXP="0\.1\.[1-9]" # >= 0.1.1 && < 0.2 MINTTY_VER="0.1.2"; MINTTY_VER_REGEXP="0\.1\.?" # 0.1.* ECHO_VER="0.1.3"; ECHO_VER_REGEXP="0\.1\.[3-9]" # >= 0.1.3 && < 0.2 EDIT_DISTANCE_VER="0.2.2.1"; EDIT_DISTANCE_VER_REGEXP="0\.2\.2\.?" # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?" # 0.0.* HACKAGE_SECURITY_VER="0.5.3.0"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.((2\.[2-9]|[3-9])|3)" # >= 0.5.2 && < 0.6 TAR_VER="0.5.1.0"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" # >= 0.5.0.3 && < 0.6 DIGEST_VER="0.0.1.2"; DIGEST_REGEXP="0\.0\.(1\.[2-9]|[2-9]\.?)" # >= 0.0.1.2 && < 0.1 ZIP_ARCHIVE_VER="0.3.3"; ZIP_ARCHIVE_REGEXP="0\.3\.[3-9]" # >= 0.3.3 && < 0.4 HACKAGE_URL="https://hackage.haskell.org/package" # Haddock fails for hackage-security for GHC <8, # c.f. https://github.com/well-typed/hackage-security/issues/149 NO_DOCS_PACKAGES_VER_REGEXP="hackage-security-0\.5\.[0-9]+\.[0-9]+" # Cache the list of packages: echo "Checking installed packages for ghc-${GHC_VER}..." ${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list || die "running '${GHC_PKG} list' failed" # Will we need to install this package, or is a suitable version installed? need_pkg () { PKG=$1 VER_MATCH=$2 if egrep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 then return 1; else return 0; fi #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it. } info_pkg () { PKG=$1 VER=$2 VER_MATCH=$3 if need_pkg ${PKG} ${VER_MATCH} then if [ -r "${PKG}-${VER}.tar.gz" ] then echo "${PKG}-${VER} will be installed from local tarball." else echo "${PKG}-${VER} will be downloaded and installed." fi else echo "${PKG} is already installed and the version is ok." fi } fetch_pkg () { PKG=$1 VER=$2 URL_PKG=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz URL_PKGDESC=${HACKAGE_URL}/${PKG}-${VER}/${PKG}.cabal if which ${CURL} > /dev/null then ${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}." ${CURL} -L --fail -C - -O ${URL_PKGDESC} \ || die "Failed to download '${PKG}.cabal'." elif which ${WGET} > /dev/null then ${WGET} -c ${URL_PKG} || die "Failed to download ${PKG}." ${WGET} -c ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'." elif which ${FETCH} > /dev/null then ${FETCH} ${URL_PKG} || die "Failed to download ${PKG}." ${FETCH} ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'." else die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required." fi [ -f "${PKG}-${VER}.tar.gz" ] || die "Downloading ${URL_PKG} did not create ${PKG}-${VER}.tar.gz" [ -f "${PKG}.cabal" ] || die "Downloading ${URL_PKGDESC} did not create ${PKG}.cabal" mv "${PKG}.cabal" "${PKG}.cabal.hackage" } unpack_pkg () { PKG=$1 VER=$2 rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}" ${GZIP_PROGRAM} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -xf - [ -d "${PKG}-${VER}" ] || die "Failed to unpack ${PKG}-${VER}.tar.gz" cp "${PKG}.cabal.hackage" "${PKG}-${VER}/${PKG}.cabal" } install_pkg () { PKG=$1 VER=$2 [ -x Setup ] && ./Setup clean [ -f Setup ] && rm Setup PKG_DBS=$(printf '%s\n' "${SCOPE_OF_INSTALLATION}" \ | sed -e 's/--package-db/-package-db/' \ -e 's/--global/-global-package-db/' \ -e 's/--user/-user-package-db/') ${GHC} --make ${JOBS} ${PKG_DBS} Setup -o Setup -XRank2Types -XFlexibleContexts || die "Compiling the Setup script failed." [ -x Setup ] || die "The Setup script does not exist or cannot be run" args="${SCOPE_OF_INSTALLATION} --prefix=${PREFIX} --with-compiler=${GHC}" args="$args --with-hc-pkg=${GHC_PKG} --with-gcc=${CC} --with-ld=${LD}" args="$args ${EXTRA_CONFIGURE_OPTS} ${VERBOSE}" ./Setup configure $args || die "Configuring the ${PKG} package failed." ./Setup build ${JOBS} ${EXTRA_BUILD_OPTS} ${VERBOSE} || die "Building the ${PKG} package failed." if [ ! ${NO_DOCUMENTATION} ] then if echo "${PKG}-${VER}" | egrep ${NO_DOCS_PACKAGES_VER_REGEXP} \ > /dev/null 2>&1 then echo "Skipping documentation for the ${PKG} package." else ./Setup haddock --with-ghc=${GHC} --with-haddock=${HADDOCK} ${VERBOSE} || die "Documenting the ${PKG} package failed." fi fi ./Setup install ${EXTRA_INSTALL_OPTS} ${VERBOSE} || die "Installing the ${PKG} package failed." } do_pkg () { PKG=$1 VER=$2 VER_MATCH=$3 if need_pkg ${PKG} ${VER_MATCH} then echo if [ -r "${PKG}-${VER}.tar.gz" ] then echo "Using local tarball for ${PKG}-${VER}." else echo "Downloading ${PKG}-${VER}..." fetch_pkg ${PKG} ${VER} fi unpack_pkg "${PKG}" "${VER}" (cd "${PKG}-${VER}" && install_pkg ${PKG} ${VER}) fi } # If we're bootstrapping from a Git clone, install the local version of Cabal # instead of downloading one from Hackage. do_Cabal_pkg () { if [ -d "../.git" ] then if need_pkg "Cabal" ${CABAL_VER_REGEXP} then echo "Cabal-${CABAL_VER} will be installed from the local Git clone." (cd ../Cabal && install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP}) else echo "Cabal is already installed and the version is ok." fi else info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} fi } # Actually do something! info_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} info_pkg "binary" ${BINARY_VER} ${BINARY_VER_REGEXP} info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} info_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} info_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} info_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} info_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} info_pkg "stm" ${STM_VER} ${STM_VER_REGEXP} info_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} info_pkg "async" ${ASYNC_VER} ${ASYNC_VER_REGEXP} info_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \ ${BASE16_BYTESTRING_VER_REGEXP} info_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \ ${BASE64_BYTESTRING_VER_REGEXP} info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ ${CRYPTOHASH_SHA256_VER_REGEXP} info_pkg "resolv" ${RESOLV_VER} ${RESOLV_VER_REGEXP} info_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} info_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} info_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} info_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP} info_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} do_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} do_pkg "binary" ${BINARY_VER} ${BINARY_VER_REGEXP} do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} # Cabal might depend on these do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} do_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} # Install the Cabal library from the local Git clone if possible. do_Cabal_pkg do_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} do_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} do_pkg "stm" ${STM_VER} ${STM_VER_REGEXP} do_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} do_pkg "async" ${ASYNC_VER} ${ASYNC_VER_REGEXP} do_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \ ${BASE16_BYTESTRING_VER_REGEXP} do_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \ ${BASE64_BYTESTRING_VER_REGEXP} do_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ ${CRYPTOHASH_SHA256_VER_REGEXP} do_pkg "resolv" ${RESOLV_VER} ${RESOLV_VER_REGEXP} do_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} do_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} do_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} do_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} do_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP} do_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} install_pkg "cabal-install" # Use the newly built cabal to turn the prefix/package database into a # legit cabal sandbox. This works because 'cabal sandbox init' will # reuse the already existing package database and other files if they # are in the expected locations. [ ! -z "$SANDBOX" ] && $SANDBOX/bin/cabal sandbox init --sandbox $SANDBOX echo echo "===========================================" CABAL_BIN="$PREFIX/bin" if [ -x "$CABAL_BIN/cabal" ] then echo "The 'cabal' program has been installed in $CABAL_BIN/" echo "You should either add $CABAL_BIN to your PATH" echo "or copy the cabal program to a directory that is on your PATH." echo echo "The first thing to do is to get the latest list of packages with:" echo " cabal update" echo "This will also create a default config file (if it does not already" echo "exist) at $HOME/.cabal/config" echo echo "By default cabal will install programs to $HOME/.cabal/bin" echo "If you do not want to add this directory to your PATH then you can" echo "change the setting in the config file, for example you could use:" echo "symlink-bindir: $HOME/bin" else echo "Sorry, something went wrong." echo "The 'cabal' executable was not successfully installed into" echo "$CABAL_BIN/" fi echo rm ghc-pkg.list cabal-install-2.4.0.0/cabal-install.cabal0000644000000000000000000003420200000000000016203 0ustar0000000000000000Cabal-Version: >= 1.10 -- NOTE: This file is autogenerated from 'cabal-install.cabal.pp'. -- DO NOT EDIT MANUALLY. -- 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: 2.4.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing Haskell software by automating the fetching, configuration, compilation and installation of Haskell libraries and programs. homepage: http://www.haskell.org/cabal/ bug-reports: https://github.com/haskell/cabal/issues License: BSD3 License-File: LICENSE Author: Cabal Development Team (see AUTHORS file) Maintainer: Cabal Development Team Copyright: 2003-2018, Cabal Development Team Category: Distribution Build-type: Custom Extra-Source-Files: README.md bash-completion/cabal bootstrap.sh changelog tests/README.md -- 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/cabal.project tests/IntegrationTests2/targets/simple/p.cabal tests/IntegrationTests2/targets/simple/q/QQ.hs tests/IntegrationTests2/targets/simple/q/q.cabal tests/IntegrationTests2/targets/test-only/p.cabal tests/IntegrationTests2/targets/tests-disabled/cabal.project tests/IntegrationTests2/targets/tests-disabled/p.cabal tests/IntegrationTests2/targets/tests-disabled/q/q.cabal tests/IntegrationTests2/targets/variety/cabal.project tests/IntegrationTests2/targets/variety/p.cabal -- END gen-extra-source-files -- 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/ subdir: cabal-install Flag native-dns description: Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups default: True manual: True Flag debug-expensive-assertions description: Enable expensive assertions for testing or debugging default: False manual: True Flag debug-conflict-sets description: Add additional information to ConflictSets default: False manual: True Flag debug-tracetree description: Compile in support for tracetree (used to debug the solver) default: False manual: True custom-setup setup-depends: Cabal >= 2.2, base, process >= 1.1.0.1 && < 1.7, filepath >= 1.3 && < 1.5 executable cabal main-is: Main.hs hs-source-dirs: main default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances ghc-options: -rtsopts -threaded -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a if os(aix) extra-libraries: bsd hs-source-dirs: . other-modules: Distribution.Client.BuildReports.Anonymous Distribution.Client.BuildReports.Storage Distribution.Client.BuildReports.Types Distribution.Client.BuildReports.Upload Distribution.Client.Check Distribution.Client.CmdBench Distribution.Client.CmdBuild Distribution.Client.CmdClean Distribution.Client.CmdConfigure Distribution.Client.CmdUpdate Distribution.Client.CmdErrorMessages Distribution.Client.CmdExec Distribution.Client.CmdFreeze Distribution.Client.CmdHaddock Distribution.Client.CmdInstall Distribution.Client.CmdRepl Distribution.Client.CmdRun Distribution.Client.CmdTest Distribution.Client.CmdLegacy Distribution.Client.CmdSdist Distribution.Client.Compat.Directory Distribution.Client.Compat.ExecutablePath Distribution.Client.Compat.FileLock Distribution.Client.Compat.FilePerms Distribution.Client.Compat.Prelude Distribution.Client.Compat.Process Distribution.Client.Compat.Semaphore Distribution.Client.Config Distribution.Client.Configure Distribution.Client.Dependency Distribution.Client.Dependency.Types Distribution.Client.DistDirLayout Distribution.Client.Exec Distribution.Client.Fetch Distribution.Client.FetchUtils Distribution.Client.FileMonitor Distribution.Client.Freeze Distribution.Client.GZipUtils Distribution.Client.GenBounds Distribution.Client.Get Distribution.Client.Glob Distribution.Client.GlobalFlags Distribution.Client.Haddock Distribution.Client.HttpUtils Distribution.Client.IndexUtils Distribution.Client.IndexUtils.Timestamp Distribution.Client.Init Distribution.Client.Init.Heuristics Distribution.Client.Init.Licenses Distribution.Client.Init.Types Distribution.Client.Install Distribution.Client.InstallPlan Distribution.Client.InstallSymlink Distribution.Client.JobControl Distribution.Client.List Distribution.Client.Manpage Distribution.Client.Nix Distribution.Client.Outdated Distribution.Client.PackageHash Distribution.Client.PackageUtils Distribution.Client.ParseUtils Distribution.Client.ProjectBuilding Distribution.Client.ProjectBuilding.Types Distribution.Client.ProjectConfig Distribution.Client.ProjectConfig.Legacy Distribution.Client.ProjectConfig.Types Distribution.Client.ProjectOrchestration Distribution.Client.ProjectPlanOutput Distribution.Client.ProjectPlanning Distribution.Client.ProjectPlanning.Types Distribution.Client.RebuildMonad Distribution.Client.Reconfigure Distribution.Client.Run Distribution.Client.Sandbox Distribution.Client.Sandbox.Index Distribution.Client.Sandbox.PackageEnvironment Distribution.Client.Sandbox.Timestamp Distribution.Client.Sandbox.Types Distribution.Client.SavedFlags Distribution.Client.Security.DNS Distribution.Client.Security.HTTP Distribution.Client.Setup Distribution.Client.SetupWrapper Distribution.Client.SolverInstallPlan Distribution.Client.SourceFiles Distribution.Client.SourceRepoParse Distribution.Client.SrcDist Distribution.Client.Store Distribution.Client.Tar Distribution.Client.TargetSelector Distribution.Client.Targets Distribution.Client.Types Distribution.Client.Update Distribution.Client.Upload Distribution.Client.Utils Distribution.Client.Utils.Assertion Distribution.Client.Utils.Json Distribution.Client.VCS Distribution.Client.Win32SelfUpgrade Distribution.Client.World Distribution.Solver.Compat.Prelude Distribution.Solver.Modular Distribution.Solver.Modular.Assignment Distribution.Solver.Modular.Builder Distribution.Solver.Modular.Configured Distribution.Solver.Modular.ConfiguredConversion Distribution.Solver.Modular.ConflictSet Distribution.Solver.Modular.Cycles Distribution.Solver.Modular.Dependency Distribution.Solver.Modular.Explore Distribution.Solver.Modular.Flag Distribution.Solver.Modular.Index Distribution.Solver.Modular.IndexConversion Distribution.Solver.Modular.LabeledGraph Distribution.Solver.Modular.Linking Distribution.Solver.Modular.Log Distribution.Solver.Modular.Message Distribution.Solver.Modular.PSQ Distribution.Solver.Modular.Package Distribution.Solver.Modular.Preference Distribution.Solver.Modular.RetryLog Distribution.Solver.Modular.Solver Distribution.Solver.Modular.Tree Distribution.Solver.Modular.Validate Distribution.Solver.Modular.Var Distribution.Solver.Modular.Version Distribution.Solver.Modular.WeightedPSQ Distribution.Solver.Types.ComponentDeps Distribution.Solver.Types.ConstraintSource Distribution.Solver.Types.DependencyResolver Distribution.Solver.Types.Flag Distribution.Solver.Types.InstSolverPackage Distribution.Solver.Types.InstalledPreference Distribution.Solver.Types.LabeledPackageConstraint Distribution.Solver.Types.OptionalStanza Distribution.Solver.Types.PackageConstraint Distribution.Solver.Types.PackageFixedDeps Distribution.Solver.Types.PackageIndex Distribution.Solver.Types.PackagePath Distribution.Solver.Types.PackagePreferences Distribution.Solver.Types.PkgConfigDb Distribution.Solver.Types.Progress Distribution.Solver.Types.ResolverPackage Distribution.Solver.Types.Settings Distribution.Solver.Types.SolverId Distribution.Solver.Types.SolverPackage Distribution.Solver.Types.SourcePackage Distribution.Solver.Types.Variable Paths_cabal_install build-depends: async >= 2.0 && < 3, array >= 0.4 && < 0.6, base >= 4.6 && < 5, base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.7 && < 0.9, bytestring >= 0.10.2 && < 1, Cabal == 2.4.*, containers >= 0.5 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, deepseq >= 1.3 && < 1.5, directory >= 1.2.2.0 && < 1.4, echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, filepath >= 1.3 && < 1.5, hashable >= 1.0 && < 2, HTTP >= 4000.1.5 && < 4000.4, mtl >= 2.0 && < 3, network-uri >= 2.6.0.2 && < 2.7, network >= 2.6 && < 2.8, pretty >= 1.1 && < 1.2, process >= 1.1.0.2 && < 1.7, random >= 1 && < 1.2, stm >= 2.0 && < 3, tar >= 0.5.0.3 && < 0.6, time >= 1.4 && < 1.10, zlib >= 0.5.3 && < 0.7, hackage-security >= 0.5.2.2 && < 0.6, text >= 1.2.3 && < 1.3, zip-archive >= 0.3.2.5 && < 0.4, parsec >= 3.1.13.0 && < 3.2 if flag(native-dns) if os(windows) build-depends: windns >= 0.1.0 && < 0.2 else build-depends: resolv >= 0.1.1 && < 0.2 if os(windows) build-depends: Win32 >= 2 && < 3 else build-depends: unix >= 2.5 && < 2.9 if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS if flag(debug-conflict-sets) cpp-options: -DDEBUG_CONFLICT_SETS build-depends: base >= 4.8 if flag(debug-tracetree) cpp-options: -DDEBUG_TRACETREE build-depends: tracetree >= 0.1 && < 0.2 cabal-install-2.4.0.0/changelog0000755000000000000000000006010000000000000014362 0ustar0000000000000000-*-change-log-*- 2.4.0.0 Mikhail Glushenkov September 2018 * Bugfix: "cabal new-build --ghc-option '--bogus' --ghc-option '-O1'" no longer ignores all arguments except the last one (#5512). * Add the following option aliases for '-dir'-suffixed options: 'storedir', 'logsdir', 'packagedir', 'sourcedir', 'outputdir' (#5484). * 'new-run' now allows the user to run scripts that use a special block to define their requirements (as in the executable stanza) in place of a target. This also allows the use of 'cabal' as an interpreter in a shebang line. * Add aliases for the "new-" commands that won't change when they lose their prefix or are eventually replaced by a third UI paradigm in the future. (#5429) * 'outdated' now accepts '--project-file FILE', which will look for bounds from the new-style freeze file named FILE.freeze. This is only available when `--new-freeze-file` has been passed. * 'new-repl' now accepts a '--build-depends' flag which accepts the same syntax as is used in .cabal files to add additional dependencies to the environment when developing in the REPL. It is now usable outside of projects. (#5425, #5454) * 'new-build' now treats Haddock errors non-fatally. In addition, it attempts to avoid trying to generate Haddocks when there is nothing to generate them from. (#5232, #5459) * 'new-run', 'new-test', and 'new-bench' now will attempt to resolve ambiguous selectors by filtering out selectors that would be invalid. (#4679, #5461) * 'new-install' now supports installing libraries and local components. (#5399) * Drop support for GHC 7.4, since it is out of our support window (and has been for over a year!). * 'new-update' now works outside of projects. (#5096) * Extend `plan.json` with `pkg-src` provenance information. (#5487) * Add 'new-sdist' command (#5389). Creates stable archives based on cabal projects in '.zip' and '.tar.gz' formats. * Add '--repl-options' flag to 'cabal repl' and 'cabal new-repl' commands. Passes its arguments to the invoked repl, bypassing the new-build's cached configurations. This assures they don't trigger useless rebuilds and are always applied within the repl. (#4247, #5287) * Add 'v1-' prefixes for the commands that will be replaced in the new-build universe, in preparation for it becoming the default. (#5358) * 'outdated' accepts '--v1-freeze-file' and '--v2-freeze-file' in the same spirit. * Completed the 'new-clean' command (#5357). The functionality is equivalent to old-style clean, but for nix-style builds. * Ensure that each package selected for a build-depends dependency contains a library (#5304). * Support packages from local tarballs in the cabal.project file. * Default changelog generated by 'cabal init' is now named 'CHANGELOG.md' (#5441). * Align output of 'new-build' command phases (#4040). 2.2.0.0 Mikhail Glushenkov March 2018 * '--with-PROG' and '--PROG-options' are applied to all packages and not local packages only (#5019). * Completed the 'new-update' command (#4809), which respects nix-style cabal.project(.local) files and allows to update from multiple repositories when using overlays. * Completed the 'new-run' command (#4477). The functionality is the same of the old 'run' command but using nix-style builds. Additionally, it can run executables across packages in a project. Tests and benchmarks are also treated as executables, providing a quick way to pass them arguments. * Completed the 'new-bench' command (#3638). Same as above. * Completed the 'new-exec' command (#3638). Same as above. * Added a preliminary 'new-install' command (#4558, nonlocal exes part) which allows to quickly install executables from Hackage. * Set symlink-bindir (used by new-install) to .cabal/bin by default on .cabal/config initialization (#5188). * 'cabal update' now supports '--index-state' which can be used to roll back the index to an earlier state. * '--allow-{newer,older}' syntax has been enhanced. Dependency relaxation can be now limited to a specific release of a package, plus there's a new syntax for relaxing only caret-style (i.e. '^>=') dependencies (#4575, #4669). * New config file field: 'cxx-options' to specify which options to be passed to the compiler when compiling C++ sources specified by the 'cxx-sources' field. (#3700) * New config file field: 'cxx-sources' to specify C++ files to be compiled separately from C source files. Useful in conjunction with the 'cxx-options' flag to pass different compiler options to C and C++ source files. (#3700) * Use [lfxtb] letters to differentiate component kind instead of opaque "c" in dist-dir layout. * 'cabal configure' now supports '--enable-static', which can be used to build static libaries with GHC via GHC's `-staticlib` flag. * 'cabal user-config now supports '--augment' which can append additional lines to a new or updated cabal config file. * Added support for '--enable-tests' and '--enable-benchmarks' to 'cabal fetch' (#4948). * Misspelled package-names on CLI will no longer be silently case-corrected (#4778). * 'cabal new-configure' now backs up the old 'cabal.project.local' file if it exists (#4460). * On macOS, `new-build` will now place dynamic libraries into `store/lib` and aggressively shorten their names in an effort to stay within the load command size limits of macOSs mach-o linker. * 'new-build' now checks for the existence of executables for build-tools and build-tool-depends dependencies in the solver (#4884). * Fixed a spurious warning telling the user to run 'cabal update' when it wasn't necessary (#4444). * Packages installed in sandboxes via 'add-source' now have their timestamps updated correctly and so will not be reinstalled unncecessarily if the main install command fails (#1375). * Add Windows device path support for copyFile, renameFile. Allows cabal new-build to use temporary store path of up to 32k length (#3972, #4914, #4515). * When a flag value is specified multiple times on the command line, the last one is now preferred, so e.g. '-f+dev -f-dev' is now equivalent to '-f-dev' (#4452). * Removed support for building cabal-install with GHC < 7.10 (#4870). * New 'package *' section in 'cabal.project' files that applies options to all packages, not just those local to the project. * Paths_ autogen modules now compile when `RebindableSyntax` or `OverloadedStrings` is used in `default-extensions`. [stack#3789](https://github.com/commercialhaskell/stack/issues/3789) * getDataDir` and other `Paths_autogen` functions now work correctly when compiling a custom `Setup.hs` script using `new-build` (#5164). 2.0.0.1 Mikhail Glushenkov December 2017 * Support for GHC's numeric -g debug levels (#4673). * Demoted 'scope' field version check to a warning (#4714). * Fixed verbosity flags getting removed before being passed to 'printPlan' (#4724). * Added a '--store-dir' option that can be used to configure the location of the build global build store (#4623). * Turned `allow-{newer,older}` in `cabal.project` files into an accumulating field to match CLI flag semantics (#4679). * Improve success message when `cabal upload`ing documentation (#4777). * Documentation fixes. 2.0.0.0 Mikhail Glushenkov August 2017 * See http://coldwa.st/e/blog/2017-09-09-Cabal-2-0.html for more detailed release notes. * Removed the '--root-cmd' parameter of the 'install' command (#3356). * Deprecated 'cabal install --global' (#3356). * Changed 'cabal upload' to upload a package candidate by default (#3419). Same applies to uploading documentation. * Added a new 'cabal upload' flag '--publish' for publishing a package on Hackage instead of uploading a candidate (#3419). * Added optional solver output visualisation support via the tracetree package. Mainly intended for debugging (#3410). * Removed the '--check' option from 'cabal upload' (#1823). It was replaced by package candidates. * Fixed various behaviour differences between network transports (#3429). * The bootstrap script now works correctly when run from a Git clone (#3439). * Removed the top-down solver (#3598). * The '-v/--verbosity' option no longer affects GHC verbosity (except in the case of '-v0'). Use '--ghc-options=-v' to enable verbose GHC output (#3540, #3671). * Changed the default logfile template from '.../$pkgid.log' to '.../$compiler/$libname.log' (#3807). * Added a new command, 'cabal reconfigure', which re-runs 'configure' with the most recently used flags (#2214). * Added the '--index-state' flag for requesting a specific version of the package index (#3893, #4115). * Support for building Backpack packages. See https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst for more details. * Support the Nix package manager (#3651). * Made the 'template-haskell' package non-upgradable again (#4185). * Fixed password echoing on MinTTY (#4128). * Added a new solver flag, '--allow-boot-library-installs', that allows any package to be installed or upgraded (#4209). * New 'cabal-install' command: 'outdated', for listing outdated version bounds in a .cabal file or a freeze file (#4207). * Added qualified constraints for setup dependencies. For example, --constraint="setup.bar == 1.0" constrains all setup dependencies on bar, and --constraint="foo:setup.bar == 1.0" constrains foo's setup dependency on bar (part of #3502). * Non-qualified constraints, such as --constraint="bar == 1.0", now only apply to top-level dependencies. They don't constrain setup or build-tool dependencies. The new syntax --constraint="any.bar == 1.0" constrains all uses of bar. * Added a technical preview version of the 'cabal doctest' command (#4480). 1.24.0.2 Mikhail Glushenkov December 2016 * Adapted to the revert of a PVP-noncompliant API change in Cabal 1.24.2.0 (#4123). * Bumped the directory upper bound to < 1.4 (#4158). 1.24.0.1 Ryan Thomas October 2016 * Fixed issue with passing '--enable-profiling' when invoking Setup scripts built with older versions of Cabal (#3873). * Fixed various behaviour differences between network transports (#3429). * Updated to depend on the latest hackage-security that fixes various issues on Windows. * Fixed 'new-build' to exit with a non-zero exit code on failure (#3506). * Store secure repo index data as 01-index.* (#3862). * Added new hackage-security root keys for distribution with cabal-install. * Fix an issue where 'cabal install' sometimes had to be run twice for packages with build-type: Custom and a custom-setup stanza (#3723). * 'cabal sdist' no longer ignores '--builddir' when the package's build-type is Custom (#3794). 1.24.0.0 Ryan Thomas March 2016 * If there are multiple remote repos, 'cabal update' now updates them in parallel (#2503). * New 'cabal upload' option '-P'/'--password-command' for reading Hackage password from arbitrary program output (#2506). * Better warning for 'cabal run' (#2510). * 'cabal init' now warns if the chosen package name is already registered in the source package index (#2436). * New 'cabal install' option: '--offline' (#2578). * Accept 'builddir' field in cabal.config (#2484) * Read 'builddir' option from 'CABAL_BUILDDIR' environment variable. * Remote repos may now be configured to use https URLs. This uses either curl or wget or, on Windows, PowerShell, under the hood (#2687). * Install target URLs can now use https e.g. 'cabal install https://example.com/foo-1.0.tar.gz'. * Automatically use https for cabal upload for the main hackage.haskell.org (other repos will use whatever they are configured to use). * Support for dependencies of custom Setup.hs scripts (see http://www.well-typed.com/blog/2015/07/cabal-setup-deps/). * 'cabal' program itself now can be used as an external setup method. This fixes an issue when Cabal version mismatch caused unnecessary reconfigures (#2633). * Improved error message for unsatisfiable package constraints (#2727). * Fixed a space leak in 'cabal update' (#2826). * 'cabal exec' and 'sandbox hc-pkg' now use the configured compiler (#2859). * New 'cabal haddock' option: '--for-hackage' (#2852). * Added a warning when the solver cannot find a dependency (#2853). * New 'cabal upload' option: '--doc': upload documentation to hackage (#2890). * Improved error handling for 'sandbox delete-source' (#2943). * Solver support for extension and language flavours (#2873). * Support for secure repos using hackage-security (#2983). * Added a log file message similar to one printed by 'make' when building in another directory (#2642). * Added new subcommand 'init' to 'cabal user-config'. This subcommand creates a cabal configuration file in either the default location or as specified by --config-file (#2553). * The man page for 'cabal-install' is now automatically generated (#2877). * The '--allow-newer' option now works as expected when specified multiple times (#2588). * New config file field: 'extra-framework-dirs' (extra locations to find OS X frameworks in). Can be also specified as an argument for 'install' and 'configure' commands (#3158). * It's now possible to limit the scope of '--allow-newer' to single packages in the install plan (#2756). * Full '--allow-newer' syntax is now supported in the config file (that is, 'allow-newer: base, ghc-prim, some-package:vector') (#3171). * Improved performance of '--reorder-goals' (#3208). * Fixed space leaks in modular solver (#2916, #2914). * Made the solver aware of pkg-config constraints (#3023). * Added a new command: 'gen-bounds' (#3223). See http://softwaresimply.blogspot.se/2015/08/cabal-gen-bounds-easy-generation-of.html. * Tech preview of new nix-style isolated project-based builds. Currently provides the commands (new-)build/repl/configure. 1.22.9.0 Ryan Thomas March 2016 * Include Cabal-1.22.8.0 1.22.8.0 Ryan Thomas February 2016 * Only Custom setup scripts should be compiled with '-i -i.'. * installedCabalVersion: Don't special-case Cabal anymore. * Bump the HTTP upper bound. See #3069. 1.22.7.0 Ryan Thomas December 2015 * Remove GZipUtils tests * maybeDecompress: bail on all errors at the beginning of the stream with zlib < 0.6 * Correct maybeDecompress 1.22.6.0 Ryan Thomas June 2015 * A fix for @ezyang's fix for #2502. (Mikhail Glushenkov) 1.22.5.0 Ryan Thomas June 2015 * Reduce temporary directory name length, fixes #2502. (Edward Z. Yang) 1.22.4.0 Ryan Thomas May 2015 * Force cabal upload to always use digest auth and never basic auth. * Add dependency-graph information to `printPlan` output * bootstrap.sh: fixes linker matching to avoid cases where tested linker names appear unexpectedly in compiler output (fixes #2542) 1.22.3.0 Ryan Thomas April 2015 * Fix bash completion for sandbox subcommands - Fixes #2513 (Mikhail Glushenkov) * filterConfigureFlags: filter more flags (Mikhail Glushenkov) 1.22.2.0 Ryan Thomas March 2015 * Don't pass '--{en,dis}able-profiling' to old setup exes. * -Wall police * Allow filepath 1.4 1.22.0.0 Johan Tibell January 2015 * New command: user-config (#2159). * Implement 'cabal repl --only' (#2016). * Fix an issue when 'cabal repl' was doing unnecessary compilation (#1715). * Prompt the user to specify source directory in 'cabal init' (#1989). * Remove the self-upgrade check (#2090). * Don't redownload already downloaded packages when bootstrapping (#2133). * Support sandboxes in 'bootstrap.sh' (#2137). * Install profiling and shared libs by default in 'bootstrap.sh' (#2009). 1.20.2.0 Ryan Thomas February 2016 * Only Custom setup scripts should be compiled with '-i -i.'. * installedCabalVersion: Don't special-case Cabal anymore. 1.20.1.0 Ryan Thomas May 2015 * Force cabal upload to always use digest auth and never basic auth. * bootstrap.sh: install network-uri before HTTP 1.20.0.5 Johan Tibell December 2014 * Support random 1.1. * Fix bootstrap script after network package split. * Support network-2.6 in test suite. 1.20.0.3 Johan Tibell June 2014 * Don't attempt to rename dist if it is already named correctly * Treat all flags of a package as interdependent. * Allow template-haskell to be upgradable again 1.20.0.2 Johan Tibell May 2014 * Increase max-backjumps to 2000. * Fix solver bug which led to missed install plans. * Fix streaming test output. * Tweak solver heuristics to avoid reinstalls. 1.20.0.1 Johan Tibell May 2014 * Fix cabal repl search path bug on Windows * Include OS and arch in cabal-install user agent * Revert --constraint flag behavior in configure to 1.18 behavior 1.20.0.0 Johan Tibell April 2014 * Build only selected executables * Add -j flag to build/test/bench/run * Improve install log file * Don't symlink executables when in a sandbox * Add --package-db flag to 'list' and 'info' * Make upload more efficient * Add --require-sandbox option * Add experimental Cabal file format command * Add haddock section to config file * Add --main-is flag to init 1.18.2.0 Ryan Thomas February 2016 * Only Custom setup scripts should be compiled with '-i -i.'. * installedCabalVersion: Don't special-case Cabal anymore. 1.18.1.0 Ryan Thomas May 2015 * Force cabal upload to always use digest auth and never basic auth. * Merge pull request #2367 from juhp/patch-2 * Fix bootstrap.sh by bumping HTTP to 4000.2.16.1 1.18.0.7 Johan Tibell December 2014 * Support random 1.1. * Fix bootstrap script after network package split. * Support network-2.6 in test suite. 1.18.0.5 Johan Tibell July 2014 * Make solver flag resolution more conservative. 1.18.0.4 Johan Tibell May 2014 * Increase max-backjumps to 2000. * Fix solver bug which led to missed install plans. * Tweak solver heuristics to avoid reinstalls. 0.14.0 Andres Loeh April 2012 * Works with ghc-7.4 * Completely new modular dependency solver (default in most cases) * Some tweaks to old topdown dependency solver * Install plans are now checked for reinstalls that break packages * Flags --constraint and --preference work for nonexisting packages * New constraint forms for source and installed packages * New constraint form for package-specific use flags * New constraint form for package-specific stanza flags * Test suite dependencies are pulled in on demand * No longer install packages on --enable-tests when tests fail * New "cabal bench" command * Various "cabal init" tweaks 0.10.0 Duncan Coutts February 2011 * New package targets: local dirs, local and remote tarballs * Initial support for a "world" package target * Partial fix for situation where user packages mask global ones * Removed cabal upgrade, new --upgrade-dependencies flag * New cabal install --only-dependencies flag * New cabal fetch --no-dependencies and --dry-run flags * Improved output for cabal info * Simpler and faster bash command line completion * Fix for broken proxies that decompress wrongly * Fix for cabal unpack to preserve executable permissions * Adjusted the output for the -v verbosity level in a few places 0.8.2 Duncan Coutts March 2010 * Fix for cabal update on Windows * On windows switch to per-user installs (rather than global) * Handle intra-package dependencies in dependency planning * Minor tweaks to cabal init feature * Fix various -Wall warnings * Fix for cabal sdist --snapshot 0.8.0 Duncan Coutts Dec 2009 * Works with ghc-6.12 * New "cabal init" command for making initial project .cabal file * New feature to maintain an index of haddock documentation 0.6.4 Duncan Coutts Nov 2009 * Improve the algorithm for selecting the base package version * Hackage errors now reported by "cabal upload [--check]" * Improved format of messages from "cabal check" * Config file can now be selected by an env var * Updated tar reading/writing code * Improve instructions in the README and bootstrap output * Fix bootstrap.sh on Solaris 9 * Fix bootstrap for systems where network uses parsec 3 * Fix building with ghc-6.6 0.6.2 Duncan Coutts Feb 2009 * The upgrade command has been disabled in this release * The configure and install commands now have consistent behaviour * Reduce the tendancy to re-install already existing packages * The --constraint= flag now works for the install command * New --preference= flag for soft constraints / version preferences * Improved bootstrap.sh script, smarter and better error checking * New cabal info command to display detailed info on packages * New cabal unpack command to download and untar a package * HTTP-4000 package required, should fix bugs with http proxies * Now works with authenticated proxies. * On Windows can now override the proxy setting using an env var * Fix compatibility with config files generated by older versions * Warn if the hackage package list is very old * More helpful --help output, mention config file and examples * Better documentation in ~/.cabal/config file * Improved command line interface for logging and build reporting * Minor improvements to some messages 0.6.0 Duncan Coutts Oct 2008 * Constraint solver can now cope with base 3 and base 4 * Allow use of package version preferences from hackage index * More detailed output from cabal install --dry-run -v * Improved bootstrap.sh 0.5.2 Duncan Coutts Aug 2008 * Suport building haddock documentaion * Self-reinstall now works on Windows * Allow adding symlinks to excutables into a separate bindir * New self-documenting config file * New install --reinstall flag * More helpful status messages in a couple places * Upload failures now report full text error message from the server * Support for local package repositories * New build logging and reporting * New command to upload build reports to (a compatible) server * Allow tilde in hackage server URIs * Internal code improvements * Many other minor improvements and bug fixes 0.5.1 Duncan Coutts June 2008 * Restore minimal hugs support in dependency resolver * Fix for disabled http proxies on Windows * Revert to global installs on Windows by default 0.5.0 Duncan Coutts June 2008 * New package dependency resolver, solving diamond dep problem * Integrate cabal-setup functionality * Integrate cabal-upload functionality * New cabal update and check commands * Improved behavior for install and upgrade commands * Full Windows support * New command line handling * Bash command line completion * Allow case insensitive package names on command line * New --dry-run flag for install, upgrade and fetch commands * New --root-cmd flag to allow installing as root * New --cabal-lib-version flag to select different Cabal lib versions * Support for HTTP proxies * Improved cabal list output * Build other non-dependent packages even when some fail * Report a summary of all build failures at the end * Partial support for hugs * Partial implementation of build reporting and logging * More consistent logging and verbosity * Significant internal code restructuring 0.4 Duncan Coutts Oct 2007 * Renamed executable from 'cabal-install' to 'cabal' * Partial Windows compatibility * Do per-user installs by default * cabal install now installs the package in the current directory * Allow multiple remote servers * Use zlib lib and internal tar code and rather than external tar * Reorganised configuration files * Significant code restructuring * Cope with packages with conditional dependencies 0.3 and older versions by Lemmih, Paolo Martini and others 2006-2007 * Switch from smart-server, dumb-client model to the reverse * New .tar.gz based index format * New remote and local package archive format cabal-install-2.4.0.0/main/0000755000000000000000000000000000000000000013434 5ustar0000000000000000cabal-install-2.4.0.0/main/Main.hs0000644000000000000000000016037500000000000014670 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (c) David Himmelstrup 2005 -- License : BSD-like -- -- Maintainer : lemmih@gmail.com -- Stability : provisional -- Portability : portable -- -- Entry point to the default cabal-install front-end. ----------------------------------------------------------------------------- module Main (main) where import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, withRepoContext , ConfigFlags(..) , ConfigExFlags(..), defaultConfigExFlags, configureExCommand , reconfigureCommand , configCompilerAux', configPackageDB' , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , buildCommand, replCommand, testCommand, benchmarkCommand , InstallFlags(..), defaultInstallFlags , installCommand, upgradeCommand, uninstallCommand , FetchFlags(..), fetchCommand , FreezeFlags(..), freezeCommand , genBoundsCommand , OutdatedFlags(..), outdatedCommand , GetFlags(..), getCommand, unpackCommand , checkCommand , formatCommand , UpdateFlags(..), updateCommand , ListFlags(..), listCommand , InfoFlags(..), infoCommand , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , runCommand , InitFlags(initVerbosity), initCommand , SDistFlags(..), SDistExFlags(..), sdistCommand , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand , ActAsSetupFlags(..), actAsSetupCommand , SandboxFlags(..), sandboxCommand , ExecFlags(..), execCommand , UserConfigFlags(..), userConfigCommand , reportCommand , manpageCommand , haddockCommand , cleanCommand , doctestCommand , copyCommand , registerCommand ) import Distribution.Simple.Setup ( HaddockTarget(..) , DoctestFlags(..) , HaddockFlags(..), defaultHaddockFlags , HscolourFlags(..), hscolourCommand , ReplFlags(..) , CopyFlags(..) , RegisterFlags(..) , CleanFlags(..) , TestFlags(..), BenchmarkFlags(..) , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag , configAbsolutePaths ) import Prelude () import Distribution.Solver.Compat.Prelude hiding (get) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) import Distribution.Client.Targets ( readUserTargets ) import qualified Distribution.Client.List as List ( list, info ) import qualified Distribution.Client.CmdConfigure as CmdConfigure import qualified Distribution.Client.CmdUpdate as CmdUpdate import qualified Distribution.Client.CmdBuild as CmdBuild import qualified Distribution.Client.CmdRepl as CmdRepl import qualified Distribution.Client.CmdFreeze as CmdFreeze import qualified Distribution.Client.CmdHaddock as CmdHaddock import qualified Distribution.Client.CmdInstall as CmdInstall import qualified Distribution.Client.CmdRun as CmdRun import qualified Distribution.Client.CmdTest as CmdTest import qualified Distribution.Client.CmdBench as CmdBench import qualified Distribution.Client.CmdExec as CmdExec import qualified Distribution.Client.CmdClean as CmdClean import qualified Distribution.Client.CmdSdist as CmdSdist import Distribution.Client.CmdLegacy import Distribution.Client.Install (install) import Distribution.Client.Configure (configure, writeConfigFlags) import Distribution.Client.Update (update) import Distribution.Client.Exec (exec) import Distribution.Client.Fetch (fetch) import Distribution.Client.Freeze (freeze) import Distribution.Client.GenBounds (genBounds) import Distribution.Client.Outdated (outdated) import Distribution.Client.Check as Check (check) --import Distribution.Client.Clean (clean) import qualified Distribution.Client.Upload as Upload import Distribution.Client.Run (run, splitRunArgs) import Distribution.Client.SrcDist (sdist) import Distribution.Client.Get (get) import Distribution.Client.Reconfigure (Check(..), reconfigure) import Distribution.Client.Nix (nixInstantiate ,nixShell ,nixShellIfSandboxed) import Distribution.Client.Sandbox (sandboxInit ,sandboxAddSource ,sandboxDelete ,sandboxDeleteSource ,sandboxListSources ,sandboxHcPkg ,dumpPackageEnvironment ,loadConfigOrSandboxConfig ,findSavedDistPref ,initPackageDBIfNeeded ,maybeWithSandboxDirOnSearchPath ,maybeWithSandboxPackageInfo ,tryGetIndexFilePath ,sandboxBuildDir ,updateSandboxConfigFileFlag ,updateInstallDirs ,getPersistOrConfigCompiler) import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB) import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) import Distribution.Client.Tar (createTarGzFile) import Distribution.Client.Types (Password (..)) import Distribution.Client.Init (initCabal) import Distribution.Client.Manpage (manpage) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Client.Utils (determineNumJobs #if defined(mingw32_HOST_OS) ,relaxEncodingErrors #endif ) import Distribution.Package (packageId) import Distribution.PackageDescription ( BuildType(..), Executable(..), buildable ) import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) import Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription ) import qualified Distribution.Simple as Simple import qualified Distribution.Make as Make import qualified Distribution.Types.UnqualComponentName as Make import Distribution.Simple.Build ( startInterpreter ) import Distribution.Simple.Command ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) , CommandType(..), commandsRun, commandAddAction, hiddenCommand , commandFromSpec, commandShowOptions ) import Distribution.Simple.Compiler (Compiler(..), PackageDBStack) import Distribution.Simple.Configure ( configCompilerAuxEx, ConfigStateFileError(..) , getPersistBuildConfig, interpretPackageDbFlags , tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Program (defaultProgramDb ,configureAllKnownPrograms ,simpleProgramInvocation ,getProgramInvocationOutput) import Distribution.Simple.Program.Db (reconfigurePrograms) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler , findPackageDesc, tryFindPackageDesc ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity ( Verbosity, normal ) import Distribution.Version ( Version, mkVersion, orLaterVersion ) import qualified Paths_cabal_install (version) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure, exitSuccess) import System.FilePath ( dropExtension, splitExtension , takeExtension, (), (<.>)) import System.IO ( BufferMode(LineBuffering), hSetBuffering #ifdef mingw32_HOST_OS , stderr #endif , stdout ) import System.Directory (doesFileExist, getCurrentDirectory) import Data.Monoid (Any(..)) import Control.Exception (SomeException(..), try) import Control.Monad (mapM_) #ifdef MONOLITHIC import qualified UnitTests import qualified MemoryUsageTests import qualified SolverQuickCheck import qualified IntegrationTests2 import qualified System.Environment as Monolithic #endif -- | Entry point -- main :: IO () #ifdef MONOLITHIC main = do mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE" case mb_exec of Just "UnitTests" -> UnitTests.main Just "MemoryUsageTests" -> MemoryUsageTests.main Just "SolverQuickCheck" -> SolverQuickCheck.main Just "IntegrationTests2" -> IntegrationTests2.main Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE" Nothing -> main' #else main = main' #endif main' :: IO () main' = do -- Enable line buffering so that we can get fast feedback even when piped. -- This is especially important for CI and build systems. hSetBuffering stdout LineBuffering -- The default locale encoding for Windows CLI is not UTF-8 and printing -- Unicode characters to it will fail unless we relax the handling of encoding -- errors when writing to stderr and stdout. #ifdef mingw32_HOST_OS relaxEncodingErrors stdout relaxEncodingErrors stderr #endif getArgs >>= mainWorker mainWorker :: [String] -> IO () mainWorker args = do validScript <- if null args then return False else doesFileExist (last args) topHandler $ case commandsRun (globalCommand commands) commands args of CommandHelp help -> printGlobalHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo (globalFlags, commandParse) -> case commandParse of _ | fromFlagOrDefault False (globalVersion globalFlags) -> printVersion | fromFlagOrDefault False (globalNumericVersion globalFlags) -> printNumericVersion CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts CommandErrors errs | validScript -> CmdRun.handleShebang (last args) | otherwise -> printErrors errs CommandReadyToGo action -> do globalFlags' <- updateSandboxConfigFileFlag globalFlags action globalFlags' where printCommandHelp help = do pname <- getProgName putStr (help pname) printGlobalHelp help = do pname <- getProgName configFile <- defaultConfigFile putStr (help pname) putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" ++ " " ++ configFile ++ "\n" exists <- doesFileExist configFile unless exists $ putStrLn $ "This file will be generated with sensible " ++ "defaults if you run 'cabal update'." printOptionsList = putStr . unlines printErrors errs = dieNoVerbosity $ intercalate "\n" errs printNumericVersion = putStrLn $ display Paths_cabal_install.version printVersion = putStrLn $ "cabal-install version " ++ display Paths_cabal_install.version ++ "\ncompiled using version " ++ display cabalVersion ++ " of the Cabal library " commands = map commandFromSpec commandSpecs commandSpecs = [ regularCmd listCommand listAction , regularCmd infoCommand infoAction , regularCmd fetchCommand fetchAction , regularCmd getCommand getAction , hiddenCmd unpackCommand unpackAction , regularCmd checkCommand checkAction , regularCmd uploadCommand uploadAction , regularCmd reportCommand reportAction , regularCmd initCommand initAction , regularCmd userConfigCommand userConfigAction , regularCmd genBoundsCommand genBoundsAction , regularCmd outdatedCommand outdatedAction , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref , hiddenCmd uninstallCommand uninstallAction , hiddenCmd formatCommand formatAction , hiddenCmd upgradeCommand upgradeAction , hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction , hiddenCmd actAsSetupCommand actAsSetupAction , hiddenCmd manpageCommand (manpageAction commandSpecs) ] ++ concat [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction , newCmd CmdBuild.buildCommand CmdBuild.buildAction , newCmd CmdRepl.replCommand CmdRepl.replAction , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction , newCmd CmdInstall.installCommand CmdInstall.installAction , newCmd CmdRun.runCommand CmdRun.runAction , newCmd CmdTest.testCommand CmdTest.testAction , newCmd CmdBench.benchCommand CmdBench.benchAction , newCmd CmdExec.execCommand CmdExec.execAction , newCmd CmdClean.cleanCommand CmdClean.cleanAction , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction , legacyCmd configureExCommand configureAction , legacyCmd updateCommand updateAction , legacyCmd buildCommand buildAction , legacyCmd replCommand replAction , legacyCmd freezeCommand freezeAction , legacyCmd haddockCommand haddockAction , legacyCmd installCommand installAction , legacyCmd runCommand runAction , legacyCmd testCommand testAction , legacyCmd benchmarkCommand benchmarkAction , legacyCmd execCommand execAction , legacyCmd cleanCommand cleanAction , legacyCmd sdistCommand sdistAction , legacyCmd doctestCommand doctestAction , legacyWrapperCmd copyCommand copyVerbosity copyDistPref , legacyWrapperCmd registerCommand regVerbosity regDistPref , legacyCmd reconfigureCommand reconfigureAction , legacyCmd sandboxCommand sandboxAction ] type Action = GlobalFlags -> IO () -- Duplicated in Distribution.Client.CmdLegacy. Any changes must be -- reflected there, as well. regularCmd :: CommandUI flags -> (flags -> [String] -> action) -> CommandSpec action regularCmd ui action = CommandSpec ui ((flip commandAddAction) action) NormalCommand hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) -> CommandSpec action hiddenCmd ui action = CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) HiddenCommand wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) -> CommandSpec Action wrapperCmd ui verbosity distPref = CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) -> Command Action wrapperAction command verbosityFlag distPrefFlag = commandAddAction command { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do let verbosity = fromFlagOrDefault normal (verbosityFlag flags) load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) snd load distPref <- findSavedDistPref config (distPrefFlag flags) let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } setupWrapper verbosity setupScriptOptions Nothing command (const flags) (const extraArgs) configureAction :: (ConfigFlags, ConfigExFlags) -> [String] -> Action configureAction (configFlags, configExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) <$> loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (configDistPref configFlags) nixInstantiate verbosity distPref True globalFlags config nixShell verbosity distPref globalFlags config $ do let configFlags' = savedConfigureFlags config `mappend` configFlags configExFlags' = savedConfigureExFlags config `mappend` configExFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAuxEx configFlags' -- If we're working inside a sandbox and the user has set the -w option, we -- may need to create a sandbox-local package DB for this compiler and add a -- timestamp record for this compiler to the timestamp file. let configFlags'' = case useSandbox of NoSandbox -> configFlags' (UseSandbox sandboxDir) -> setPackageDB sandboxDir comp platform configFlags' writeConfigFlags verbosity distPref (configFlags'', configExFlags') -- What package database(s) to use let packageDBs :: PackageDBStack packageDBs = interpretPackageDbFlags (fromFlag (configUserInstall configFlags'')) (configPackageDBs configFlags'') whenUsingSandbox useSandbox $ \sandboxDir -> do initPackageDBIfNeeded verbosity configFlags'' comp progdb -- NOTE: We do not write the new sandbox package DB location to -- 'cabal.sandbox.config' here because 'configure -w' must not affect -- subsequent 'install' (for UI compatibility with non-sandboxed mode). indexFile <- tryGetIndexFilePath verbosity config maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile (compilerId comp) platform maybeWithSandboxDirOnSearchPath useSandbox $ withRepoContext verbosity globalFlags' $ \repoContext -> configure verbosity packageDBs repoContext comp platform progdb configFlags'' configExFlags' extraArgs reconfigureAction :: (ConfigFlags, ConfigExFlags) -> [String] -> Action reconfigureAction flags@(configFlags, _) _ globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) <$> loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (configDistPref configFlags) let checkFlags = Check $ \_ saved -> do let flags' = saved <> flags unless (saved == flags') $ info verbosity message pure (Any True, flags') where -- This message is correct, but not very specific: it will list all -- of the new flags, even if some have not actually changed. The -- *minimal* set of changes is more difficult to determine. message = "flags changed: " ++ unwords (commandShowOptions configureExCommand flags) nixInstantiate verbosity distPref True globalFlags config _ <- reconfigure configureAction verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag checkFlags [] globalFlags config pure () buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck (buildOnly buildExFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (buildDistPref buildFlags) -- Calls 'configureAction' to do the real work, so nothing special has to be -- done to support sandboxes. config' <- reconfigure configureAction verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) mempty [] globalFlags config nixShell verbosity distPref globalFlags config $ do maybeWithSandboxDirOnSearchPath useSandbox $ build verbosity config' distPref buildFlags extraArgs -- | Actually do the work of building the package. This is separate from -- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke -- 'reconfigure' twice. build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () build verbosity config distPref buildFlags extraArgs = setupWrapper verbosity setupOptions Nothing (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs) where progDb = defaultProgramDb setupOptions = defaultSetupScriptOptions { useDistPref = distPref } mkBuildFlags version = filterBuildFlags version config buildFlags' buildFlags' = buildFlags { buildVerbosity = toFlag verbosity , buildDistPref = toFlag distPref } -- | Make sure that we don't pass new flags to setup scripts compiled against -- old versions of Cabal. filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags filterBuildFlags version config buildFlags | version >= mkVersion [1,19,1] = buildFlags_latest -- Cabal < 1.19.1 doesn't support 'build -j'. | otherwise = buildFlags_pre_1_19_1 where buildFlags_pre_1_19_1 = buildFlags { buildNumJobs = NoFlag } buildFlags_latest = buildFlags { -- Take the 'jobs' setting '~/.cabal/config' into account. buildNumJobs = Flag . Just . determineNumJobs $ (numJobsConfigFlag `mappend` numJobsCmdLineFlag) } numJobsConfigFlag = installNumJobs . savedInstallFlags $ config numJobsCmdLineFlag = buildNumJobs buildFlags replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action replAction (replFlags, buildExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (replDistPref replFlags) cwd <- getCurrentDirectory pkgDesc <- findPackageDesc cwd let -- There is a .cabal file in the current directory: start a REPL and load -- the project's modules. onPkgDesc = do let noAddSource = case replReload replFlags of Flag True -> SkipAddSourceDepsCheck _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck (buildOnly buildExFlags) -- Calls 'configureAction' to do the real work, so nothing special has to -- be done to support sandboxes. _ <- reconfigure configureAction verbosity distPref useSandbox noAddSource NoFlag mempty [] globalFlags config let progDb = defaultProgramDb setupOptions = defaultSetupScriptOptions { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] , useDistPref = distPref } replFlags' = replFlags { replVerbosity = toFlag verbosity , replDistPref = toFlag distPref } nixShell verbosity distPref globalFlags config $ do maybeWithSandboxDirOnSearchPath useSandbox $ setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs) -- No .cabal file in the current directory: just start the REPL (possibly -- using the sandbox package DB). onNoPkgDesc = do let configFlags = savedConfigureFlags config (comp, platform, programDb) <- configCompilerAux' configFlags programDb' <- reconfigurePrograms verbosity (replProgramPaths replFlags) (replProgramArgs replFlags) programDb nixShell verbosity distPref globalFlags config $ do startInterpreter verbosity programDb' comp platform (configPackageDB' configFlags) either (const onNoPkgDesc) (const onPkgDesc) pkgDesc installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> Action installAction (configFlags, _, installFlags, _) _ globalFlags | fromFlagOrDefault False (installOnly installFlags) = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags dist <- findSavedDistPref config (configDistPref configFlags) let setupOpts = defaultSetupScriptOptions { useDistPref = dist } nixShellIfSandboxed verb dist globalFlags config useSandbox $ setupWrapper verb setupOpts Nothing installCommand (const mempty) (const []) installAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) <$> loadConfigOrSandboxConfig verb globalFlags let sandboxDist = case useSandbox of NoSandbox -> NoFlag UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir dist <- findSavedDistPref config (configDistPref configFlags `mappend` sandboxDist) nixShellIfSandboxed verb dist globalFlags config useSandbox $ do targets <- readUserTargets verb extraArgs -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to -- 'configure' when run inside a sandbox. Right now, running -- -- $ cabal sandbox init && cabal configure -w /path/to/ghc -- && cabal build && cabal install -- -- performs the compilation twice unless you also pass -w to 'install'. -- However, this is the same behaviour that 'cabal install' has in the normal -- mode of operation, so we stick to it for consistency. let configFlags' = maybeForceTests installFlags' $ savedConfigureFlags config `mappend` configFlags { configDistPref = toFlag dist } configExFlags' = defaultConfigExFlags `mappend` savedConfigureExFlags config `mappend` configExFlags installFlags' = defaultInstallFlags `mappend` savedInstallFlags config `mappend` installFlags haddockFlags' = defaultHaddockFlags `mappend` savedHaddockFlags config `mappend` haddockFlags { haddockDistPref = toFlag dist } globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags' -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the -- future. progdb' <- configureAllKnownPrograms verb progdb -- If we're working inside a sandbox and the user has set the -w option, we -- may need to create a sandbox-local package DB for this compiler and add a -- timestamp record for this compiler to the timestamp file. configFlags'' <- case useSandbox of NoSandbox -> configAbsolutePaths $ configFlags' (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform configFlags' whenUsingSandbox useSandbox $ \sandboxDir -> do initPackageDBIfNeeded verb configFlags'' comp progdb' indexFile <- tryGetIndexFilePath verb config maybeAddCompilerTimestampRecord verb sandboxDir indexFile (compilerId comp) platform -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means -- that 'cabal install some-package' inside a sandbox will sometimes reinstall -- modified add-source deps, even if they are not among the dependencies of -- 'some-package'. This can also prevent packages that depend on older -- versions of add-source'd packages from building (see #1362). maybeWithSandboxPackageInfo verb configFlags'' globalFlags' comp platform progdb useSandbox $ \mSandboxPkgInfo -> maybeWithSandboxDirOnSearchPath useSandbox $ withRepoContext verb globalFlags' $ \repoContext -> install verb (configPackageDB' configFlags'') repoContext comp platform progdb' useSandbox mSandboxPkgInfo globalFlags' configFlags'' configExFlags' installFlags' haddockFlags' targets where -- '--run-tests' implies '--enable-tests'. maybeForceTests installFlags' configFlags' = if fromFlagOrDefault False (installRunTests installFlags') then configFlags' { configTests = toFlag True } else configFlags' testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO () testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (testDistPref testFlags) let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck (buildOnly buildExFlags) buildFlags' = buildFlags { buildVerbosity = testVerbosity testFlags } checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> if fromFlagOrDefault False (configTests configFlags) then pure (mempty, flags) else do info verbosity "reconfiguring to enable tests" let flags' = ( configFlags { configTests = toFlag True } , configExFlags ) pure (Any True, flags') -- reconfigure also checks if we're in a sandbox and reinstalls add-source -- deps if needed. _ <- reconfigure configureAction verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') checkFlags [] globalFlags config nixShell verbosity distPref globalFlags config $ do let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } testFlags' = testFlags { testDistPref = toFlag distPref } -- The package was just configured, so the LBI must be available. names <- componentNamesFromLBI verbosity distPref "test suites" (\c -> case c of { LBI.CTest{} -> True; _ -> False }) let extraArgs' | null extraArgs = case names of ComponentNamesUnknown -> [] ComponentNames names' -> [ Make.unUnqualComponentName name | LBI.CTestName name <- names' ] | otherwise = extraArgs maybeWithSandboxDirOnSearchPath useSandbox $ build verbosity config distPref buildFlags' extraArgs' maybeWithSandboxDirOnSearchPath useSandbox $ setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs') data ComponentNames = ComponentNamesUnknown | ComponentNames [LBI.ComponentName] -- | Return the names of all buildable components matching a given predicate. componentNamesFromLBI :: Verbosity -> FilePath -> String -> (LBI.Component -> Bool) -> IO ComponentNames componentNamesFromLBI verbosity distPref targetsDescr compPred = do eLBI <- tryGetPersistBuildConfig distPref case eLBI of Left err -> case err of -- Note: the build config could have been generated by a custom setup -- script built against a different Cabal version, so it's crucial that -- we ignore the bad version error here. ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown _ -> die' verbosity (show err) Right lbi -> do let pkgDescr = LBI.localPkgDescr lbi names = map LBI.componentName . filter (buildable . LBI.componentBuildInfo) . filter compPred $ LBI.pkgComponents pkgDescr if null names then do notice verbosity $ "Package has no buildable " ++ targetsDescr ++ "." exitSuccess -- See #3215. else return $! (ComponentNames names) benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO () benchmarkAction (benchmarkFlags, buildFlags, buildExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (benchmarkVerbosity benchmarkFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) let buildFlags' = buildFlags { buildVerbosity = benchmarkVerbosity benchmarkFlags } noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck (buildOnly buildExFlags) let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> if fromFlagOrDefault False (configBenchmarks configFlags) then pure (mempty, flags) else do info verbosity "reconfiguring to enable benchmarks" let flags' = ( configFlags { configBenchmarks = toFlag True } , configExFlags ) pure (Any True, flags') -- reconfigure also checks if we're in a sandbox and reinstalls add-source -- deps if needed. config' <- reconfigure configureAction verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') checkFlags [] globalFlags config nixShell verbosity distPref globalFlags config $ do let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } -- The package was just configured, so the LBI must be available. names <- componentNamesFromLBI verbosity distPref "benchmarks" (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) let extraArgs' | null extraArgs = case names of ComponentNamesUnknown -> [] ComponentNames names' -> [ Make.unUnqualComponentName name | LBI.CBenchName name <- names'] | otherwise = extraArgs maybeWithSandboxDirOnSearchPath useSandbox $ build verbosity config' distPref buildFlags' extraArgs' maybeWithSandboxDirOnSearchPath useSandbox $ setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do let verbosity = fromFlag (haddockVerbosity haddockFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (haddockDistPref haddockFlags) config' <- reconfigure configureAction verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag mempty [] globalFlags config nixShell verbosity distPref globalFlags config $ do let haddockFlags' = defaultHaddockFlags `mappend` savedHaddockFlags config' `mappend` haddockFlags { haddockDistPref = toFlag distPref } setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } setupWrapper verbosity setupScriptOptions Nothing haddockCommand (const haddockFlags') (const extraArgs) when (haddockForHackage haddockFlags == Flag ForHackage) $ do pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) let dest = distPref name <.> "tar.gz" name = display (packageId pkg) ++ "-docs" docDir = distPref "doc" "html" createTarGzFile dest docDir name notice verbosity $ "Documentation tarball created: " ++ dest doctestAction :: DoctestFlags -> [String] -> Action doctestAction doctestFlags extraArgs _globalFlags = do let verbosity = fromFlag (doctestVerbosity doctestFlags) setupWrapper verbosity defaultSetupScriptOptions Nothing doctestCommand (const doctestFlags) (const extraArgs) cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) snd load distPref <- findSavedDistPref config (cleanDistPref cleanFlags) let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref , useWin32CleanHack = True } cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } setupWrapper verbosity setupScriptOptions Nothing cleanCommand (const cleanFlags') (const extraArgs) where verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) listAction :: ListFlags -> [String] -> Action listAction listFlags extraArgs globalFlags = do let verbosity = fromFlag (listVerbosity listFlags) (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) let configFlags' = savedConfigureFlags config configFlags = configFlags' { configPackageDBs = configPackageDBs configFlags' `mappend` listPackageDBs listFlags } globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, _, progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> List.list verbosity (configPackageDB' configFlags) repoContext comp progdb listFlags extraArgs infoAction :: InfoFlags -> [String] -> Action infoAction infoFlags extraArgs globalFlags = do let verbosity = fromFlag (infoVerbosity infoFlags) targets <- readUserTargets verbosity extraArgs (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) let configFlags' = savedConfigureFlags config configFlags = configFlags' { configPackageDBs = configPackageDBs configFlags' `mappend` infoPackageDBs infoFlags } globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, _, progdb) <- configCompilerAuxEx configFlags withRepoContext verbosity globalFlags' $ \repoContext -> List.info verbosity (configPackageDB' configFlags) repoContext comp progdb globalFlags' infoFlags targets updateAction :: 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 (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) let globalFlags' = savedGlobalFlags config `mappend` globalFlags withRepoContext verbosity globalFlags' $ \repoContext -> update verbosity updateFlags repoContext upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> Action upgradeAction (configFlags, _, _, _) _ _ = die' verbosity $ "Use the 'cabal install' command instead of 'cabal upgrade'.\n" ++ "You can install the latest version of a package using 'cabal install'. " ++ "The 'cabal upgrade' command has been removed because people found it " ++ "confusing and it often led to broken packages.\n" ++ "If you want the old upgrade behaviour then use the install command " ++ "with the --upgrade-dependencies flag (but check first with --dry-run " ++ "to see what would happen). This will try to pick the latest versions " ++ "of all dependencies, rather than the usual behaviour of trying to pick " ++ "installed versions of all dependencies. If you do use " ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " ++ "packages (e.g. by using appropriate --constraint= flags)." where verbosity = fromFlag (configVerbosity configFlags) fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do let verbosity = fromFlag (fetchVerbosity fetchFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> fetch verbosity (configPackageDB' configFlags) repoContext comp platform progdb globalFlags' fetchFlags targets freezeAction :: FreezeFlags -> [String] -> Action freezeAction freezeFlags _extraArgs globalFlags = do let verbosity = fromFlag (freezeVerbosity freezeFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config NoFlag nixShell verbosity distPref globalFlags config $ do let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags maybeWithSandboxPackageInfo verbosity configFlags globalFlags' comp platform progdb useSandbox $ \mSandboxPkgInfo -> maybeWithSandboxDirOnSearchPath useSandbox $ withRepoContext verbosity globalFlags' $ \repoContext -> freeze verbosity (configPackageDB' configFlags) repoContext comp platform progdb mSandboxPkgInfo globalFlags' freezeFlags genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () genBoundsAction freezeFlags _extraArgs globalFlags = do let verbosity = fromFlag (freezeVerbosity freezeFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config NoFlag nixShell verbosity distPref globalFlags config $ do let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags maybeWithSandboxPackageInfo verbosity configFlags globalFlags' comp platform progdb useSandbox $ \mSandboxPkgInfo -> maybeWithSandboxDirOnSearchPath useSandbox $ withRepoContext verbosity globalFlags' $ \repoContext -> genBounds verbosity (configPackageDB' configFlags) repoContext comp platform progdb mSandboxPkgInfo globalFlags' freezeFlags outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () outdatedAction outdatedFlags _extraArgs globalFlags = do let verbosity = fromFlag (outdatedVerbosity outdatedFlags) (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, _progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> outdated verbosity outdatedFlags repoContext comp platform uploadAction :: UploadFlags -> [String] -> Action uploadAction uploadFlags extraArgs globalFlags = do config <- loadConfig verbosity (globalConfigFile globalFlags) let uploadFlags' = savedUploadFlags config `mappend` uploadFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags tarfiles = extraArgs when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ die' verbosity "the 'upload' command expects at least one .tar.gz archive." checkTarFiles extraArgs maybe_password <- case uploadPasswordCmd uploadFlags' of Flag (xs:xss) -> Just . Password <$> getProgramInvocationOutput verbosity (simpleProgramInvocation xs xss) _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' withRepoContext verbosity globalFlags' $ \repoContext -> do if fromFlag (uploadDoc uploadFlags') then do when (length tarfiles > 1) $ die' verbosity $ "the 'upload' command can only upload documentation " ++ "for one package at a time." tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles Upload.uploadDoc verbosity repoContext (flagToMaybe $ uploadUsername uploadFlags') maybe_password (fromFlag (uploadCandidate uploadFlags')) tarfile else do Upload.upload verbosity repoContext (flagToMaybe $ uploadUsername uploadFlags') maybe_password (fromFlag (uploadCandidate uploadFlags')) tarfiles where verbosity = fromFlag (uploadVerbosity uploadFlags) checkTarFiles tarfiles | not (null otherFiles) = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " ++ intercalate ", " otherFiles | otherwise = sequence_ [ do exists <- doesFileExist tarfile unless exists $ die' verbosity $ "file not found: " ++ tarfile | tarfile <- tarfiles ] where otherFiles = filter (not . isTarGzFile) tarfiles isTarGzFile file = case splitExtension file of (file', ".gz") -> takeExtension file' == ".tar" _ -> False generateDocTarball config = do notice verbosity $ "No documentation tarball specified. " ++ "Building a documentation tarball with default settings...\n" ++ "If you need to customise Haddock options, " ++ "run 'haddock --for-hackage' first " ++ "to generate a documentation tarball." haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) [] globalFlags distPref <- findSavedDistPref config NoFlag pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" checkAction :: Flag Verbosity -> [String] -> Action checkAction verbosityFlag extraArgs _globalFlags = do let verbosity = fromFlag verbosityFlag unless (null extraArgs) $ die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs allOk <- Check.check (fromFlag verbosityFlag) unless allOk exitFailure formatAction :: Flag Verbosity -> [String] -> Action formatAction verbosityFlag extraArgs _globalFlags = do let verbosity = fromFlag verbosityFlag path <- case extraArgs of [] -> do cwd <- getCurrentDirectory tryFindPackageDesc cwd (p:_) -> return p pkgDesc <- readGenericPackageDescription verbosity path -- Uses 'writeFileAtomic' under the hood. writeGenericPackageDescription path pkgDesc uninstallAction :: Flag Verbosity -> [String] -> Action uninstallAction verbosityFlag extraArgs _globalFlags = do let verbosity = fromFlag verbosityFlag package = case extraArgs of p:_ -> p _ -> "PACKAGE_NAME" die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' " ++ "operation. " ++ "It will likely be implemented at some point in the future; " ++ "in the meantime you're advised to use either 'ghc-pkg unregister " ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do let verbosity = fromFlag (sDistVerbosity sdistFlags) unless (null extraArgs) $ die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) snd load distPref <- findSavedDistPref config (sDistDistPref sdistFlags) let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref } sdist sdistFlags' sdistExFlags reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do let verbosity = fromFlag (reportVerbosity reportFlags) unless (null extraArgs) $ die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) let globalFlags' = savedGlobalFlags config `mappend` globalFlags reportFlags' = savedReportFlags config `mappend` reportFlags withRepoContext verbosity globalFlags' $ \repoContext -> Upload.report verbosity repoContext (flagToMaybe $ reportUsername reportFlags') (flagToMaybe $ reportPassword reportFlags') runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action runAction (buildFlags, buildExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (buildDistPref buildFlags) let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck (buildOnly buildExFlags) -- reconfigure also checks if we're in a sandbox and reinstalls add-source -- deps if needed. config' <- reconfigure configureAction verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) mempty [] globalFlags config nixShell verbosity distPref globalFlags config $ do lbi <- getPersistBuildConfig distPref (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs maybeWithSandboxDirOnSearchPath useSandbox $ build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] maybeWithSandboxDirOnSearchPath useSandbox $ run verbosity lbi exe exeArgs getAction :: GetFlags -> [String] -> Action getAction getFlags extraArgs globalFlags = do let verbosity = fromFlag (getVerbosity getFlags) targets <- readUserTargets verbosity extraArgs (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) let globalFlags' = savedGlobalFlags config `mappend` globalFlags withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> get verbosity repoContext globalFlags' getFlags targets unpackAction :: GetFlags -> [String] -> Action unpackAction getFlags extraArgs globalFlags = do getAction getFlags extraArgs globalFlags initAction :: InitFlags -> [String] -> Action initAction initFlags extraArgs globalFlags = do let verbosity = fromFlag (initVerbosity initFlags) when (extraArgs /= []) $ die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) let configFlags = savedConfigureFlags config let globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, _, progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> initCabal verbosity (configPackageDB' configFlags) repoContext comp progdb initFlags sandboxAction :: SandboxFlags -> [String] -> Action sandboxAction sandboxFlags extraArgs globalFlags = do let verbosity = fromFlag (sandboxVerbosity sandboxFlags) case extraArgs of -- Basic sandbox commands. ["init"] -> sandboxInit verbosity sandboxFlags globalFlags ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags ("add-source":extra) -> do when (noExtraArgs extra) $ die' verbosity "The 'sandbox add-source' command expects at least one argument" sandboxAddSource verbosity extra sandboxFlags globalFlags ("delete-source":extra) -> do when (noExtraArgs extra) $ die' verbosity ("The 'sandbox delete-source' command expects " ++ "at least one argument") sandboxDeleteSource verbosity extra sandboxFlags globalFlags ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags -- More advanced commands. ("hc-pkg":extra) -> do when (noExtraArgs extra) $ die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument" sandboxHcPkg verbosity sandboxFlags globalFlags extra ["buildopts"] -> die' verbosity "Not implemented!" -- Hidden commands. ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags -- Error handling. [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')" _ -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs where noExtraArgs = (<1) . length execAction :: ExecFlags -> [String] -> Action execAction execFlags extraArgs globalFlags = do let verbosity = fromFlag (execVerbosity execFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (execDistPref execFlags) let configFlags = savedConfigureFlags config configFlags' = configFlags { configDistPref = Flag distPref } (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' exec verbosity useSandbox comp platform progdb extraArgs userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do let verbosity = fromFlag (userConfigVerbosity ucflags) force = fromFlag (userConfigForce ucflags) extraLines = fromFlag (userConfigAppendLines ucflags) case extraArgs of ("init":_) -> do path <- configFile fileExists <- doesFileExist path if (not fileExists || (fileExists && force)) then void $ createDefaultConfigFile verbosity extraLines path else die' verbosity $ path ++ " already exists." ("diff":_) -> mapM_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines ("update":_) -> userConfigUpdate verbosity globalFlags extraLines -- Error handling. [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs where configFile = getConfigFilePath (globalConfigFile globalFlags) -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. -- win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse win32SelfUpgradeAction _ _ _ = return () -- | Used as an entry point when cabal-install needs to invoke itself -- as a setup script. This can happen e.g. when doing parallel builds. -- actAsSetupAction :: ActAsSetupFlags -> [String] -> Action actAsSetupAction actAsSetupFlags args _globalFlags = let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) in case bt of Simple -> Simple.defaultMainArgs args Configure -> Simple.defaultMainWithHooksArgs Simple.autoconfUserHooks args Make -> Make.defaultMainArgs args Custom -> error "actAsSetupAction Custom" manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action manpageAction commands flagVerbosity extraArgs _ = do let verbosity = fromFlag flagVerbosity unless (null extraArgs) $ die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs pname <- getProgName let cabalCmd = if takeExtension pname == ".exe" then dropExtension pname else pname putStrLn $ manpage cabalCmd commands cabal-install-2.4.0.0/tests/IntegrationTests2/build/keep-going/0000755000000000000000000000000000000000000022366 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/build/keep-going/cabal.project0000755000000000000000000000001600000000000025020 0ustar0000000000000000packages: p q cabal-install-2.4.0.0/tests/IntegrationTests2/build/keep-going/p/0000755000000000000000000000000000000000000022625 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/build/keep-going/p/P.hs0000755000000000000000000000007500000000000023365 0ustar0000000000000000module P where p :: Int p = this_is_not_expected_to_compile cabal-install-2.4.0.0/tests/IntegrationTests2/build/keep-going/p/p.cabal0000755000000000000000000000016200000000000024052 0ustar0000000000000000name: p version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: P build-depends: base cabal-install-2.4.0.0/tests/IntegrationTests2/build/keep-going/q/0000755000000000000000000000000000000000000022626 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/build/keep-going/q/Q.hs0000755000000000000000000000004000000000000023357 0ustar0000000000000000module Q where q :: Int q = 42 cabal-install-2.4.0.0/tests/IntegrationTests2/build/keep-going/q/q.cabal0000755000000000000000000000016300000000000024055 0ustar0000000000000000name: q version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: Q build-depends: base cabal-install-2.4.0.0/tests/IntegrationTests2/build/local-tarball/0000755000000000000000000000000000000000000023052 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/build/local-tarball/cabal.project0000755000000000000000000000004400000000000025505 0ustar0000000000000000packages: p-0.1.tar.gz q/ cabal-install-2.4.0.0/tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz0000755000000000000000000000047700000000000024747 0ustar0000000000000000‹í•Ín„ €÷ÌSLö®MLvO½61Ù'À:$¨°í¾}YmšÔ¤ÙC«ýã» £aá%1½Ù­Jâ)8ŸZϲžiš&ŒS–¦ÔÇ‹¢HvÀ×ÖÌh0>ågÇYþÜ/AOõ?¡uÜÚur\Ö#ϲëÏó÷õ§4c|›,â?¯¿ìô`ÜJ댬G'‡>>ù BÒ ÙÃ|£rw¾G¾{¶¯fö_Ç÷¢j¥×ü§9[úÏ( þoA/:,A“G4Ö»_‚ߤ¥j"wÖþÕëa0íèí«ãhÌQ²6Âœ >ëÁbuC3*´%T>8Ԡƾñ¡ZX gÈbö¿Zíî¿põþO³…ÿ gIð f]¡‚§ ¢ý¿oQ©aL ?Ì }(cabal-install-2.4.0.0/tests/IntegrationTests2/build/local-tarball/q/0000755000000000000000000000000000000000000023312 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/build/local-tarball/q/Q.hs0000755000000000000000000000005400000000000024050 0ustar0000000000000000module Q where import P q = p ++ " world" cabal-install-2.4.0.0/tests/IntegrationTests2/build/local-tarball/q/q.cabal0000755000000000000000000000016500000000000024543 0ustar0000000000000000name: q version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: Q build-depends: base, p cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-custom1/0000755000000000000000000000000000000000000023072 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-custom1/A.hs0000755000000000000000000000004000000000000023603 0ustar0000000000000000module A where a :: Int a = 42 cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-custom1/Setup.hs0000755000000000000000000000011100000000000024522 0ustar0000000000000000import Distribution.Simple main = defaultMain >> writeFile "marker" "ok" cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-custom1/a.cabal0000755000000000000000000000033600000000000024303 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-custom2/0000755000000000000000000000000000000000000023073 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-custom2/A.hs0000755000000000000000000000004000000000000023604 0ustar0000000000000000module A where a :: Int a = 42 cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-custom2/Setup.hs0000755000000000000000000000011100000000000024523 0ustar0000000000000000import Distribution.Simple main = defaultMain >> writeFile "marker" "ok" cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-custom2/a.cabal0000755000000000000000000000025600000000000024305 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-simple/0000755000000000000000000000000000000000000022770 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-simple/A.hs0000755000000000000000000000004000000000000023501 0ustar0000000000000000module A where a :: Int a = 42 cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-simple/Setup.hs0000755000000000000000000000005600000000000024430 0ustar0000000000000000import Distribution.Simple main = defaultMain cabal-install-2.4.0.0/tests/IntegrationTests2/build/setup-simple/a.cabal0000755000000000000000000000022300000000000024174 0ustar0000000000000000name: a version: 0.1 build-type: Simple cabal-version: >= 1.10 library exposed-modules: A build-depends: base default-language: Haskell2010 cabal-install-2.4.0.0/tests/IntegrationTests2/exception/bad-config/0000755000000000000000000000000000000000000023231 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/exception/bad-config/cabal.project0000755000000000000000000000005300000000000025664 0ustar0000000000000000packages: package foo ghc-location: bar cabal-install-2.4.0.0/tests/IntegrationTests2/exception/build/0000755000000000000000000000000000000000000022337 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/exception/build/Main.hs0000755000000000000000000000003400000000000023557 0ustar0000000000000000main = thisNameDoesNotExist cabal-install-2.4.0.0/tests/IntegrationTests2/exception/build/a.cabal0000755000000000000000000000016300000000000023546 0ustar0000000000000000name: a version: 1 build-type: Simple cabal-version: >= 1.2 executable a main-is: Main.hs build-depends: base cabal-install-2.4.0.0/tests/IntegrationTests2/exception/configure/0000755000000000000000000000000000000000000023221 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/exception/configure/a.cabal0000755000000000000000000000043000000000000024425 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/exception/no-pkg/0000755000000000000000000000000000000000000022433 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/exception/no-pkg/empty.in0000755000000000000000000000007700000000000024130 0ustar0000000000000000this is just here to ensure the source control creates the dir cabal-install-2.4.0.0/tests/IntegrationTests2/exception/no-pkg2/0000755000000000000000000000000000000000000022515 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/exception/no-pkg2/cabal.project0000755000000000000000000000001500000000000025146 0ustar0000000000000000packages: ./ cabal-install-2.4.0.0/tests/IntegrationTests2/regression/3324/0000755000000000000000000000000000000000000022015 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/regression/3324/cabal.project0000755000000000000000000000001600000000000024447 0ustar0000000000000000packages: p q cabal-install-2.4.0.0/tests/IntegrationTests2/regression/3324/p/0000755000000000000000000000000000000000000022254 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/regression/3324/p/P.hs0000755000000000000000000000004000000000000023004 0ustar0000000000000000module P where p :: Int p = 42 cabal-install-2.4.0.0/tests/IntegrationTests2/regression/3324/p/p.cabal0000755000000000000000000000016200000000000023501 0ustar0000000000000000name: p version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: P build-depends: base cabal-install-2.4.0.0/tests/IntegrationTests2/regression/3324/q/0000755000000000000000000000000000000000000022255 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/regression/3324/q/Q.hs0000755000000000000000000000005100000000000023010 0ustar0000000000000000module Q where import P q :: Int q = p cabal-install-2.4.0.0/tests/IntegrationTests2/regression/3324/q/q.cabal0000755000000000000000000000025400000000000023505 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/all-disabled/0000755000000000000000000000000000000000000023230 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/all-disabled/cabal.project0000755000000000000000000000001500000000000025661 0ustar0000000000000000packages: ./ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/all-disabled/p.cabal0000755000000000000000000000062200000000000024456 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/benchmarks-disabled/0000755000000000000000000000000000000000000024575 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project0000755000000000000000000000002200000000000027224 0ustar0000000000000000packages: ./ ./q/ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal0000755000000000000000000000042500000000000026024 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/benchmarks-disabled/q/0000755000000000000000000000000000000000000025035 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal0000755000000000000000000000023400000000000026263 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/complex/0000755000000000000000000000000000000000000022362 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/complex/cabal.project0000755000000000000000000000001500000000000025013 0ustar0000000000000000packages: q/ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/complex/q/0000755000000000000000000000000000000000000022622 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/complex/q/Q.hs0000755000000000000000000000000000000000000023347 0ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/complex/q/q.cabal0000755000000000000000000000057700000000000024062 0ustar0000000000000000name: q version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: Q build-depends: base, filepath executable buildable-false main-is: Main.hs buildable: False test-suite solver-disabled type: exitcode-stdio-1.0 main-is: Test.hs build-depends: a-package-that-does-not-exist benchmark user-disabled type: exitcode-stdio-1.0 main-is: Test.hs cabal-install-2.4.0.0/tests/IntegrationTests2/targets/empty-pkg/0000755000000000000000000000000000000000000022630 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/empty-pkg/cabal.project0000755000000000000000000000001500000000000025261 0ustar0000000000000000packages: ./ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/empty-pkg/p.cabal0000755000000000000000000000007700000000000024062 0ustar0000000000000000name: p version: 0.1 build-type: Simple cabal-version: >= 1.2 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/empty/0000755000000000000000000000000000000000000022051 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/empty/cabal.project0000755000000000000000000000001200000000000024477 0ustar0000000000000000packages: cabal-install-2.4.0.0/tests/IntegrationTests2/targets/empty/foo.hs0000755000000000000000000000000000000000000023161 0ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/exes-disabled/0000755000000000000000000000000000000000000023424 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/exes-disabled/cabal.project0000755000000000000000000000002000000000000026051 0ustar0000000000000000packages: p/ q/ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/exes-disabled/p/0000755000000000000000000000000000000000000023663 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal0000755000000000000000000000020500000000000025106 0ustar0000000000000000name: p version: 0.1 build-type: Simple cabal-version: >= 1.2 executable p main-is: P.hs build-depends: base buildable: False cabal-install-2.4.0.0/tests/IntegrationTests2/targets/exes-disabled/q/0000755000000000000000000000000000000000000023664 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal0000755000000000000000000000020500000000000025110 0ustar0000000000000000name: q version: 0.1 build-type: Simple cabal-version: >= 1.2 executable q main-is: Q.hs build-depends: base buildable: False cabal-install-2.4.0.0/tests/IntegrationTests2/targets/lib-only/0000755000000000000000000000000000000000000022440 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/lib-only/p.cabal0000755000000000000000000000016200000000000023665 0ustar0000000000000000name: p version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: P build-depends: base cabal-install-2.4.0.0/tests/IntegrationTests2/targets/libs-disabled/0000755000000000000000000000000000000000000023411 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/libs-disabled/cabal.project0000755000000000000000000000002000000000000026036 0ustar0000000000000000packages: p/ q/ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/libs-disabled/p/0000755000000000000000000000000000000000000023650 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal0000755000000000000000000000020500000000000025073 0ustar0000000000000000name: p version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: P build-depends: base buildable: False cabal-install-2.4.0.0/tests/IntegrationTests2/targets/libs-disabled/q/0000755000000000000000000000000000000000000023651 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal0000755000000000000000000000020500000000000025075 0ustar0000000000000000name: q version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: Q build-depends: base buildable: False cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-exes/0000755000000000000000000000000000000000000023510 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-exes/cabal.project0000755000000000000000000000001500000000000026141 0ustar0000000000000000packages: ./ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-exes/p.cabal0000755000000000000000000000025500000000000024740 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-libs/0000755000000000000000000000000000000000000023475 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-libs/cabal.project0000755000000000000000000000002000000000000026122 0ustar0000000000000000packages: p/ q/ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-libs/p/0000755000000000000000000000000000000000000023734 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal0000755000000000000000000000016200000000000025161 0ustar0000000000000000name: p version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: P build-depends: base cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-libs/q/0000755000000000000000000000000000000000000023735 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-libs/q/q.cabal0000755000000000000000000000016200000000000025163 0ustar0000000000000000name: q version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: Q build-depends: base cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-tests/0000755000000000000000000000000000000000000023706 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-tests/cabal.project0000755000000000000000000000001500000000000026337 0ustar0000000000000000packages: ./ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/multiple-tests/p.cabal0000755000000000000000000000034300000000000025134 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/simple/0000755000000000000000000000000000000000000022204 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/simple/P.hs0000755000000000000000000000000000000000000022730 0ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/simple/cabal.project0000755000000000000000000000002000000000000024631 0ustar0000000000000000packages: ./ q/ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/simple/p.cabal0000755000000000000000000000025500000000000023434 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/simple/q/0000755000000000000000000000000000000000000022444 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/simple/q/QQ.hs0000755000000000000000000000000000000000000023312 0ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/simple/q/q.cabal0000755000000000000000000000025600000000000023676 0ustar0000000000000000name: q version: 0.1 build-type: Simple cabal-version: >= 1.2 library exposed-modules: QQ build-depends: base executable qexe main-is: Main.hs other-modules: QMain cabal-install-2.4.0.0/tests/IntegrationTests2/targets/test-only/0000755000000000000000000000000000000000000022651 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/test-only/p.cabal0000755000000000000000000000022400000000000024075 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/tests-disabled/0000755000000000000000000000000000000000000023622 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/tests-disabled/cabal.project0000755000000000000000000000002200000000000026251 0ustar0000000000000000packages: ./ ./q/ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/tests-disabled/p.cabal0000755000000000000000000000042700000000000025053 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/tests-disabled/q/0000755000000000000000000000000000000000000024062 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal0000755000000000000000000000023500000000000025311 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/IntegrationTests2/targets/variety/0000755000000000000000000000000000000000000022376 5ustar0000000000000000cabal-install-2.4.0.0/tests/IntegrationTests2/targets/variety/cabal.project0000755000000000000000000000001500000000000025027 0ustar0000000000000000packages: ./ cabal-install-2.4.0.0/tests/IntegrationTests2/targets/variety/p.cabal0000755000000000000000000000066400000000000023632 0ustar0000000000000000name: 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 cabal-install-2.4.0.0/tests/0000755000000000000000000000000000000000000013652 5ustar0000000000000000cabal-install-2.4.0.0/tests/README.md0000755000000000000000000000235700000000000015143 0ustar0000000000000000Integration Tests ================= Each test is a shell script. Tests that share files (e.g., `.cabal` files) are grouped under a common sub-directory of [IntegrationTests]. The framework copies the whole group's directory before running each test, which allows tests to reuse files, yet run independently. A group's tests are further divided into `should_run` and `should_fail` directories, based on the expected exit status. For example, the test `IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh` has access to all files under `exec` and is expected to fail. Tests can specify their expected output. For a test named `x.sh`, `x.out` specifies `stdout` and `x.err` specifies `stderr`. Both files are optional. The framework expects an exact match between lines in the file and output, except for lines beginning with "RE:", which are interpreted as regular expressions. [IntegrationTests.hs] defines several environment variables: * `CABAL` - The path to the executable being tested. * `GHC_PKG` - The path to ghc-pkg. * `CABAL_ARGS` - A common set of arguments for running cabal. * `CABAL_ARGS_NO_CONFIG_FILE` - `CABAL_ARGS` without `--config-file`. [IntegrationTests]: IntegrationTests [IntegrationTests.hs]: IntegrationTests.hs