{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}

-- | Build-specific types.


module Stack.Types.Build
  ( BuildException (..)
  , BuildPrettyException (..)
  , ConstructPlanException (..)
  , BadDependency (..)
  , ParentMap
  , FlagSource (..)
  , UnusedFlags (..)
  , InstallLocation (..)
  , Installed (..)
  , psVersion
  , Task (..)
  , taskIsTarget
  , taskLocation
  , taskTargetIsMutable
  , LocalPackage (..)
  , BaseConfigOpts (..)
  , Plan (..)
  , TestOpts (..)
  , BenchmarkOpts (..)
  , FileWatchOpts (..)
  , BuildOpts (..)
  , BuildSubset (..)
  , defaultBuildOpts
  , TaskType (..)
  , IsMutable (..)
  , installLocationIsMutable
  , TaskConfigOpts (..)
  , BuildCache (..)
  , ConfigCache (..)
  , configureOpts
  , CachePkgSrc (..)
  , toCachePkgSrc
  , isStackOpt
  , wantedLocalPackages
  , FileCacheInfo (..)
  , ConfigureOpts (..)
  , PrecompiledCache (..)
  ) where

import           Data.Aeson ( ToJSON, FromJSON )
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           Database.Persist.Sql
                   ( PersistField (..), PersistFieldSql (..)
                   , PersistValue (PersistText), SqlType (SqlString)
                   )
import           Distribution.PackageDescription
                   ( TestSuiteInterface, mkPackageName )
import           Distribution.System ( Arch )
import qualified Distribution.Text as C
import qualified Distribution.Version as C
import           Path ( parseRelDir, (</>), parent )
import           Path.Extra ( toFilePathNoTrailingSep )
import           RIO.Process ( showProcessArgDebug )
import           Stack.Constants
import           Stack.Prelude
import           Stack.Types.Compiler
import           Stack.Types.CompilerBuild
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.Version
import           System.FilePath ( pathSeparator )

-- | 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)
  | InvalidFlagSpecification (Set UnusedFlags)
  | InvalidGhcOptionsSpecification [PackageName]
  | TargetParseException [Text]
  | SomeTargetsNotBuildable [(PackageName, NamedComponent)]
  | TestSuiteExeMissing Bool String String String
  | CabalCopyFailed Bool String
  | LocalPackagesPresent [PackageIdentifier]
  | CouldNotLockDistDir !(Path Abs File)
  | TaskCycleBug PackageIdentifier
  | PackageIdMissingBug PackageIdentifier
  | AllInOneBuildBug
  | MulipleResultsBug PackageName [DumpPackage]
  | TemplateHaskellNotFoundBug
  | HaddockIndexNotFound
  | ShowBuildErrorBug
  deriving (Int -> BuildException -> ShowS
[BuildException] -> ShowS
BuildException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildException] -> ShowS
$cshowList :: [BuildException] -> ShowS
show :: BuildException -> String
$cshow :: BuildException -> String
showsPrec :: Int -> BuildException -> ShowS
$cshowsPrec :: Int -> BuildException -> ShowS
Show, Typeable)

instance Exception BuildException where
    displayException :: BuildException -> String
displayException (Couldn'tFindPkgId PackageName
name) = String -> ShowS
bugReport String
"[S-7178]" forall a b. (a -> b) -> a -> b
$ 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) = 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) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ String
"Compiler version mismatched, found "
                , ActualCompiler -> String
compilerVersionString ActualCompiler
actual
                , 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 forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display WantedCompiler
expected
        , 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 " forall a. [a] -> [a] -> [a]
++ 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
        forall a b. (a -> b) -> a -> b
$ String
"Error: [S-3127]"
        forall a. a -> [a] -> [a]
: String
"The following targets could not be parsed as package names or \
          \directories:"
        forall a. a -> [a] -> [a]
: 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
        forall a b. (a -> b) -> a -> b
$ String
"Error: [S-2154]"
        forall a. a -> [a] -> [a]
: ([String]
noKnown' forall a. [a] -> [a] -> [a]
++ [String]
notInSnapshot')
      where
        noKnown' :: [String]
noKnown'
            | forall a. Set a -> Bool
Set.null Set PackageName
noKnown = []
            | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                String
"The following target packages were not found: " forall a. [a] -> [a] -> [a]
++
                forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set PackageName
noKnown) forall a. [a] -> [a] -> [a]
++
                String
"\nSee https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details."
        notInSnapshot' :: [String]
notInSnapshot'
            | 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"
                forall a. a -> [a] -> [a]
: String
"in your package index. Recommended action: add them to your"
                forall a. a -> [a] -> [a]
: (String
"extra-deps in " forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> String
toFilePath Path Abs File
stackYaml)
                forall a. a -> [a] -> [a]
: String
"(Note: these are the most recent versions,"
                forall a. a -> [a] -> [a]
: String
"but there's no guarantee that they'll build together)."
                forall a. a -> [a] -> [a]
: String
""
                forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map
                    (\(PackageName
name, Version
version') -> String
"- " forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString
                        (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
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
        forall a b. (a -> b) -> a -> b
$ String
"Error: [S-1995]"
        forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [String
"Test suite failure for package " forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident]
            , forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Maybe ExitCode)
codes) forall a b. (a -> b) -> a -> b
$ \(Text
name, Maybe ExitCode
mcode) -> 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: " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> String
displayException ExitCode
ec
                ]
            , forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 " forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
bs]
            ]
      where
        indent' :: ShowS
indent' = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
l -> String
"  " forall a. [a] -> [a] -> [a]
++ String
l) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
        doubleIndent :: ShowS
doubleIndent = ShowS
indent' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
indent'
    displayException (TestSuiteTypeUnsupported TestSuiteInterface
interface) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Error: [S-3819]\n"
        , String
"Unsupported test suite type: "
        , forall a. Show a => a -> String
show TestSuiteInterface
interface
        ]
     -- Suppressing duplicate output

    displayException (LocalPackageDoesn'tMatchTarget PackageName
name Version
localV Version
requestedV) = 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) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Error: [S-3118]\n"
        , String
"No Setup.hs or Setup.lhs file found in "
        , forall b t. Path b t -> String
toFilePath Path Abs Dir
dir
        ]
    displayException (InvalidFlagSpecification Set UnusedFlags
unused) = [String] -> String
unlines
        forall a b. (a -> b) -> a -> b
$ String
"Error: [S-8664]"
        forall a. a -> [a] -> [a]
: String
"Invalid flag specification:"
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map UnusedFlags -> String
go (forall a. Set a -> [a]
Set.toList Set UnusedFlags
unused)
      where
        showFlagSrc :: FlagSource -> String
        showFlagSrc :: FlagSource -> String
showFlagSrc FlagSource
FSCommandLine = String
" (specified on command line)"
        showFlagSrc FlagSource
FSStackYaml = String
" (specified in stack.yaml)"

        go :: UnusedFlags -> String
        go :: UnusedFlags -> String
go (UFNoPackage FlagSource
src PackageName
name) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"- Package '"
            , PackageName -> String
packageNameString PackageName
name
            , String
"' not found"
            , FlagSource -> String
showFlagSrc FlagSource
src
            ]
        go (UFFlagsNotDefined FlagSource
src PackageName
pname Set FlagName
pkgFlags Set FlagName
flags) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"- Package '"
            , String
name
            , String
"' does not define the following flags"
            , FlagSource -> String
showFlagSrc FlagSource
src
            , String
":\n"
            , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
                          (forall a b. (a -> b) -> [a] -> [b]
map (\FlagName
flag -> String
"  " forall a. [a] -> [a] -> [a]
++ FlagName -> String
flagNameString FlagName
flag)
                               (forall a. Set a -> [a]
Set.toList Set FlagName
flags))
            , String
"\n- Flags defined by package '" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"':\n"
            , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
                          (forall a b. (a -> b) -> [a] -> [b]
map (\FlagName
flag -> String
"  " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ FlagName -> String
flagNameString FlagName
flag)
                               (forall a. Set a -> [a]
Set.toList Set FlagName
pkgFlags))
            ]
          where name :: String
name = PackageName -> String
packageNameString PackageName
pname
        go (UFSnapshot PackageName
name) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"- Attempted to set flag on snapshot package "
            , PackageName -> String
packageNameString PackageName
name
            , String
", please add to extra-deps"
            ]
    displayException (InvalidGhcOptionsSpecification [PackageName]
unused) = [String] -> String
unlines
        forall a b. (a -> b) -> a -> b
$ String
"Error: [S-4925]"
        forall a. a -> [a] -> [a]
: String
"Invalid GHC options specification:"
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
showGhcOptionSrc [PackageName]
unused
      where
        showGhcOptionSrc :: PackageName -> String
