{-# LANGUAGE CPP #-}
{-# 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
    HcPkgInfo (..)
  , 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
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Program.Run
import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
import Distribution.Types.ComponentId
import Distribution.Types.PackageId
import Distribution.Types.UnitId
import Distribution.Utils.Path
import Distribution.Verbosity

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

-- | Information about the features and capabilities of an @hc-pkg@
--   program.
data HcPkgInfo = HcPkgInfo
  { HcPkgInfo -> ConfiguredProgram
hcPkgProgram :: ConfiguredProgram
  , HcPkgInfo -> Bool
noPkgDbStack :: Bool
  -- ^ no package DB stack supported
  , HcPkgInfo -> Bool
noVerboseFlag :: Bool
  -- ^ hc-pkg does not support verbosity flags
  , HcPkgInfo -> Bool
flagPackageConf :: Bool
  -- ^ use package-conf option instead of package-db
  , HcPkgInfo -> Bool
supportsDirDbs :: Bool
  -- ^ supports directory style package databases
  , HcPkgInfo -> Bool
requiresDirDbs :: Bool
  -- ^ requires directory style package databases
  , HcPkgInfo -> Bool
nativeMultiInstance :: Bool
  -- ^ supports --enable-multi-instance flag
  , HcPkgInfo -> Bool
recacheMultiInstance :: Bool
  -- ^ supports multi-instance via recache
  , HcPkgInfo -> Bool
suppressFilesCheck :: Bool
  -- ^ supports --force-files or equivalent
  }

-- | Call @hc-pkg@ to initialise a package database at the location {path}.
--
-- > hc-pkg init {path}
init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()
init :: HcPkgInfo -> Verbosity -> Bool -> String -> IO ()
init HcPkgInfo
hpi Verbosity
verbosity Bool
preferCompat String
path
  | Bool -> Bool
not (HcPkgInfo -> Bool
supportsDirDbs HcPkgInfo
hpi)
      Bool -> Bool -> Bool
|| (Bool -> Bool
not (HcPkgInfo -> Bool
requiresDirDbs HcPkgInfo
hpi) Bool -> Bool -> Bool
&& Bool
preferCompat) =
      String -> String -> IO ()
writeFile String
path String
"[]"
  | Bool
otherwise =
      Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (HcPkgInfo -> Verbosity -> String -> ProgramInvocation
initInvocation HcPkgInfo
hpi Verbosity
verbosity String
path)

-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invoke
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> [String]
  -> IO ()
invoke :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> [String]
-> IO ()
invoke HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
dbStack [String]
extraArgs =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
invocation
  where
    args :: [String]
args = HcPkgInfo -> PackageDBStack -> [String]
forall from. HcPkgInfo -> PackageDBStackS from -> [String]
packageDbStackOpts HcPkgInfo
hpi 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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [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. This will fail if the @hc-pkg@
  -- does not support it, see 'nativeMultiInstance' and
  -- 'recacheMultiInstance'.
  , 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
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBStackS from
  -> InstalledPackageInfo
  -> RegisterOptions
  -> IO ()
register :: forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
register HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackS from
packagedbs InstalledPackageInfo
pkgInfo RegisterOptions
registerOptions
  | RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions
  , Bool -> Bool
not (HcPkgInfo -> Bool
nativeMultiInstance HcPkgInfo
hpi Bool -> Bool -> Bool
|| HcPkgInfo -> Bool
recacheMultiInstance HcPkgInfo
hpi) =
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
RegMultipleInstancePkg
  | RegisterOptions -> Bool
registerSuppressFilesCheck RegisterOptions
registerOptions
  , Bool -> Bool
not (HcPkgInfo -> Bool
suppressFilesCheck HcPkgInfo
hpi) =
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
SuppressingChecksOnFile
  -- This is a trick. Older versions of GHC do not support the
  -- --enable-multi-instance flag for ghc-pkg register but it turns out that
  -- the same ability is available by using ghc-pkg recache. The recache
  -- command is there to support distro package managers that like to work
  -- by just installing files and running update commands, rather than
  -- special add/remove commands. So the way to register by this method is
  -- to write the package registration file directly into the package db and
  -- then call hc-pkg recache.
  --
  | RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions
  , HcPkgInfo -> Bool
recacheMultiInstance HcPkgInfo
hpi =
      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
-> HcPkgInfo
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> InstalledPackageInfo
-> IO ()
forall from.
Verbosity
-> HcPkgInfo
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> InstalledPackageInfo
-> IO ()
writeRegistrationFileDirectly Verbosity
verbosity HcPkgInfo
hpi Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
pkgdb InstalledPackageInfo
pkgInfo
        HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> IO ()
forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> IO ()
recache HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
pkgdb
  | Bool
otherwise =
      Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
        Verbosity
verbosity
        (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
registerInvocation HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackS from
packagedbs InstalledPackageInfo
pkgInfo RegisterOptions
registerOptions)

writeRegistrationFileDirectly
  :: Verbosity
  -> HcPkgInfo
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBS from
  -> InstalledPackageInfo
  -> IO ()
writeRegistrationFileDirectly :: forall from.
Verbosity
-> HcPkgInfo
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> InstalledPackageInfo
-> IO ()
writeRegistrationFileDirectly Verbosity
verbosity HcPkgInfo
hpi Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir (SpecificPackageDB SymbolicPath from ('Dir PkgDB)
dir) InstalledPackageInfo
pkgInfo
  | HcPkgInfo -> Bool
supportsDirDbs HcPkgInfo
hpi =
      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)
  | Bool
otherwise =
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
NoSupportDirStylePackageDb
writeRegistrationFileDirectly Verbosity
verbosity HcPkgInfo
_ Maybe (SymbolicPath CWD ('Dir from))
_ PackageDBX (SymbolicPath from ('Dir PkgDB))
_ InstalledPackageInfo
_ =
  -- 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, Show a1, Typeable a1,
 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 :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO ()
unregister :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> IO ()
unregister HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
unregisterInvocation HcPkgInfo
hpi 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 :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO ()
recache :: forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> IO ()
recache HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBS from
packagedb =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
recacheInvocation HcPkgInfo
hpi 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
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> IO ()
expose :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> IO ()
expose HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
exposeInvocation HcPkgInfo
hpi 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
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> PackageId
  -> IO [InstalledPackageInfo]
describe :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageId
-> IO [InstalledPackageInfo]
describe HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
packagedb PackageId
pid = do
  output <-
    Verbosity -> ProgramInvocation -> IO ByteString
getProgramInvocationLBS
      Verbosity
verbosity
      (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageId
-> ProgramInvocation
describeInvocation HcPkgInfo
hpi 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, Show a1, Typeable a1,
 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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi)) PackageId
pid

-- | Call @hc-pkg@ to hide a package.
--
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
hide
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> IO ()
hide :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> IO ()
hide HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageId
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
hideInvocation HcPkgInfo
hpi 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
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBX (SymbolicPath from (Dir PkgDB))
  -> IO [InstalledPackageInfo]
dump :: forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> IO [InstalledPackageInfo]
dump HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb = do
  output <-
    Verbosity -> ProgramInvocation -> IO ByteString
getProgramInvocationLBS
      Verbosity
verbosity
      (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> ProgramInvocation
forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
dumpInvocation HcPkgInfo
hpi 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, Show a1, Typeable a1,
 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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi)) (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, Show a1, Typeable a1,
 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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi))

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 (Maybe ByteString -> Maybe ByteString -> Maybe ByteString)
-> Maybe ByteString -> [Maybe 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
forall a. Maybe a
Nothing ([Maybe ByteString] -> Maybe ByteString)
-> [Maybe ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe ByteString)
-> [ByteString] -> [Maybe ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> Maybe ByteString
`lbsStripPrefix` ByteString
sfx) [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"]

lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString
#if MIN_VERSION_bytestring(0,10,8)
lbsStripPrefix :: ByteString -> ByteString -> Maybe ByteString
lbsStripPrefix ByteString
pfx ByteString
lbs = ByteString -> ByteString -> Maybe ByteString
LBS.stripPrefix ByteString
pfx ByteString
lbs
#else
lbsStripPrefix pfx lbs
    | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs)
    | otherwise              = Nothing
#endif

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 = 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
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> IO [PackageId]
list :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> IO [PackageId]
list HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb = do
  output <-
    Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput
      Verbosity
verbosity
      (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> ProgramInvocation
listInvocation HcPkgInfo
hpi 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, Show a1, Typeable a1,
 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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi))

  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, Show a1, Typeable a1,
 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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi))
  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 :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation :: HcPkgInfo -> Verbosity -> String -> ProgramInvocation
initInvocation HcPkgInfo
hpi Verbosity
verbosity String
path =
  ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [String]
args
  where
    args :: [String]
args =
      [String
"init", String
path]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity

registerInvocation
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBStackS from
  -> InstalledPackageInfo
  -> RegisterOptions
  -> ProgramInvocation
registerInvocation :: forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
registerInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) (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]
++ HcPkgInfo -> PackageDBStackS from -> [String]
forall from. HcPkgInfo -> PackageDBStackS from -> [String]
packageDbStackOpts HcPkgInfo
hpi 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]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity

