{-# 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 -> [Char] -> IO ()
init ConfiguredProgram
hpi Verbosity
verbosity [Char]
path =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ConfiguredProgram -> Verbosity -> [Char] -> ProgramInvocation
initInvocation ConfiguredProgram
hpi Verbosity
verbosity [Char]
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
-> [[Char]]
-> IO ()
invoke ConfiguredProgram
ghcProg Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
dbStack [[Char]]
extraArgs =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
invocation
  where
    args :: [[Char]]
args = PackageDBStack -> [[Char]]
forall from. PackageDBStackS from -> [[Char]]
packageDbStackOpts PackageDBStack
dbStack [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
extraArgs
    invocation :: ProgramInvocation
invocation = Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg [[Char]]
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 :: [Char]
pkgfile = Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPath from ('Dir PkgDB) -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir SymbolicPath from ('Dir PkgDB)
dir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
pkgInfo) [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"conf"
      [Char] -> [Char] -> IO ()
writeUTF8File [Char]
pkgfile (InstalledPackageInfo -> [Char]
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
-> PackageIdentifier
-> IO ()
unregister ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageIdentifier
-> ProgramInvocation
unregisterInvocation ConfiguredProgram
hpi (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
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
-> PackageIdentifier
-> IO ()
expose ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageIdentifier
-> ProgramInvocation
exposeInvocation ConfiguredProgram
hpi (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
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
-> PackageIdentifier
-> IO [InstalledPackageInfo]
describe ConfiguredProgram
ghcProg Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
packagedb PackageIdentifier
pid = do
  output <-
    Verbosity -> ProgramInvocation -> IO ByteString
getProgramInvocationLBS
      Verbosity
verbosity
      (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageIdentifier
-> ProgramInvocation
describeInvocation ConfiguredProgram
ghcProg (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
packagedb PackageIdentifier
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] [[Char]]
_ -> 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
$ [Char] -> PackageIdentifier -> CabalException
FailedToParseOutputDescribe (ConfiguredProgram -> [Char]
programId ConfiguredProgram
ghcProg) PackageIdentifier
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
-> PackageIdentifier
-> IO ()
hide ConfiguredProgram
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageIdentifier
-> ProgramInvocation
hideInvocation ConfiguredProgram
hpi (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
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
$ [Char] -> [Char] -> CabalException
DumpFailed (ConfiguredProgram -> [Char]
programId ConfiguredProgram
ghcProg) (IOException -> [Char]
forall e. Exception e => e -> [Char]
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] [[Char]]
_ -> 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
$ [Char] -> CabalException
FailedToParseOutputDump (ConfiguredProgram -> [Char]
programId ConfiguredProgram
ghcProg)

parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String]
parsePackages :: ByteString -> Either [InstalledPackageInfo] [[Char]]
parsePackages ByteString
lbs0 =
  case (ByteString
 -> Either (NonEmpty [Char]) ([[Char]], InstalledPackageInfo))
-> [ByteString]
-> Either (NonEmpty [Char]) [([[Char]], 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 [Char]) ([[Char]], InstalledPackageInfo)
parseInstalledPackageInfo ([ByteString]
 -> Either (NonEmpty [Char]) [([[Char]], InstalledPackageInfo)])
-> [ByteString]
-> Either (NonEmpty [Char]) [([[Char]], InstalledPackageInfo)]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
splitPkgs ByteString
lbs0 of
    Right [([[Char]], InstalledPackageInfo)]
ok -> [InstalledPackageInfo] -> Either [InstalledPackageInfo] [[Char]]
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)
-> ([Char] -> InstalledPackageInfo -> InstalledPackageInfo)
-> Maybe [Char]
-> InstalledPackageInfo
-> InstalledPackageInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe InstalledPackageInfo -> InstalledPackageInfo
forall a. a -> a
id [Char] -> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths (InstalledPackageInfo -> Maybe [Char]
pkgRoot InstalledPackageInfo
pkg) (InstalledPackageInfo -> InstalledPackageInfo)
-> InstalledPackageInfo -> InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
pkg | ([[Char]]
_, InstalledPackageInfo
pkg) <- [([[Char]], InstalledPackageInfo)]
ok]
    Left NonEmpty [Char]
msgs -> [[Char]] -> Either [InstalledPackageInfo] [[Char]]
forall a b. b -> Either a b
Right (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
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 :: [Char] -> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths [Char]
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 :: [[Char]] -> [[Char]]
mungePaths = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
mungePath
    mungeUrls :: [[Char]] -> [[Char]]
mungeUrls = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
mungeUrl

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

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

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

    stripVarPrefix :: [Char] -> [Char] -> Maybe [Char]
stripVarPrefix [Char]
var [Char]
p =
      case [Char] -> [[Char]]
splitPath [Char]
p of
        ([Char]
root : [[Char]]
path') -> case [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
var [Char]
root of
          Just [Char
sep] | Char -> Bool
isPathSeparator Char
sep -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([[Char]] -> [Char]
joinPath [[Char]]
path')
          Maybe [Char]
_ -> Maybe [Char]
forall a. Maybe a
Nothing
        [[Char]]
_ -> Maybe [Char]
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 -> PackageIdentifier
sourcePackageId = PackageIdentifier
pid
    }
    | UnitId -> [Char]
unUnitId UnitId
uid [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"" =
        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 [PackageIdentifier]
list ConfiguredProgram
ghcProg Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb = do
  output <-
    Verbosity -> ProgramInvocation -> IO [Char]
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 [Char] -> (IOException -> IO [Char]) -> IO [Char]
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> Verbosity -> CabalException -> IO [Char]
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO [Char]) -> CabalException -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalException
ListFailed (ConfiguredProgram -> [Char]
programId ConfiguredProgram
ghcProg)

  case parsePackageIds output of
    Just [PackageIdentifier]
ok -> [PackageIdentifier] -> IO [PackageIdentifier]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [PackageIdentifier]
ok
    Maybe [PackageIdentifier]
_ -> Verbosity -> CabalException -> IO [PackageIdentifier]
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO [PackageIdentifier])
-> CabalException -> IO [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalException
FailedToParseOutputList (ConfiguredProgram -> [Char]
programId ConfiguredProgram
ghcProg)
  where
    parsePackageIds :: [Char] -> Maybe [PackageIdentifier]
parsePackageIds = ([Char] -> Maybe PackageIdentifier)
-> [[Char]] -> Maybe [PackageIdentifier]
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 [Char] -> Maybe PackageIdentifier
forall a. Parsec a => [Char] -> Maybe a
simpleParsec ([[Char]] -> Maybe [PackageIdentifier])
-> ([Char] -> [[Char]]) -> [Char] -> Maybe [PackageIdentifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words

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

initInvocation :: ConfiguredProgram -> Verbosity -> FilePath -> ProgramInvocation
initInvocation :: ConfiguredProgram -> Verbosity -> [Char] -> ProgramInvocation
initInvocation ConfiguredProgram
ghcProg Verbosity
verbosity [Char]
path =
  ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocation ConfiguredProgram
ghcProg [[Char]]
args
  where
    args :: [[Char]]
args =
      [[Char]
"init", [Char]
path]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [[Char]]
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 -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir ConfiguredProgram
ghcProg ([Char] -> [[Char]]
args [Char]
"-"))
    { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo
    , progInvokeInputEncoding = IOEncodingUTF8
    }
  where
    cmdname :: [Char]
cmdname
      | RegisterOptions -> Bool
registerAllowOverwrite RegisterOptions
registerOptions = [Char]
"update"
      | RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions = [Char]
"update"
      | Bool
otherwise = [Char]
"register"

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

unregisterInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> ProgramInvocation
unregisterInvocation :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageIdentifier
-> ProgramInvocation
unregisterInvocation ConfiguredProgram
ghcProg VerbosityLevel
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
pkgid =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [[Char]
"unregister", PackageDB -> [Char]
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts PackageDB
packagedb, PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageIdentifier
pkgid]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [[Char]]
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 -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir ConfiguredProgram
ghcProg ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [[Char]
"recache", PackageDBS from -> [Char]
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts PackageDBS from
packagedb]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [[Char]]
verbosityOpts VerbosityLevel
verbosity

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

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

hideInvocation
  :: ConfiguredProgram
  -> VerbosityLevel
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> ProgramInvocation
hideInvocation :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageIdentifier
-> ProgramInvocation
hideInvocation ConfiguredProgram
ghcProg VerbosityLevel
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
pkgid =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [[Char]
"hide", PackageDB -> [Char]
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts PackageDB
packagedb, PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageIdentifier
pkgid]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [[Char]]
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 -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir ConfiguredProgram
ghcProg [[Char]]
args)
    { progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args :: [[Char]]
args =
      [[Char]
"dump", PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [[Char]]
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 -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
ghcProg [[Char]]
args)
    { progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args :: [[Char]]
args =
      [[Char]
"list", [Char]
"--simple-output", PackageDB -> [Char]
forall from. PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts PackageDB
packagedb]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ VerbosityLevel -> [[Char]]
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 -> [[Char]]
packageDbStackOpts PackageDBStackS from
dbstack = case PackageDBStackS from
dbstack of
  (PackageDBX (SymbolicPath from ('Dir PkgDB))
GlobalPackageDB : PackageDBX (SymbolicPath from ('Dir PkgDB))
UserPackageDB : PackageDBStackS from
dbs) ->
    [Char]
"--global"
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"--user"
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char])
-> PackageDBStackS from -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> [Char]
specific PackageDBStackS from
dbs
  (PackageDBX (SymbolicPath from ('Dir PkgDB))
GlobalPackageDB : PackageDBStackS from
dbs) ->
    [Char]
"--global"
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"--no-user-package-db"
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char])
-> PackageDBStackS from -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> [Char]
specific PackageDBStackS from
dbs
  PackageDBStackS from
_ -> [[Char]]
forall a. a
ierror
  where
    specific :: PackageDBX (SymbolicPathX allowAbsolute from to) -> [Char]
specific (SpecificPackageDB SymbolicPathX allowAbsolute from to
db) = [Char]
"--package-db=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPathX allowAbsolute from to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPathCWD SymbolicPathX allowAbsolute from to
db
    specific PackageDBX (SymbolicPathX allowAbsolute from to)
_ = [Char]
forall a. a
ierror
    ierror :: a
    ierror :: forall a. a
ierror = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: unexpected package db stack: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackageDBStackS from -> [Char]
forall a. Show a => a -> [Char]
show PackageDBStackS from
dbstack)

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

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