{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# 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.NonEmpty ( nonEmpty )
import           RIO.Process ( showProcessArgDebug )
import           Stack.Constants
                   ( defaultUserConfigPath, wiredInPackages )
import           Stack.Prelude
import           Stack.Types.Compiler ( ActualCompiler, compilerVersionString )
import           Stack.Types.CompilerBuild
                   ( CompilerBuild, compilerBuildSuffix )
import           Stack.Types.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
  | 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
  | CallStackEmptyBug
  deriving (Show, Typeable)

instance Exception BuildException where
  displayException (Couldn'tFindPkgId name) = bugReport "[S-7178]" $ concat
    [ "After installing "
    , packageNameString name
    ,", the package id couldn't be found (via ghc-pkg describe "
    , packageNameString name
    , ")."
    ]
  displayException (Couldn'tParseTargets targets) = unlines
    $ "Error: [S-3127]"
    : "The following targets could not be parsed as package names or \
      \directories:"
    : map T.unpack targets
  displayException (UnknownTargets noKnown notInSnapshot stackYaml) = unlines
    $ "Error: [S-2154]"
    : (noKnown' ++ notInSnapshot')
   where
    noKnown'
      | Set.null noKnown = []
      | otherwise = pure $
          "The following target packages were not found: " ++
          intercalate ", " (map packageNameString $ Set.toList noKnown) ++
          "\nSee https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details."
    notInSnapshot'
      | Map.null notInSnapshot = []
      | otherwise =
            "The following packages are not in your snapshot, but exist"
          : "in your package index. Recommended action: add them to your"
          : ("extra-deps in " ++ toFilePath stackYaml)
          : "(Note: these are the most recent versions,"
          : "but there's no guarantee that they'll build together)."
          : ""
          : map
              (\(name, version') -> "- " ++ packageIdentifierString
                  (PackageIdentifier name version'))
              (Map.toList notInSnapshot)
  displayException (TestSuiteFailure ident codes mlogFile bs) = unlines
    $ "Error: [S-1995]"
    : concat
        [ ["Test suite failure for package " ++ packageIdentifierString ident]
        , flip map (Map.toList codes) $ \(name, mcode) -> concat
            [ "    "
            , T.unpack name
            , ": "
            , case mcode of
                Nothing -> " executable not found"
                Just ec -> " exited with: " ++ displayException ec
            ]
        , pure $ case mlogFile of
            Nothing -> "Logs printed to console"
            -- TODO Should we load up the full error output and print it here?
            Just logFile -> "Full log available at " ++ toFilePath logFile
        , if S.null bs
            then []
            else
              [ ""
              , ""
              , doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs
              ]
        ]
   where
    indent' = dropWhileEnd isSpace . unlines . fmap ("  " ++) . lines
    doubleIndent = indent' . indent'
  displayException (TestSuiteTypeUnsupported interface) = concat
    [ "Error: [S-3819]\n"
    , "Unsupported test suite type: "
    , show interface
    ]
     -- Suppressing duplicate output
  displayException (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat
    [ "Error: [S-5797]\n"
    , "Version for local package "
    , packageNameString name
    , " is "
    , versionString localV
    , ", but you asked for "
    , versionString requestedV
    , " on the command line"
    ]
  displayException (NoSetupHsFound dir) = concat
    [ "Error: [S-3118]\n"
    , "No Setup.hs or Setup.lhs file found in "
    , toFilePath dir
    ]
  displayException (InvalidGhcOptionsSpecification unused) = unlines
    $ "Error: [S-4925]"
    : "Invalid GHC options specification:"
    : map showGhcOptionSrc unused
   where
    showGhcOptionSrc name = concat
      [ "- Package '"
      , packageNameString name
      , "' not found"
      ]
  displayException (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) =
    missingExeError "[S-7987]"
      isSimpleBuildType $ concat
        [ "Test suite executable \""
        , exeName
        , " not found for "
        , pkgName'
        , ":test:"
        , testName
        ]
  displayException (CabalCopyFailed isSimpleBuildType innerMsg) =
    missingExeError "[S-8027]"
      isSimpleBuildType $ concat
        [ "'cabal copy' failed.  Error message:\n"
        , innerMsg
        , "\n"
        ]
  displayException (LocalPackagesPresent locals) = unlines
    $ "Error: [S-5510]"
    : "Local packages are not allowed when using the 'script' command. \
      \Packages found:"
    : map (\ident -> "- " ++ packageIdentifierString ident) locals
  displayException (CouldNotLockDistDir lockFile) = unlines
    [ "Error: [S-7168]"
    , "Locking the dist directory failed, try to lock file:"
    , "  " ++ toFilePath lockFile
    , "Maybe you're running another copy of Stack?"
    ]
  displayException (TaskCycleBug pid) = bugReport "[S-7868]" $
    "Unexpected task cycle for "
    ++ packageNameString (pkgName pid)
  displayException (PackageIdMissingBug ident) = bugReport "[S-8923]" $
    "singleBuild: missing package ID missing: "
    ++ show ident
  displayException AllInOneBuildBug = bugReport "[S-7371]"
    "Cannot have an all-in-one build that also has a final build step."
  displayException (MultipleResultsBug name dps) = bugReport "[S-6739]" $
    "singleBuild: multiple results when describing installed package "
    ++ show (name, dps)
  displayException TemplateHaskellNotFoundBug = bugReport "[S-3121]"
    "template-haskell is a wired-in GHC boot library but it wasn't found."
  displayException HaddockIndexNotFound =
    "Error: [S-6901]\n"
    ++ "No local or snapshot doc index found to open."
  displayException ShowBuildErrorBug = bugReport "[S-5452]"
    "Unexpected case in showBuildError."
  displayException CallStackEmptyBug = bugReport "[S-2696]"
    "addDep: call stack is empty."

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
  | NotOnlyLocal [PackageName] [Text]
  | CompilerVersionMismatch
      (Maybe (ActualCompiler, Arch)) -- found
      (WantedCompiler, Arch) -- expected
      GHCVariant -- expected
      CompilerBuild -- expected
      VersionCheck
      (Maybe (Path Abs File)) -- Path to the stack.yaml file
      StyleDoc -- recommended resolution
  deriving (Show, Typeable)

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

    go :: UnusedFlags -> StyleDoc
    go (UFNoPackage src name) = fillSep
      [ "Package"
      , style Error (fromPackageName name)
      , flow "not found"
      , showFlagSrc src
      ]
    go (UFFlagsNotDefined src pname pkgFlags flags) =
         fillSep
           ( "Package"
           : style Current (fromString name)
           : flow "does not define the following flags"
           : showFlagSrc src <> ":"
           : mkNarrativeList (Just Error) False
               (map (fromString . flagNameString) (Set.toList flags) :: [StyleDoc])
           )
      <> line
      <> if Set.null pkgFlags
           then fillSep
             [ flow "No flags are defined by package"
             , style Current (fromString name) <> "."
             ]
           else fillSep
           ( flow "Flags defined by package"
           : style Current (fromString name)
           : "are:"
           : mkNarrativeList (Just Good) False
               (map (fromString . flagNameString) (Set.toList pkgFlags) :: [StyleDoc])
           )
     where
      name = packageNameString pname
    go (UFSnapshot name) = fillSep
      [ flow "Attempted to set flag on snapshot package"
      , style Current (fromPackageName name) <> ","
      , flow "please add the package to"
      , style Shell "extra-deps" <> "."
      ]
  pretty GHCProfOptionInvalid =
    "[S-8100]"
    <> line
    <> fillSep
         [ flow "When building with Stack, you should not use GHC's"
         , style Shell "-prof"
         , flow "option. Instead, please use Stack's"
         , style Shell "--library-profiling"
         , "and"
         , style Shell "--executable-profiling"
         , flow "flags. See:"
         , style Url "https://github.com/commercialhaskell/stack/issues/1015" <> "."
         ]
  pretty (NotOnlyLocal packages exes) =
    "[S-1727]"
    <> line
    <> flow "Specified only-locals, but Stack needs to build snapshot contents:"
    <> line
    <> if null packages
         then mempty
         else
              fillSep
                ( "Packages:"
                : mkNarrativeList Nothing False
                    (map fromPackageName packages :: [StyleDoc])
                )
           <> line
    <> if null exes
         then mempty
         else
              fillSep
                ( "Executables:"
                : mkNarrativeList Nothing False
                    (map (fromString . T.unpack) exes :: [StyleDoc])
                )
           <> line
  pretty (CompilerVersionMismatch mactual (expected, eArch) ghcVariant ghcBuild check mstack resolution) =
    "[S-6362]"
    <> line
    <> fillSep
         [ case mactual of
             Nothing -> flow "No compiler found, expected"
             Just (actual, arch) -> fillSep
               [ flow "Compiler version mismatched, found"
               , fromString $ compilerVersionString actual
               , parens (pretty arch) <> ","
               , flow "but expected"
               ]
         , case check of
             MatchMinor -> flow "minor version match with"
             MatchExact -> flow "exact version"
             NewerMinor -> flow "minor version match or newer with"
         , fromString $ T.unpack $ utf8BuilderToText $ display expected
         , parens $ mconcat
             [ pretty eArch
             , fromString $ ghcVariantSuffix ghcVariant
             , fromString $ compilerBuildSuffix ghcBuild
             ]
         ,    parens
                ( fillSep
                    [ flow "based on"
                    , case mstack of
                        Nothing -> flow "command line arguments"
                        Just stack -> fillSep
                          [ flow "resolver setting in"
                          , pretty stack
                          ]
                    ]
                )
          <> "."
         ]
    <> blankLine
    <> resolution

instance Exception BuildPrettyException

-- | Helper function to pretty print an error message for target parse errors.
pprintTargetParseErrors :: [StyleDoc] -> StyleDoc
pprintTargetParseErrors errs =
     line
  <> flow "Stack failed to parse the target(s)."
  <> blankLine
  <> fillSep
       [ flow "While parsing, Stack encountered the"
       , case errs of
           [err] ->
                  "error:"
               <> blankLine
               <> indent 4 err
           _ ->
                  flow "following errors:"
               <> blankLine
               <> bulletedList errs
       ]
  <> blankLine
  <> fillSep
       [ flow "Stack expects a target to be a package name (e.g."
       , style Shell "my-package" <> "),"
       , flow "a package identifier (e.g."
       , style Shell "my-package-0.1.2.3" <> "),"
       , flow "a package component (e.g."
       , style Shell "my-package:test:my-test-suite" <> "),"
       , flow "or, failing that, a relative path to a directory that is a \
              \local package directory or a parent directory of one or more \
              \local package directories."
       ]

pprintExceptions ::
     [ConstructPlanException]
  -> Path Abs File
  -> Path Abs Dir
  -> Bool
  -> ParentMap
  -> Set PackageName
  -> Map PackageName [PackageName]
  -> StyleDoc
pprintExceptions exceptions stackYaml stackRoot isImplicitGlobal parentMap wanted' prunedGlobalDeps =
     fillSep
       [ flow
           (  "While constructing the build plan, Stack encountered the \
              \following errors"
           <> if hasConfigurationRefs then "." else ":"
           )
       , if hasConfigurationRefs
           then flow
             "The 'Stack configuration' refers to the set of package versions \
             \specified by the snapshot (after any dropped packages, or pruned \
             \GHC boot packages; if a boot package is replaced, Stack prunes \
             \all other such packages that depend on it) and any extra-deps:"
           else mempty
       ]
  <> blankLine
  <> mconcat (L.intersperse blankLine (mapMaybe pprintException exceptions'))
  <> if L.null recommendations
       then mempty
       else
            blankLine
         <> flow "Some different approaches to resolving some or all of this:"
         <> blankLine
         <> indent 2 (spacedBulletedList recommendations)
 where
  exceptions' = {- should we dedupe these somehow? nubOrd -} exceptions

  recommendations =
       [ allowNewerMsg True False | onlyHasDependencyMismatches ]
    <> [ fillSep
           $ allowNewerMsg False onlyHasDependencyMismatches
           : flow "add these package names under"
           : style Shell "allow-newer-deps" <> ":"
           : mkNarrativeList (Just Shell) False
               (map fromPackageName (Set.elems pkgsWithMismatches) :: [StyleDoc])
       | not $ Set.null pkgsWithMismatches
       ]
    <> addExtraDepsRecommendations
   where
    allowNewerMsg isAll isRepetitive = fillSep
      $ flow "To ignore"
      : (if isAll then "all" else "certain")
      : flow "version constraints and build anyway,"
      : if isRepetitive
          then ["also"]
          else
            [ fillSep
                $  [ "in"
                   , pretty (defaultUserConfigPath stackRoot)
                   , flow
                       (  "(global configuration)"
                       <> if isImplicitGlobal then "," else mempty
                       )
                   ]
                <> ( if isImplicitGlobal
                       then []
                       else
                         [ "or"
                         , pretty stackYaml
                         , flow "(project-level configuration),"
                         ]
                   )
                <> [ "set"
                   ,    style Shell (flow "allow-newer: true")
                     <> if isAll then "." else mempty
                   ]
                <> [ "and" | not isAll ]
            ]

  addExtraDepsRecommendations
    | Map.null extras = []
    | (Just _) <- Map.lookup (mkPackageName "base") extras =
        [ fillSep
            [ flow "Build requires unattainable version of the"
            , style Current "base"
            , flow "package. Since"
            , style Current "base"
            , flow "is a part of GHC, you most likely need to use a \
                   \different GHC version with the matching"
            , style Current "base"<> "."
            ]
        ]
    | otherwise =
        [   fillSep
              [ style Recommendation (flow "Recommended action:")
              , flow "try adding the following to your"
              , style Shell "extra-deps"
              , "in"
              , pretty stackYaml
              , "(project-level configuration):"
              ]
          <> blankLine
          <> vsep (map pprintExtra (Map.toList extras))
        ]

  pprintExtra (name, (version, BlobKey cabalHash cabalSize)) =
    let cfInfo = CFIHash cabalHash (Just cabalSize)
        packageIdRev = PackageIdentifierRevision name version cfInfo
    in  fromString ("- " ++ T.unpack (utf8BuilderToText (display packageIdRev)))

  allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions'
  toNotInBuildPlan (DependencyPlanFailures _ pDeps) =
    map fst $
      filter
        (\(_, (_, _, badDep)) -> badDep == NotInBuildPlan)
        (Map.toList pDeps)
  toNotInBuildPlan _ = []

  (onlyHasDependencyMismatches, hasConfigurationRefs, extras, pkgsWithMismatches) =
    filterExceptions

  filterExceptions ::
    ( Bool
      -- ^ All the errors are DependencyMismatch. This checks if
      -- 'allow-newer: true' could resolve all reported issues.
    , Bool
      -- ^ One or more messages refer to 'the Stack configuration'. This
      -- triggers a message to explain what that phrase means.
    , Map PackageName (Version, BlobKey)
      -- ^ Recommended extras. TO DO: Likely a good idea to distinguish these to
      -- the user. In particular, those recommended for DependencyMismatch.
    , Set.Set PackageName
      -- ^ Set of names of packages with one or more DependencyMismatch errors.
    )
  filterExceptions = L.foldl' go acc0 exceptions'
   where
    acc0 = (True, False, Map.empty, Set.empty)
    go acc (DependencyPlanFailures pkg m) = Map.foldrWithKey go' acc m
     where
      pkgName = pkg.name
      go' name (_, Just extra, NotInBuildPlan) (_, _, m', s) =
        (False, True, Map.insert name extra m', s)
      go' _ (_, _, NotInBuildPlan) (_, _, m', s) = (False, True, m', s)
      go' name (_, Just extra, DependencyMismatch _) (p1, _, m', s) =
        (p1, True, Map.insert name extra m', Set.insert pkgName s)
      go' _ (_, _, DependencyMismatch _) (p1, _, m', s) =
        (p1, True, m', Set.insert pkgName s)
      go' _ (_, _, Couldn'tResolveItsDependencies _) acc' = acc'
      go' _ _ (_, p2, m', s) = (False, p2, m', s)
    go (_, p2, m, s) _ = (False, p2, m, s)

  pprintException (DependencyCycleDetected pNames) = Just $
       flow "Dependency cycle detected in packages:"
    <> line
    <> indent 4
         (encloseSep "[" "]" "," (map (style Error . fromPackageName) pNames))
  pprintException (DependencyPlanFailures pkg pDeps) =
    case mapMaybe pprintDep (Map.toList pDeps) of
      [] -> Nothing
      depErrors -> Just $
           fillSep
             [ flow "In the dependencies for"
             , pkgIdent <> pprintFlags pkg.flags <> ":"
             ]
        <> line
        <> indent 2 (bulletedList depErrors)
        <> line
        <> fillSep
             ( flow "The above is/are needed"
             : case getShortestDepsPath parentMap wanted' pkg.name of
                 Nothing ->
                   [flow "for unknown reason - Stack invariant violated."]
                 Just [] ->
                   [ "since"
                   , pkgName'
                   , flow "is a build target."
                   ]
                 Just (target:path) ->
                   [ flow "due to"
                   , encloseSep "" "" " -> " pathElems
                   ]
                  where
                   pathElems =
                        [style Target . fromPackageId $ target]
                     <> map fromPackageId path
                     <> [pkgIdent]
             )
       where
        pkgName' = style Current (fromPackageName pkg.name)
        pkgIdent = style Current (fromPackageId $ packageIdentifier pkg)
  -- Skip these when they are redundant with 'NotInBuildPlan' info.
  pprintException (UnknownPackage name)
    | name `Set.member` allNotInBuildPlan = Nothing
    | name `Set.member` wiredInPackages = Just $ fillSep
        [ flow "Can't build a package with same name as a wired-in-package:"
        , style Current . fromPackageName $ name
        ]
    | Just pruned <- Map.lookup name prunedGlobalDeps =
        let prunedDeps =
              map (style Current . fromPackageName) pruned
        in  Just $ fillSep
              [ flow "Can't use GHC boot package"
              , style Current . fromPackageName $ name
              , flow "when it depends on a replaced boot package. You need to \
                     \add the following as explicit dependencies to the \
                     \project:"
              , line
              , encloseSep "" "" ", " prunedDeps
              ]
    | otherwise = Just $ fillSep
        [ flow "Unknown package:"
        , style Current . fromPackageName $ name
        ]

  pprintFlags flags
    | Map.null flags = ""
    | otherwise = parens $ sep $ map pprintFlag $ Map.toList flags
  pprintFlag (name, True) = "+" <> fromString (flagNameString name)
  pprintFlag (name, False) = "-" <> fromString (flagNameString name)

  pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of
    NotInBuildPlan
      | name `elem` fold prunedGlobalDeps -> butMsg $ fillSep
          [ flow "this GHC boot package has been pruned from the Stack \
                 \configuration. You need to add the package explicitly to"
          , style Shell "extra-deps" <> "."
          ]
      | otherwise -> butMsg $ inconsistentMsg Nothing
    -- TODO: For local packages, suggest editing constraints
    DependencyMismatch version -> butMsg $ inconsistentMsg $ Just version
    -- I think the main useful info is these explain why missing packages are
    -- needed. Instead lets give the user the shortest path from a target to the
    -- package.
    Couldn'tResolveItsDependencies _version -> Nothing
    HasNoLibrary -> Just $ fillSep
      [ errorName
      , flow "is a library dependency, but the package provides no library."
      ]
    BDDependencyCycleDetected names -> Just $ fillSep
      [ errorName
      , flow $ "dependency cycle detected: "
             ++ L.intercalate ", " (map packageNameString names)
      ]
   where
    errorName = style Error . fromPackageName $ name
    goodRange = style Good (fromString (C.display range))
    rangeMsg = if range == C.anyVersion
      then "needed,"
      else fillSep
        [ flow "must match"
        , goodRange <> ","
        ]
    butMsg msg = Just $ fillSep
      [ errorName
      , rangeMsg
      , "but"
      , msg
      , latestApplicable Nothing
      ]
    inconsistentMsg mVersion = fillSep
      [ style Error $ maybe
          ( flow "no version" )
          ( fromPackageId . PackageIdentifier name )
          mVersion
      , flow "is in the Stack configuration"
      ]
    latestApplicable mversion =
      case mlatestApplicable of
        Nothing
          | isNothing mversion -> fillSep
              [ flow "(no matching package and version found. Perhaps there is \
                     \an error in the specification of a package's"
              , style Shell "dependencies"
              , "or"
              , style Shell "build-tools"
              , flow "(Hpack) or"
              , style Shell "build-depends" <> ","
              , style Shell "build-tools"
              , "or"
              , style Shell "build-tool-depends"
              , flow "(Cabal file)"
              , flow "or an omission from the"
              , style Shell "packages"
              , flow "list in"
              , pretty stackYaml
              , flow "(project-level configuration).)"
              ]
          | otherwise -> ""
        Just (laVer, _)
          | Just laVer == mversion ->
              flow "(latest matching version is specified)."
          | otherwise ->
              fillSep
                [ flow "(latest matching version is"
                , style Good (fromString $ versionString laVer) <> ")."
                ]

data ConstructPlanException
  = DependencyCycleDetected [PackageName]
  | DependencyPlanFailures
      Package
      (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))
  | UnknownPackage PackageName -- TODO perhaps this constructor will be removed,
                               -- and BadDependency will handle it all
  -- ^ Recommend adding to extra-deps, give a helpful version number?
  deriving (Eq, Show, Typeable)

-- | The latest applicable version and it's latest Cabal file revision.
-- For display purposes only, Nothing if package not found
type LatestApplicableVersion = Maybe (Version, BlobKey)

-- | Reason why a dependency was not used
data BadDependency
  = NotInBuildPlan
  | Couldn'tResolveItsDependencies Version
  | DependencyMismatch Version
  | HasNoLibrary
  -- ^ See description of 'DepType'
  | BDDependencyCycleDetected ![PackageName]
  deriving (Eq, Ord, Show, Typeable)

missingExeError :: String -> Bool -> String -> String
missingExeError errorCode isSimpleBuildType msg = unlines
  $ "Error: " <> errorCode
  : msg
  : "Possible causes of this issue:"
  : map ("* " <>) possibleCauses
 where
  possibleCauses
    = "No module named \"Main\". The 'main-is' source file should usually \
      \have a header indicating that it's a 'Main' module."
    : "A Cabal file that refers to nonexistent other files (e.g. a \
      \license-file that doesn't exist). Running 'cabal check' may point \
      \out these issues."
    : [ "The Setup.hs file is changing the installation target dir."
      | not isSimpleBuildType
      ]

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

-- | Get the shortest reason for the package to be in the build plan. In
-- other words, trace the parent dependencies back to a 'wanted'
-- package.
getShortestDepsPath ::
     ParentMap
  -> Set PackageName
  -> PackageName
  -> Maybe [PackageIdentifier]
getShortestDepsPath (MonoidMap parentsMap) wanted' name =
  if Set.member name wanted'
    then Just []
    else case M.lookup name parentsMap of
      Nothing -> Nothing
      Just parents -> Just $ findShortest 256 paths0
       where
        paths0 = M.fromList $
          map (\(ident, _) -> (pkgName ident, startDepsPath ident)) parents
 where
  -- The 'paths' map is a map from PackageName to the shortest path
  -- found to get there. It is the frontier of our breadth-first
  -- search of dependencies.
  findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
  findShortest fuel _ | fuel <= 0 =
    [ PackageIdentifier
        (mkPackageName "stack-ran-out-of-jet-fuel")
        (C.mkVersion [0])
    ]
  findShortest _ paths | M.null paths = []
  findShortest fuel paths =
    case nonEmpty targets of
      Nothing -> findShortest (fuel - 1) $ M.fromListWith chooseBest $
              concatMap extendPath recurses
      Just targets' ->
        let (DepsPath _ _ path) = minimum (snd <$> targets')
        in  path
   where
    (targets, recurses) =
      L.partition (\(n, _) -> n `Set.member` wanted') (M.toList paths)
  chooseBest :: DepsPath -> DepsPath -> DepsPath
  chooseBest = max
  -- Extend a path to all its parents.
  extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
  extendPath (n, dp) =
    case M.lookup n parentsMap of
      Nothing -> []
      Just parents ->
        map (\(pkgId, _) -> (pkgName pkgId, extendDepsPath pkgId dp)) parents

startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath ident = DepsPath
  { dpLength = 1
  , dpNameLength = length (packageNameString (pkgName ident))
  , dpPath = [ident]
  }

extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath ident dp = DepsPath
  { dpLength = dp.dpLength + 1
  , dpNameLength = dp.dpNameLength + length (packageNameString (pkgName ident))
  , dpPath = [ident]
  }

data DepsPath = DepsPath
  { dpLength :: Int
    -- ^ Length of dpPath
  , dpNameLength :: Int
    -- ^ Length of package names combined
  , dpPath :: [PackageIdentifier]
    -- ^ A path where the packages later in the list depend on those that come
    -- earlier
  }
  deriving (Eq, Ord, Show)