unregisterInvocation
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> ProgramInvocation
unregisterInvocation :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
unregisterInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"unregister", HcPkgInfo -> PackageDB -> String
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity

recacheInvocation
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBS from
  -> ProgramInvocation
recacheInvocation :: forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
recacheInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"recache", HcPkgInfo -> PackageDBS from -> String
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts HcPkgInfo
hpi PackageDBS from
packagedb]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity

exposeInvocation
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> ProgramInvocation
exposeInvocation :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
exposeInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"expose", HcPkgInfo -> PackageDB -> String
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity

describeInvocation
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> PackageId
  -> ProgramInvocation
describeInvocation :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageId
-> ProgramInvocation
describeInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([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]
++ HcPkgInfo -> PackageDBStack -> [String]
forall from. HcPkgInfo -> PackageDBStackS from -> [String]
packageDbStackOpts HcPkgInfo
hpi PackageDBStack
packagedbs
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity

hideInvocation
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> PackageId
  -> ProgramInvocation
hideInvocation :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageId
-> ProgramInvocation
hideInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [String
"hide", HcPkgInfo -> PackageDB -> String
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity

dumpInvocation
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBX (SymbolicPath from (Dir PkgDB))
  -> ProgramInvocation
dumpInvocation :: forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBS from
-> ProgramInvocation
dumpInvocation HcPkgInfo
hpi Verbosity
_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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [String]
args)
    { progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args :: [String]
args =
      [String
"dump", HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts HcPkgInfo
hpi PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
silent

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

listInvocation
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDB
  -> ProgramInvocation
listInvocation :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> ProgramInvocation
listInvocation HcPkgInfo
hpi Verbosity
_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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [String]
args)
    { progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args :: [String]
args =
      [String
"list", String
"--simple-output", HcPkgInfo -> PackageDB -> String
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
silent

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

packageDbStackOpts :: HcPkgInfo -> PackageDBStackS from -> [String]
packageDbStackOpts :: forall from. HcPkgInfo -> PackageDBStackS from -> [String]
packageDbStackOpts HcPkgInfo
hpi PackageDBStackS from
dbstack
  | HcPkgInfo -> Bool
noPkgDbStack HcPkgInfo
hpi = [HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts HcPkgInfo
hpi (PackageDBStackS from -> PackageDBX (SymbolicPath from ('Dir PkgDB))
forall from. PackageDBStackX from -> PackageDBX from
registrationPackageDB PackageDBStackS from
dbstack)]
  | Bool
otherwise = 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-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> String
packageDbFlag HcPkgInfo
hpi)
          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
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> String
packageDbFlag HcPkgInfo
hpi String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" 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)

packageDbFlag :: HcPkgInfo -> String
packageDbFlag :: HcPkgInfo -> String
packageDbFlag HcPkgInfo
hpi
  | HcPkgInfo -> Bool
flagPackageConf HcPkgInfo
hpi =
      String
"package-conf"
  | Bool
otherwise =
      String
"package-db"

packageDbOpts :: HcPkgInfo -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> String
packageDbOpts :: forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> String
packageDbOpts HcPkgInfo
_ PackageDBX (SymbolicPath from ('Dir PkgDB))
GlobalPackageDB = String
"--global"
packageDbOpts HcPkgInfo
_ PackageDBX (SymbolicPath from ('Dir PkgDB))
UserPackageDB = String
"--user"
packageDbOpts HcPkgInfo
hpi (SpecificPackageDB SymbolicPath from ('Dir PkgDB)
db) = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> String
packageDbFlag HcPkgInfo
hpi String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" 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 :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts HcPkgInfo
hpi Verbosity
v
  | HcPkgInfo -> Bool
noVerboseFlag HcPkgInfo
hpi =
      []
  | Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening = [String
"-v2"]
  | Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
silent = [String
"-v0"]
  | Bool
otherwise = []