{-# 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 (Int -> BuildException -> ShowS
[BuildException] -> ShowS
BuildException -> String
(Int -> BuildException -> ShowS)
-> (BuildException -> String)
-> ([BuildException] -> ShowS)
-> Show BuildException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildException -> ShowS
showsPrec :: Int -> BuildException -> ShowS
$cshow :: BuildException -> String
show :: BuildException -> String
$cshowList :: [BuildException] -> ShowS
showList :: [BuildException] -> ShowS
Show, Typeable)

instance Exception BuildException where
  displayException :: BuildException -> String
displayException (Couldn'tFindPkgId PackageName
name) = String -> ShowS
bugReport String
"[S-7178]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"After installing "
    , PackageName -> String
packageNameString PackageName
name
    ,String
", the package id couldn't be found (via ghc-pkg describe "
    , PackageName -> String
packageNameString PackageName
name
    , String
")."
    ]
  displayException (CompilerVersionMismatch Maybe (ActualCompiler, Arch)
mactual (WantedCompiler
expected, Arch
eArch) GHCVariant
ghcVariant CompilerBuild
ghcBuild VersionCheck
check Maybe (Path Abs File)
mstack Text
resolution) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-6362]\n"
    , case Maybe (ActualCompiler, Arch)
mactual of
        Maybe (ActualCompiler, Arch)
Nothing -> String
"No compiler found, expected "
        Just (ActualCompiler
actual, Arch
arch) -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ String
"Compiler version mismatched, found "
          , ActualCompiler -> String
compilerVersionString ActualCompiler
actual
          , String
" ("
          , Arch -> String
forall a. Pretty a => a -> String
C.display Arch
arch
          , String
")"
          , String
", but expected "
          ]
    , case VersionCheck
check of
        VersionCheck
MatchMinor -> String
"minor version match with "
        VersionCheck
MatchExact -> String
"exact version "
        VersionCheck
NewerMinor -> String
"minor version match or newer with "
    , Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display WantedCompiler
expected
    , String
" ("
    , Arch -> String
forall a. Pretty a => a -> String
C.display Arch
eArch
    , GHCVariant -> String
ghcVariantSuffix GHCVariant
ghcVariant
    , CompilerBuild -> String
compilerBuildSuffix CompilerBuild
ghcBuild
    , String
") (based on "
    , case Maybe (Path Abs File)
mstack of
        Maybe (Path Abs File)
Nothing -> String
"command line arguments"
        Just Path Abs File
stack -> String
"resolver setting in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
stack
    , String
").\n"
    , Text -> String
T.unpack Text
resolution
    ]
  displayException (Couldn'tParseTargets [Text]
targets) = [String] -> String
unlines
    ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Error: [S-3127]"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"The following targets could not be parsed as package names or \
      \directories:"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
targets
  displayException (UnknownTargets Set PackageName
noKnown Map PackageName Version
notInSnapshot Path Abs File
stackYaml) = [String] -> String
unlines
    ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Error: [S-2154]"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([String]
noKnown' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
notInSnapshot')
   where
    noKnown' :: [String]
noKnown'
      | Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
noKnown = []
      | Bool
otherwise = String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$
          String
"The following target packages were not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString ([PackageName] -> [String]) -> [PackageName] -> [String]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
noKnown) String -> ShowS
forall a. [a] -> [a] -> [a]
++
          String
"\nSee https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details."
    notInSnapshot' :: [String]
notInSnapshot'
      | Map PackageName Version -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName Version
notInSnapshot = []
      | Bool
otherwise =
            String
"The following packages are not in your snapshot, but exist"
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"in your package index. Recommended action: add them to your"
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String
"extra-deps in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
stackYaml)
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"(Note: these are the most recent versions,"
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"but there's no guarantee that they'll build together)."
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
""
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((PackageName, Version) -> String)
-> [(PackageName, Version)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
              (\(PackageName
name, Version
version') -> String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString
                  (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version'))
              (Map PackageName Version -> [(PackageName, Version)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName Version
notInSnapshot)
  displayException (TestSuiteFailure PackageIdentifier
ident Map Text (Maybe ExitCode)
codes Maybe (Path Abs File)
mlogFile ByteString
bs) = [String] -> String
unlines
    ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Error: [S-1995]"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [String
"Test suite failure for package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident]
        , (((Text, Maybe ExitCode) -> String)
 -> [(Text, Maybe ExitCode)] -> [String])
-> [(Text, Maybe ExitCode)]
-> ((Text, Maybe ExitCode) -> String)
-> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, Maybe ExitCode) -> String)
-> [(Text, Maybe ExitCode)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Map Text (Maybe ExitCode) -> [(Text, Maybe ExitCode)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Maybe ExitCode)
codes) (((Text, Maybe ExitCode) -> String) -> [String])
-> ((Text, Maybe ExitCode) -> String) -> [String]
forall a b. (a -> b) -> a -> b
$ \(Text
name, Maybe ExitCode
mcode) -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"    "
            , Text -> String
T.unpack Text
name
            , String
": "
            , case Maybe ExitCode
mcode of
                Maybe ExitCode
Nothing -> String
" executable not found"
                Just ExitCode
ec -> String
" exited with: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall e. Exception e => e -> String
displayException ExitCode
ec
            ]
        , String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ case Maybe (Path Abs File)
mlogFile of
            Maybe (Path Abs File)
Nothing -> String
"Logs printed to console"
            -- TODO Should we load up the full error output and print it here?

            Just Path Abs File
logFile -> String
"Full log available at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
logFile
        , if ByteString -> Bool
S.null ByteString
bs
            then []
            else
              [ String
""
              , String
""
              , ShowS
doubleIndent ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
bs
              ]
        ]
   where
    indent' :: ShowS
indent' = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"  " ++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    doubleIndent :: ShowS
doubleIndent = ShowS
indent' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
indent'
  displayException (TestSuiteTypeUnsupported TestSuiteInterface
interface) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-3819]\n"
    , String
"Unsupported test suite type: "
    , TestSuiteInterface -> String
forall a. Show a => a -> String
show TestSuiteInterface
interface
    ]
     -- Suppressing duplicate output

  displayException (LocalPackageDoesn'tMatchTarget PackageName
name Version
localV Version
requestedV) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-5797]\n"
    , String
"Version for local package "
    , PackageName -> String
packageNameString PackageName
name
    , String
" is "
    , Version -> String
versionString Version
localV
    , String
", but you asked for "
    , Version -> String
versionString Version
requestedV
    , String
" on the command line"
    ]
  displayException (NoSetupHsFound Path Abs Dir
dir) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-3118]\n"
    , String
"No Setup.hs or Setup.lhs file found in "
    , Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
dir
    ]
  displayException (InvalidGhcOptionsSpecification [PackageName]
unused) = [String] -> String
unlines
    ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Error: [S-4925]"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"Invalid GHC options specification:"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
showGhcOptionSrc [PackageName]
unused
   where
    showGhcOptionSrc :: PackageName -> String
showGhcOptionSrc PackageName
name = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"- Package '"
      , PackageName -> String
packageNameString PackageName
name
      , String
