stack-2.11.1: src/Stack/Types/Build/Exception.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
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.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.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 )
-- | Type representing exceptions thrown by functions exported by modules with
-- names beginning @Stack.Build@.
data BuildException
= Couldn'tFindPkgId PackageName
| CompilerVersionMismatch
(Maybe (ActualCompiler, Arch)) -- found
(WantedCompiler, Arch) -- expected
GHCVariant -- expected
CompilerBuild -- expected
VersionCheck
(Maybe (Path Abs File)) -- Path to the stack.yaml file
Text -- recommended resolution
| 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 Text (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
deriving (Show, Typeable)
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 (CompilerVersionMismatch mactual (expected, eArch) ghcVariant ghcBuild check mstack resolution) = concat
[ "Error: [S-6362]\n"
, case mactual of
Nothing -> "No compiler found, expected "
Just (actual, arch) -> concat
[ "Compiler version mismatched, found "
, compilerVersionString actual
, " ("
, C.display arch
, ")"
, ", but expected "
]
, case check of
MatchMinor -> "minor version match with "
MatchExact -> "exact version "
NewerMinor -> "minor version match or newer with "
, T.unpack $ utf8BuilderToText $ display expected
, " ("
, C.display eArch
, ghcVariantSuffix ghcVariant
, compilerBuildSuffix ghcBuild
, ") (based on "
, case mstack of
Nothing -> "command line arguments"
Just stack -> "resolver setting in " ++ toFilePath stack
, ").\n"
, T.unpack resolution
]
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/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
[ " "
, T.unpack 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 local 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."
data BuildPrettyException
= ConstructPlanFailed
[ConstructPlanException]
(Path Abs File)
(Path Abs Dir)
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 (Set UnusedFlags)
| GHCProfOptionInvalid
deriving (Show, Typeable)
instance Pretty BuildPrettyException where
pretty ( ConstructPlanFailed errs stackYaml stackRoot parents wanted prunedGlobalDeps ) =
"[S-4804]"
<> line
<> flow "Stack failed to construct a build plan."
<> blankLine
<> pprintExceptions
errs stackYaml stackRoot 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 (Set.toList 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 (fromString $ packageNameString 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 (fromString $ packageNameString 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" <> "."
]
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 directory that is a \
\local package directory or a parent directory of one or more \
\local package directories."
]
pprintExceptions ::
[ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDeps =
mconcat $
[ flow "While constructing the build plan, Stack encountered the \
\following errors:"
, blankLine
, mconcat (L.intersperse blankLine (mapMaybe pprintException exceptions'))
] ++ if L.null recommendations
then []
else
[ blankLine
, flow "Some different approaches to resolving this:"
, blankLine
] ++ recommendations
where
exceptions' = {- should we dedupe these somehow? nubOrd -} exceptions
recommendations =
if not onlyHasDependencyMismatches
then []
else
[ " *" <+> align (fillSep
[ "Set"
, style Shell (flow "allow-newer: true")
, "in"
, pretty (defaultUserConfigPath stackRoot)
, flow "to ignore all version constraints and build anyway."
])
, blankLine
]
++ addExtraDepsRecommendations
addExtraDepsRecommendations
| Map.null extras = []
| (Just _) <- Map.lookup (mkPackageName "base") extras =
[ " *" <+> align (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"<> "."
])
, line
]
| otherwise =
[ " *" <+> align (fillSep
[ style Recommendation (flow "Recommended action:")
, flow "try adding the following to your"
, style Shell "extra-deps"
, "in"
, pretty stackYaml <> ":"
])
, blankLine
, vsep (map pprintExtra (Map.toList extras))
, line
]
extras = Map.unions $ map getExtras exceptions'
getExtras DependencyCycleDetected{} = Map.empty
getExtras UnknownPackage{} = Map.empty
getExtras (DependencyPlanFailures _ m) =
Map.unions $ map go $ Map.toList m
where
-- TODO: Likely a good idea to distinguish these to the user. In
-- particular, for DependencyMismatch
go (name, (_range, Just (version,cabalHash), NotInBuildPlan)) =
Map.singleton name (version,cabalHash)
go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) =
Map.singleton name (version, cabalHash)
go _ = Map.empty
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 _ = []
-- This checks if 'allow-newer: true' could resolve all issues.
onlyHasDependencyMismatches = all go exceptions'
where
go DependencyCycleDetected{} = False
go UnknownPackage{} = False
go (DependencyPlanFailures _ m) =
all (\(_, _, depErr) -> isMismatch depErr) (M.elems m)
isMismatch DependencyMismatch{} = True
isMismatch Couldn'tResolveItsDependencies{} = True
isMismatch _ = False
pprintException (DependencyCycleDetected pNames) = Just $
flow "Dependency cycle detected in packages:"
<> line
<> indent 4
( encloseSep "[" "]" ","
(map (style Error . fromString . packageNameString) pNames)
)
pprintException (DependencyPlanFailures pkg pDeps) =
case mapMaybe pprintDep (Map.toList pDeps) of
[] -> Nothing
depErrors -> Just $
flow "In the dependencies for" <+> pkgIdent <>
pprintFlags (packageFlags pkg) <> ":" <> line <>
indent 4 (vsep depErrors) <>
case getShortestDepsPath parentMap wanted' (packageName pkg) of
Nothing ->
line
<> flow "needed for unknown reason - stack invariant violated."
Just [] ->
line
<> fillSep
[ flow "needed since"
, pkgName'
, flow "is a build target."
]
Just (target:path) ->
line
<> flow "needed due to" <+> encloseSep "" "" " -> " pathElems
where
pathElems =
[style Target . fromString . packageIdentifierString $ target] ++
map (fromString . packageIdentifierString) path ++
[pkgIdent]
where
pkgName' =
style Current . fromString . packageNameString $ packageName pkg
pkgIdent =
style
Current
(fromString . packageIdentifierString $ packageIdentifier pkg)
-- Skip these when they are redundant with 'NotInBuildPlan' info.
pprintException (UnknownPackage name)
| name `Set.member` allNotInBuildPlan = Nothing
| name `Set.member` wiredInPackages = Just $ fillSep
[ flow "Can't build a package with same name as a wired-in-package:"
, style Current . fromString . packageNameString $ name
]
| Just pruned <- Map.lookup name prunedGlobalDeps =
let prunedDeps =
map (style Current . fromString . packageNameString) pruned
in Just $ fillSep
[ flow "Can't use GHC boot package"
, style Current . fromString . packageNameString $ name
, flow "when it has an overridden dependency (issue #4510);"
, flow "you need to add the following as explicit dependencies \
\to the project:"
, line
, encloseSep "" "" ", " prunedDeps
]
| otherwise = Just $ fillSep
[ flow "Unknown package:"
, style Current . fromString . packageNameString $ 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 -> Just $
style Error (fromString $ packageNameString name) <+>
align
( ( if range == C.anyVersion
then flow "needed"
else flow "must match" <+> goodRange
)
<> ","
<> softline
<> fillSep
[ flow "but this GHC boot package has been pruned (issue \
\#4510); you need to add the package explicitly to \
\extra-deps"
,latestApplicable Nothing
]
)
| otherwise -> Just $
style Error (fromString $ packageNameString name) <+>
align
( ( if range == C.anyVersion
then flow "needed"
else flow "must match" <+> goodRange
)
<> ","
<> softline
<> fillSep
[ flow "but the Stack configuration has no specified version"
, latestApplicable Nothing
]
)
-- TODO: For local packages, suggest editing constraints
DependencyMismatch version -> Just $
style
Error
(fromString . packageIdentifierString $ PackageIdentifier name version)
<+>
align
( fillSep
[ flow "from Stack configuration does not match"
, goodRange
, latestApplicable (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 $
style Error (fromString $ packageNameString name) <+>
align (flow "is a library dependency, but the package provides no library")
BDDependencyCycleDetected names -> Just $
style Error (fromString $ packageNameString name) <+>
align
( flow $ "dependency cycle detected: "
++ L.intercalate ", " (map packageNameString names)
)
where
goodRange = style Good (fromString (C.display range))
latestApplicable mversion =
case mlatestApplicable of
Nothing
| isNothing mversion ->
flow "(no package with that name found, perhaps there is a typo \
\in a package's build-depends or an omission from the \
\stack.yaml packages list?)"
| 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 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, Typeable)
-- | 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 'DepType'
| BDDependencyCycleDetected ![PackageName]
deriving (Eq, Ord, Show, Typeable)
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 targets of
[] -> findShortest (fuel - 1) $ M.fromListWith chooseBest $
concatMap extendPath recurses
_ -> let (DepsPath _ _ path) = L.minimum (map 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 = dpLength dp + 1
, dpNameLength = dpNameLength dp + 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)