{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Types.GhcPkgExe
( GhcPkgPrettyException (..)
, GlobPackageIdentifier (..)
, PackageArg (..)
) where
import Distribution.Package ( UnitId )
import Distribution.Text ( display )
import Path ( SomeBase (..) )
import Stack.Prelude hiding ( display )
data GhcPkgPrettyException
= CannotParse !String !String !String
| CannotOpenDBForModification !(SomeBase Dir) !IOException
| SingleFileDBUnsupported !(SomeBase Dir)
| ParsePackageInfoExceptions !String
| CannotFindPackage !PackageArg !(Maybe (SomeBase Dir))
| CannotParseRelFileBug !String
| CannotParseDirectoryWithDBug !String
| CannotRecacheAfterUnregister !(Path Abs Dir) !SomeException
deriving (Int -> GhcPkgPrettyException -> ShowS
[GhcPkgPrettyException] -> ShowS
GhcPkgPrettyException -> [Char]
(Int -> GhcPkgPrettyException -> ShowS)
-> (GhcPkgPrettyException -> [Char])
-> ([GhcPkgPrettyException] -> ShowS)
-> Show GhcPkgPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhcPkgPrettyException -> ShowS
showsPrec :: Int -> GhcPkgPrettyException -> ShowS
$cshow :: GhcPkgPrettyException -> [Char]
show :: GhcPkgPrettyException -> [Char]
$cshowList :: [GhcPkgPrettyException] -> ShowS
showList :: [GhcPkgPrettyException] -> ShowS
Show, Typeable)
instance Pretty GhcPkgPrettyException where
pretty :: GhcPkgPrettyException -> StyleDoc
pretty (CannotParse [Char]
str [Char]
what [Char]
e) =
StyleDoc
"[S-6512]"
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
[ [Char] -> StyleDoc
flow [Char]
"cannot parse"
, Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
str)
, [Char] -> StyleDoc
flow [Char]
"as a"
, [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
what StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
]
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
e
pretty (CannotOpenDBForModification SomeBase Dir
db_path IOException
e) =
StyleDoc
"[S-3384]"
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
[ [Char] -> StyleDoc
flow [Char]
"Couldn't open database"
, SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty SomeBase Dir
db_path
, [Char] -> StyleDoc
flow [Char]
"for modification:"
]
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e)
pretty (SingleFileDBUnsupported SomeBase Dir
path) =
StyleDoc
"[S-1430]"
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
[ [Char] -> StyleDoc
flow [Char]
"ghc no longer supports single-file style package databases"
, StyleDoc -> StyleDoc
parens (SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty SomeBase Dir
path)
, StyleDoc
"use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell ([Char] -> StyleDoc
flow [Char]
"ghc-pkg init")
, [Char] -> StyleDoc
flow [Char]
"to create the database with the correct format."
]
pretty (ParsePackageInfoExceptions [Char]
errs) =
StyleDoc
"[S-5996]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
errs
pretty (CannotFindPackage PackageArg
pkgarg Maybe (SomeBase Dir)
mdb_path) =
StyleDoc
"[S-3189]"
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
[ [Char] -> StyleDoc
flow [Char]
"cannot find package"
, Style -> StyleDoc -> StyleDoc
style Style
Current (PackageArg -> StyleDoc
pkg_msg PackageArg
pkgarg)
, StyleDoc
-> (SomeBase Dir -> StyleDoc) -> Maybe (SomeBase Dir) -> StyleDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
StyleDoc
""
(\SomeBase Dir
db_path -> [StyleDoc] -> StyleDoc
fillSep [StyleDoc
"in", SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty SomeBase Dir
db_path])
Maybe (SomeBase Dir)
mdb_path
]
where
pkg_msg :: PackageArg -> StyleDoc
pkg_msg (Substring [Char]
pkgpat [Char] -> Bool
_) = [StyleDoc] -> StyleDoc
fillSep [StyleDoc
"matching", [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
pkgpat]
pkg_msg PackageArg
pkgarg' = [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageArg -> [Char]
forall a. Show a => a -> [Char]
show PackageArg
pkgarg'
pretty (CannotParseRelFileBug [Char]
relFileName) = [Char] -> StyleDoc -> StyleDoc
bugPrettyReport [Char]
"[S-9323]" (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ [Char] -> StyleDoc
flow [Char]
"changeDBDir': Could not parse"
, Style -> StyleDoc -> StyleDoc
style Style
File ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
relFileName)
, [Char] -> StyleDoc
flow [Char]
"as a relative path to a file."
]
pretty (CannotParseDirectoryWithDBug [Char]
dirName) = [Char] -> StyleDoc -> StyleDoc
bugPrettyReport [Char]
"[S-7651]" (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ [Char] -> StyleDoc
flow [Char]
"adjustOldDatabasePath: Could not parse"
, Style -> StyleDoc -> StyleDoc
style Style
Dir ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
dirName)
, [Char] -> StyleDoc
flow [Char]
"as a directory."
]
pretty (CannotRecacheAfterUnregister Path Abs Dir
pkgDb SomeException
e) =
StyleDoc
"[S-6590]"
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
[ [Char] -> StyleDoc
flow [Char]
"While recaching"
, Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
pkgDb
, [Char] -> StyleDoc
flow [Char]
"after unregistering packages, 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
<> [Char] -> StyleDoc
string (SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
e)
instance Exception GhcPkgPrettyException
data PackageArg
= Id GlobPackageIdentifier
| IUId UnitId
| Substring String (String -> Bool)
instance Show PackageArg where
show :: PackageArg -> [Char]
show (Id GlobPackageIdentifier
pkgid) = GlobPackageIdentifier -> [Char]
displayGlobPkgId GlobPackageIdentifier
pkgid
show (IUId UnitId
ipid) = UnitId -> [Char]
forall a. Pretty a => a -> [Char]
display UnitId
ipid
show (Substring [Char]
pkgpat [Char] -> Bool
_) = [Char]
pkgpat
displayGlobPkgId :: GlobPackageIdentifier -> String
displayGlobPkgId :: GlobPackageIdentifier -> [Char]
displayGlobPkgId (ExactPackageIdentifier MungedPackageId
pid) = MungedPackageId -> [Char]
forall a. Pretty a => a -> [Char]
display MungedPackageId
pid
displayGlobPkgId (GlobPackageIdentifier MungedPackageName
pn) = MungedPackageName -> [Char]
forall a. Pretty a => a -> [Char]
display MungedPackageName
pn [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-*"
data GlobPackageIdentifier
= ExactPackageIdentifier MungedPackageId
| GlobPackageIdentifier MungedPackageName