{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : Stack.Types.GhcPkgExe
License     : BSD-3-Clause
-}

module Stack.Types.GhcPkgExe
  ( GhcPkgPrettyException (..)
  , GlobPackageIdentifier (..)
  , PackageArg (..)
  ) where

import           Distribution.Package ( UnitId )
import           Distribution.Text ( display )
import           Path ( SomeBase (..) )
import           Stack.Prelude hiding ( display )

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

-- "GHC.Utils.GhcPkg.Main.Compat" module or the "Stack.GhcPkg" module.

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

-- | Represents how a package may be specified by a user on the command line.

data PackageArg
    -- | A package identifier foo-0.1, or a glob foo-*

  = Id GlobPackageIdentifier
    -- | An installed package ID foo-0.1-HASH.  This is guaranteed to uniquely

    -- match a single entry in the package database.

  | IUId UnitId
    -- | A glob against the package name.  The first string is the literal

    -- glob, the second is a function which returns @True@ if the argument

    -- matches.

  | 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]
"-*"

-- | Either an exact t'PackageIdentifier', or a glob for all packages

-- matching 'PackageName'.

data GlobPackageIdentifier
  = ExactPackageIdentifier MungedPackageId
  | GlobPackageIdentifier  MungedPackageName