showGhcOptionSrc PackageName
name = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"- Package '"
            , PackageName -> String
packageNameString PackageName
name
            , String
"' not found"
            ]
    displayException (TargetParseException [Text
err]) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Error: [S-8506]\n"
        , String
"Error parsing targets: "
        , Text -> String
T.unpack Text
err
        ]
    displayException (TargetParseException [Text]
errs) = [String] -> String
unlines
        forall a b. (a -> b) -> a -> b
$ String
"Error [S-8506]"
        forall a. a -> [a] -> [a]
: String
"The following errors occurred while parsing the build targets:"
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((String
"- " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
errs
    displayException (SomeTargetsNotBuildable [(PackageName, NamedComponent)]
xs) = [String] -> String
unlines
        [ String
"Error: [S-7086]"
        , String
"The following components have 'buildable: False' set in the Cabal \
          \configuration, and so cannot be targets:"
        , String
"    " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack ([(PackageName, NamedComponent)] -> Text
renderPkgComponents [(PackageName, NamedComponent)]
xs)
        , String
"To resolve this, either provide flags such that these components \
          \are buildable, or only specify buildable targets."
        ]
    displayException (TestSuiteExeMissing Bool
isSimpleBuildType String
exeName String
pkgName' String
testName) =
        String -> Bool -> ShowS
missingExeError String
"[S-7987]"
          Bool
isSimpleBuildType forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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
        forall a b. (a -> b) -> a -> b
$ String
"Error: [S-5510]"
        forall a. a -> [a] -> [a]
: String
"Local packages are not allowed when using the 'script' command. \
          \Packages found:"
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\PackageIdentifier
ident -> String
"- " 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
"  " forall a. [a] -> [a] -> [a]
++ 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]" forall a b. (a -> b) -> a -> b
$
        String
"Error: The impossible happened! Unexpected task cycle for "
        forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pid)
    displayException (PackageIdMissingBug PackageIdentifier
ident) = String -> ShowS
bugReport String
"[S-8923]" forall a b. (a -> b) -> a -> b
$
        String
"The impossible happened! singleBuild: missing package ID missing: "
        forall a. [a] -> [a] -> [a]
++ 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 (MulipleResultsBug PackageName
name [DumpPackage]
dps) = String -> ShowS
bugReport String
"[S-6739]"
        String
"singleBuild: multiple results when describing installed package "
        forall a. [a] -> [a] -> [a]
++ 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"
        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)
        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

    deriving (Int -> BuildPrettyException -> ShowS
[BuildPrettyException] -> ShowS
BuildPrettyException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildPrettyException] -> ShowS
$cshowList :: [BuildPrettyException] -> ShowS
show :: BuildPrettyException -> String
$cshow :: BuildPrettyException -> String
showsPrec :: Int -> BuildPrettyException -> ShowS
$cshowsPrec :: Int -> BuildPrettyException -> ShowS
Show, Typeable)

instance Pretty BuildPrettyException where
    pretty :: BuildPrettyException -> StyleDoc
pretty ( ConstructPlanFailed [ConstructPlanException]
errs Path Abs File
stackYaml Path Abs Dir
stackRoot ParentMap
parents Set PackageName
wanted Map PackageName [PackageName]
prunedGlobalDeps ) =
           StyleDoc
"[S-4804]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack failed to construct a build plan."
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions
               [ConstructPlanException]
errs Path Abs File
stackYaml Path Abs Dir
stackRoot ParentMap
parents Set PackageName
wanted Map PackageName [PackageName]
prunedGlobalDeps
    pretty (ExecutionFailure [SomeException]
es) =
           StyleDoc
"[S-7282]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack failed to execute the build plan."
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While executing the build plan, Stack encountered the \
                \following errors:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
hcat (forall a. a -> [a] -> [a]
L.intersperse StyleDoc
blankLine (forall a b. (a -> b) -> [a] -> [b]
map SomeException -> StyleDoc
ppExceptions [SomeException]
es))
      where
        ppExceptions :: SomeException -> StyleDoc
        ppExceptions :: SomeException -> StyleDoc
ppExceptions SomeException
e = case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
            Just (PrettyException e
e') -> forall a. Pretty a => a -> StyleDoc
pretty e
e'
            Maybe PrettyException
Nothing -> (String -> StyleDoc
string forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) SomeException
e
    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 (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

instance Exception BuildPrettyException

pprintExceptions
    :: [ConstructPlanException]
    -> Path Abs File
    -> Path Abs Dir
    -> ParentMap
    -> Set PackageName
    -> Map PackageName [PackageName]
    -> StyleDoc
pprintExceptions :: [ConstructPlanException]
-> Path Abs File
-> Path Abs Dir
-> ParentMap
-> Set PackageName
-> Map PackageName [PackageName]
-> StyleDoc
pprintExceptions [ConstructPlanException]
exceptions Path Abs File
stackYaml Path Abs Dir
stackRoot ParentMap
parentMap Set PackageName
wanted' Map PackageName [PackageName]
prunedGlobalDeps =
    forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
      [ String -> StyleDoc
flow String
"While constructing the build plan, Stack encountered the \
             \following errors:"
      , StyleDoc
blankLine
      , forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse StyleDoc
blankLine (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ConstructPlanException -> Maybe StyleDoc
pprintException [ConstructPlanException]
exceptions'))
      ] forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [StyleDoc]
recommendations
               then []
               else
                   [ StyleDoc
blankLine
                   , String -> StyleDoc
flow String
"Some different approaches to resolving this:"
                   , StyleDoc
blankLine
                   ] forall a. [a] -> [a] -> [a]
++ [StyleDoc]
recommendations

  where
    exceptions' :: [ConstructPlanException]
exceptions' = {- should we dedupe these somehow? nubOrd -} [ConstructPlanException]
exceptions

    recommendations :: [StyleDoc]
recommendations =
        if Bool -> Bool
not Bool
onlyHasDependencyMismatches
            then []
            else
                [ StyleDoc
"  *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align
                    (   String -> StyleDoc
flow String
"Set 'allow-newer: true' in "
                    StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty (Path Abs Dir -> Path Abs File
defaultUserConfigPath Path Abs Dir
stackRoot)
                    StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"to ignore all version constraints and build anyway."
                    )
                , StyleDoc
blankLine
                ]
        forall a. [a] -> [a] -> [a]
++ [StyleDoc]
addExtraDepsRecommendations

    addExtraDepsRecommendations :: [StyleDoc]
addExtraDepsRecommendations
      | forall k a. Map k a -> Bool
Map.null Map PackageName (Version, BlobKey)
extras = []
      | (Just (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 -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align (String -> StyleDoc
flow String
"Build requires unattainable version of base. Since base is a part of GHC, you most likely need to use a different GHC version with the matching base.")
           , StyleDoc
line
          ]
      | Bool
otherwise =
         [ StyleDoc
"  *" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
align
           (Style -> StyleDoc -> StyleDoc
style Style
Recommendation (String -> StyleDoc
flow String
"Recommended action:") StyleDoc -> StyleDoc -> StyleDoc
<+>
            String -> StyleDoc
flow String
"try adding the following to your extra-deps in" StyleDoc -> StyleDoc -> StyleDoc
<+>
            forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml forall a. Semigroup a => a -> a -> a
<> StyleDoc
":")
         , StyleDoc
blankLine
         , [StyleDoc] -> StyleDoc
vsep (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. IsString a => (PackageName, (Version, BlobKey)) -> a
pprintExtra (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Version, BlobKey)
extras))
         , StyleDoc
line
         ]

    extras :: Map PackageName (Version, BlobKey)
extras = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ConstructPlanException -> Map PackageName (Version, BlobKey)
getExtras [ConstructPlanException]
exceptions'
    getExtras :: ConstructPlanException -> Map PackageName (Version, BlobKey)
getExtras DependencyCycleDetected{} = forall k a. Map k a
Map.empty
    getExtras UnknownPackage{} = forall k a. Map k a
Map.empty
    getExtras (DependencyPlanFailures Package
_ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m) =
       forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {k} {a} {a} {b}.
(k, (a, Maybe (a, b), BadDependency)) -> Map k (a, b)
go forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m
     where
       -- TODO: Likely a good idea to distinguish these to the user.  In particular, for DependencyMismatch

       go :: (k, (a, Maybe (a, b), BadDependency)) -> Map k (a, b)
go (k
name, (a
_range, Just (a
version,b
cabalHash), BadDependency
NotInBuildPlan)) =
           forall k a. k -> a -> Map k a
Map.singleton k
name (a
version,b
cabalHash)
       go (k
name, (a
_range, Just (a
version,b
cabalHash), DependencyMismatch{})) =
           forall k a. k -> a -> Map k a
Map.singleton k
name (a
version, b
cabalHash)
       go (k, (a, Maybe (a, b), BadDependency))
_ = forall k a. Map k a
Map.empty
    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 (forall a. a -> Maybe a
Just FileSize
cabalSize)
          packageIdRev :: PackageIdentifierRevision
packageIdRev = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfInfo
       in forall a. IsString a => String -> a
fromString (String
"- " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Utf8Builder -> Text
utf8BuilderToText (forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
packageIdRev)))

    allNotInBuildPlan :: Set PackageName
allNotInBuildPlan = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ 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) =
      forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName
_, (VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
badDep)) -> BadDependency
badDep forall a. Eq a => a -> a -> Bool
== BadDependency
NotInBuildPlan) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps
    toNotInBuildPlan ConstructPlanException
