{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module      :  Distribution.Simple.Program.HcPkg
-- Copyright   :  Duncan Coutts 2009, 2013
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module provides an library interface to the @hc-pkg@ program.
-- Currently only GHC and GHCJS have hc-pkg programs.
module Distribution.Simple.Program.HcPkg
  ( -- * Types
    ConfiguredProgram (..)
  , RegisterOptions (..)
  , defaultRegisterOptions

    -- * Actions
  , init
  , invoke
  , register
  , unregister
  , recache
  , expose
  , hide
  , dump
  , describe
  , list

    -- * Program invocations
  , initInvocation
  , registerInvocation
  , unregisterInvocation
  , recacheInvocation
  , exposeInvocation
  , hideInvocation
  , dumpInvocation
  , describeInvocation
  , listInvocation
  ) where

import Distribution.Compat.Prelude hiding (init)
import Prelude ()

import Distribution.InstalledPackageInfo (InstalledPackageInfo (..), parseInstalledPackageInfo, showInstalledPackageInfo)
import Distribution.Parsec (simpleParsec)
import Distribution.Pretty (prettyShow)
import Distribution.Simple.Compiler
  ( PackageDB
  , PackageDBS
  , PackageDBStack
  , PackageDBStackS
  , PackageDBX (..)
  , registrationPackageDB
  )
import Distribution.Simple.Errors (CabalException (..))
import Distribution.Simple.Program.Run
  ( IOEncoding (..)
  , ProgramInvocation (..)
  , getProgramInvocationLBS
  , getProgramInvocationOutput
  , programInvocation
  , programInvocationCwd
  , runProgramInvocation
  )
import Distribution.Simple.Program.Types (ConfiguredProgram (..))
import Distribution.Simple.Utils (IOData (..), dieWithException, writeUTF8File)
import Distribution.Types.ComponentId (mkComponentId)
import Distribution.Types.PackageId (PackageId)
import Distribution.Types.UnitId (mkLegacyUnitId, unUnitId)
import Distribution.Utils.Path
  ( CWD
  , FileLike ((<.>))
  , FileOrDir (Dir)
  , PathLike ((</>))
  , Pkg
  , PkgDB
  , SymbolicPath
  , interpretSymbolicPath
  , interpretSymbolicPathCWD
  )
import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel)

import Data.List (stripPrefix)
import System.FilePath as FilePath
  ( isPathSeparator
  , joinPath
  , splitDirectories
  , splitPath
  )

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List.NonEmpty as NE
import qualified System.FilePath.Posix as FilePath.Posix

-- | Call @hc-pkg@ to initialise a package database at the location {path}.
--
-- > hc-pkg init {path}
init :: ConfiguredProgram -> Verbosity -> FilePath -> IO ()
init :: ConfiguredProgram -> Verbosity -> String -> IO ()
init ConfiguredProgram
hpi Verbosity
verbosity String
path =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ConfiguredProgram -> Verbosity -> String -> ProgramInvocation
initInvocation ConfiguredProgram
hpi Verbosity
verbosity String
path)

-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invoke
  :: ConfiguredProgram
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> [String]
  -> IO ()
invoke :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> [String]
-> IO ()
invoke ConfiguredProgram
ghcProg Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
dbStack [String]
extraArgs =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
invocation
  where
    args :: [String]
