{-# 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 -> [Char] -> IO ()
init HcPkgInfo
hpi Verbosity
verbosity Bool
preferCompat [Char]
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) =
      [Char] -> [Char] -> IO ()
writeFile [Char]
path [Char]
"[]"
  | Bool
otherwise =
      Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (HcPkgInfo -> Verbosity -> [Char] -> ProgramInvocation
initInvocation HcPkgInfo
hpi Verbosity
verbosity [Char]
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
-> [[Char]]
-> IO ()
invoke HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
dbStack [[Char]]
extraArgs =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
invocation
  where
    args :: [[Char]]
args = HcPkgInfo -> PackageDBStack -> [[Char]]
forall from. HcPkgInfo -> PackageDBStackS from -> [[Char]]
packageDbStackOpts HcPkgInfo
hpi 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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [[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. 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 :: [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)
  | 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
-> PackageIdentifier
-> IO ()
unregister HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageIdentifier
-> ProgramInvocation
unregisterInvocation HcPkgInfo
hpi 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 :: 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
-> PackageIdentifier
-> IO ()
expose HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageIdentifier
-> ProgramInvocation
exposeInvocation HcPkgInfo
hpi 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
  :: HcPkgInfo
  -> Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> PackageDBStack
  -> PackageId
  -> IO [InstalledPackageInfo]
describe :: HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageIdentifier
-> IO [InstalledPackageInfo]
describe HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDBStack
packagedb PackageIdentifier
pid = do
  output <-
    Verbosity -> ProgramInvocation -> IO ByteString
getProgramInvocationLBS
      Verbosity
verbosity
      (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack
-> PackageIdentifier
-> ProgramInvocation
describeInvocation HcPkgInfo
hpi 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, 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
$ [Char] -> PackageIdentifier -> CabalException
FailedToParseOutputDescribe (ConfiguredProgram -> [Char]
programId (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi)) PackageIdentifier
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
-> PackageIdentifier
-> IO ()
hide HcPkgInfo
hpi Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageDB
packagedb PackageIdentifier
pkgid =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDB
-> PackageIdentifier
-> ProgramInvocation
hideInvocation HcPkgInfo
hpi 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
  :: 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
$ [Char] -> [Char] -> CabalException
DumpFailed (ConfiguredProgram -> [Char]
programId (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi)) (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, 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
$ [Char] -> CabalException
FailedToParseOutputDump (ConfiguredProgram -> [Char]
programId (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi))

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

  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, Show a1, Typeable a1,
 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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi))
  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 :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation :: HcPkgInfo -> Verbosity -> [Char] -> ProgramInvocation
initInvocation HcPkgInfo
hpi Verbosity
verbosity [Char]
path =
  ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [[Char]]
args
  where
    args :: [[Char]]
args =
      [[Char]
"init", [Char]
path]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [[Char]]
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 -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([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]
++ HcPkgInfo -> PackageDBStackS from -> [[Char]]
forall from. HcPkgInfo -> PackageDBStackS from -> [[Char]]
packageDbStackOpts HcPkgInfo
hpi 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]
++ HcPkgInfo -> Verbosity -> [[Char]]
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
-> PackageIdentifier
-> ProgramInvocation
unregisterInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [[Char]
"unregister", HcPkgInfo -> PackageDB -> [Char]
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageIdentifier
pkgid]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [[Char]]
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 -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [[Char]
"recache", HcPkgInfo -> PackageDBS from -> [Char]
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts HcPkgInfo
hpi PackageDBS from
packagedb]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [[Char]]
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
-> PackageIdentifier
-> ProgramInvocation
exposeInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [[Char]
"expose", HcPkgInfo -> PackageDB -> [Char]
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageIdentifier
pkgid]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [[Char]]
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
-> PackageIdentifier
-> ProgramInvocation
describeInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([[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]
++ HcPkgInfo -> PackageDBStack -> [[Char]]
forall from. HcPkgInfo -> PackageDBStackS from -> [[Char]]
packageDbStackOpts HcPkgInfo
hpi PackageDBStack
packagedbs
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [[Char]]
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
-> PackageIdentifier
-> ProgramInvocation
hideInvocation HcPkgInfo
hpi Verbosity
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 (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [[Char]
"hide", HcPkgInfo -> PackageDB -> [Char]
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageIdentifier
pkgid]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [[Char]]
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 -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [[Char]]
args)
    { progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args :: [[Char]]
args =
      [[Char]
"dump", HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts HcPkgInfo
hpi PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [[Char]]
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 -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [[Char]]
args)
    { progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args :: [[Char]]
args =
      [[Char]
"list", [Char]
"--simple-output", HcPkgInfo -> PackageDB -> [Char]
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [[Char]]
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 -> [[Char]]
packageDbStackOpts HcPkgInfo
hpi PackageDBStackS from
dbstack
  | HcPkgInfo -> Bool
noPkgDbStack HcPkgInfo
hpi = [HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
forall from.
HcPkgInfo -> PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [Char]
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) ->
        [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-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> [Char]
packageDbFlag HcPkgInfo
hpi)
          [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]
"--" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> [Char]
packageDbFlag HcPkgInfo
hpi [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"=" [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)

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

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