_ = []

    -- This checks if 'allow-newer: true' could resolve all issues.

    onlyHasDependencyMismatches :: Bool
onlyHasDependencyMismatches = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructPlanException -> Bool
go [ConstructPlanException]
exceptions'
      where
        go :: ConstructPlanException -> Bool
go DependencyCycleDetected{} = Bool
False
        go UnknownPackage{} = Bool
False
        go (DependencyPlanFailures Package
_ Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m) =
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(VersionRange
_, Maybe (Version, BlobKey)
_, BadDependency
depErr) -> BadDependency -> Bool
isMismatch BadDependency
depErr) (forall k a. Map k a -> [a]
M.elems Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
m)
        isMismatch :: BadDependency -> Bool
isMismatch DependencyMismatch{} = Bool
True
        isMismatch Couldn'tResolveItsDependencies{} = Bool
True
        isMismatch BadDependency
_ = Bool
False

    pprintException :: ConstructPlanException -> Maybe StyleDoc
pprintException (DependencyCycleDetected [PackageName]
pNames) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        String -> StyleDoc
flow String
"Dependency cycle detected in packages:" forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
        Int -> StyleDoc -> StyleDoc
indent Int
4 (StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"[" StyleDoc
"]" StyleDoc
"," (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString 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 forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b}.
(PackageName, (VersionRange, Maybe (Version, b), BadDependency))
-> Maybe StyleDoc
pprintDep (forall k a. Map k a -> [(k, a)]
Map.toList Map
  PackageName (VersionRange, Maybe (Version, BlobKey), BadDependency)
pDeps) of
            [] -> forall a. Maybe a
Nothing
            [StyleDoc]
depErrors -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                String -> StyleDoc
flow String
"In the dependencies for" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
pkgIdent forall a. Semigroup a => a -> a -> a
<>
                Map FlagName Bool -> StyleDoc
pprintFlags (Package -> Map FlagName Bool
packageFlags Package
pkg) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                Int -> StyleDoc -> StyleDoc
indent Int
4 ([StyleDoc] -> StyleDoc
vsep [StyleDoc]
depErrors) 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 forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"needed for unknown reason - stack invariant violated."
                    Just [] -> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"needed since" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
pkgName' StyleDoc -> StyleDoc -> StyleDoc
<+> String -> StyleDoc
flow String
"is a build target."
                    Just (PackageIdentifier
target:[PackageIdentifier]
path) -> StyleDoc
line 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString forall a b. (a -> b) -> a -> b
$ PackageIdentifier
target] forall a. [a] -> [a] -> [a]
++
                            forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString) [PackageIdentifier]
path forall a. [a] -> [a] -> [a]
++
                            [StyleDoc
pkgIdent]
              where
                pkgName' :: StyleDoc
pkgName' = Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
pkg
                pkgIdent :: StyleDoc
pkgIdent = Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
allNotInBuildPlan = forall a. Maybe a
Nothing
        | PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"Can't build a package with same name as a wired-in-package:" StyleDoc -> StyleDoc -> StyleDoc
<+> (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ PackageName
name)
        | Just [PackageName]
pruned <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName [PackageName]
prunedGlobalDeps =
            let prunedDeps :: [StyleDoc]
prunedDeps = forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
pruned
            in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"Can't use GHC boot package" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
                      String -> StyleDoc
flow String
"when it has an overridden dependency (issue #4510);" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      String -> StyleDoc
flow String
"you need to add the following as explicit dependencies to the project:" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep StyleDoc
"" StyleDoc
"" StyleDoc
", " [StyleDoc]
prunedDeps
        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"Unknown package:" StyleDoc -> StyleDoc -> StyleDoc
<+> (Style -> StyleDoc -> StyleDoc
style Style
Current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ PackageName
name)

    pprintFlags :: Map FlagName Bool -> StyleDoc
pprintFlags Map FlagName Bool
flags
        | forall k a. Map k a -> Bool
Map.null Map FlagName Bool
flags = StyleDoc
""
        | Bool
otherwise = StyleDoc -> StyleDoc
parens forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
sep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (Semigroup a, IsString a) => (FlagName, Bool) -> a
pprintFlag forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map FlagName Bool
flags
    pprintFlag :: (FlagName, Bool) -> a
pprintFlag (FlagName
name, Bool
True) = a
"+" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (FlagName -> String
flagNameString FlagName
name)
    pprintFlag (FlagName
name, Bool
False) = a
"-" forall a. Semigroup a => a -> a -> 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map PackageName [PackageName]
prunedGlobalDeps -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
              Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
              StyleDoc -> StyleDoc
align ((if VersionRange
range forall a. Eq a => a -> a -> Bool
== VersionRange
C.anyVersion
                        then String -> StyleDoc
flow String
"needed"
                        else String -> StyleDoc
flow String
"must match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"," forall a. Semigroup a => a -> a -> a
<> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
                     String -> StyleDoc
flow String
"but this GHC boot package has been pruned (issue #4510);" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     String -> StyleDoc
flow String
"you need to add the package explicitly to extra-deps" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     Maybe Version -> StyleDoc
latestApplicable forall a. Maybe a
Nothing)
          | Bool
otherwise -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
              Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
              StyleDoc -> StyleDoc
align ((if VersionRange
range forall a. Eq a => a -> a -> Bool
== VersionRange
C.anyVersion
                        then String -> StyleDoc
flow String
"needed"
                        else String -> StyleDoc
flow String
"must match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"," forall a. Semigroup a => a -> a -> a
<> StyleDoc
softline forall a. Semigroup a => a -> a -> a
<>
                     String -> StyleDoc
flow String
"but the Stack configuration has no specified version" StyleDoc -> StyleDoc -> StyleDoc
<+>
                     Maybe Version -> StyleDoc
latestApplicable forall a. Maybe a
Nothing)
        -- TODO: For local packages, suggest editing constraints

        DependencyMismatch Version
version -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            (Style -> StyleDoc -> StyleDoc
style Style
Error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString) (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align (String -> StyleDoc
flow String
"from Stack configuration does not match" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
goodRange StyleDoc -> StyleDoc -> StyleDoc
<+>
                   Maybe Version -> StyleDoc
latestApplicable (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 -> forall a. Maybe a
Nothing
        BadDependency
HasNoLibrary -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align (String -> StyleDoc
flow String
"is a library dependency, but the package provides no library")
        BDDependencyCycleDetected [PackageName]
names -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
<+>
            StyleDoc -> StyleDoc
align (String -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ String
"dependency cycle detected: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
names))
      where
        goodRange :: StyleDoc
goodRange = Style -> StyleDoc -> StyleDoc
style Style
Good (forall a. IsString a => String -> a
fromString (forall a. Pretty a => a -> String
C.display VersionRange
range))
        latestApplicable :: Maybe Version -> StyleDoc
latestApplicable Maybe Version
mversion =
            case Maybe (Version, b)
mlatestApplicable of
                Maybe (Version, b)
Nothing
                    | forall a. Maybe a -> Bool
isNothing Maybe Version
mversion ->
                        String -> StyleDoc
flow String
"(no package with that name found, perhaps there \
                             \is a typo in a package's build-depends or an \
                             \omission from the stack.yaml packages list?)"
                    | Bool
otherwise -> StyleDoc
""
                Just (Version
laVer, b
_)
                    | forall a. a -> Maybe a
Just Version
laVer 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 (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
laVer) forall a. Semigroup a => a -> a -> a
<> StyleDoc
")"
                          ]

-- | 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 forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name Set PackageName
wanted'
        then forall a. a -> Maybe a
Just []
        else case 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 -> forall a. Maybe a
Nothing
            Just (First Version
_, [(PackageIdentifier, VersionRange)]
parents) -> forall a. a -> Maybe a
Just 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 = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ 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 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 | 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 forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith DepsPath -> DepsPath -> DepsPath
chooseBest forall a b. (a -> b) -> a -> b
$ 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) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
L.minimum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(PackageName, DepsPath)]
targets) in [PackageIdentifier]
path
      where
        ([(PackageName, DepsPath)]
targets, [(PackageName, DepsPath)]
recurses) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (\(PackageName
n, DepsPath
_) -> PackageName
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wanted') (forall k a. Map k a -> [(k, a)]
M.toList Map PackageName DepsPath
paths)
    chooseBest :: DepsPath -> DepsPath -> DepsPath
    chooseBest :: DepsPath -> DepsPath -> DepsPath
