stack-3.9.1: src/Stack/Types/Build/Exception.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : Stack.Types.Build.Exception
License : BSD-3-Clause
-}
module Stack.Types.Build.Exception
( BuildException (..)
, BuildPrettyException (..)
, pprintTargetParseErrors
, ConstructPlanException (..)
, LatestApplicableVersion
, BadDependency (..)
) where
import qualified Data.ByteString as S
import Data.Char ( isSpace )
import Data.List as L
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Set as Set
import qualified Data.Text as T
import Distribution.System ( Arch )
import qualified Distribution.Text as C
import Distribution.Types.PackageName ( mkPackageName )
import Distribution.Types.TestSuiteInterface ( TestSuiteInterface )
import qualified Distribution.Version as C
import RIO.NonEmpty ( nonEmpty )
import RIO.Process ( showProcessArgDebug )
import Stack.Constants ( defaultUserConfigPath, wiredInPackages )
import Stack.Prelude
import Stack.Types.Compiler ( ActualCompiler, compilerVersionString )
import Stack.Types.CompilerBuild
( CompilerBuild, compilerBuildSuffix )
import Stack.Types.ComponentUtils
( StackUnqualCompName, unqualCompToString )
import Stack.Types.DumpPackage ( DumpPackage )
import Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) )
import Stack.Types.GHCVariant ( GHCVariant, ghcVariantSuffix )
import Stack.Types.NamedComponent
( NamedComponent, renderPkgComponent )
import Stack.Types.Package ( Package (..), packageIdentifier )
import Stack.Types.ParentMap ( ParentMap )
import Stack.Types.Version ( VersionCheck (..), VersionRange )
import Stack.Types.WantedCompilerSetter ( WantedCompilerSetter (..) )
-- | Type representing exceptions thrown by functions exported by modules with
-- names beginning @Stack.Build@.
data BuildException
= Couldn'tFindPkgId PackageName
| Couldn'tParseTargets [Text]
| UnknownTargets
(Set PackageName) -- no known version
(Map PackageName Version) -- not in snapshot, here's the most recent
-- version in the index
(Path Abs File) -- stack.yaml
| TestSuiteFailure
PackageIdentifier
(Map StackUnqualCompName (Maybe ExitCode))
(Maybe (Path Abs File))
S.ByteString
| TestSuiteTypeUnsupported TestSuiteInterface
| LocalPackageDoesn'tMatchTarget
PackageName
Version -- local version
Version -- version specified on command line
| NoSetupHsFound (Path Abs Dir)
| InvalidGhcOptionsSpecification [PackageName]
| TestSuiteExeMissing Bool String String String
| CabalCopyFailed Bool String
| LocalPackagesPresent [PackageIdentifier]
| CouldNotLockDistDir !(Path Abs File)
| TaskCycleBug PackageIdentifier
| PackageIdMissingBug PackageIdentifier
| AllInOneBuildBug
| MultipleResultsBug PackageName [DumpPackage]
| TemplateHaskellNotFoundBug
| HaddockIndexNotFound
| ShowBuildErrorBug
| CallStackEmptyBug
deriving Show
instance Exception BuildException where
displayException (Couldn'tFindPkgId name) = bugReport "[S-7178]" $ concat
[ "After installing "
, packageNameString name
,", the package id couldn't be found (via ghc-pkg describe "
, packageNameString name
, ")."
]
displayException (Couldn'tParseTargets targets) = unlines
$ "Error: [S-3127]"
: "The following targets could not be parsed as package names or \
\directories:"
: map T.unpack targets
displayException (UnknownTargets noKnown notInSnapshot stackYaml) = unlines
$ "Error: [S-2154]"
: (noKnown' ++ notInSnapshot')
where
noKnown'
| Set.null noKnown = []
| otherwise = pure $
"The following target packages were not found: " ++
intercalate ", " (map packageNameString $ Set.toList noKnown) ++
"\nSee https://docs.haskellstack.org/en/stable/commands/build_command/#target-syntax for details."
notInSnapshot'
| Map.null notInSnapshot = []
| otherwise =
"The following packages are not in your snapshot, but exist"
: "in your package index. Recommended action: add them to your"
: ("extra-deps in " ++ toFilePath stackYaml)
: "(Note: these are the most recent versions,"
: "but there's no guarantee that they'll build together)."
: ""
: map
(\(name, version') -> "- " ++ packageIdentifierString
(PackageIdentifier name version'))
(Map.toList notInSnapshot)
displayException (TestSuiteFailure ident codes mlogFile bs) = unlines
$ "Error: [S-1995]"
: concat
[ ["Test suite failure for package " ++ packageIdentifierString ident]
, flip map (Map.toList codes) $ \(name, mcode) -> concat
[ " "
, unqualCompToString name
, ": "
, case mcode of
Nothing -> " executable not found"
Just ec -> " exited with: " ++ displayException ec
]
, pure $ case mlogFile of
Nothing -> "Logs printed to console"
-- TODO Should we load up the full error output and print it here?
Just logFile -> "Full log available at " ++ toFilePath logFile
, if S.null bs
then []
else
[ ""
, ""
, doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs
]
]
where
indent' = dropWhileEnd isSpace . unlines . fmap (" " ++) . lines
doubleIndent = indent' . indent'
displayException (TestSuiteTypeUnsupported interface) = concat
[ "Error: [S-3819]\n"
, "Unsupported test suite type: "
, show interface
]
-- Suppressing duplicate output
displayException (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat
[ "Error: [S-5797]\n"
, "Version for project package "
, packageNameString name
, " is "
, versionString localV
, ", but you asked for "
, versionString requestedV
, " on the command line"
]
displayException (NoSetupHsFound dir) = concat
[ "Error: [S-3118]\n"
, "No Setup.hs or Setup.lhs file found in "
, toFilePath dir
]
displayException (InvalidGhcOptionsSpecification unused) = unlines
$ "Error: [S-4925]"
: "Invalid GHC options specification:"
: map showGhcOptionSrc unused
where
showGhcOptionSrc name = concat
[ "- Package '"
, packageNameString name
, "' not found"
]
displayException (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) =
missingExeError "[S-7987]"
isSimpleBuildType $ concat
[ "Test suite executable \""
, exeName
, " not found for "
, pkgName'
, ":test:"
, testName
]
displayException (CabalCopyFailed isSimpleBuildType innerMsg) =
missingExeError "[S-8027]"
isSimpleBuildType $ concat
[ "'cabal copy' failed. Error message:\n"
, innerMsg
, "\n"
]
displayException (LocalPackagesPresent locals) = unlines
$ "Error: [S-5510]"
: "Local packages are not allowed when using the 'script' command. \
\Packages found:"
: map (\ident -> "- " ++ packageIdentifierString ident) locals
displayException (CouldNotLockDistDir lockFile) = unlines
[ "Error: [S-7168]"
, "Locking the dist directory failed, try to lock file:"
, " " ++ toFilePath lockFile
, "Maybe you're running another copy of Stack?"
]
displayException (TaskCycleBug pid) = bugReport "[S-7868]" $
"Unexpected task cycle for "
++ packageNameString (pkgName pid)
displayException (PackageIdMissingBug ident) = bugReport "[S-8923]" $
"singleBuild: missing package ID missing: "
++ show ident
displayException AllInOneBuildBug = bugReport "[S-7371]"
"Cannot have an all-in-one build that also has a final build step."
displayException (MultipleResultsBug name dps) = bugReport "[S-6739]" $
"singleBuild: multiple results when describing installed package "
++ show (name, dps)
displayException TemplateHaskellNotFoundBug = bugReport "[S-3121]"
"template-haskell is a wired-in GHC boot library but it wasn't found."
displayException HaddockIndexNotFound =
"Error: [S-6901]\n"
++ "No local or snapshot doc index found to open."
displayException ShowBuildErrorBug = bugReport "[S-5452]"
"Unexpected case in showBuildError."
displayException CallStackEmptyBug = bugReport "[S-2696]"
"addDep: call stack is empty."
data BuildPrettyException
= ConstructPlanFailed
[ConstructPlanException]
(Either (Path Abs File) (Path Abs File))
(Path Abs Dir)
Bool -- Is the project the implicit global project?
ParentMap
(Set PackageName)
(Map PackageName [PackageName])
| ExecutionFailure [SomeException]
| CabalExitedUnsuccessfully
ExitCode
PackageIdentifier
(Path Abs File) -- cabal Executable
[String] -- cabal arguments
(Maybe (Path Abs File)) -- logfiles location
[Text] -- log contents
| SetupHsBuildFailure
ExitCode
(Maybe PackageIdentifier) -- which package's custom setup, is simple setup
-- if Nothing
(Path Abs File) -- ghc Executable
[String] -- ghc arguments
(Maybe (Path Abs File)) -- logfiles location
[Text] -- log contents
| TargetParseException [StyleDoc]
| SomeTargetsNotBuildable [(PackageName, NamedComponent)]
| InvalidFlagSpecification [UnusedFlags]
| GHCProfOptionInvalid
| NotOnlyLocal [PackageName] [StackUnqualCompName]
| CompilerVersionMismatch
(Maybe (ActualCompiler, Arch)) -- found
(WantedCompiler, Arch) -- expected
GHCVariant -- expected
CompilerBuild -- expected
VersionCheck
WantedCompilerSetter -- Way that the wanted compiler is set
StyleDoc -- recommended resolution
| ActionNotFilteredBug StyleDoc
deriving Show
instance Pretty BuildPrettyException where
pretty ( ConstructPlanFailed errs configFile stackRoot isImplicitGlobal parents wanted prunedGlobalDeps ) =
"[S-4804]"
<> line
<> flow "Stack failed to construct a build plan."
<> blankLine
<> pprintExceptions
errs configFile stackRoot isImplicitGlobal parents wanted prunedGlobalDeps
pretty (ExecutionFailure es) =
"[S-7282]"
<> line
<> flow "Stack failed to execute the build plan."
<> blankLine
<> fillSep
[ flow "While executing the build plan, Stack encountered the"
, case es of
[_] -> "error:"
_ -> flow "following errors:"
]
<> blankLine
<> hcat (L.intersperse blankLine (map ppException es))
pretty (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =
showBuildError "[S-7011]"
False exitCode (Just taskProvides') execName fullArgs logFiles bss
pretty (SetupHsBuildFailure exitCode mtaskProvides execName fullArgs logFiles bss) =
showBuildError "[S-6374]"
True exitCode mtaskProvides execName fullArgs logFiles bss
pretty (TargetParseException errs) =
"[S-8506]"
<> pprintTargetParseErrors errs
pretty (SomeTargetsNotBuildable xs) =
"[S-7086]"
<> line
<> fillSep
( [ flow "The following components have"
, style Shell (flow "buildable: False")
, flow "set in the Cabal configuration, and so cannot be targets:"
]
<> mkNarrativeList (Just Target) False
(map (fromString . T.unpack . renderPkgComponent) xs :: [StyleDoc])
)
<> blankLine
<> flow "To resolve this, either provide flags such that these components \
\are buildable, or only specify buildable targets."
pretty (InvalidFlagSpecification unused) =
"[S-8664]"
<> line
<> flow "Invalid flag specification:"
<> line
<> bulletedList (map go (L.sort unused))
where
showFlagSrc :: FlagSource -> StyleDoc
showFlagSrc FSCommandLine = flow "(specified on the command line)"
showFlagSrc FSStackYaml =
flow "(specified in the project-level configuration (e.g. stack.yaml))"
go :: UnusedFlags -> StyleDoc
go (UFNoPackage src name) = fillSep
[ "Package"
, style Error (fromPackageName name)
, flow "not found"
, showFlagSrc src
]
go (UFFlagsNotDefined src pname pkgFlags flags) =
fillSep
( "Package"
: style Current (fromString name)
: flow "does not define the following flags"
: showFlagSrc src <> ":"
: mkNarrativeList (Just Error) False
(map (fromString . flagNameString) (Set.toList flags) :: [StyleDoc])
)
<> line
<> if Set.null pkgFlags
then fillSep
[ flow "No flags are defined by package"
, style Current (fromString name) <> "."
]
else fillSep
( flow "Flags defined by package"
: style Current (fromString name)
: "are:"
: mkNarrativeList (Just Good) False
(map (fromString . flagNameString) (Set.toList pkgFlags) :: [StyleDoc])
)
where
name = packageNameString pname
go (UFSnapshot name) = fillSep
[ flow "Attempted to set flag on snapshot package"
, style Current (fromPackageName name) <> ","
, flow "please add the package to"
, style Shell "extra-deps" <> "."
]
pretty GHCProfOptionInvalid =
"[S-8100]"
<> line
<> fillSep
[ flow "When building with Stack, you should not use GHC's"
, style Shell "-prof"
, flow "option. Instead, please use Stack's"
, style Shell "--library-profiling"
, "and"
, style Shell "--executable-profiling"
, flow "flags. See:"
, style Url "https://github.com/commercialhaskell/stack/issues/1015" <> "."
]
pretty (NotOnlyLocal packages exes) =
"[S-1727]"
<> line
<> flow "Specified only-locals, but Stack needs to build snapshot contents:"
<> line
<> if null packages
then mempty
else
fillSep
( "Packages:"
: mkNarrativeList Nothing False
(map fromPackageName packages :: [StyleDoc])
)
<> line
<> if null exes
then mempty
else
fillSep
( "Executables:"
: mkNarrativeList Nothing False
(map (fromString . unqualCompToString) exes :: [StyleDoc])
)
<> line
pretty ( CompilerVersionMismatch
mactual
(expected, eArch)
ghcVariant
ghcBuild
check
wantedCompilerSetter
resolution
) =
"[S-6362]"
<> line
<> fillSep
[ case mactual of
Nothing -> flow "No compiler found, expected"
Just (actual, arch) -> fillSep
[ flow "Compiler version mismatched, found"
, fromString $ compilerVersionString actual
, parens (pretty arch) <> ","
, flow "but expected"
]
, case check of
MatchMinor -> flow "minor version match with"
MatchExact -> flow "exact version"
NewerMinor -> flow "minor version match or newer with"
, fromString $ T.unpack $ utf8BuilderToText $ display expected
, parens $ mconcat
[ pretty eArch
, fromString $ ghcVariantSuffix ghcVariant
, fromString $ compilerBuildSuffix ghcBuild
]
, parens
( fillSep
[ flow "based on"
, case wantedCompilerSetter of
CompilerAtCommandLine -> fillSep
[ "the"
, style Shell "--compiler"
, "option"
]
SnapshotAtCommandLine -> fillSep
[ "the"
, style Shell "--snapshot" <> ","
, "or"
, style Shell "--resolver" <> ","
, "option"
]
YamlConfiguration mConfigFile -> case mConfigFile of
Nothing -> flow "command line arguments"
Just configFile -> fillSep
[ flow "the configuration in"
, pretty configFile
]
]
)
<> "."
]
<> blankLine
<> resolution
pretty (ActionNotFilteredBug source) = bugPrettyReport "S-4660" $
fillSep
[ source
, flow "is seeking to run an action that should have been filtered from \
\the list of actions."
]
instance Exception BuildPrettyException
-- | Helper function to pretty print an error message for target parse errors.
pprintTargetParseErrors :: [StyleDoc] -> StyleDoc
pprintTargetParseErrors errs =
line
<> flow "Stack failed to parse the target(s)."
<> blankLine
<> fillSep
[ flow "While parsing, Stack encountered the"
, case errs of
[err] ->
"error:"
<> blankLine
<> indent 4 err
_ ->
flow "following errors:"
<> blankLine
<> bulletedList errs
]
<> blankLine
<> fillSep
[ flow "Stack expects a target to be a package name (e.g."
, style Shell "my-package" <> "),"
, flow "a package identifier (e.g."
, style Shell "my-package-0.1.2.3" <> "),"
, flow "a package component (e.g."
, style Shell "my-package:test:my-test-suite" <> "),"
, flow "or, failing that, a relative path to a local directory for a \
\package or a parent directory of one or more such directories."
]
pprintExceptions ::
[ConstructPlanException]
-> Either (Path Abs File) (Path Abs File)
-- ^ The configuration file, which may be either (Left) a user-specific
-- global one or (Right) a project-level one.
-> Path Abs Dir
-> Bool
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions exceptions configFile stackRoot isImplicitGlobal parentMap wanted' prunedGlobalDeps =
fillSep
[ flow
( "While constructing the build plan, Stack encountered the \
\following errors"
<> if hasConfigurationRefs then "." else ":"
)
, if hasConfigurationRefs
then flow
"The 'Stack configuration' refers to the set of package versions \
\specified by the snapshot (after any dropped packages, or pruned \
\GHC boot packages; if a boot package is replaced, Stack prunes \
\all other such packages that depend on it) and any extra-deps:"
else mempty
]
<> blankLine
<> mconcat (L.intersperse blankLine (mapMaybe pprintException exceptions'))
<> if L.null recommendations
then mempty
else
blankLine
<> flow "Some different approaches to resolving some or all of this:"
<> blankLine
<> indent 2 (spacedBulletedList recommendations)
where
exceptions' = {- should we dedupe these somehow? nubOrd -} exceptions
recommendations =
[ allowNewerMsg True False | onlyHasDependencyMismatches ]
<> [ fillSep
$ allowNewerMsg False onlyHasDependencyMismatches
: flow "add these package names under"
: style Shell "allow-newer-deps" <> ":"
: mkNarrativeList (Just Shell) False
(map fromPackageName (Set.elems pkgsWithMismatches) :: [StyleDoc])
| not $ Set.null pkgsWithMismatches
]
<> addExtraDepsRecommendations
where
allowNewerMsg isAll isRepetitive = fillSep
$ flow "To ignore"
: (if isAll then "all" else "certain")
: flow "version constraints and build anyway,"
: if isRepetitive
then ["also"]
else
[ fillSep
$ [ "pass"
, style Shell "--allow-newer" <> ","
, flow "or, in"
, pretty (defaultUserConfigPath stackRoot)
, flow
( "(global configuration)"
<> if isImplicitGlobal then "," else mempty
)
]
<> ( case configFile of
Left _ -> []
Right projectConfigFile -> if isImplicitGlobal
then []
else
[ "or"
, pretty projectConfigFile
, flow "(project-level configuration),"
]
)
<> [ "set"
, style Shell (flow "allow-newer: true")
<> if isAll then "." else mempty
]
<> [ "and" | not isAll ]
]
addExtraDepsRecommendations
| Map.null extras = []
| (Just _) <- Map.lookup (mkPackageName "base") extras =
[ fillSep
[ flow "Build requires unattainable version of the"
, style Current "base"
, flow "package. Since"
, style Current "base"
, flow "is a part of GHC, you most likely need to use a \
\different GHC version with the matching"
, style Current "base"<> "."
]
]
| otherwise =
[ fillSep
[ style Recommendation (flow "Recommended action:")
, flow "try adding the following to your"
, case configFile of
Left _ -> fillSep
[ style Shell "--extra-dep"
, flow "options of the"
, style Shell (flow "stack script")
, "command:"
]
Right projectConfigFile -> fillSep
[ style Shell "extra-deps"
, "in"
, pretty projectConfigFile
, "(project-level configuration):"
]
]
<> blankLine
<> vsep (map pprintExtra (Map.toList extras))
]
pprintExtra (name, (version, BlobKey cabalHash cabalSize)) =
let cfInfo = CFIHash cabalHash (Just cabalSize)
packageIdRev = PackageIdentifierRevision name version cfInfo
in fromString ("- " ++ T.unpack (utf8BuilderToText (display packageIdRev)))
allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions'
toNotInBuildPlan (DependencyPlanFailures _ pDeps) =
map fst $
filter
(\(_, (_, _, badDep)) -> badDep == NotInBuildPlan)
(Map.toList pDeps)
toNotInBuildPlan _ = []
(onlyHasDependencyMismatches, hasConfigurationRefs, extras, pkgsWithMismatches) =
filterExceptions
filterExceptions ::
( Bool
-- ^ All the errors are DependencyMismatch. This checks if
-- 'allow-newer: true' could resolve all reported issues.
, Bool
-- ^ One or more messages refer to 'the Stack configuration'. This
-- triggers a message to explain what that phrase means.
, Map PackageName (Version, BlobKey)
-- ^ Recommended extras. TO DO: Likely a good idea to distinguish these to
-- the user. In particular, those recommended for DependencyMismatch.
, Set.Set PackageName
-- ^ Set of names of packages with one or more DependencyMismatch errors.
)
filterExceptions = L.foldl' go acc0 exceptions'
where
acc0 = (True, False, Map.empty, Set.empty)
go acc (DependencyPlanFailures pkg m) = Map.foldrWithKey go' acc m
where
pkgName = pkg.name
go' name (_, Just extra, NotInBuildPlan) (_, _, m', s) =
(False, True, Map.insert name extra m', s)
go' _ (_, _, NotInBuildPlan) (_, _, m', s) = (False, True, m', s)
go' name (_, Just extra, DependencyMismatch _) (p1, _, m', s) =
(p1, True, Map.insert name extra m', Set.insert pkgName s)
go' _ (_, _, DependencyMismatch _) (p1, _, m', s) =
(p1, True, m', Set.insert pkgName s)
go' _ (_, _, Couldn'tResolveItsDependencies _) acc' = acc'
go' _ _ (_, p2, m', s) = (False, p2, m', s)
go (_, p2, m, s) _ = (False, p2, m, s)
pprintException (DependencyCycleDetected pNames) = Just $
flow "Dependency cycle detected in packages:"
<> line
<> indent 4
(encloseSep "[" "]" "," (map (style Error . fromPackageName) pNames))
pprintException (DependencyPlanFailures pkg pDeps) =
case mapMaybe pprintDep (Map.toList pDeps) of
[] -> Nothing
depErrors -> Just $
fillSep
[ flow "In the dependencies for"
, pkgIdent <> pprintFlags pkg.flags <> ":"
]
<> line
<> indent 2 (bulletedList depErrors)
<> line
<> fillSep
( flow "The above is/are needed"
: case getShortestDepsPath parentMap wanted' pkg.name of
Nothing ->
[flow "for unknown reason - Stack invariant violated."]
Just [] ->
[ "since"
, pkgName'
, flow "is a build target."
]
Just (target:path) ->
[ flow "due to"
, encloseSep "" "" " -> " pathElems
]
where
pathElems =
[style Target . fromPackageId $ target]
<> map fromPackageId path
<> [pkgIdent]
)
where
pkgName' = style Current (fromPackageName pkg.name)
pkgIdent = style Current (fromPackageId $ packageIdentifier pkg)
-- Skip these when they are redundant with 'NotInBuildPlan' info.
pprintException (UnknownPackage compiler name)
| name `Set.member` allNotInBuildPlan = Nothing
| name `Set.member` wiredInPackages compiler =
Just $ fillSep
[ flow "Can't build a package with same name as a wired-in-package:"
, style Current . fromPackageName $ name
]
| Just pruned <- Map.lookup name prunedGlobalDeps =
let prunedDeps =
map (style Current . fromPackageName) pruned
in Just $ fillSep
[ flow "Can't use GHC boot package"
, style Current . fromPackageName $ name
, flow "when it depends on a replaced boot package. You need to \
\add the following as explicit dependencies to the \
\project:"
, line
, encloseSep "" "" ", " prunedDeps
]
| otherwise = Just $ fillSep
[ flow "Unknown package:"
, style Current . fromPackageName $ name
]
pprintFlags flags
| Map.null flags = ""
| otherwise = parens $ sep $ map pprintFlag $ Map.toList flags
pprintFlag (name, True) = "+" <> fromString (flagNameString name)
pprintFlag (name, False) = "-" <> fromString (flagNameString name)
pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of
NotInBuildPlan
| name `elem` fold prunedGlobalDeps -> butMsg $ fillSep
[ flow "this GHC boot package has been pruned from the Stack \
\configuration. You need to add the package explicitly to"
, style Shell "extra-deps" <> "."
]
| otherwise -> butMsg $ inconsistentMsg Nothing
-- TODO: For local packages, suggest editing constraints
DependencyMismatch version -> butMsg $ inconsistentMsg $ Just version
-- I think the main useful info is these explain why missing packages are
-- needed. Instead lets give the user the shortest path from a target to the
-- package.
Couldn'tResolveItsDependencies _version -> Nothing
HasNoLibrary -> Just $ fillSep
[ errorName
, flow "is a library dependency, but the package provides no library."
]
BDDependencyCycleDetected names -> Just $ fillSep
[ errorName
, flow $ "dependency cycle detected: "
++ L.intercalate ", " (map packageNameString names)
]
where
errorName = style Error . fromPackageName $ name
goodRange = style Good (fromString (C.display range))
rangeMsg = if range == C.anyVersion
then "needed,"
else fillSep
[ flow "must match"
, goodRange <> ","
]
butMsg msg = Just $ fillSep
[ errorName
, rangeMsg
, "but"
, msg
, latestApplicable Nothing
]
inconsistentMsg mVersion = fillSep
[ style Error $ maybe
( flow "no version" )
( fromPackageId . PackageIdentifier name )
mVersion
, flow "is in the Stack configuration"
]
latestApplicable mversion =
case mlatestApplicable of
Nothing
| isNothing mversion -> fillSep
[ flow "(no matching package and version found. Perhaps there is \
\an error in the specification of a package's"
, style Shell "dependencies"
, "or"
, style Shell "build-tools"
, flow "(Hpack) or"
, style Shell "build-depends" <> ","
, style Shell "build-tools"
, "or"
, style Shell "build-tool-depends"
, case configFile of
Left _ -> flow "(Cabal file)."
Right projectConfigFile -> fillSep
[ flow "(Cabal file) or an omission from the"
, style Shell "packages"
, flow "list in"
, pretty projectConfigFile
, flow "(project-level configuration).)"
]
]
| otherwise -> ""
Just (laVer, _)
| Just laVer == mversion ->
flow "(latest matching version is specified)."
| otherwise ->
fillSep
[ flow "(latest matching version is"
, style Good (fromString $ versionString laVer) <> ")."
]
data ConstructPlanException
= DependencyCycleDetected [PackageName]
| DependencyPlanFailures
Package
(Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))
| UnknownPackage ActualCompiler PackageName
-- TODO perhaps this constructor will be removed, and BadDependency will
-- handle it all
-- ^ Recommend adding to extra-deps, give a helpful version number?
deriving (Eq, Show)
-- | The latest applicable version and it's latest Cabal file revision.
-- For display purposes only, Nothing if package not found
type LatestApplicableVersion = Maybe (Version, BlobKey)
-- | Reason why a dependency was not used
data BadDependency
= NotInBuildPlan
| Couldn'tResolveItsDependencies Version
| DependencyMismatch Version
| HasNoLibrary
-- ^ See description of 'Stack.Types.Dependency.DepType'
| BDDependencyCycleDetected ![PackageName]
deriving (Eq, Ord, Show)
missingExeError :: String -> Bool -> String -> String
missingExeError errorCode isSimpleBuildType msg = unlines
$ "Error: " <> errorCode
: msg
: "Possible causes of this issue:"
: map ("* " <>) possibleCauses
where
possibleCauses
= "No module named \"Main\". The 'main-is' source file should usually \
\have a header indicating that it's a 'Main' module."
: "A Cabal file that refers to nonexistent other files (e.g. a \
\license-file that doesn't exist). Running 'cabal check' may point \
\out these issues."
: [ "The Setup.hs file is changing the installation target dir."
| not isSimpleBuildType
]
showBuildError ::
String
-> Bool
-> ExitCode
-> Maybe PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
-> StyleDoc
showBuildError errorCode isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles bss =
let fullCmd = unwords
$ dropQuotes (toFilePath execName)
: map (T.unpack . showProcessArgDebug) fullArgs
logLocations =
maybe
mempty
(\fp -> line <> flow "Logs have been written to:" <+>
pretty fp)
logFiles
in fromString errorCode
<> line
<> flow "While building" <+>
( case (isBuildingSetup, mtaskProvides) of
(False, Nothing) -> impureThrow ShowBuildErrorBug
(False, Just taskProvides') ->
"package" <+>
style
Target
(fromString $ dropQuotes (packageIdentifierString taskProvides'))
(True, Nothing) -> "simple" <+> style File "Setup.hs"
(True, Just taskProvides') ->
"custom" <+>
style File "Setup.hs" <+>
flow "for package" <+>
style
Target
(fromString $ dropQuotes (packageIdentifierString taskProvides'))
) <+>
flow "(scroll up to its section to see the error) using:"
<> line
<> style Shell (fromString fullCmd)
<> line
<> flow "Process exited with code:" <+> (fromString . show) exitCode <+>
( if exitCode == ExitFailure (-9)
then flow "(THIS MAY INDICATE OUT OF MEMORY)"
else mempty
)
<> logLocations
<> if null bss
then mempty
else blankLine <> string (removeTrailingSpaces (map T.unpack bss))
where
removeTrailingSpaces = dropWhileEnd isSpace . unlines
dropQuotes = filter ('\"' /=)
-- | Get the shortest reason for the package to be in the build plan. In other
-- words, trace the parent dependencies back to a \'wanted\' package.
getShortestDepsPath ::
ParentMap
-> Set PackageName
-> PackageName
-> Maybe [PackageIdentifier]
getShortestDepsPath (MonoidMap parentsMap) wanted' name =
if Set.member name wanted'
then Just []
else case M.lookup name parentsMap of
Nothing -> Nothing
Just parents -> Just $ findShortest 256 paths0
where
paths0 = M.fromList $
map (\(ident, _) -> (pkgName ident, startDepsPath ident)) parents
where
-- The 'paths' map is a map from PackageName to the shortest path
-- found to get there. It is the frontier of our breadth-first
-- search of dependencies.
findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest fuel _ | fuel <= 0 =
[ PackageIdentifier
(mkPackageName "stack-ran-out-of-jet-fuel")
(C.mkVersion [0])
]
findShortest _ paths | M.null paths = []
findShortest fuel paths =
case nonEmpty targets of
Nothing -> findShortest (fuel - 1) $ M.fromListWith chooseBest $
concatMap extendPath recurses
Just targets' ->
let (DepsPath _ _ path) = minimum (snd <$> targets')
in path
where
(targets, recurses) =
L.partition (\(n, _) -> n `Set.member` wanted') (M.toList paths)
chooseBest :: DepsPath -> DepsPath -> DepsPath
chooseBest = max
-- Extend a path to all its parents.
extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath (n, dp) =
case M.lookup n parentsMap of
Nothing -> []
Just parents ->
map (\(pkgId, _) -> (pkgName pkgId, extendDepsPath pkgId dp)) parents
startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath ident = DepsPath
{ dpLength = 1
, dpNameLength = length (packageNameString (pkgName ident))
, dpPath = [ident]
}
extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath ident dp = DepsPath
{ dpLength = dp.dpLength + 1
, dpNameLength = dp.dpNameLength + length (packageNameString (pkgName ident))
, dpPath = [ident]
}
data DepsPath = DepsPath
{ dpLength :: Int
-- ^ Length of dpPath
, dpNameLength :: Int
-- ^ Length of package names combined
, dpPath :: [PackageIdentifier]
-- ^ A path where the packages later in the list depend on those that come
-- earlier
}
deriving (Eq, Ord, Show)