args = PackageDBStack -> [String]
forall from. PackageDBStackS from -> [String]
packageDbStackOpts PackageDBStack
dbStack [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extraArgs
    invocation :: ProgramInvocation
invocation = Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg [String]
args

-- | Additional variations in the behaviour for 'register'.
data RegisterOptions = RegisterOptions
  { RegisterOptions -> Bool
registerAllowOverwrite :: Bool
  -- ^ Allows re-registering \/ overwriting an existing package
  , RegisterOptions -> Bool
registerMultiInstance :: Bool
  -- ^ Insist on the ability to register multiple instances of a
  -- single version of a single package.
  , RegisterOptions -> Bool
registerSuppressFilesCheck :: Bool
  -- ^ Require that no checks are performed on the existence of package
  -- files mentioned in the registration info. This must be used if
  -- registering prior to putting the files in their final place. This will
  -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'.
  }

-- | Defaults are @True@, @False@ and @False@
defaultRegisterOptions :: RegisterOptions
defaultRegisterOptions :: RegisterOptions
defaultRegisterOptions =
  RegisterOptions
    { registerAllowOverwrite :: Bool
registerAllowOverwrite = Bool
True
    , registerMultiInstance :: Bool
registerMultiInstance = Bool
False
    , registerSuppressFilesCheck :: Bool
registerSuppressFilesCheck = Bool
False
    }

-- | Call @hc-pkg@ to register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
register
  :: ConfiguredProgram
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBStackS from
  -> InstalledPackageInfo
  -> RegisterOptions
  -> IO ()
register :: forall from.
ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
register ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackS from
packagedbs InstalledPackageInfo
pkgInfo RegisterOptions
registerOptions
  | RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions =
      do
        let pkgdb :: PackageDBX (SymbolicPath from ('Dir PkgDB))
pkgdb = PackageDBStackS from -> PackageDBX (SymbolicPath from ('Dir PkgDB))
forall from. PackageDBStackX from -> PackageDBX from
registrationPackageDB PackageDBStackS from
packagedbs
        Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> InstalledPackageInfo
-> IO ()
forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> InstalledPackageInfo
-> IO ()
writeRegistrationFileDirectly Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
pkgdb InstalledPackageInfo
pkgInfo
        ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> IO ()
forall from.
ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> IO ()
recache ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
pkgdb
  | Bool
otherwise =
      Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
        Verbosity
verbosity
        (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
forall from.
ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
registerInvocation ConfiguredProgram
hpi (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackS from
packagedbs InstalledPackageInfo
pkgInfo RegisterOptions
registerOptions)

writeRegistrationFileDirectly
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBS from
  -> InstalledPackageInfo
  -> IO ()
writeRegistrationFileDirectly :: forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> InstalledPackageInfo
-> IO ()
writeRegistrationFileDirectly Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBS from
package InstalledPackageInfo
pkgInfo =
  case PackageDBS from
package of
    (SpecificPackageDB SymbolicPath from ('Dir PkgDB)
dir) -> do
      let pkgfile :: String
pkgfile = Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPath from ('Dir PkgDB) -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir SymbolicPath from ('Dir PkgDB)
dir String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> UnitId -> String
forall a. Pretty a => a -> String
prettyShow (InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
pkgInfo) String -> String -> String
forall p. FileLike p => p -> String -> p
<.> String
"conf"
      String -> String -> IO ()
writeUTF8File String
pkgfile (InstalledPackageInfo -> String
showInstalledPackageInfo InstalledPackageInfo
pkgInfo)
    PackageDBS from
_ -> do
      -- We don't know here what the dir for the global or user dbs are,
      -- if that's needed it'll require a bit more plumbing to support.
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
OnlySupportSpecificPackageDb

-- | Call @hc-pkg@ to unregister a package
--
-- > hc-pkg unregister [pkgid] [--user | --global | --package-db]
unregister :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO ()
unregister :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> IO ()
unregister ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
unregisterInvocation ConfiguredProgram
hpi (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid)

-- | Call @hc-pkg@ to recache the registered packages.
--
-- > hc-pkg recache [--user | --global | --package-db]
recache :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO ()
recache :: forall from.
ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> IO ()
recache ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBS from
packagedb =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
forall from.
ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
recacheInvocation ConfiguredProgram
hpi (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBS from
packagedb)

-- | Call @hc-pkg@ to expose a package.
--
-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
expose
  :: ConfiguredProgram
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> IO ()
expose :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> IO ()
expose ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
exposeInvocation ConfiguredProgram
hpi (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid)

-- | Call @hc-pkg@ to retrieve a specific package
--
-- > hc-pkg describe [pkgid] [--user | --global | --package-db]
describe
  :: ConfiguredProgram
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> PackageId
  -> IO [InstalledPackageInfo]
describe :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageId
-> IO [InstalledPackageInfo]
describe ConfiguredProgram
ghcProg Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
packagedb PackageId
pid = do
  output <-
    Verbosity -> ProgramInvocation -> IO ByteString
getProgramInvocationLBS
      Verbosity
verbosity
      (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageId
-> ProgramInvocation
describeInvocation ConfiguredProgram
ghcProg (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
packagedb PackageId
pid)
      IO ByteString -> (IOException -> IO ByteString) -> IO ByteString
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
forall a. Monoid a => a
mempty

  case parsePackages output of
    Left [InstalledPackageInfo]
ok -> [InstalledPackageInfo] -> IO [InstalledPackageInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledPackageInfo]
ok
    Either [InstalledPackageInfo] [String]
_ -> Verbosity -> CabalException -> IO [InstalledPackageInfo]
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO [InstalledPackageInfo])
-> CabalException -> IO [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$ String -> PackageId -> CabalException
FailedToParseOutputDescribe (ConfiguredProgram -> String
programId ConfiguredProgram
ghcProg) PackageId
pid

-- | Call @hc-pkg@ to hide a package.
--
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
hide
  :: ConfiguredProgram
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> IO ()
hide :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> IO ()
hide ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
hideInvocation ConfiguredProgram
hpi (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid)

-- | Call @hc-pkg@ to get all the details of all the packages in the given
-- package database.
dump
  :: ConfiguredProgram
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBX (SymbolicPath from (Dir PkgDB))
  -> IO [InstalledPackageInfo]
dump :: forall from.
ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> IO [InstalledPackageInfo]
dump ConfiguredProgram
ghcProg Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb = do
  output <-
    Verbosity -> ProgramInvocation -> IO ByteString
getProgramInvocationLBS
      Verbosity
verbosity
      (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> ProgramInvocation
forall from.
ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
dumpInvocation ConfiguredProgram
ghcProg (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb)
      IO ByteString -> (IOException -> IO ByteString) -> IO ByteString
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e ->
        Verbosity -> CabalException -> IO ByteString
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ByteString)
-> CabalException -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> String -> CabalException
DumpFailed (ConfiguredProgram -> String
programId ConfiguredProgram
ghcProg) (IOException -> String
forall e. Exception e => e -> String
displayException IOException
e)

  case parsePackages output of
    Left [InstalledPackageInfo]
ok -> [InstalledPackageInfo] -> IO [InstalledPackageInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledPackageInfo]
ok
    Either [InstalledPackageInfo] [String]
_ -> Verbosity -> CabalException -> IO [InstalledPackageInfo]
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO [InstalledPackageInfo])
-> CabalException -> IO [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$ String -> CabalException
FailedToParseOutputDump (ConfiguredProgram -> String
programId ConfiguredProgram
ghcProg)

parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String]
parsePackages :: ByteString -> Either [InstalledPackageInfo] [String]
parsePackages ByteString
lbs0 =
  case (ByteString
 -> Either (NonEmpty String) ([String], InstalledPackageInfo))
-> [ByteString]
-> Either (NonEmpty String) [([String], InstalledPackageInfo)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ByteString
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
parseInstalledPackageInfo ([ByteString]
 -> Either (NonEmpty String) [([String], InstalledPackageInfo)])
-> [ByteString]
-> Either (NonEmpty String) [([String], InstalledPackageInfo)]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
splitPkgs ByteString
lbs0 of
    Right [([String], InstalledPackageInfo)]
ok -> [InstalledPackageInfo] -> Either [InstalledPackageInfo] [String]
forall a b. a -> Either a b
Left [InstalledPackageInfo -> InstalledPackageInfo
setUnitId (InstalledPackageInfo -> InstalledPackageInfo)
-> (InstalledPackageInfo -> InstalledPackageInfo)
-> InstalledPackageInfo
-> InstalledPackageInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledPackageInfo -> InstalledPackageInfo)
-> (String -> InstalledPackageInfo -> InstalledPackageInfo)
-> Maybe String
-> InstalledPackageInfo
-> InstalledPackageInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe InstalledPackageInfo -> InstalledPackageInfo
forall a. a -> a
id String -> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths (InstalledPackageInfo -> Maybe String
pkgRoot InstalledPackageInfo
pkg) (InstalledPackageInfo -> InstalledPackageInfo)
-> InstalledPackageInfo -> InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
pkg | ([String]
_, InstalledPackageInfo
pkg) <- [([String], InstalledPackageInfo)]
ok]
    Left NonEmpty String
msgs -> [String] -> Either [InstalledPackageInfo] [String]
forall a b. b -> Either a b
Right (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
msgs)
  where
    splitPkgs :: LBS.ByteString -> [BS.ByteString]
    splitPkgs :: ByteString -> [ByteString]
splitPkgs = [ByteString] -> [ByteString]
checkEmpty ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
doSplit
      where
        -- Handle the case of there being no packages at all.
        checkEmpty :: [ByteString] -> [ByteString]
checkEmpty [ByteString
s] | (Word8 -> Bool) -> ByteString -> Bool
BS.all Word8 -> Bool
isSpace8 ByteString
s = []
        checkEmpty [ByteString]
ss = [ByteString]
ss

        isSpace8 :: Word8 -> Bool
        isSpace8 :: Word8 -> Bool
isSpace8 Word8
9 = Bool
True -- '\t'
        isSpace8 Word8
10 = Bool
True -- '\n'
        isSpace8 Word8
13 = Bool
True -- '\r'
        isSpace8 Word8
32 = Bool
True -- ' '
        isSpace8 Word8
_ = Bool
False

        doSplit :: LBS.ByteString -> [BS.ByteString]
        doSplit :: ByteString -> [ByteString]
doSplit ByteString
lbs = [Int64] -> [ByteString]
go ((Word8 -> Bool) -> ByteString -> [Int64]
LBS.findIndices (\Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
10 Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
13) ByteString
lbs)
          where
            go :: [Int64] -> [BS.ByteString]
            go :: [Int64] -> [ByteString]
go [] = [ByteString -> ByteString
LBS.toStrict ByteString
lbs]
            go (Int64
idx : [Int64]
idxs) =
              let (ByteString
pfx, ByteString
sfx) = Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
idx ByteString
lbs
               in case (ByteString -> Maybe ByteString -> Maybe ByteString)
-> Maybe ByteString -> [ByteString] -> Maybe ByteString
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (Maybe ByteString -> Maybe ByteString -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> Maybe ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> Maybe ByteString
`LBS.stripPrefix` ByteString
sfx)) Maybe ByteString
forall a. Maybe a
Nothing [ByteString]
separators of
                    Just ByteString
sfx' -> ByteString -> ByteString
LBS.toStrict ByteString
pfx ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString]
doSplit ByteString
sfx'
                    Maybe ByteString
Nothing -> [Int64] -> [ByteString]
go [Int64]
idxs

            separators :: [LBS.ByteString]
            separators :: [ByteString]
separators = [ByteString
"\n---\n", ByteString
"\r\n---\r\n", ByteString
"\r---\r"]

mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
mungePackagePaths :: String -> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths String
pkgroot InstalledPackageInfo
pkginfo =
  InstalledPackageInfo
pkginfo
    { importDirs = mungePaths (importDirs pkginfo)
    , includeDirs = mungePaths (includeDirs pkginfo)
    , libraryDirs = mungePaths (libraryDirs pkginfo)
    , libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo)
    , libraryDynDirs = mungePaths (libraryDynDirs pkginfo)
    , frameworkDirs = mungePaths (frameworkDirs pkginfo)
    , haddockInterfaces = mungePaths (haddockInterfaces pkginfo)
    , haddockHTMLs = mungePaths (mungeUrls (haddockHTMLs pkginfo))
    }
  where
    mungePaths :: [String] -> [String]
mungePaths = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mungePath
    mungeUrls :: [String] -> [String]
mungeUrls = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mungeUrl

    mungePath :: String -> String
mungePath String
p = case String -> String -> Maybe String
stripVarPrefix String
"${pkgroot}" String
p of
      Just String
p' -> String
pkgroot String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
p'
      Maybe String
Nothing -> String
p

    mungeUrl :: String -> String
mungeUrl String
p = case String -> String -> Maybe String
stripVarPrefix String
"${pkgrooturl}" String
p of
      Just String
p' -> String -> String -> String
toUrlPath String
pkgroot String
p'
      Maybe String
Nothing -> String
p

    toUrlPath :: String -> String -> String
toUrlPath String
r String
p =
      String
"file:///"
        -- URLs always use posix style '/' separators:
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
FilePath.Posix.joinPath (String
r String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
FilePath.splitDirectories String
p)

    stripVarPrefix :: String -> String -> Maybe String
stripVarPrefix String
var String
p =
      case String -> [String]
splitPath String
p of
        (String
root : [String]
path') -> case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
var String
root of
          Just [Char
sep] | Char -> Bool
isPathSeparator Char
sep -> String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String
joinPath [String]
path')
          Maybe String
_ -> Maybe String
forall a. Maybe a
Nothing
        [String]
_ -> Maybe String
forall a. Maybe a
Nothing

-- Older installed package info files did not have the installedUnitId
-- field, so if it is missing then we fill it as the source package ID.
-- NB: Internal libraries not supported.
setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
setUnitId
  pkginfo :: InstalledPackageInfo
pkginfo@InstalledPackageInfo
    { installedUnitId :: InstalledPackageInfo -> UnitId
installedUnitId = UnitId
uid
    , sourcePackageId :: InstalledPackageInfo -> PackageId
sourcePackageId = PackageId
pid
    }
    | UnitId -> String
unUnitId UnitId
uid String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" =
        InstalledPackageInfo
pkginfo
          { installedUnitId = mkLegacyUnitId pid
          , installedComponentId_ = mkComponentId (prettyShow pid)
          }
setUnitId InstalledPackageInfo
pkginfo = InstalledPackageInfo
pkginfo

-- | Call @hc-pkg@ to get the source package Id of all the packages in the
-- given package database.
--
-- This is much less information than with 'dump', but also rather quicker.
-- Note in particular that it does not include the 'UnitId', just
-- the source 'PackageId' which is not necessarily unique in any package db.
list
  :: ConfiguredProgram
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> IO [PackageId]
list :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> IO [PackageId]
list ConfiguredProgram
ghcProg Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb = do
  output <-
    Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput
      Verbosity
verbosity
      (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> ProgramInvocation
listInvocation ConfiguredProgram
ghcProg (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb)
      IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> Verbosity -> CabalException -> IO String
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO String) -> CabalException -> IO String
forall a b. (a -> b) -> a -> b
$ String -> CabalException
ListFailed (ConfiguredProgram -> String
programId ConfiguredProgram
ghcProg)

  case parsePackageIds output of
    Just [PackageId]
ok -> [PackageId] -> IO [PackageId]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [PackageId]
ok
    Maybe [PackageId]
_ -> Verbosity -> CabalException -> IO [PackageId]
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO [PackageId])
-> CabalException -> IO [PackageId]
forall a b. (a -> b) -> a -> b
$ String -> CabalException
FailedToParseOutputList (ConfiguredProgram -> String
programId ConfiguredProgram
ghcProg)
  where
    parsePackageIds :: String -> Maybe [PackageId]
parsePackageIds = (String -> Maybe PackageId) -> [String] -> Maybe [PackageId]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> Maybe PackageId
forall a. Parsec a => String -> Maybe a
simpleParsec ([String] -> Maybe [PackageId])
-> (String -> [String]) -> String -> Maybe [PackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words

--------------------------
-- The program invocations
--

initInvocation :: ConfiguredProgram -> Verbosity -> FilePath -> ProgramInvocation
initInvocation :: ConfiguredProgram -> Verbosity -> String -> ProgramInvocation
initInvocation ConfiguredProgram
ghcProg Verbosity
verbosity String
path =
  ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
ghcProg [String]
args
  where
    args :: [String]
args =
      [String
"init", String
path]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity)

registerInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBStackS from
  -> InstalledPackageInfo
  -> RegisterOptions
  -> ProgramInvocation
registerInvocation :: forall from.
ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
registerInvocation ConfiguredProgram
ghcProg VerbosityLevel
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackS from
packagedbs InstalledPackageInfo
pkgInfo RegisterOptions
registerOptions =
  (Maybe (SymbolicPath CWD ('Dir from))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir ConfiguredProgram
ghcProg (String -> [String]
args String
"-"))
    { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo
    , progInvokeInputEncoding = IOEncodingUTF8
    }
  where
    cmdname :: String
cmdname
      | RegisterOptions -> Bool
registerAllowOverwrite RegisterOptions
registerOptions = String
"update"
      | RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions = String
"update"
      | Bool
otherwise = String
"register"

    args :: String -> [String]
args String
file =
      [String
cmdname, String
file]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ PackageDBStackS from -> [String]
forall from. PackageDBStackS from -> [String]
packageDbStackOpts PackageDBStackS from
packagedbs
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"--enable-multi-instance"
           | RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions
           ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"--force-files"
           | RegisterOptions -> Bool
registerSuppressFilesCheck RegisterOptions
registerOptions
           ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
verbosity

unregisterInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> ProgramInvocation
unregisterInvocation :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
unregisterInvocation ConfiguredProgram
ghcProg VerbosityLevel
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"unregister", PackageDB -> String
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts PackageDB
packagedb, PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
verbosity

recacheInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBS from
  -> ProgramInvocation
recacheInvocation :: forall from.
ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
recacheInvocation ConfiguredProgram
ghcProg VerbosityLevel
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBS from
packagedb =
  Maybe (SymbolicPath CWD ('Dir from))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir ConfiguredProgram
ghcProg ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"recache", PackageDBS from -> String
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts PackageDBS from
packagedb]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
verbosity

exposeInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> ProgramInvocation
exposeInvocation :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
exposeInvocation ConfiguredProgram
ghcProg VerbosityLevel
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"expose", PackageDB -> String
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts PackageDB
packagedb, PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
verbosity

describeInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> PackageId
  -> ProgramInvocation
describeInvocation :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageId
-> ProgramInvocation
describeInvocation ConfiguredProgram
ghcProg VerbosityLevel
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
packagedbs PackageId
pkgid =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"describe", PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ PackageDBStack -> [String]
forall from. PackageDBStackS from -> [String]
packageDbStackOpts PackageDBStack
packagedbs
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
verbosity

hideInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> ProgramInvocation
hideInvocation :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
hideInvocation ConfiguredProgram
ghcProg VerbosityLevel
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"hide", PackageDB -> String
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts PackageDB
packagedb, PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
verbosity

dumpInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBX (SymbolicPath from (Dir PkgDB))
  -> ProgramInvocation
dumpInvocation :: forall from.
ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
dumpInvocation ConfiguredProgram
ghcProg VerbosityLevel
_verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb =
  (Maybe (SymbolicPath CWD ('Dir from))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir ConfiguredProgram
ghcProg [String]
args)
    { progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args :: [String]
args =
      [String
"dump", PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
Silent

-- We use verbosity level 'Silent' because it is important that we
-- do not contaminate the output with info/debug messages.

listInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> ProgramInvocation
listInvocation :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> ProgramInvocation
listInvocation ConfiguredProgram
ghcProg VerbosityLevel
_verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb =
  (Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg [String]
args)
    { progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args :: [String]
args =
      [String
"list", String
"--simple-output", PackageDB -> String
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts PackageDB
packagedb]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
Silent

-- We use verbosity level 'Silent' because it is important that we
-- do not contaminate the output with info/debug messages.

packageDbStackOpts :: PackageDBStackS from -> [String]
packageDbStackOpts :: forall from. PackageDBStackS from -> [String]
packageDbStackOpts PackageDBStackS from
dbstack = case PackageDBStackS from
dbstack of
  (PackageDBX (SymbolicPath from ('Dir PkgDB))
GlobalPackageDB : PackageDBX (SymbolicPath from ('Dir PkgDB))
UserPackageDB : PackageDBStackS from
dbs) ->
    String
"--global"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--user"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String)
-> PackageDBStackS from -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> String
specific PackageDBStackS from
dbs
  (PackageDBX (SymbolicPath from ('Dir PkgDB))
GlobalPackageDB : PackageDBStackS from
dbs) ->
    String
"--global"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--no-user-package-db"
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String)
-> PackageDBStackS from -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> String
specific PackageDBStackS from
dbs
  PackageDBStackS from
_ -> [String]
forall a. a
ierror
  where
    specific :: PackageDBX (SymbolicPathX allowAbsolute from to) -> String
specific (SpecificPackageDB SymbolicPathX allowAbsolute from to
db) = String
"--package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPathX allowAbsolute from to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD SymbolicPathX allowAbsolute from to
db
    specific PackageDBX (SymbolicPathX allowAbsolute from to)
_ = String
forall a. a
ierror
    ierror :: a
    ierror :: forall a. a
ierror = String -> a
forall a. HasCallStack => String -> a
error (String
"internal error: unexpected package db stack: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageDBStackS from -> String
forall a. Show a => a -> String
show PackageDBStackS from
dbstack)

packageDbOpts :: PackageDBX (SymbolicPath from (Dir PkgDB)) -> String
packageDbOpts :: forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts PackageDBX (SymbolicPath from ('Dir PkgDB))
GlobalPackageDB = String
"--global"
packageDbOpts PackageDBX (SymbolicPath from ('Dir PkgDB))
UserPackageDB = String
"--user"
packageDbOpts (SpecificPackageDB SymbolicPath from ('Dir PkgDB)
db) = String
"--package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPath from ('Dir PkgDB) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD SymbolicPath from ('Dir PkgDB)
db

verbosityOpts :: VerbosityLevel -> [String]
verbosityOpts :: VerbosityLevel -> [String]
verbosityOpts VerbosityLevel
v
  | VerbosityLevel
v VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Deafening = [String
"-v2"]
  | VerbosityLevel
v VerbosityLevel -> VerbosityLevel -> Bool
forall a. Eq a => a -> a -> Bool
== VerbosityLevel
Silent = [String
"-v0"]
  | Bool
otherwise = []