chooseBest DepsPath
x DepsPath
y = forall a. Ord a => a -> a -> a
max DepsPath
x DepsPath
y
    -- Extend a path to all its parents.

    extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
    extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
extendPath (PackageName
n, DepsPath
dp) =
        case 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) -> 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 = 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 forall a. Num a => a -> a -> a
+ Int
1
    , dpNameLength :: Int
dpNameLength = DepsPath -> Int
dpNameLength DepsPath
dp forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageName -> String
packageNameString (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident))
    , dpPath :: [PackageIdentifier]
dpPath = [PackageIdentifier
ident]
    }

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 (Typeable, ConstructPlanException -> ConstructPlanException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstructPlanException -> ConstructPlanException -> Bool
$c/= :: ConstructPlanException -> ConstructPlanException -> Bool
== :: ConstructPlanException -> ConstructPlanException -> Bool
$c== :: ConstructPlanException -> ConstructPlanException -> Bool
Eq, Int -> ConstructPlanException -> ShowS
[ConstructPlanException] -> ShowS
ConstructPlanException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConstructPlanException] -> ShowS
$cshowList :: [ConstructPlanException] -> ShowS
show :: ConstructPlanException -> String
$cshow :: ConstructPlanException -> String
showsPrec :: Int -> ConstructPlanException -> ShowS
$cshowsPrec :: Int -> ConstructPlanException -> ShowS
Show)

-- | The latest applicable version and it's latest Cabal file revision.

-- For display purposes only, Nothing if package not found

type LatestApplicableVersion = Maybe (Version, BlobKey)

-- | Reason why a dependency was not used

data BadDependency
    = NotInBuildPlan
    | Couldn'tResolveItsDependencies Version
    | DependencyMismatch Version
    | HasNoLibrary
    -- ^ See description of 'DepType'

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

type ParentMap = MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)])

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

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

data UnusedFlags = UFNoPackage FlagSource PackageName
                 | UFFlagsNotDefined
                       FlagSource
                       PackageName
                       (Set FlagName) -- defined in package

                       (Set FlagName) -- not defined

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

missingExeError :: String -> Bool -> String -> String
missingExeError :: String -> Bool -> ShowS
missingExeError String
errorCode Bool
isSimpleBuildType String
msg = [String] -> String
unlines
    forall a b. (a -> b) -> a -> b
$ String
"Error: " forall a. Semigroup a => a -> a -> a
<> String
errorCode
    forall a. a -> [a] -> [a]
: String
msg
    forall a. a -> [a] -> [a]
: String
"Possible causes of this issue:"
    forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (String
"* " forall a. Semigroup a => a -> a -> a
<>) [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."
        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."
        forall a. a -> [a] -> [a]
: if Bool
isSimpleBuildType
            then []
            else [String
"The Setup.hs file is changing the installation target dir."]

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
              forall a b. (a -> b) -> a -> b
$ ShowS
dropQuotes (forall b t. Path b t -> String
toFilePath Path Abs File
execName)
              forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
showProcessArgDebug) [String]
fullArgs
      logLocations :: StyleDoc
logLocations =
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              forall a. Monoid a => a
mempty
              (\Path Abs File
fp -> StyleDoc
line forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Logs have been written to:" StyleDoc -> StyleDoc -> StyleDoc
<+>
                        Style -> StyleDoc -> StyleDoc
style Style
File (forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp))
              Maybe (Path Abs File)
logFiles
  in     forall a. IsString a => String -> a
fromString String
errorCode
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      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) -> 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
                    (forall a. IsString a => String -> a
fromString 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
                    (forall a. IsString a => String -> a
fromString 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:"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
Shell (forall a. IsString a => String -> a
fromString String
fullCmd)
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Process exited with code:" StyleDoc -> StyleDoc -> StyleDoc
<+> (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) ExitCode
exitCode StyleDoc -> StyleDoc -> StyleDoc
<+>
         ( if ExitCode
exitCode forall a. Eq a => a -> a -> Bool
== Int -> ExitCode
ExitFailure (-Int
9)
             then String -> StyleDoc
flow String
"(THIS MAY INDICATE OUT OF MEMORY)"
             else forall a. Monoid a => a
mempty
         )
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
logLocations
      forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
bss
           then forall a. Monoid a => a
mempty
           else StyleDoc
blankLine forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string ([String] -> String
removeTrailingSpaces (forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
bss))
   where
    removeTrailingSpaces :: [String] -> String
removeTrailingSpaces = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
    dropQuotes :: ShowS
dropQuotes = forall a. (a -> Bool) -> [a] -> [a]
filter (Char
'\"' forall a. Eq a => a -> a -> Bool
/=)

----------------------------------------------


-- | Package dependency oracle.

newtype PkgDepsOracle =
    PkgDeps PackageName
    deriving (Int -> PkgDepsOracle -> ShowS
[PkgDepsOracle] -> ShowS
PkgDepsOracle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PkgDepsOracle] -> ShowS
$cshowList :: [PkgDepsOracle] -> ShowS
show :: PkgDepsOracle -> String
$cshow :: PkgDepsOracle -> String
showsPrec :: Int -> PkgDepsOracle -> ShowS
$cshowsPrec :: Int -> PkgDepsOracle -> ShowS
Show,Typeable,PkgDepsOracle -> PkgDepsOracle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PkgDepsOracle -> PkgDepsOracle -> Bool
$c/= :: PkgDepsOracle -> PkgDepsOracle -> Bool
== :: PkgDepsOracle -> PkgDepsOracle -> Bool
$c== :: PkgDepsOracle -> PkgDepsOracle -> Bool
Eq,PkgDepsOracle -> ()
forall a. (a -> ()) -> NFData a
rnf :: PkgDepsOracle -> ()
$crnf :: PkgDepsOracle -> ()
NFData)

-- | Stored on disk to know whether the files have changed.

newtype BuildCache = BuildCache
    { BuildCache -> Map String FileCacheInfo
buildCacheTimes :: Map FilePath FileCacheInfo
      -- ^ Modification times of files.

    }
    deriving (forall x. Rep BuildCache x -> BuildCache
forall x. BuildCache -> Rep BuildCache x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BuildCache x -> BuildCache
$cfrom :: forall x. BuildCache -> Rep BuildCache x
Generic, BuildCache -> BuildCache -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildCache -> BuildCache -> Bool
$c/= :: BuildCache -> BuildCache -> Bool
== :: BuildCache -> BuildCache -> Bool
$c== :: BuildCache -> BuildCache -> Bool
Eq, Int -> BuildCache -> ShowS
[BuildCache] -> ShowS
BuildCache -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildCache] -> ShowS
$cshowList :: [BuildCache] -> ShowS
show :: BuildCache -> String
$cshow :: BuildCache -> String
showsPrec :: Int -> BuildCache -> ShowS
$cshowsPrec :: Int -> BuildCache -> ShowS
Show, Typeable, [BuildCache] -> Encoding
[BuildCache] -> Value
BuildCache -> Encoding
BuildCache -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BuildCache] -> Encoding
$ctoEncodingList :: [BuildCache] -> Encoding
toJSONList :: [BuildCache] -> Value
$ctoJSONList :: [BuildCache] -> Value
toEncoding :: BuildCache -> Encoding
$ctoEncoding :: BuildCache -> Encoding
toJSON :: BuildCache -> Value
$ctoJSON :: BuildCache -> Value
ToJSON, Value -> Parser [BuildCache]
Value -> Parser BuildCache
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BuildCache]
$cparseJSONList :: Value -> Parser [BuildCache]
parseJSON :: Value -> Parser BuildCache
$cparseJSON :: Value -> Parser BuildCache
FromJSON)
instance NFData BuildCache

-- | Stored on disk to know whether the flags have changed.

