{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}

module Stack.Types.Config.Exception
  ( ConfigException (..)
  , ConfigPrettyException (..)
  , ParseAbsolutePathException (..)
  , packageIndicesWarning
  ) where

import qualified Data.Text as T
import           Data.Yaml ( ParseException )
import qualified Data.Yaml as Yaml
import           Path( dirname, filename )
import           Stack.Prelude
import           Stack.Types.ConfigMonoid
                   ( configMonoidAllowDifferentUserName
                   , configMonoidGHCVariantName, configMonoidSystemGHCName
                   )
import           Stack.Types.Version
                   ( VersionRange, stackVersion, versionRangeText )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Config" module.

data ConfigException
  = ParseCustomSnapshotException Text ParseException
  | NoProjectConfigFound (Path Abs Dir) (Maybe Text)
  | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]
  | UnableToExtractArchive Text (Path Abs File)
  | BadStackVersionException VersionRange
  | NoSuchDirectory FilePath
  | ParseGHCVariantException String
  | BadStackRoot (Path Abs Dir)
  | Won'tCreateStackRootInDirectoryOwnedByDifferentUser
      (Path Abs Dir)
      (Path Abs Dir)
    -- ^ @$STACK_ROOT@, parent dir

  | UserDoesn'tOwnDirectory (Path Abs Dir)
  | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
  | NixRequiresSystemGhc
  | NoResolverWhenUsingNoProject
  | NoLTSWithMajorVersion Int
  | NoLTSFound
  deriving (Int -> ConfigException -> ShowS
[ConfigException] -> ShowS
ConfigException -> String
(Int -> ConfigException -> ShowS)
-> (ConfigException -> String)
-> ([ConfigException] -> ShowS)
-> Show ConfigException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigException -> ShowS
showsPrec :: Int -> ConfigException -> ShowS
$cshow :: ConfigException -> String
show :: ConfigException -> String
$cshowList :: [ConfigException] -> ShowS
showList :: [ConfigException] -> ShowS
Show, Typeable)

instance Exception ConfigException where
  displayException :: ConfigException -> String
displayException (ParseCustomSnapshotException Text
url ParseException
exception) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-8981]\n"
    , String
"Could not parse '"
    , Text -> String
T.unpack Text
url
    , String
"':\n"
    , ParseException -> String
Yaml.prettyPrintParseException ParseException
exception
    , String
"\nSee https://docs.haskellstack.org/en/stable/custom_snapshot/"
    ]
  displayException (NoProjectConfigFound Path Abs Dir
dir Maybe Text
mcmd) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-2206]\n"
    , String
"Unable to find a stack.yaml file in the current directory ("
    , Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
dir
    , String
") or its ancestors"
    , case Maybe Text
mcmd of
        Maybe Text
Nothing -> String
""
        Just Text
cmd -> String
"\nRecommended action: stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
cmd
    ]
  displayException (UnexpectedArchiveContents [Path Abs Dir]
dirs [Path Abs File]
files) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-4964]\n"
    , String
"When unpacking an archive specified in your stack.yaml file, "
    , String
"did not find expected contents. Expected: a single directory. Found: "
    , ([String], [String]) -> String
forall a. Show a => a -> String
show ( (Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath (Path Rel Dir -> String)
-> (Path Abs Dir -> Path Rel Dir) -> Path Abs Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname) [Path Abs Dir]
dirs
           , (Path Abs File -> String) -> [Path Abs File] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Rel File -> String)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename) [Path Abs File]
files
           )
    ]
  displayException (UnableToExtractArchive Text
url Path Abs File
file) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-2040]\n"
    , String
"Archive extraction failed. Tarballs and zip archives are supported, \
      \couldn't handle the following URL, "
    , Text -> String
T.unpack Text
url
    , String
" downloaded to the file "
    , Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Rel File -> String) -> Path Rel File -> String
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
file
    ]
  displayException (BadStackVersionException VersionRange
requiredRange) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-1641]\n"
    , String
"The version of Stack you are using ("
    , Version -> String
forall a. Show a => a -> String
show Version
stackVersion
    , String
") is outside the required\n"
    ,String
"version range specified in stack.yaml ("
    , Text -> String
T.unpack (VersionRange -> Text
versionRangeText VersionRange
requiredRange)
    , String
").\n"
    , String
"You can upgrade Stack by running:\n\n"
    , String
"stack upgrade"
    ]
  displayException (NoSuchDirectory String
dir) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-8773]\n"
    , String
"No directory could be located matching the supplied path: "
    , String
dir
    ]
  displayException (ParseGHCVariantException String
v) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-3938]\n"
    , String
"Invalid ghc-variant value: "
    , String
v
    ]
  displayException (BadStackRoot Path Abs Dir
stackRoot) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-8530]\n"
    , String
"Invalid Stack root: '"
    , Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
stackRoot
    , String
"'. Please provide a valid absolute path."
    ]
  displayException (Won'tCreateStackRootInDirectoryOwnedByDifferentUser Path Abs Dir
envStackRoot Path Abs Dir
parentDir) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-7613]\n"
    , String
"Preventing creation of Stack root '"
    , Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
envStackRoot
    , String
"'. Parent directory '"
    , Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
parentDir
    , String
"' is owned by someone else."
    ]
  displayException (UserDoesn'tOwnDirectory Path Abs Dir
dir) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-8707]\n"
    , String
"You are not the owner of '"
    , Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
dir
    , String
"'. Aborting to protect file permissions."
    , String
"\nRetry with '--"
    , Text -> String
T.unpack Text
configMonoidAllowDifferentUserName
    , String
"' to disable this precaution."
    ]
  displayException ConfigException