"' not found"
      ]
  displayException (TestSuiteExeMissing Bool
isSimpleBuildType String
exeName String
pkgName' String
testName) =
    String -> Bool -> ShowS
missingExeError String
"[S-7987]"
      Bool
isSimpleBuildType ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Test suite executable \""
        , String
exeName
        , String
" not found for "
        , String
pkgName'
        , String
":test:"
        , String
testName
        ]
  displayException (CabalCopyFailed Bool
isSimpleBuildType String
innerMsg) =
    String -> Bool -> ShowS
missingExeError String
"[S-8027]"
      Bool
isSimpleBuildType ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"'cabal copy' failed.  Error message:\n"
        , String
innerMsg
        , String
"\n"
        ]
  displayException (LocalPackagesPresent [PackageIdentifier]
locals) = [String] -> String
unlines
    ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Error: [S-5510]"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"Local packages are not allowed when using the 'script' command. \
      \Packages found:"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageIdentifier
ident -> String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident) [PackageIdentifier]
locals
  displayException (CouldNotLockDistDir Path Abs File
lockFile) = [String] -> String
unlines
    [ String
"Error: [S-7168]"
    , String
"Locking the dist directory failed, try to lock file:"
    , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
lockFile
    , String
"Maybe you're running another copy of Stack?"
    ]
  displayException (TaskCycleBug PackageIdentifier
pid) = String -> ShowS
bugReport String
"[S-7868]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String
"Unexpected task cycle for "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pid)
  displayException (PackageIdMissingBug PackageIdentifier
ident) = String -> ShowS
bugReport String
"[S-8923]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String
"singleBuild: missing package ID missing: "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Show a => a -> String
show PackageIdentifier
ident
  displayException BuildException
AllInOneBuildBug = String -> ShowS
bugReport String
"[S-7371]"
    String
"Cannot have an all-in-one build that also has a final build step."
  displayException (MultipleResultsBug PackageName
name [DumpPackage]
dps) = String -> ShowS
bugReport String
"[S-6739]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String
"singleBuild: multiple results when describing installed package "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ (PackageName, [DumpPackage]) -> String
forall a. Show a => a -> String
show (PackageName
name, [DumpPackage]
dps)
  displayException BuildException
TemplateHaskellNotFoundBug = String -> ShowS
bugReport String
"[S-3121]"
    String
"template-haskell is a wired-in GHC boot library but it wasn't found."
  displayException BuildException
HaddockIndexNotFound =
    String
"Error: [S-6901]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"No local or snapshot doc index found to open."
  displayException BuildException
ShowBuildErrorBug = String -> ShowS
bugReport String
"[S-5452]"
    String
"Unexpected case in showBuildError."

data BuildPrettyException
  = ConstructPlanFailed
      [ConstructPlanException]
      (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 (Set UnusedFlags)
  | GHCProfOptionInvalid
  deriving (Int -> BuildPrettyException -> ShowS
[BuildPrettyException] -> ShowS
BuildPrettyException -> String
(Int -> BuildPrettyException -> ShowS)
-> (BuildPrettyException -> String)
-> ([BuildPrettyException] -> ShowS)
-> Show BuildPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildPrettyException -> ShowS
showsPrec :: Int -> BuildPrettyException -> ShowS
$cshow :: BuildPrettyException -> String
show :: BuildPrettyException -> String
$cshowList :: [BuildPrettyException] -> ShowS
showList :: [BuildPrettyException] -> ShowS
Show, Typeable)

instance Pretty BuildPrettyException where
  pretty :: BuildPrettyException -> StyleDoc
pretty ( ConstructPlanFailed [ConstructPlanException]
errs Path Abs File
stackYaml Path Abs Dir
stackRoot Bool
isImplicitGlobal ParentMap
parents Set PackageName
wanted Map PackageName [PackageName]
prunedGlobalDeps ) =
    StyleDoc
"[S-4804]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack failed to construct a build plan."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> Bool
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions
         [ConstructPlanException]
errs Path Abs File
stackYaml Path Abs Dir
stackRoot Bool
isImplicitGlobal ParentMap
parents Set PackageName
wanted Map PackageName [PackageName]
prunedGlobalDeps
  pretty (ExecutionFailure [SomeException]
es) =
    StyleDoc
"[S-7282]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack failed to execute the build plan."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"While executing the build plan, Stack encountered the"
         , case [SomeException]
es of
             [SomeException
_] -> StyleDoc
"error:"
             [SomeException]
_ -> String -> StyleDoc
flow String
"following errors:"
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
hcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
blankLine ((SomeException -> StyleDoc) -> [SomeException] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map SomeException -> StyleDoc
ppException [SomeException]
es))
  pretty (CabalExitedUnsuccessfully ExitCode
exitCode PackageIdentifier
taskProvides' Path Abs File
execName [String]
fullArgs Maybe (Path Abs File)
logFiles [Text]
bss) =
    String
-> Bool
-> ExitCode
-> Maybe PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
-> StyleDoc
showBuildError String
"[S-7011]"
      Bool
False ExitCode
exitCode (PackageIdentifier -> Maybe PackageIdentifier
forall a. a -> Maybe a
Just PackageIdentifier
taskProvides') Path Abs File
execName [String]
fullArgs Maybe (Path Abs File)
logFiles [Text]
bss
  pretty (SetupHsBuildFailure ExitCode
exitCode Maybe PackageIdentifier
mtaskProvides Path Abs File
execName [String]
fullArgs Maybe (Path Abs File)
logFiles [Text]
bss) =
    String
-> Bool
-> ExitCode
-> Maybe PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
-> StyleDoc
showBuildError String
"[S-6374]"
      Bool
True ExitCode
exitCode Maybe PackageIdentifier
mtaskProvides Path Abs File
execName [String]
fullArgs Maybe (Path Abs File)
logFiles [Text]
bss
  pretty (TargetParseException [StyleDoc]
errs) =
    StyleDoc
"[S-8506]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
pprintTargetParseErrors [StyleDoc]
errs
  pretty (SomeTargetsNotBuildable [(PackageName, NamedComponent)]
xs) =
    StyleDoc
"[S-7086]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         (  [ String -> StyleDoc
flow String
"The following components have"
            , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"buildable: False")
            , String -> StyleDoc
flow String
"set in the Cabal configuration, and so cannot be targets:"
            ]
         [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Target) Bool
False
              (((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ((PackageName, NamedComponent) -> String)
-> (PackageName, NamedComponent)
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> ((PackageName, NamedComponent) -> Text)
-> (PackageName, NamedComponent)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent) [(PackageName, NamedComponent)]
xs :: [StyleDoc])
         )
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"To resolve this, either provide flags such that these components \
            \are buildable, or only specify buildable targets."
  pretty (InvalidFlagSpecification Set UnusedFlags
unused) =
    StyleDoc
"[S-8664]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Invalid flag specification:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((UnusedFlags -> StyleDoc) -> [UnusedFlags] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnusedFlags -> StyleDoc
go (Set UnusedFlags -> [UnusedFlags]
forall a. Set a -> [a]
Set.toList Set UnusedFlags
unused))
   where
    showFlagSrc :: FlagSource -> StyleDoc
    showFlagSrc :: FlagSource -> StyleDoc