data ConfigCache = ConfigCache
    { ConfigCache -> ConfigureOpts
configCacheOpts :: !ConfigureOpts
      -- ^ All options used for this package.

    , ConfigCache -> Set GhcPkgId
configCacheDeps :: !(Set GhcPkgId)
      -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take

      -- the complete GhcPkgId (only a PackageIdentifier) in the configure

      -- options, just using the previous value is insufficient to know if

      -- dependencies have changed.

    , ConfigCache -> Set ByteString
configCacheComponents :: !(Set S.ByteString)
      -- ^ The components to be built. It's a bit of a hack to include this in

      -- here, as it's not a configure option (just a build option), but this

      -- is a convenient way to force compilation when the components change.

    , ConfigCache -> Bool
configCacheHaddock :: !Bool
      -- ^ Are haddocks to be built?

    , ConfigCache -> CachePkgSrc
configCachePkgSrc :: !CachePkgSrc
    , ConfigCache -> Text
configCachePathEnvVar :: !Text
    -- ^ Value of the PATH env var, see <https://github.com/commercialhaskell/stack/issues/3138>

    }
    deriving (forall x. Rep ConfigCache x -> ConfigCache
forall x. ConfigCache -> Rep ConfigCache x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConfigCache x -> ConfigCache
$cfrom :: forall x. ConfigCache -> Rep ConfigCache x
Generic, ConfigCache -> ConfigCache -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigCache -> ConfigCache -> Bool
$c/= :: ConfigCache -> ConfigCache -> Bool
== :: ConfigCache -> ConfigCache -> Bool
$c== :: ConfigCache -> ConfigCache -> Bool
Eq, Int -> ConfigCache -> ShowS
[ConfigCache] -> ShowS
ConfigCache -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigCache] -> ShowS
$cshowList :: [ConfigCache] -> ShowS
show :: ConfigCache -> String
$cshow :: ConfigCache -> String
showsPrec :: Int -> ConfigCache -> ShowS
$cshowsPrec :: Int -> ConfigCache -> ShowS
Show, Typeable ConfigCache
ConfigCache -> DataType
ConfigCache -> Constr
(forall b. Data b => b -> b) -> ConfigCache -> ConfigCache
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> ConfigCache -> u
forall u. (forall d. Data d => d -> u) -> ConfigCache -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigCache -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigCache -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ConfigCache -> m ConfigCache
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigCache -> m ConfigCache
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConfigCache
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConfigCache -> c ConfigCache
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConfigCache)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConfigCache)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigCache -> m ConfigCache
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigCache -> m ConfigCache
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigCache -> m ConfigCache
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigCache -> m ConfigCache
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ConfigCache -> m ConfigCache
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ConfigCache -> m ConfigCache
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ConfigCache -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ConfigCache -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> ConfigCache -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ConfigCache -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigCache -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigCache -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigCache -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigCache -> r
gmapT :: (forall b. Data b => b -> b) -> ConfigCache -> ConfigCache
$cgmapT :: (forall b. Data b => b -> b) -> ConfigCache -> ConfigCache
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConfigCache)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConfigCache)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConfigCache)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConfigCache)
dataTypeOf :: ConfigCache -> DataType
$cdataTypeOf :: ConfigCache -> DataType
toConstr :: ConfigCache -> Constr
$ctoConstr :: ConfigCache -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConfigCache
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConfigCache
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConfigCache -> c ConfigCache
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConfigCache -> c ConfigCache
Data, Typeable)
instance NFData ConfigCache

data CachePkgSrc = CacheSrcUpstream | CacheSrcLocal FilePath
    deriving (forall x. Rep CachePkgSrc x -> CachePkgSrc
forall x. CachePkgSrc -> Rep CachePkgSrc x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CachePkgSrc x -> CachePkgSrc
$cfrom :: forall x. CachePkgSrc -> Rep CachePkgSrc x
Generic, CachePkgSrc -> CachePkgSrc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CachePkgSrc -> CachePkgSrc -> Bool
$c/= :: CachePkgSrc -> CachePkgSrc -> Bool
== :: CachePkgSrc -> CachePkgSrc -> Bool
$c== :: CachePkgSrc -> CachePkgSrc -> Bool
Eq, ReadPrec [CachePkgSrc]
ReadPrec CachePkgSrc
Int -> ReadS CachePkgSrc
ReadS [CachePkgSrc]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CachePkgSrc]
$creadListPrec :: ReadPrec [CachePkgSrc]
readPrec :: ReadPrec CachePkgSrc
$creadPrec :: ReadPrec CachePkgSrc
readList :: ReadS [CachePkgSrc]
$creadList :: ReadS [CachePkgSrc]
readsPrec :: Int -> ReadS CachePkgSrc
$creadsPrec :: Int -> ReadS CachePkgSrc
Read, Int -> CachePkgSrc -> ShowS
[CachePkgSrc] -> ShowS
CachePkgSrc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CachePkgSrc] -> ShowS
$cshowList :: [CachePkgSrc] -> ShowS
show :: CachePkgSrc -> String
$cshow :: CachePkgSrc -> String
showsPrec :: Int -> CachePkgSrc -> ShowS
$cshowsPrec :: Int -> CachePkgSrc -> ShowS
Show, Typeable CachePkgSrc
CachePkgSrc -> DataType
CachePkgSrc -> Constr
(forall b. Data b => b -> b) -> CachePkgSrc -> CachePkgSrc
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> CachePkgSrc -> u
forall u. (forall d. Data d => d -> u) -> CachePkgSrc -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CachePkgSrc -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CachePkgSrc -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CachePkgSrc -> m CachePkgSrc
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CachePkgSrc -> m CachePkgSrc
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CachePkgSrc
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CachePkgSrc -> c CachePkgSrc
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CachePkgSrc)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CachePkgSrc)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CachePkgSrc -> m CachePkgSrc
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CachePkgSrc -> m CachePkgSrc
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CachePkgSrc -> m CachePkgSrc
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CachePkgSrc -> m CachePkgSrc
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CachePkgSrc -> m CachePkgSrc
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CachePkgSrc -> m CachePkgSrc
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CachePkgSrc -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CachePkgSrc -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> CachePkgSrc -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CachePkgSrc -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CachePkgSrc -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CachePkgSrc -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CachePkgSrc -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CachePkgSrc -> r
gmapT :: (forall b. Data b => b -> b) -> CachePkgSrc -> CachePkgSrc
$cgmapT :: (forall b. Data b => b -> b) -> CachePkgSrc -> CachePkgSrc
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CachePkgSrc)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CachePkgSrc)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CachePkgSrc)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CachePkgSrc)
dataTypeOf :: CachePkgSrc -> DataType
$cdataTypeOf :: CachePkgSrc -> DataType
toConstr :: CachePkgSrc -> Constr
$ctoConstr :: CachePkgSrc -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CachePkgSrc
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CachePkgSrc
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CachePkgSrc -> c CachePkgSrc
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CachePkgSrc -> c CachePkgSrc
Data, Typeable)
instance NFData CachePkgSrc

instance PersistField CachePkgSrc where
    toPersistValue :: CachePkgSrc -> PersistValue
toPersistValue CachePkgSrc
CacheSrcUpstream = Text -> PersistValue
PersistText Text
"upstream"
    toPersistValue (CacheSrcLocal String
fp) = Text -> PersistValue
PersistText (Text
"local:" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
fp)
    fromPersistValue :: PersistValue -> Either Text CachePkgSrc
fromPersistValue (PersistText Text
t) = do
        if Text
t forall a. Eq a => a -> a -> Bool
== Text
"upstream"
            then forall a b. b -> Either a b
Right CachePkgSrc
CacheSrcUpstream
            else case Text -> Text -> Maybe Text
T.stripPrefix Text
"local:" Text
t of
                Just Text
fp -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> CachePkgSrc
CacheSrcLocal (Text -> String
T.unpack Text
fp)
                Maybe Text
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Unexpected CachePkgSrc value: " forall a. Semigroup a => a -> a -> a
<> Text
t
    fromPersistValue PersistValue
_ = forall a b. a -> Either a b
Left Text
"Unexpected CachePkgSrc type"

instance PersistFieldSql CachePkgSrc where
    sqlType :: Proxy CachePkgSrc -> SqlType
sqlType Proxy CachePkgSrc
_ = SqlType
SqlString

toCachePkgSrc :: PackageSource -> CachePkgSrc
toCachePkgSrc :: PackageSource -> CachePkgSrc
toCachePkgSrc (PSFilePath LocalPackage
lp) = String -> CachePkgSrc
CacheSrcLocal (forall b t. Path b t -> String
toFilePath (forall b t. Path b t -> Path b Dir
parent (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)))
toCachePkgSrc PSRemote{} = CachePkgSrc
CacheSrcUpstream

-- | A task to perform when building