ManualGHCVariantSettingsAreIncompatibleWithSystemGHC = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
    [ Text
"Error: [S-3605]\n"
    , Text
"Stack can only control the "
    , Text
configMonoidGHCVariantName
    , Text
" of its own GHC installations. Please use '--no-"
    , Text
configMonoidSystemGHCName
    , Text
"'."
    ]
  displayException ConfigException
NixRequiresSystemGhc = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
    [ Text
"Error: [S-6816]\n"
    , Text
"Stack's Nix integration is incompatible with '--no-system-ghc'. "
    , Text
"Please use '--"
    , Text
configMonoidSystemGHCName
    , Text
"' or disable the Nix integration."
    ]
  displayException ConfigException
NoResolverWhenUsingNoProject =
    String
"Error: [S-5027]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"When using the script command, you must provide a resolver argument"
  displayException (NoLTSWithMajorVersion Int
n) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-3803]\n"
    , String
"No LTS release found with major version "
    , Int -> String
forall a. Show a => a -> String
show Int
n
    , String
"."
    ]
  displayException ConfigException
NoLTSFound =
    String
"Error: [S-5472]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"No LTS releases found."

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Config" module.

data ConfigPrettyException
  = ParseConfigFileException !(Path Abs File) !ParseException
  | StackWorkEnvNotRelativeDir !String
  | MultiplePackageIndices [PackageIndexConfig]
  | DuplicateLocalPackageNames ![(PackageName, [PackageLocation])]
  deriving (Int -> ConfigPrettyException -> ShowS
[ConfigPrettyException] -> ShowS
ConfigPrettyException -> String
(Int -> ConfigPrettyException -> ShowS)
-> (ConfigPrettyException -> String)
-> ([ConfigPrettyException] -> ShowS)
-> Show ConfigPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigPrettyException -> ShowS
showsPrec :: Int -> ConfigPrettyException -> ShowS
$cshow :: ConfigPrettyException -> String
show :: ConfigPrettyException -> String
$cshowList :: [ConfigPrettyException] -> ShowS
showList :: [ConfigPrettyException] -> ShowS
Show, Typeable)

instance Pretty ConfigPrettyException where
  pretty :: ConfigPrettyException -> StyleDoc
pretty (ParseConfigFileException Path Abs File
configFile ParseException
exception) =
    StyleDoc
"[S-6602]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack could not load and parse"
         , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
configFile
         , String -> StyleDoc
flow String
"as a YAML configuraton file."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While loading and parsing, Stack encountered the following \
            \error:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (ParseException -> String
Yaml.prettyPrintParseException ParseException
exception)
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"For help about the content of Stack's YAML configuration \
                \files, see (for the most recent release of Stack)"
         ,    Style -> StyleDoc -> StyleDoc
style
                Style
Url
                StyleDoc
"http://docs.haskellstack.org/en/stable/yaml_configuration/"
           StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (StackWorkEnvNotRelativeDir String
x) =
    StyleDoc
"[S-7462]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack failed to interpret the value of the STACK_WORK \
            \environment variable as a valid relative path to a directory. \
            \Stack will not accept an absolute path. A path containing a \
            \.. (parent directory) component is not valid."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"If set, Stack expects the value to identify the location \
                \of Stack's work directory, relative to the root directory \
                \of the project or package. Stack encountered the value:"
         , Style -> StyleDoc -> StyleDoc
style Style
Error (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
x) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (MultiplePackageIndices [PackageIndexConfig]
pics) =
    StyleDoc
"[S-3251]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"When using the"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"package-indices"
         , String -> StyleDoc
flow String
"key to override the default package index, you must \
                \provide exactly one value, received:"
         , [StyleDoc] -> StyleDoc
bulletedList ((PackageIndexConfig -> StyleDoc)
-> [PackageIndexConfig] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
string (String -> StyleDoc)
-> (PackageIndexConfig -> String) -> PackageIndexConfig -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIndexConfig -> String
forall a. Show a => a -> String
show) [PackageIndexConfig]
pics)
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
packageIndicesWarning
  pretty (DuplicateLocalPackageNames [(PackageName, [PackageLocation])]
pairs) =
    StyleDoc
"[S-5470]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
        [ String -> StyleDoc
flow String
"The same package name is used in more than one local package or"
        , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"extra-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (((PackageName, [PackageLocation]) -> StyleDoc)
-> [(PackageName, [PackageLocation])] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, [PackageLocation]) -> StyleDoc
forall {a}. Display a => (PackageName, [a]) -> StyleDoc
go [(PackageName, [PackageLocation])]
pairs)
   where
    go :: (PackageName, [a]) -> StyleDoc
go (PackageName
name, [a]
dirs) =
         StyleDoc
blankLine
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
           [ Style -> StyleDoc -> StyleDoc
style Style
Error (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name)
           , String -> StyleDoc
flow String
"used in:"
           ]
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((a -> StyleDoc) -> [a] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> (a -> String) -> a -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Display a => a -> Text
textDisplay) [a]
dirs)

instance Exception ConfigPrettyException

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

instance Exception ParseAbsolutePathException where
  displayException :: ParseAbsolutePathException -> String
displayException (ParseAbsolutePathException String
envVar String
dir) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-9437]\n"
    , String
"Failed to parse "
    , String
envVar
    , String
" environment variable (expected absolute directory): "
    , String
dir
    ]

packageIndicesWarning :: StyleDoc
packageIndicesWarning :: StyleDoc
packageIndicesWarning =
  [StyleDoc] -> StyleDoc
fillSep
    [ StyleDoc
"The"
    , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"package-indices"
    , String -> StyleDoc
flow String
"key is deprecated in favour of"
    , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"package-index" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]