showFlagSrc FlagSource
FSCommandLine = String -> StyleDoc
flow String
"(specified on the command line)"
    showFlagSrc FlagSource
FSStackYaml =
      String -> StyleDoc
flow String
"(specified in the project-level configuration (e.g. stack.yaml))"

    go :: UnusedFlags -> StyleDoc
    go :: UnusedFlags -> StyleDoc
go (UFNoPackage FlagSource
src PackageName
name) = [StyleDoc] -> StyleDoc
fillSep
      [ StyleDoc
"Package"
      , Style -> StyleDoc -> StyleDoc
style Style
Error (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name)
      , String -> StyleDoc
flow String
"not found"
      , FlagSource -> StyleDoc
showFlagSrc FlagSource
src
      ]
    go (UFFlagsNotDefined FlagSource
src PackageName
pname Set FlagName
pkgFlags Set FlagName
flags) =
         [StyleDoc] -> StyleDoc
fillSep
           ( StyleDoc
"Package"
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name)
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: String -> StyleDoc
flow String
"does not define the following flags"
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: FlagSource -> StyleDoc
showFlagSrc FlagSource
src StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Error) Bool
False
               ((FlagName -> StyleDoc) -> [FlagName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (FlagName -> String) -> FlagName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagName -> String
flagNameString) (Set FlagName -> [FlagName]
forall a. Set a -> [a]
Set.toList Set FlagName
flags) :: [StyleDoc])
           )
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> if Set FlagName -> Bool
forall a. Set a -> Bool
Set.null Set FlagName
pkgFlags
           then [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"No flags are defined by package"
             , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
           else [StyleDoc] -> StyleDoc
fillSep
           ( String -> StyleDoc
flow String
"Flags defined by package"
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name)
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: StyleDoc
"are:"
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Good) Bool
False
               ((FlagName -> StyleDoc) -> [FlagName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (FlagName -> String) -> FlagName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagName -> String
flagNameString) (Set FlagName -> [FlagName]
forall a. Set a -> [a]
Set.toList Set FlagName
pkgFlags) :: [StyleDoc])
           )
     where
      name :: String