data Task = Task
    { Task -> PackageIdentifier
taskProvides        :: !PackageIdentifier -- FIXME turn this into a function on taskType?

    -- ^ the package/version to be built

    , Task -> TaskType
taskType            :: !TaskType
    -- ^ the task type, telling us how to build this

    , Task -> TaskConfigOpts
taskConfigOpts      :: !TaskConfigOpts
    , Task -> Bool
taskBuildHaddock    :: !Bool
    , Task -> Map PackageIdentifier GhcPkgId
taskPresent         :: !(Map PackageIdentifier GhcPkgId)
    -- ^ GhcPkgIds of already-installed dependencies

    , Task -> Bool
taskAllInOne        :: !Bool
    -- ^ indicates that the package can be built in one step

    , Task -> CachePkgSrc
taskCachePkgSrc     :: !CachePkgSrc
    , Task -> Bool
taskAnyMissing      :: !Bool
    -- ^ Were any of the dependencies missing? The reason this is

    -- necessary is... hairy. And as you may expect, a bug in

    -- Cabal. See:

    -- <https://github.com/haskell/cabal/issues/4728#issuecomment-337937673>. The

    -- problem is that Cabal may end up generating the same package ID

    -- for a dependency, even if the ABI has changed. As a result,

    -- without this field, Stack would think that a reconfigure is

    -- unnecessary, when in fact we _do_ need to reconfigure. The

    -- details here suck. We really need proper hashes for package

    -- identifiers.

    , Task -> Bool
taskBuildTypeConfig :: !Bool
    -- ^ Is the build type of this package Configure. Check out

    -- ensureConfigureScript in Stack.Build.Execute for the motivation

    }
    deriving Int -> Task -> ShowS
[Task] -> ShowS
Task -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Task] -> ShowS
$cshowList :: [Task] -> ShowS
show :: Task -> String
$cshow :: Task -> String
showsPrec :: Int -> Task -> ShowS
$cshowsPrec :: Int -> Task -> ShowS
Show

-- | Given the IDs of any missing packages, produce the configure options

data TaskConfigOpts = TaskConfigOpts
    { TaskConfigOpts -> Set PackageIdentifier
tcoMissing :: !(Set PackageIdentifier)
      -- ^ Dependencies for which we don't yet have an GhcPkgId

    , TaskConfigOpts -> Map PackageIdentifier GhcPkgId -> ConfigureOpts
tcoOpts    :: !(Map PackageIdentifier GhcPkgId -> ConfigureOpts)
      -- ^ Produce the list of options given the missing @GhcPkgId@s

    }
instance Show TaskConfigOpts where
    show :: TaskConfigOpts -> String
show (TaskConfigOpts Set PackageIdentifier
missing Map PackageIdentifier GhcPkgId -> ConfigureOpts
f) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Missing: "
        , forall a. Show a => a -> String
show Set PackageIdentifier
missing
        , String
". Without those: "
        , forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Map PackageIdentifier GhcPkgId -> ConfigureOpts
f forall k a. Map k a
Map.empty
        ]

-- | The type of a task, either building local code or something from the

-- package index (upstream)

data TaskType
  = TTLocalMutable LocalPackage
  | TTRemotePackage IsMutable Package PackageLocationImmutable
    deriving Int -> TaskType -> ShowS
[TaskType] -> ShowS
TaskType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TaskType] -> ShowS
$cshowList :: [TaskType] -> ShowS
show :: TaskType -> String
$cshow :: TaskType -> String
showsPrec :: Int -> TaskType -> ShowS
$cshowsPrec :: Int -> TaskType -> ShowS
Show

data IsMutable
    = Mutable
    | Immutable
    deriving (IsMutable -> IsMutable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsMutable -> IsMutable -> Bool
$c/= :: IsMutable -> IsMutable -> Bool
== :: IsMutable -> IsMutable -> Bool
$c== :: IsMutable -> IsMutable -> Bool
Eq, Int -> IsMutable -> ShowS
[IsMutable] -> ShowS
IsMutable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IsMutable] -> ShowS
$cshowList :: [IsMutable] -> ShowS
show :: IsMutable -> String
$cshow :: IsMutable -> String
showsPrec :: Int -> IsMutable -> ShowS
$cshowsPrec :: Int -> IsMutable -> ShowS
Show)

instance Semigroup IsMutable where
    IsMutable
Mutable <> :: IsMutable -> IsMutable -> IsMutable
<> IsMutable
_ = IsMutable
Mutable
    IsMutable
_ <> IsMutable
Mutable = IsMutable
Mutable
    IsMutable
Immutable <> IsMutable
Immutable = IsMutable
Immutable

instance Monoid IsMutable where
    mempty :: IsMutable
mempty = IsMutable
Immutable
    mappend :: IsMutable -> IsMutable -> IsMutable
mappend = forall a. Semigroup a => a -> a -> a
(<>)

taskIsTarget :: Task -> Bool
taskIsTarget :: Task -> Bool
taskIsTarget Task
t =
    case Task -> TaskType
taskType Task
t of
        TTLocalMutable LocalPackage
lp -> LocalPackage -> Bool
lpWanted LocalPackage
lp
        TaskType
_ -> Bool
False

taskLocation :: Task -> InstallLocation
taskLocation :: Task -> InstallLocation
taskLocation Task
task =
    case Task -> TaskType
taskType Task
task of
        TTLocalMutable LocalPackage
_ -> InstallLocation
Local
        TTRemotePackage IsMutable
Mutable Package
_ PackageLocationImmutable
_ -> InstallLocation
Local
        TTRemotePackage IsMutable
Immutable Package
_ PackageLocationImmutable
_ -> InstallLocation
Snap

taskTargetIsMutable :: Task -> IsMutable
taskTargetIsMutable :: Task -> IsMutable
taskTargetIsMutable Task
task =
    case Task -> TaskType
taskType Task
task of
        TTLocalMutable LocalPackage
_ -> IsMutable
Mutable
        TTRemotePackage IsMutable
mutable Package
_ PackageLocationImmutable
_ -> IsMutable
mutable

installLocationIsMutable :: InstallLocation -> IsMutable
installLocationIsMutable :: InstallLocation -> IsMutable
installLocationIsMutable InstallLocation
Snap = IsMutable
Immutable
installLocationIsMutable InstallLocation
Local = IsMutable
Mutable

-- | A complete plan of what needs to be built and how to do it

data Plan = Plan
    { Plan -> Map PackageName Task
planTasks :: !(Map PackageName Task)
    , Plan -> Map PackageName Task
planFinals :: !(Map PackageName Task)
    -- ^ Final actions to be taken (test, benchmark, etc)

    , Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text))
    -- ^ Text is reason we're unregistering, for display only

    , Plan -> Map Text InstallLocation
planInstallExes :: !(Map Text InstallLocation)
    -- ^ Executables that should be installed after successful building

    }
    deriving Int -> Plan -> ShowS
[Plan] -> ShowS
Plan -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Plan] -> ShowS
$cshowList :: [Plan] -> ShowS
show :: Plan -> String
$cshow :: Plan -> String
showsPrec :: Int -> Plan -> ShowS
$cshowsPrec :: Int -> Plan -> ShowS
Show

-- | Basic information used to calculate what the configure options are

data BaseConfigOpts = BaseConfigOpts
    { BaseConfigOpts -> Path Abs Dir
bcoSnapDB :: !(Path Abs Dir)
    , BaseConfigOpts -> Path Abs Dir
bcoLocalDB :: !(Path Abs Dir)
    , BaseConfigOpts -> Path Abs Dir
bcoSnapInstallRoot :: !(Path Abs Dir)
    , BaseConfigOpts -> Path Abs Dir
bcoLocalInstallRoot :: !(Path Abs Dir)
    , BaseConfigOpts -> BuildOpts
bcoBuildOpts :: !BuildOpts
    , BaseConfigOpts -> BuildOptsCLI
bcoBuildOptsCLI :: !BuildOptsCLI
    , BaseConfigOpts -> [Path Abs Dir]
bcoExtraDBs :: ![Path Abs Dir]
    }
    deriving Int -> BaseConfigOpts -> ShowS
[BaseConfigOpts] -> ShowS
BaseConfigOpts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BaseConfigOpts] -> ShowS
$cshowList :: [BaseConfigOpts] -> ShowS
show :: BaseConfigOpts -> String
$cshow :: BaseConfigOpts -> String
showsPrec :: Int -> BaseConfigOpts -> ShowS
$cshowsPrec :: Int -> BaseConfigOpts -> ShowS
Show

-- | Render a @BaseConfigOpts@ to an actual list of options

configureOpts :: EnvConfig
              -> BaseConfigOpts
              -> Map PackageIdentifier GhcPkgId -- ^ dependencies

              -> Bool -- ^ local non-extra-dep?

              -> IsMutable
              -> Package
              -> ConfigureOpts