name = PackageName -> String
packageNameString PackageName
pname
    go (UFSnapshot PackageName
name) = [StyleDoc] -> StyleDoc
fillSep
      [ String -> StyleDoc
flow String
"Attempted to set flag on snapshot package"
      , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
      , String -> StyleDoc
flow String
"please add the package to"
      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"extra-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
  pretty BuildPrettyException
GHCProfOptionInvalid =
    StyleDoc
"[S-8100]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"When building with Stack, you should not use GHC's"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"-prof"
         , String -> StyleDoc
flow String
"option. Instead, please use Stack's"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--library-profiling"
         , StyleDoc
"and"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--executable-profiling"
         , String -> StyleDoc
flow String
"flags. See:"
         , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/1015" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]

instance Exception BuildPrettyException

-- | Helper function to pretty print an error message for target parse errors.

pprintTargetParseErrors :: [StyleDoc] -> StyleDoc
pprintTargetParseErrors :: [StyleDoc] -> StyleDoc
pprintTargetParseErrors [StyleDoc]
errs =
     StyleDoc
line
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack failed to parse the target(s)."
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
       [ String -> StyleDoc
flow String
"While parsing, Stack encountered the"
       , case [StyleDoc]
errs of
           [StyleDoc
err] ->
                  StyleDoc
"error:"
               StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
               StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 StyleDoc
err
           [StyleDoc]
_ ->
                  String -> StyleDoc
flow String
"following errors:"
               StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
               StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList [StyleDoc]
errs
       ]
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
       [ String -> StyleDoc
flow String
"Stack expects a target to be a package name (e.g."
       , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"my-package" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"),"
       , String -> StyleDoc
flow String
"a package identifier (e.g."
       , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"my-package-0.1.2.3" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"),"
       , String -> StyleDoc
flow String
"a package component (e.g."
       , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"my-package:test:my-test-suite" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"),"
       , String -> StyleDoc
flow String
"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
  -> Bool
  -> ParentMap
  -> Set PackageName
  -> Map PackageName [PackageName]
  -> StyleDoc
pprintExceptions :: [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> Bool
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions [ConstructPlanException]
exceptions Path Abs File
stackYaml Path Abs Dir
stackRoot Bool
isImplicitGlobal ParentMap
parentMap Set PackageName
wanted' Map PackageName [PackageName]
prunedGlobalDeps =
     [StyleDoc] -> StyleDoc
fillSep
       [ String -> StyleDoc
flow
           (  String
"While constructing the build plan, Stack encountered the \
              \following errors"
           String -> ShowS
forall a. Semigroup a => a -> a -> a
<> if Bool
hasConfigurationRefs then String
"." else String
":"
           )
       , if Bool
hasConfigurationRefs
           then String -> StyleDoc
flow
             String
"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 StyleDoc
forall a. Monoid a => a
mempty
       ]
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
blankLine ((ConstructPlanException -> Maybe StyleDoc)
-> [ConstructPlanException] -> [StyleDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ConstructPlanException -> Maybe StyleDoc
pprintException [ConstructPlanException]
exceptions'))
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> if [StyleDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [StyleDoc]
recommendations
       then StyleDoc
forall a. Monoid a => a
mempty
       else
            StyleDoc
blankLine
         StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Some different approaches to resolving some or all of this:"
         StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
         StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
2 ([StyleDoc] -> StyleDoc
spacedBulletedList [StyleDoc]
recommendations)
 where
  exceptions' :: [ConstructPlanException]
exceptions' = {- should we dedupe these somehow? nubOrd -} [ConstructPlanException]
exceptions

  recommendations :: [StyleDoc]
recommendations =
       [ Bool -> Bool -> StyleDoc
allowNewerMsg Bool
True Bool
False | Bool
onlyHasDependencyMismatches ]
    [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ [StyleDoc] -> StyleDoc
fillSep
           ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> StyleDoc
allowNewerMsg Bool
False Bool
onlyHasDependencyMismatches
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: String -> StyleDoc
flow String
"add these package names under"
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"allow-newer-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
           StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Shell) Bool
False
               ((PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) (Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.elems Set PackageName
pkgsWithMismatches) :: [StyleDoc])
       | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
pkgsWithMismatches
       ]
    [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [StyleDoc]
addExtraDepsRecommendations
   where
    allowNewerMsg :: Bool -> Bool -> StyleDoc
allowNewerMsg Bool
isAll Bool
isRepetitive = [StyleDoc] -> StyleDoc
fillSep
      ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"To ignore"
      StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: (if Bool
isAll then StyleDoc
"all" else StyleDoc
"certain")
      StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: String -> StyleDoc
flow String
"version constraints and build anyway,"
      StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: if Bool
isRepetitive
          then [StyleDoc
"also"]
          else
            [ [StyleDoc] -> StyleDoc
fillSep
                ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$  [ StyleDoc
"in"
                   , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
stackRoot)
                   , String -> StyleDoc
flow
                       (  String
"(global configuration)"
                       String -> ShowS
forall a. Semigroup a => a -> a -> a
<> if Bool
isImplicitGlobal then String
"," else String
forall a. Monoid a => a
mempty
                       )
                   ]
                [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isImplicitGlobal
                       then []
                       else
                         [ StyleDoc
"or"
                         , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml
                         , String -> StyleDoc
flow String
"(project-level configuration),"
                         ]
                   )
                [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ StyleDoc
"set"
                   ,    Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"allow-newer: true")
                     StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> if Bool
isAll then StyleDoc
"." else StyleDoc
forall a. Monoid a => a
mempty
                   ]
                [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ StyleDoc
"and" | Bool -> Bool
not Bool
isAll ]
            ]

  addExtraDepsRecommendations :: [StyleDoc]
addExtraDepsRecommendations
    | Map PackageName (Version, BlobKey) -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName (Version, BlobKey)
extras = []
    | (Just (Version, BlobKey)
_) <- PackageName
-> Map PackageName (Version, BlobKey) -> Maybe (Version, BlobKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> PackageName
mkPackageName String
"base") Map PackageName (Version, BlobKey)
extras =
        [ [StyleDoc] -> StyleDoc
fillSep
            [ String -> StyleDoc
flow String
"Build requires unattainable version of the"
            , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base"
            , String -> StyleDoc
flow String
"package. Since"
            , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base"
            , String -> StyleDoc
flow String
"is a part of GHC, you most likely need to use a \
                   \different GHC version with the matching"
            , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"base"StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
            ]
        ]
    | Bool
otherwise =
        [   [StyleDoc] -> StyleDoc
fillSep
              [ Style -> StyleDoc -> StyleDoc
style Style
Recommendation (String -> StyleDoc
flow String
"Recommended action:")
              , String -> StyleDoc
flow String
"try adding the following to your"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"extra-deps"
              , StyleDoc
"in"
              , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml
              , StyleDoc
"(project-level configuration):"
              ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
vsep (((PackageName, (Version, BlobKey)) -> StyleDoc)
-> [(PackageName, (Version, BlobKey))] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, (Version, BlobKey)) -> StyleDoc
forall {a}. IsString a => (PackageName, (Version, BlobKey)) -> a
pprintExtra (Map PackageName (Version, BlobKey)
-> [(PackageName, (Version, BlobKey))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Version, BlobKey)
extras))
        ]

  pprintExtra :: (PackageName, (Version, BlobKey)) -> a
pprintExtra (PackageName
name, (Version
version, BlobKey SHA256
cabalHash FileSize
cabalSize)) =
    let cfInfo :: CabalFileInfo
cfInfo = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
cabalHash (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
cabalSize)
        packageIdRev :: PackageIdentifierRevision
packageIdRev = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfInfo
    in  String -> a
forall a. IsString a => String -> a
fromString (String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Utf8Builder -> Text
utf8BuilderToText (PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
packageIdRev)))

  allNotInBuildPlan :: Set PackageName
allNotInBuildPlan = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (ConstructPlanException -> [PackageName])
-> [ConstructPlanException] -> [PackageName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructPlanException -> [PackageName]
toNotInBuildPlan [ConstructPlanException]
exceptions'
  toNotInBuildPlan :: ConstructPlanException -> [PackageName]
toNotInBuildPlan (DependencyPlanFailures Package
_ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) =
    ((PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))
 -> PackageName)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> PackageName
forall a b. (a, b) -> a
fst ([(PackageName,
   (VersionRange, Maybe (Version, BlobKey), BadDependency))]
 -> [PackageName])
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [PackageName]
forall a b. (a -> b) -> a -> b
$
      ((PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))
 -> Bool)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (\(PackageName
_, (VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
badDep)) -> BadDependency
badDep BadDependency -> BadDependency -> Bool
forall a. Eq a => a -> a -> Bool
== BadDependency
NotInBuildPlan)
        (Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps)
  toNotInBuildPlan ConstructPlanException
_ = []

  (Bool
onlyHasDependencyMismatches, Bool
hasConfigurationRefs, Map PackageName (Version, BlobKey)
extras, Set PackageName
pkgsWithMismatches) =
    (Bool, Bool, Map PackageName (Version, BlobKey), Set PackageName)
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 :: (Bool, Bool, Map PackageName (Version, BlobKey), Set PackageName)
filterExceptions = ((Bool, Bool, Map PackageName (Version, BlobKey), Set PackageName)
 -> ConstructPlanException
 -> (Bool, Bool, Map PackageName (Version, BlobKey),
     Set PackageName))
-> (Bool, Bool, Map PackageName (Version, BlobKey),
    Set PackageName)
-> [ConstructPlanException]
-> (Bool, Bool, Map PackageName (Version, BlobKey),
    Set PackageName)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (Bool, Bool, Map PackageName (Version, BlobKey), Set PackageName)
-> ConstructPlanException
-> (Bool, Bool, Map PackageName (Version, BlobKey),
    Set PackageName)
go (Bool, Bool, Map PackageName (Version, BlobKey), Set PackageName)
forall {k} {a} {a}. (Bool, Bool, Map k a, Set a)
acc0 [ConstructPlanException]
exceptions'
   where
    acc0 :: (Bool, Bool, Map k a, Set a)
acc0 = (Bool
True, Bool
False, Map k a
forall k a. Map k a
Map.empty, Set a
forall a. Set a
Set.empty)
    go :: (Bool, Bool, Map PackageName (Version, BlobKey), Set PackageName)
-> ConstructPlanException
-> (Bool, Bool, Map PackageName (Version, BlobKey),
    Set PackageName)
go (Bool, Bool, Map PackageName (Version, BlobKey), Set PackageName)
acc (DependencyPlanFailures Package
pkg Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m) = (PackageName
 -> (VersionRange, Maybe (Version, BlobKey), BadDependency)
 -> (Bool, Bool, Map PackageName (Version, BlobKey),
     Set PackageName)
 -> (Bool, Bool, Map PackageName (Version, BlobKey),
     Set PackageName))
-> (Bool, Bool, Map PackageName (Version, BlobKey),
    Set PackageName)
-> Map
     PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> (Bool, Bool, Map PackageName (Version, BlobKey),
    Set PackageName)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey PackageName
-> (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> (Bool, Bool, Map PackageName (Version, BlobKey),
    Set PackageName)
-> (Bool, Bool, Map PackageName (Version, BlobKey),
    Set PackageName)
forall {k} {a} {a}.
Ord k =>
k
-> (a, Maybe a, BadDependency)
-> (Bool, Bool, Map k a, Set PackageName)
-> (Bool, Bool, Map k a, Set PackageName)
go' (Bool, Bool, Map PackageName (Version, BlobKey), Set PackageName)
acc Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m
     where
      pkgName :: PackageName
pkgName = Package -> PackageName
packageName Package
pkg
      go' :: k
-> (a, Maybe a, BadDependency)
-> (Bool, Bool, Map k a, Set PackageName)
-> (Bool, Bool, Map k a, Set PackageName)
go' k
name (a
_, Just a
extra, BadDependency
NotInBuildPlan) (Bool
_, Bool
_, Map k a
m', Set PackageName
s) =
        (Bool
False, Bool
True, k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
name a
extra Map k a
m', Set PackageName
s)
      go' k
_ (a
_, Maybe a
_, BadDependency
NotInBuildPlan) (Bool
_, Bool
_, Map k a
m', Set PackageName
s) = (Bool
False, Bool
True, Map k a
m', Set PackageName
s)
      go' k
name (a
_, Just a
extra, DependencyMismatch Version
_) (Bool
p1, Bool
_, Map k a
m', Set PackageName
s) =
        (Bool
p1, Bool
True, k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
name a
extra Map k a
m', PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.insert PackageName
pkgName Set PackageName
s)
      go' k
_ (a
_, Maybe a
_, DependencyMismatch Version
_) (Bool
p1, Bool
_, Map k a
m', Set PackageName
s) =
        (Bool
p1, Bool
True, Map k a
m', PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.insert PackageName
pkgName Set PackageName
s)
      go' k
_ (a
_, Maybe a
_, Couldn'tResolveItsDependencies Version
_) (Bool, Bool, Map k a, Set PackageName)
acc' = (Bool, Bool, Map k a, Set PackageName)
acc'
      go' k
_ (a, Maybe a, BadDependency)
_ (Bool
_, Bool
p2, Map k a
m', Set PackageName
s) = (Bool
False, Bool
p2, Map k a
m', Set PackageName
s)
    go (Bool
_, Bool
p2, Map PackageName (Version, BlobKey)
m, Set PackageName
s) ConstructPlanException
_ = (Bool
False, Bool
p2, Map PackageName (Version, BlobKey)
m, Set PackageName
s)

  pprintException :: ConstructPlanException -> Maybe StyleDoc
pprintException (DependencyCycleDetected [PackageName]
pNames) = StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
       String -> StyleDoc
flow String
"Dependency cycle detected in packages:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4
         ( StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"[" StyleDoc
"]" StyleDoc
","
             ((PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Error (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
pNames)
         )
  pprintException (DependencyPlanFailures Package
pkg Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) =
    case ((PackageName,
  (VersionRange, Maybe (Version, BlobKey), BadDependency))
 -> Maybe StyleDoc)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
-> [StyleDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageName,
 (VersionRange, Maybe (Version, BlobKey), BadDependency))
-> Maybe StyleDoc
forall {b}.
(PackageName, (VersionRange, Maybe (Version, b), BadDependency))
-> Maybe StyleDoc
pprintDep (Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
-> [(PackageName,
     (VersionRange, Maybe (Version, BlobKey), BadDependency))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) of
      [] -> Maybe StyleDoc
forall a. Maybe a
Nothing
      [StyleDoc]
depErrors -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$
           [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"In the dependencies for"
             , StyleDoc
pkgIdent StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Map FlagName Bool -> StyleDoc
pprintFlags (Package -> Map FlagName Bool
packageFlags Package
pkg) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
2 ([StyleDoc] -> StyleDoc
bulletedList [StyleDoc]
depErrors)
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> case ParentMap
-> Set PackageName -> PackageName -> Maybe [PackageIdentifier]
getShortestDepsPath ParentMap
parentMap Set PackageName
wanted' (Package -> PackageName
packageName Package
pkg) of
             Maybe [PackageIdentifier]
Nothing ->
                  StyleDoc
line
               StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"needed for unknown reason - Stack invariant violated."
             Just [] ->
                  StyleDoc
line
               StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                    [ String -> StyleDoc
flow String
"needed since"
                    , StyleDoc
pkgName'
                    , String -> StyleDoc
flow String
"is a build target."
                    ]
             Just (PackageIdentifier
target:[PackageIdentifier]
path) ->
                  StyleDoc
line
               StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"needed due to" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"" StyleDoc
"" StyleDoc
" -> " [StyleDoc]
pathElems
              where
               pathElems :: [StyleDoc]
pathElems =
                    [Style -> StyleDoc -> StyleDoc
style Style
Target (StyleDoc -> StyleDoc)
-> (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageIdentifier -> String) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
target]
                 [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> (PackageIdentifier -> StyleDoc)
-> [PackageIdentifier] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageIdentifier -> String) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString) [PackageIdentifier]
path
                 [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [StyleDoc
pkgIdent]
       where
        pkgName' :: StyleDoc
pkgName' =
          Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
pkg
        pkgIdent :: StyleDoc
pkgIdent =
          Style -> StyleDoc -> StyleDoc
style
            Style
Current
            (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageIdentifier -> String) -> PackageIdentifier -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString (PackageIdentifier -> StyleDoc) -> PackageIdentifier -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdentifier Package
pkg)
  -- Skip these when they are redundant with 'NotInBuildPlan' info.

  pprintException (UnknownPackage PackageName
name)
    | PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
allNotInBuildPlan = Maybe StyleDoc
forall a. Maybe a
Nothing
    | PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages = StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
        [ String -> StyleDoc
flow String
"Can't build a package with same name as a wired-in-package:"
        , Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name
        ]
    | Just [PackageName]
pruned <- PackageName -> Map PackageName [PackageName] -> Maybe [PackageName]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName [PackageName]
prunedGlobalDeps =
        let prunedDeps :: [StyleDoc]
prunedDeps =
              (PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
pruned
        in  StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
              [ String -> StyleDoc
flow String
"Can't use GHC boot package"
              , Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name
              , String -> StyleDoc
flow String
"when it depends on a replaced boot package. You need to \
                     \add the following as explicit dependencies to the \
                     \project:"
              , StyleDoc
line
              , StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"" StyleDoc
"" StyleDoc
", " [StyleDoc]
prunedDeps
              ]
    | Bool
otherwise = StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
        [ String -> StyleDoc
flow String
"Unknown package:"
        , Style -> StyleDoc -> StyleDoc
style Style
Current (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name
        ]

  pprintFlags :: Map FlagName Bool -> StyleDoc
pprintFlags Map FlagName Bool
flags
    | Map FlagName Bool -> Bool
forall k a. Map k a -> Bool
Map.null Map FlagName Bool
flags = StyleDoc
""
    | Bool
otherwise = StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
sep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ ((FlagName, Bool) -> StyleDoc) -> [(FlagName, Bool)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FlagName, Bool) -> StyleDoc
forall {a}. (Semigroup a, IsString a) => (FlagName, Bool) -> a
pprintFlag ([(FlagName, Bool)] -> [StyleDoc])
-> [(FlagName, Bool)] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ Map FlagName Bool -> [(FlagName, Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FlagName Bool
flags
  pprintFlag :: (FlagName, Bool) -> a
pprintFlag (FlagName
name, Bool
True) = a
"+" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> String -> a
forall a. IsString a => String -> a
fromString (FlagName -> String
flagNameString FlagName
name)
  pprintFlag (FlagName
name, Bool
False) = a
"-" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> String -> a
forall a. IsString a => String -> a
fromString (FlagName -> String
flagNameString FlagName
name)

  pprintDep :: (PackageName, (VersionRange, Maybe (Version, b), BadDependency))
-> Maybe StyleDoc
pprintDep (PackageName
name, (VersionRange
range, Maybe (Version, b)
mlatestApplicable, BadDependency
badDep)) = case BadDependency
badDep of
    BadDependency
NotInBuildPlan
      | PackageName
name PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map PackageName [PackageName] -> [PackageName]
forall m. Monoid m => Map PackageName m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map PackageName [PackageName]
prunedGlobalDeps -> StyleDoc -> Maybe StyleDoc
butMsg (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"this GHC boot package has been pruned from the Stack \
                 \configuration. You need to add the package explicitly to"
          , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"extra-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
      | Bool
otherwise -> StyleDoc -> Maybe StyleDoc
butMsg (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ Maybe Version -> StyleDoc
inconsistentMsg Maybe Version
forall a. Maybe a
Nothing
    -- TODO: For local packages, suggest editing constraints

    DependencyMismatch Version
version -> StyleDoc -> Maybe StyleDoc
butMsg (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ Maybe Version -> StyleDoc
inconsistentMsg (Maybe Version -> StyleDoc) -> Maybe Version -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just Version
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
_version -> Maybe StyleDoc
forall a. Maybe a
Nothing
    BadDependency
HasNoLibrary -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
      [ StyleDoc
errorName
      , String -> StyleDoc
flow String
"is a library dependency, but the package provides no library."
      ]
    BDDependencyCycleDetected [PackageName]
names -> StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
      [ StyleDoc
errorName
      , String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ String
"dependency cycle detected: "
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ((PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
names)
      ]
   where
    errorName :: StyleDoc
errorName = Style -> StyleDoc -> StyleDoc
style Style
Error (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name
    goodRange :: StyleDoc
goodRange = Style -> StyleDoc -> StyleDoc
style Style
Good (String -> StyleDoc
forall a. IsString a => String -> a
fromString (VersionRange -> String
forall a. Pretty a => a -> String
C.display VersionRange
range))
    rangeMsg :: StyleDoc
rangeMsg = if VersionRange
range VersionRange -> VersionRange -> Bool
forall a. Eq a => a -> a -> Bool
== VersionRange
C.anyVersion
      then StyleDoc
"needed,"
      else [StyleDoc] -> StyleDoc
fillSep
        [ String -> StyleDoc
flow String
"must match"
        , StyleDoc
goodRange StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
        ]
    butMsg :: StyleDoc -> Maybe StyleDoc
butMsg StyleDoc
msg = StyleDoc -> Maybe StyleDoc
forall a. a -> Maybe a
Just (StyleDoc -> Maybe StyleDoc) -> StyleDoc -> Maybe StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
      [ StyleDoc
errorName
      , StyleDoc
rangeMsg
      , StyleDoc
"but"
      , StyleDoc
msg
      , Maybe Version -> StyleDoc
latestApplicable Maybe Version
forall a. Maybe a
Nothing
      ]
    inconsistentMsg :: Maybe Version -> StyleDoc
inconsistentMsg Maybe Version
mVersion = [StyleDoc] -> StyleDoc
fillSep
      [ Style -> StyleDoc -> StyleDoc
style Style
Error (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> (Version -> StyleDoc) -> Maybe Version -> StyleDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          ( String -> StyleDoc
flow String
"no version" )
          ( String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> (Version -> String) -> Version -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString (PackageIdentifier -> String)
-> (Version -> PackageIdentifier) -> Version -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name )
          Maybe Version
mVersion
      , String -> StyleDoc
flow String
"is in the Stack configuration"
      ]
    latestApplicable :: Maybe Version -> StyleDoc
latestApplicable Maybe Version
mversion =
      case Maybe (Version, b)
mlatestApplicable of
        Maybe (Version, b)
Nothing
          | Maybe Version -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Version
mversion -> [StyleDoc] -> StyleDoc
fillSep
              [ String -> StyleDoc
flow String
"(no matching package and version found. Perhaps there is \
                     \an error in the specification of a package's"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"dependencies"
              , StyleDoc
"or"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"build-tools"
              , String -> StyleDoc
flow String
"(Hpack) or"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"build-depends" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"build-tools"
              , StyleDoc
"or"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"build-tool-depends"
              , String -> StyleDoc
flow String
"(Cabal file)"
              , String -> StyleDoc
flow String
"or an omission from the"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"packages"
              , String -> StyleDoc
flow String
"list in"
              , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml
              , String -> StyleDoc
flow String
"(project-level configuration).)"
              ]
          | Bool
otherwise -> StyleDoc
""
        Just (Version
laVer, b
_)
          | Version -> Maybe Version
forall a. a -> Maybe a
Just Version
laVer Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Version
mversion ->
              String -> StyleDoc
flow String
"(latest matching version is specified)."
          | Bool
otherwise ->
              [StyleDoc] -> StyleDoc
fillSep
                [ String -> StyleDoc
flow String
"(latest matching version is"
                , Style -> StyleDoc -> StyleDoc
style Style
Good (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
laVer) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
")."
                ]

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 (ConstructPlanException -> ConstructPlanException -> Bool
(ConstructPlanException -> ConstructPlanException -> Bool)
-> (ConstructPlanException -> ConstructPlanException -> Bool)
-> Eq ConstructPlanException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstructPlanException -> ConstructPlanException -> Bool
== :: ConstructPlanException -> ConstructPlanException -> Bool
$c/= :: ConstructPlanException -> ConstructPlanException -> Bool
/= :: ConstructPlanException -> ConstructPlanException -> Bool
Eq, Int -> ConstructPlanException -> ShowS
[ConstructPlanException] -> ShowS
ConstructPlanException -> String
(Int -> ConstructPlanException -> ShowS)
-> (ConstructPlanException -> String)
-> ([ConstructPlanException] -> ShowS)
-> Show ConstructPlanException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstructPlanException -> ShowS
showsPrec :: Int -> ConstructPlanException -> ShowS
$cshow :: ConstructPlanException -> String
show :: ConstructPlanException -> String
$cshowList :: [ConstructPlanException] -> ShowS
showList :: [ConstructPlanException] -> ShowS
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 (BadDependency -> BadDependency -> Bool
(BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> Bool) -> Eq BadDependency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BadDependency -> BadDependency -> Bool
== :: BadDependency -> BadDependency -> Bool
$c/= :: BadDependency -> BadDependency -> Bool
/= :: BadDependency -> BadDependency -> Bool
Eq, Eq BadDependency
Eq BadDependency
-> (BadDependency -> BadDependency -> Ordering)
-> (BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> Bool)
-> (BadDependency -> BadDependency -> BadDependency)
-> (BadDependency -> BadDependency -> BadDependency)
-> Ord BadDependency
BadDependency -> BadDependency -> Bool
BadDependency -> BadDependency -> Ordering
BadDependency -> BadDependency -> BadDependency
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BadDependency -> BadDependency -> Ordering
compare :: BadDependency -> BadDependency -> Ordering
$c< :: BadDependency -> BadDependency -> Bool
< :: BadDependency -> BadDependency -> Bool
$c<= :: BadDependency -> BadDependency -> Bool
<= :: BadDependency -> BadDependency -> Bool
$c> :: BadDependency -> BadDependency -> Bool
> :: BadDependency -> BadDependency -> Bool
$c>= :: BadDependency -> BadDependency -> Bool
>= :: BadDependency -> BadDependency -> Bool
$cmax :: BadDependency -> BadDependency -> BadDependency
max :: BadDependency -> BadDependency -> BadDependency
$cmin :: BadDependency -> BadDependency -> BadDependency
min :: BadDependency -> BadDependency -> BadDependency
Ord, Int -> BadDependency -> ShowS
[BadDependency] -> ShowS
BadDependency -> String
(Int -> BadDependency -> ShowS)
-> (BadDependency -> String)
-> ([BadDependency] -> ShowS)
-> Show BadDependency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BadDependency -> ShowS
showsPrec :: Int -> BadDependency -> ShowS
$cshow :: BadDependency -> String
show :: BadDependency -> String
$cshowList :: [BadDependency] -> ShowS
showList :: [BadDependency] -> ShowS
Show, Typeable)

missingExeError :: String -> Bool -> String -> String
missingExeError :: String -> Bool -> ShowS
missingExeError String
errorCode Bool
isSimpleBuildType String
msg = [String] -> String
unlines
  ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
errorCode
  String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
msg
  String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"Possible causes of this issue:"
  String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"* " <>) [String]
possibleCauses
 where
  possibleCauses :: [String]
possibleCauses
    = String
"No module named \"Main\". The 'main-is' source file should usually \
      \have a header indicating that it's a 'Main' module."
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"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."
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [ String
"The Setup.hs file is changing the installation target dir."
      | Bool -> Bool
not Bool
isSimpleBuildType
      ]

showBuildError ::
     String
  -> Bool
  -> ExitCode
  -> Maybe PackageIdentifier
  -> Path Abs File
  -> [String]
  -> Maybe (Path Abs File)
  -> [Text]
  -> StyleDoc
showBuildError :: String
-> Bool
-> ExitCode
-> Maybe PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
-> StyleDoc
showBuildError String
errorCode Bool
isBuildingSetup ExitCode
exitCode Maybe PackageIdentifier
mtaskProvides Path Abs File
execName [String]
fullArgs Maybe (Path Abs File)
logFiles [Text]
bss =
  let fullCmd :: String
fullCmd = [String] -> String
unwords
        ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ShowS
dropQuotes (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
execName)
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (String -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
showProcessArgDebug) [String]
fullArgs
      logLocations :: StyleDoc
logLocations =
        StyleDoc
-> (Path Abs File -> StyleDoc) -> Maybe (Path Abs File) -> StyleDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          StyleDoc
forall a. Monoid a => a
mempty
          (\Path Abs File
fp -> StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Logs have been written to:" StyleDoc -> StyleDoc -> StyleDoc
<+>
                    Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp)
          Maybe (Path Abs File)
logFiles
  in     String -> StyleDoc
forall a. IsString a => String -> a
fromString String
errorCode
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While building" StyleDoc -> StyleDoc -> StyleDoc
<+>
         ( case (Bool
isBuildingSetup, Maybe PackageIdentifier
mtaskProvides) of
             (Bool
False, Maybe PackageIdentifier
Nothing) -> BuildException -> StyleDoc
forall e a. Exception e => e -> a
impureThrow BuildException
ShowBuildErrorBug
             (Bool
False, Just PackageIdentifier
taskProvides') ->
                StyleDoc
"package" StyleDoc -> StyleDoc -> StyleDoc
<+>
                  Style -> StyleDoc -> StyleDoc
style
                    Style
Target
                    (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ ShowS
dropQuotes (PackageIdentifier -> String
packageIdentifierString PackageIdentifier
taskProvides'))
             (Bool
True, Maybe PackageIdentifier
Nothing) -> StyleDoc
"simple" StyleDoc -> StyleDoc -> StyleDoc
<+> Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"Setup.hs"
             (Bool
True, Just PackageIdentifier
taskProvides') ->
                StyleDoc
"custom" StyleDoc -> StyleDoc -> StyleDoc
<+>
                  Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"Setup.hs" StyleDoc -> StyleDoc -> StyleDoc
<+>
                  String -> StyleDoc
flow String
"for package" StyleDoc -> StyleDoc -> StyleDoc
<+>
                  Style -> StyleDoc -> StyleDoc
style
                    Style
Target
                    (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ ShowS
dropQuotes (PackageIdentifier -> String
packageIdentifierString PackageIdentifier
taskProvides'))
         ) StyleDoc -> StyleDoc -> StyleDoc
<+>
         String -> StyleDoc
flow String
"(scroll up to its section to see the error) using:"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
fullCmd)
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Process exited with code:" StyleDoc -> StyleDoc -> StyleDoc
<+> (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (ExitCode -> String) -> ExitCode -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExitCode -> String
forall a. Show a => a -> String
show) ExitCode
exitCode StyleDoc -> StyleDoc -> StyleDoc
<+>
         ( if ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ExitCode
ExitFailure (-Int
9)
             then String -> StyleDoc
flow String
"(THIS MAY INDICATE OUT OF MEMORY)"
             else StyleDoc
forall a. Monoid a => a
mempty
         )
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
logLocations
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
bss
           then StyleDoc
forall a. Monoid a => a
mempty
           else StyleDoc
blankLine StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string ([String] -> String
removeTrailingSpaces ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
bss))
   where
    removeTrailingSpaces :: [String] -> String
removeTrailingSpaces = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
    dropQuotes :: ShowS
dropQuotes = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char
'\"' /=)

-- | 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 :: ParentMap
-> Set PackageName -> PackageName -> Maybe [PackageIdentifier]
getShortestDepsPath (MonoidMap Map
  PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap) Set PackageName
wanted' PackageName
name =
  if PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name Set PackageName
wanted'
    then [PackageIdentifier] -> Maybe [PackageIdentifier]
forall a. a -> Maybe a
Just []
    else case PackageName
-> Map
     PackageName (First Version, [(PackageIdentifier, VersionRange)])
-> Maybe (First Version, [(PackageIdentifier, VersionRange)])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map
  PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap of
      Maybe (First Version, [(PackageIdentifier, VersionRange)])
Nothing -> Maybe [PackageIdentifier]
forall a. Maybe a
Nothing
      Just (First Version
_, [(PackageIdentifier, VersionRange)]
parents) -> [PackageIdentifier] -> Maybe [PackageIdentifier]
forall a. a -> Maybe a
Just ([PackageIdentifier] -> Maybe [PackageIdentifier])
-> [PackageIdentifier] -> Maybe [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest Int
256 Map PackageName DepsPath
paths0
       where
        paths0 :: Map PackageName DepsPath
paths0 = [(PackageName, DepsPath)] -> Map PackageName DepsPath
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PackageName, DepsPath)] -> Map PackageName DepsPath)
-> [(PackageName, DepsPath)] -> Map PackageName DepsPath
forall a b. (a -> b) -> a -> b
$
          ((PackageIdentifier, VersionRange) -> (PackageName, DepsPath))
-> [(PackageIdentifier, VersionRange)] -> [(PackageName, DepsPath)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
ident, VersionRange
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident, PackageIdentifier -> DepsPath
startDepsPath PackageIdentifier
ident)) [(PackageIdentifier, VersionRange)]
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 :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest Int
fuel Map PackageName DepsPath
_ | Int
fuel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 =
    [ PackageName -> Version -> PackageIdentifier
PackageIdentifier
        (String -> PackageName
mkPackageName String
"stack-ran-out-of-jet-fuel")
        ([Int] -> Version
C.mkVersion [Int
0])
    ]
  findShortest Int
_ Map PackageName DepsPath
paths | Map PackageName DepsPath -> Bool
forall k a. Map k a -> Bool
M.null Map PackageName DepsPath
paths = []
  findShortest Int
fuel Map PackageName DepsPath
paths =
    case [(PackageName, DepsPath)]
targets of
      [] -> Int -> Map PackageName DepsPath -> [PackageIdentifier]
findShortest (Int
fuel Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Map PackageName DepsPath -> [PackageIdentifier])
-> Map PackageName DepsPath -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ (DepsPath -> DepsPath -> DepsPath)
-> [(PackageName, DepsPath)] -> Map PackageName DepsPath
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith DepsPath -> DepsPath -> DepsPath
chooseBest ([(PackageName, DepsPath)] -> Map PackageName DepsPath)
-> [(PackageName, DepsPath)] -> Map PackageName DepsPath
forall a b. (a -> b) -> a -> b
$
              ((PackageName, DepsPath) -> [(PackageName, DepsPath)])
-> [(PackageName, DepsPath)] -> [(PackageName, DepsPath)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath [(PackageName, DepsPath)]
recurses
      [(PackageName, DepsPath)]
_ -> let (DepsPath Int
_ Int
_ [PackageIdentifier]
path) = [DepsPath] -> DepsPath
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
L.minimum (((PackageName, DepsPath) -> DepsPath)
-> [(PackageName, DepsPath)] -> [DepsPath]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, DepsPath) -> DepsPath
forall a b. (a, b) -> b
snd [(PackageName, DepsPath)]
targets) in [PackageIdentifier]
path
   where
    ([(PackageName, DepsPath)]
targets, [(PackageName, DepsPath)]
recurses) =
      ((PackageName, DepsPath) -> Bool)
-> [(PackageName, DepsPath)]
-> ([(PackageName, DepsPath)], [(PackageName, DepsPath)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (\(PackageName
n, DepsPath
_) -> PackageName
n PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wanted') (Map PackageName DepsPath -> [(PackageName, DepsPath)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName DepsPath
paths)
  chooseBest :: DepsPath -> DepsPath -> DepsPath
  chooseBest :: DepsPath -> DepsPath -> DepsPath
chooseBest = DepsPath -> DepsPath -> DepsPath
forall a. Ord a => a -> a -> a
max
  -- Extend a path to all its parents.

  extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
  extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath (PackageName
n, DepsPath
dp) =
    case PackageName
-> Map
     PackageName (First Version, [(PackageIdentifier, VersionRange)])
-> Maybe (First Version, [(PackageIdentifier, VersionRange)])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
n Map
  PackageName (First Version, [(PackageIdentifier, VersionRange)])
parentsMap of
      Maybe (First Version, [(PackageIdentifier, VersionRange)])
Nothing -> []
      Just (First Version
_, [(PackageIdentifier, VersionRange)]
parents) ->
        ((PackageIdentifier, VersionRange) -> (PackageName, DepsPath))
-> [(PackageIdentifier, VersionRange)] -> [(PackageName, DepsPath)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
pkgId, VersionRange
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId, PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath PackageIdentifier
pkgId DepsPath
dp)) [(PackageIdentifier, VersionRange)]
parents

startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath PackageIdentifier
ident = DepsPath
  { dpLength :: Int
dpLength = Int
1
  , dpNameLength :: Int
dpNameLength = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> String
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident))
  , dpPath :: [PackageIdentifier]
dpPath = [PackageIdentifier
ident]
  }

extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath PackageIdentifier
ident DepsPath
dp = DepsPath
  { dpLength :: Int
dpLength = DepsPath -> Int
dpLength DepsPath
dp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  , dpNameLength :: Int
dpNameLength = DepsPath -> Int
dpNameLength DepsPath
dp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> String
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident))
  , dpPath :: [PackageIdentifier]
dpPath = [PackageIdentifier
ident]
  }

data DepsPath = DepsPath
  { DepsPath -> Int
dpLength :: Int
    -- ^ Length of dpPath

  , DepsPath -> Int
dpNameLength :: Int
    -- ^ Length of package names combined

  , DepsPath -> [PackageIdentifier]
dpPath :: [PackageIdentifier]
    -- ^ A path where the packages later in the list depend on those that come

    -- earlier

  }
  deriving (DepsPath -> DepsPath -> Bool
(DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> Bool) -> Eq DepsPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DepsPath -> DepsPath -> Bool
== :: DepsPath -> DepsPath -> Bool
$c/= :: DepsPath -> DepsPath -> Bool
/= :: DepsPath -> DepsPath -> Bool
Eq, Eq DepsPath
Eq DepsPath
-> (DepsPath -> DepsPath -> Ordering)
-> (DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> Bool)
-> (DepsPath -> DepsPath -> DepsPath)
-> (DepsPath -> DepsPath -> DepsPath)
-> Ord DepsPath
DepsPath -> DepsPath -> Bool
DepsPath -> DepsPath -> Ordering
DepsPath -> DepsPath -> DepsPath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DepsPath -> DepsPath -> Ordering
compare :: DepsPath -> DepsPath -> Ordering
$c< :: DepsPath -> DepsPath -> Bool
< :: DepsPath -> DepsPath -> Bool
$c<= :: DepsPath -> DepsPath -> Bool
<= :: DepsPath -> DepsPath -> Bool
$c> :: DepsPath -> DepsPath -> Bool
> :: DepsPath -> DepsPath -> Bool
$c>= :: DepsPath -> DepsPath -> Bool
>= :: DepsPath -> DepsPath -> Bool
$cmax :: DepsPath -> DepsPath -> DepsPath
max :: DepsPath -> DepsPath -> DepsPath
$cmin :: DepsPath -> DepsPath -> DepsPath
min :: DepsPath -> DepsPath -> DepsPath
Ord, Int -> DepsPath -> ShowS
[DepsPath] -> ShowS
DepsPath -> String
(Int -> DepsPath -> ShowS)
-> (DepsPath -> String) -> ([DepsPath] -> ShowS) -> Show DepsPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DepsPath -> ShowS
showsPrec :: Int -> DepsPath -> ShowS
$cshow :: DepsPath -> String
show :: DepsPath -> String
$cshowList :: [DepsPath] -> ShowS
showList :: [DepsPath] -> ShowS
Show)