configureOpts :: EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> Package
-> ConfigureOpts
configureOpts EnvConfig
econfig BaseConfigOpts
bco Map PackageIdentifier GhcPkgId
deps Bool
isLocal IsMutable
isMutable Package
package = ConfigureOpts
    { coDirs :: [String]
coDirs = BaseConfigOpts -> IsMutable -> Package -> [String]
configureOptsDirs BaseConfigOpts
bco IsMutable
isMutable Package
package
    , coNoDirs :: [String]
coNoDirs = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> Package
-> [String]
configureOptsNoDir EnvConfig
econfig BaseConfigOpts
bco Map PackageIdentifier GhcPkgId
deps Bool
isLocal Package
package
    }

-- options set by stack

isStackOpt :: Text -> Bool
isStackOpt :: Text -> Bool
isStackOpt Text
t = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
t)
    [ Text
"--dependency="
    , Text
"--constraint="
    , Text
"--package-db="
    , Text
"--libdir="
    , Text
"--bindir="
    , Text
"--datadir="
    , Text
"--libexecdir="
    , Text
"--sysconfdir"
    , Text
"--docdir="
    , Text
"--htmldir="
    , Text
"--haddockdir="
    , Text
"--enable-tests"
    , Text
"--enable-benchmarks"
    , Text
"--exact-configuration"
    -- Treat these as causing dirtiness, to resolve

    -- https://github.com/commercialhaskell/stack/issues/2984

    --

    -- , "--enable-library-profiling"

    -- , "--enable-executable-profiling"

    -- , "--enable-profiling"

    ] Bool -> Bool -> Bool
|| Text
t forall a. Eq a => a -> a -> Bool
== Text
"--user"

configureOptsDirs :: BaseConfigOpts
                  -> IsMutable
                  -> Package
                  -> [String]
configureOptsDirs :: BaseConfigOpts -> IsMutable -> Package -> [String]
configureOptsDirs BaseConfigOpts
bco IsMutable
isMutable Package
package = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [String
"--user", String
"--package-db=clear", String
"--package-db=global"]
    , forall a b. (a -> b) -> [a] -> [b]
map ((String
"--package-db=" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> String
toFilePathNoTrailingSep) forall a b. (a -> b) -> a -> b
$ case IsMutable
isMutable of
        IsMutable
Immutable -> BaseConfigOpts -> [Path Abs Dir]
bcoExtraDBs BaseConfigOpts
bco forall a. [a] -> [a] -> [a]
++ [BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
bco]
        IsMutable
Mutable -> BaseConfigOpts -> [Path Abs Dir]
bcoExtraDBs BaseConfigOpts
bco forall a. [a] -> [a] -> [a]
++ [BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
bco] forall a. [a] -> [a] -> [a]
++ [BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
bco]
    , [ String
"--libdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLib)
      , String
"--bindir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix)
      , String
"--datadir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirShare)
      , String
"--libexecdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLibexec)
      , String
"--sysconfdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirEtc)
      , String
"--docdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
docDir
      , String
"--htmldir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
docDir
      , String
"--haddockdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
docDir]
    ]
  where
    installRoot :: Path Abs Dir
installRoot =
        case IsMutable
isMutable of
            IsMutable
Immutable -> BaseConfigOpts -> Path Abs Dir
bcoSnapInstallRoot BaseConfigOpts
bco
            IsMutable
Mutable -> BaseConfigOpts -> Path Abs Dir
bcoLocalInstallRoot BaseConfigOpts
bco
    docDir :: Path Abs Dir
docDir =
        case Maybe (Path Rel Dir)
pkgVerDir of
            Maybe (Path Rel Dir)
Nothing -> Path Abs Dir
installRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix
            Just Path Rel Dir
dir -> Path Abs Dir
installRoot forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
dir
    pkgVerDir :: Maybe (Path Rel Dir)
pkgVerDir =
        forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (PackageIdentifier -> String
packageIdentifierString (PackageName -> Version -> PackageIdentifier
PackageIdentifier (Package -> PackageName
packageName Package
package)
                                                                (Package -> Version
packageVersion Package
package)) forall a. [a] -> [a] -> [a]
++
                     [Char
pathSeparator])

-- | Same as 'configureOpts', but does not include directory path options

configureOptsNoDir :: EnvConfig
                   -> BaseConfigOpts
                   -> Map PackageIdentifier GhcPkgId -- ^ dependencies

                   -> Bool -- ^ is this a local, non-extra-dep?

                   -> Package
                   -> [String]
configureOptsNoDir :: EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> Package
-> [String]
configureOptsNoDir EnvConfig
econfig BaseConfigOpts
bco Map PackageIdentifier GhcPkgId
deps Bool
isLocal Package
package = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [String]
depOptions
    , [String
"--enable-library-profiling" | BuildOpts -> Bool
boptsLibProfile BuildOpts
bopts Bool -> Bool -> Bool
|| BuildOpts -> Bool
boptsExeProfile BuildOpts
bopts]
    -- Cabal < 1.21.1 does not support --enable-profiling, use --enable-executable-profiling instead

    , let profFlag :: String
profFlag = String
"--enable-" forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"executable-" | Bool -> Bool
not Bool
newerCabal] forall a. Semigroup a => a -> a -> a
<> String
"profiling"
      in [ String
profFlag | BuildOpts -> Bool
boptsExeProfile BuildOpts
bopts Bool -> Bool -> Bool
&& Bool
isLocal]
    , [String
"--enable-split-objs" | BuildOpts -> Bool
boptsSplitObjs BuildOpts
bopts]
    , [String
"--disable-library-stripping" | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ BuildOpts -> Bool
boptsLibStrip BuildOpts
bopts Bool -> Bool -> Bool
|| BuildOpts -> Bool
boptsExeStrip BuildOpts
bopts]
    , [String
"--disable-executable-stripping" | Bool -> Bool
not (BuildOpts -> Bool
boptsExeStrip BuildOpts
bopts) Bool -> Bool -> Bool
&& Bool
isLocal]
    , forall a b. (a -> b) -> [a] -> [b]
map (\(FlagName
name,Bool
enabled) ->
                       String
"-f" forall a. Semigroup a => a -> a -> a
<>
                       (if Bool
enabled
                           then String
""
                           else String
"-") forall a. Semigroup a => a -> a -> a
<>
                       FlagName -> String
flagNameString FlagName
name)
                    (forall k a. Map k a -> [(k, a)]
Map.toList Map FlagName Bool
flags)
    , forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Package -> [Text]
packageCabalConfigOpts Package
package
    , [Text] -> [String]
processGhcOptions (Package -> [Text]
packageGhcOptions Package
package)
    , forall a b. (a -> b) -> [a] -> [b]
map (String
"--extra-include-dirs=" forall a. [a] -> [a] -> [a]
++) (Config -> [String]
configExtraIncludeDirs Config
config)
    , forall a b. (a -> b) -> [a] -> [b]
map (String
"--extra-lib-dirs=" forall a. [a] -> [a] -> [a]
++) (Config -> [String]
configExtraLibDirs Config
config)
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Path Abs File
customGcc -> [String
"--with-gcc=" forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> String
toFilePath Path Abs File
customGcc]) (Config -> Maybe (Path Abs File)
configOverrideGccPath Config
config)
    , [String
"--exact-configuration"]
    , [String
"--ghc-option=-fhide-source-paths" | Version -> Bool
hideSourcePaths Version
cv]
    ]
  where
    -- This function parses the GHC options that are providing in the

    -- stack.yaml file. In order to handle RTS arguments correctly, we need

    -- to provide the RTS arguments as a single argument.

    processGhcOptions :: [Text] -> [String]
    processGhcOptions :: [Text] -> [String]
processGhcOptions [Text]
args =
        let
            ([Text]
preRtsArgs, [Text]
mid) =
                forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"+RTS" forall a. Eq a => a -> a -> Bool
==) [Text]
args
            ([Text]
rtsArgs, [Text]
end) =
                forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"-RTS" forall a. Eq a => a -> a -> Bool
==) [Text]
mid
            fullRtsArgs :: [Text]
fullRtsArgs =
                case [Text]
rtsArgs of
                    [] ->
                        -- This means that we didn't have any RTS args - no

                        -- `+RTS` - and therefore no need for a `-RTS`.

                        []
                    [Text]
_ ->
                        -- In this case, we have some RTS args. `break`

                        -- puts the `"-RTS"` string in the `snd` list, so

                        -- we want to append it on the end of `rtsArgs`

                        -- here.

                        --

                        -- We're not checking that `-RTS` is the first

                        -- element of `end`. This is because the GHC RTS

                        -- allows you to omit a trailing -RTS if that's the

                        -- last of the arguments. This permits a GHC

                        -- options in stack.yaml that matches what you

                        -- might pass directly to GHC.

                        [[Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ [Text]
rtsArgs forall a. [a] -> [a] -> [a]
++ [Text
"-RTS"]]
            -- We drop the first element from `end`, because it is always

            -- either `"-RTS"` (and we don't want that as a separate

            -- argument) or the list is empty (and `drop _ [] = []`).

            postRtsArgs :: [Text]
postRtsArgs =
                forall a. Int -> [a] -> [a]
drop Int
1 [Text]
end
            newArgs :: [Text]
newArgs =
                forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]
preRtsArgs, [Text]
fullRtsArgs, [Text]
postRtsArgs]
        in
            forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Text
x -> [WhichCompiler -> String
compilerOptionsCabalFlag WhichCompiler
wc, Text -> String
T.unpack Text
x]) [Text]
newArgs

    wc :: WhichCompiler
wc = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> WhichCompiler
whichCompiler) EnvConfig
econfig
    cv :: Version
cv = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Version
getGhcVersion) EnvConfig
econfig

    hideSourcePaths :: Version -> Bool
hideSourcePaths Version
ghcVersion = Version
ghcVersion forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
C.mkVersion [Int
8, Int
2] Bool -> Bool -> Bool
&& Config -> Bool
configHideSourcePaths Config
config

    config :: Config
config = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL EnvConfig
econfig
    bopts :: BuildOpts
bopts = BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
bco

    newerCabal :: Bool
newerCabal = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
cabalVersionL EnvConfig
econfig forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
C.mkVersion [Int
1, Int
22]

    -- Unioning atop defaults is needed so that all flags are specified

    -- with --exact-configuration.

    flags :: Map FlagName Bool
flags = Package -> Map FlagName Bool
packageFlags Package
package forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Package -> Map FlagName Bool
packageDefaultFlags Package
package

    depOptions :: [String]
depOptions = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PackageIdentifier -> GhcPkgId -> String
toDepOption) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map PackageIdentifier GhcPkgId
deps
      where
        toDepOption :: PackageIdentifier -> GhcPkgId -> String
toDepOption = if Bool
newerCabal then PackageIdentifier -> GhcPkgId -> String
toDepOption1_22 else forall {p}. PackageIdentifier -> p -> String
toDepOption1_18

    toDepOption1_22 :: PackageIdentifier -> GhcPkgId -> String
toDepOption1_22 (PackageIdentifier PackageName
name Version
_) GhcPkgId
gid = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"--dependency="
        , PackageName -> String
packageNameString PackageName
name
        , String
"="
        , GhcPkgId -> String
ghcPkgIdString GhcPkgId
gid
        ]

    toDepOption1_18 :: PackageIdentifier -> p -> String
toDepOption1_18 PackageIdentifier
ident p
_gid = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"--constraint="
        , PackageName -> String
packageNameString PackageName
name
        , String
"=="
        , Version -> String
versionString Version
version'
        ]
      where
        PackageIdentifier PackageName
name Version
version' = PackageIdentifier
ident

-- | Get set of wanted package names from locals.

wantedLocalPackages :: [LocalPackage] -> Set PackageName
wantedLocalPackages :: [LocalPackage] -> Set PackageName
wantedLocalPackages = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Package -> PackageName
packageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalPackage -> Package
lpPackage) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter LocalPackage -> Bool
lpWanted

-- | Configure options to be sent to Setup.hs configure

data ConfigureOpts = ConfigureOpts
    { ConfigureOpts -> [String]
coDirs :: ![String]
    -- ^ Options related to various paths. We separate these out since they do

    -- not have an impact on the contents of the compiled binary for checking

    -- if we can use an existing precompiled cache.

    , ConfigureOpts -> [String]
coNoDirs :: ![String]
    }
    deriving (Int -> ConfigureOpts -> ShowS
[ConfigureOpts] -> ShowS
ConfigureOpts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigureOpts] -> ShowS
$cshowList :: [ConfigureOpts] -> ShowS
show :: ConfigureOpts -> String
$cshow :: ConfigureOpts -> String
showsPrec :: Int -> ConfigureOpts -> ShowS
$cshowsPrec :: Int -> ConfigureOpts -> ShowS
Show, ConfigureOpts -> ConfigureOpts -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigureOpts -> ConfigureOpts -> Bool
$c/= :: ConfigureOpts -> ConfigureOpts -> Bool
== :: ConfigureOpts -> ConfigureOpts -> Bool
$c== :: ConfigureOpts -> ConfigureOpts -> Bool
Eq, forall x. Rep ConfigureOpts x -> ConfigureOpts
forall x. ConfigureOpts -> Rep ConfigureOpts x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConfigureOpts x -> ConfigureOpts
$cfrom :: forall x. ConfigureOpts -> Rep ConfigureOpts x
Generic, Typeable ConfigureOpts
ConfigureOpts -> DataType
ConfigureOpts -> Constr
(forall b. Data b => b -> b) -> ConfigureOpts -> ConfigureOpts
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> ConfigureOpts -> u
forall u. (forall d. Data d => d -> u) -> ConfigureOpts -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigureOpts -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigureOpts -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ConfigureOpts -> m ConfigureOpts
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigureOpts -> m ConfigureOpts
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConfigureOpts
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConfigureOpts -> c ConfigureOpts
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConfigureOpts)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConfigureOpts)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigureOpts -> m ConfigureOpts
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigureOpts -> m ConfigureOpts
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigureOpts -> m ConfigureOpts
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ConfigureOpts -> m ConfigureOpts
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ConfigureOpts -> m ConfigureOpts
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ConfigureOpts -> m ConfigureOpts
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ConfigureOpts -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ConfigureOpts -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> ConfigureOpts -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ConfigureOpts -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigureOpts -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigureOpts -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigureOpts -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ConfigureOpts -> r
gmapT :: (forall b. Data b => b -> b) -> ConfigureOpts -> ConfigureOpts
$cgmapT :: (forall b. Data b => b -> b) -> ConfigureOpts -> ConfigureOpts
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConfigureOpts)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ConfigureOpts)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConfigureOpts)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ConfigureOpts)
dataTypeOf :: ConfigureOpts -> DataType
$cdataTypeOf :: ConfigureOpts -> DataType
toConstr :: ConfigureOpts -> Constr
$ctoConstr :: ConfigureOpts -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConfigureOpts
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConfigureOpts
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConfigureOpts -> c ConfigureOpts
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ConfigureOpts -> c ConfigureOpts
Data, Typeable)
instance NFData ConfigureOpts

-- | Information on a compiled package: the library conf file (if relevant),

-- the sublibraries (if present) and all of the executable paths.

data PrecompiledCache base = PrecompiledCache
    { forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary :: !(Maybe (Path base File))
    -- ^ .conf file inside the package database

    , forall base. PrecompiledCache base -> [Path base File]
pcSubLibs :: ![Path base File]
    -- ^ .conf file inside the package database, for each of the sublibraries

    , forall base. PrecompiledCache base -> [Path base File]
pcExes    :: ![Path base File]
    -- ^ Full paths to executables

    }
    deriving (Int -> PrecompiledCache base -> ShowS
forall base. Int -> PrecompiledCache base -> ShowS
forall base. [PrecompiledCache base] -> ShowS
forall base. PrecompiledCache base -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrecompiledCache base] -> ShowS
$cshowList :: forall base. [PrecompiledCache base] -> ShowS
show :: PrecompiledCache base -> String
$cshow :: forall base. PrecompiledCache base -> String
showsPrec :: Int -> PrecompiledCache base -> ShowS
$cshowsPrec :: forall base. Int -> PrecompiledCache base -> ShowS
Show, PrecompiledCache base -> PrecompiledCache base -> Bool
forall base. PrecompiledCache base -> PrecompiledCache base -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrecompiledCache base -> PrecompiledCache base -> Bool
$c/= :: forall base. PrecompiledCache base -> PrecompiledCache base -> Bool
== :: PrecompiledCache base -> PrecompiledCache base -> Bool
$c== :: forall base. PrecompiledCache base -> PrecompiledCache base -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall base x.
Rep (PrecompiledCache base) x -> PrecompiledCache base
forall base x.
PrecompiledCache base -> Rep (PrecompiledCache base) x
$cto :: forall base x.
Rep (PrecompiledCache base) x -> PrecompiledCache base
$cfrom :: forall base x.
PrecompiledCache base -> Rep (PrecompiledCache base) x
Generic, Typeable)
instance NFData (PrecompiledCache Abs)
instance NFData (PrecompiledCache Rel)