{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Program.HcPkg (
HcPkgInfo(..),
RegisterOptions(..),
defaultRegisterOptions,
init,
invoke,
register,
unregister,
recache,
expose,
hide,
dump,
describe,
list,
initInvocation,
registerInvocation,
unregisterInvocation,
recacheInvocation,
exposeInvocation,
hideInvocation,
dumpInvocation,
describeInvocation,
listInvocation,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (init)
import Data.Either (partitionEithers)
import Distribution.InstalledPackageInfo
import Distribution.Simple.Compiler
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Run
import Distribution.Simple.Utils
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Types.ComponentId
import Distribution.Types.PackageId
import Distribution.Types.UnitId
import Distribution.Verbosity
import Distribution.Compat.Exception
import Data.List
( stripPrefix )
import System.FilePath as FilePath
( (</>), (<.>)
, splitPath, splitDirectories, joinPath, isPathSeparator )
import qualified System.FilePath.Posix as FilePath.Posix
data HcPkgInfo = HcPkgInfo
{ HcPkgInfo -> ConfiguredProgram
hcPkgProgram :: ConfiguredProgram
, HcPkgInfo -> Bool
noPkgDbStack :: Bool
, HcPkgInfo -> Bool
noVerboseFlag :: Bool
, HcPkgInfo -> Bool
flagPackageConf :: Bool
, HcPkgInfo -> Bool
supportsDirDbs :: Bool
, HcPkgInfo -> Bool
requiresDirDbs :: Bool
, HcPkgInfo -> Bool
nativeMultiInstance :: Bool
, HcPkgInfo -> Bool
recacheMultiInstance :: Bool
, HcPkgInfo -> Bool
suppressFilesCheck :: Bool
}
init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()
init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()
init hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity preferCompat :: Bool
preferCompat path :: FilePath
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)
= FilePath -> FilePath -> IO ()
writeFile FilePath
path "[]"
| Bool
otherwise
= Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation HcPkgInfo
hpi Verbosity
verbosity FilePath
path)
invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()
invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [FilePath] -> IO ()
invoke hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity dbStack :: PackageDBStack
dbStack extraArgs :: [FilePath]
extraArgs =
Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
invocation
where
args :: [FilePath]
args = HcPkgInfo -> PackageDBStack -> [FilePath]
packageDbStackOpts HcPkgInfo
hpi PackageDBStack
dbStack [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extraArgs
invocation :: ProgramInvocation
invocation = ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [FilePath]
args
data RegisterOptions = RegisterOptions {
RegisterOptions -> Bool
registerAllowOverwrite :: Bool,
RegisterOptions -> Bool
registerMultiInstance :: Bool,
RegisterOptions -> Bool
registerSuppressFilesCheck :: Bool
}
defaultRegisterOptions :: RegisterOptions
defaultRegisterOptions :: RegisterOptions
defaultRegisterOptions = RegisterOptions :: Bool -> Bool -> Bool -> RegisterOptions
RegisterOptions {
registerAllowOverwrite :: Bool
registerAllowOverwrite = Bool
True,
registerMultiInstance :: Bool
registerMultiInstance = Bool
False,
registerSuppressFilesCheck :: Bool
registerSuppressFilesCheck = Bool
False
}
register :: HcPkgInfo -> Verbosity -> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
register :: HcPkgInfo
-> Verbosity
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
register hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedbs :: PackageDBStack
packagedbs pkgInfo :: InstalledPackageInfo
pkgInfo registerOptions :: RegisterOptions
registerOptions
| RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions
, Bool -> Bool
not (HcPkgInfo -> Bool
nativeMultiInstance HcPkgInfo
hpi Bool -> Bool -> Bool
|| HcPkgInfo -> Bool
recacheMultiInstance HcPkgInfo
hpi)
= Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "HcPkg.register: the compiler does not support "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "registering multiple instances of packages."
| RegisterOptions -> Bool
registerSuppressFilesCheck RegisterOptions
registerOptions
, Bool -> Bool
not (HcPkgInfo -> Bool
suppressFilesCheck HcPkgInfo
hpi)
= Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "HcPkg.register: the compiler does not support "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "suppressing checks on files."
| RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions
, HcPkgInfo -> Bool
recacheMultiInstance HcPkgInfo
hpi
= do let pkgdb :: PackageDB
pkgdb = PackageDBStack -> PackageDB
forall a. [a] -> a
last PackageDBStack
packagedbs
Verbosity
-> HcPkgInfo -> PackageDB -> InstalledPackageInfo -> IO ()
writeRegistrationFileDirectly Verbosity
verbosity HcPkgInfo
hpi PackageDB
pkgdb InstalledPackageInfo
pkgInfo
HcPkgInfo -> Verbosity -> PackageDB -> IO ()
recache HcPkgInfo
hpi Verbosity
verbosity PackageDB
pkgdb
| Bool
otherwise
= Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity
(HcPkgInfo
-> Verbosity
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
registerInvocation HcPkgInfo
hpi Verbosity
verbosity PackageDBStack
packagedbs InstalledPackageInfo
pkgInfo RegisterOptions
registerOptions)
writeRegistrationFileDirectly :: Verbosity
-> HcPkgInfo
-> PackageDB
-> InstalledPackageInfo
-> IO ()
writeRegistrationFileDirectly :: Verbosity
-> HcPkgInfo -> PackageDB -> InstalledPackageInfo -> IO ()
writeRegistrationFileDirectly verbosity :: Verbosity
verbosity hpi :: HcPkgInfo
hpi (SpecificPackageDB dir :: FilePath
dir) pkgInfo :: InstalledPackageInfo
pkgInfo
| HcPkgInfo -> Bool
supportsDirDbs HcPkgInfo
hpi
= do let pkgfile :: FilePath
pkgfile = FilePath
dir FilePath -> FilePath -> FilePath
</> UnitId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
pkgInfo) FilePath -> FilePath -> FilePath
<.> "conf"
FilePath -> FilePath -> IO ()
writeUTF8File FilePath
pkgfile (InstalledPackageInfo -> FilePath
showInstalledPackageInfo InstalledPackageInfo
pkgInfo)
| Bool
otherwise
= Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs"
writeRegistrationFileDirectly verbosity :: Verbosity
verbosity _ _ _ =
Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"
unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
unregister hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb pkgid :: PackageId
pkgid =
Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity
(HcPkgInfo
-> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
unregisterInvocation HcPkgInfo
hpi Verbosity
verbosity PackageDB
packagedb PackageId
pkgid)
recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO ()
recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO ()
recache hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb =
Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity
(HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
recacheInvocation HcPkgInfo
hpi Verbosity
verbosity PackageDB
packagedb)
expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
expose hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb pkgid :: PackageId
pkgid =
Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity
(HcPkgInfo
-> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
exposeInvocation HcPkgInfo
hpi Verbosity
verbosity PackageDB
packagedb PackageId
pkgid)
describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo]
describe :: HcPkgInfo
-> Verbosity
-> PackageDBStack
-> PackageId
-> IO [InstalledPackageInfo]
describe hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDBStack
packagedb pid :: PackageId
pid = do
FilePath
output <- Verbosity -> ProgramInvocation -> IO FilePath
getProgramInvocationOutput Verbosity
verbosity
(HcPkgInfo
-> Verbosity -> PackageDBStack -> PackageId -> ProgramInvocation
describeInvocation HcPkgInfo
hpi Verbosity
verbosity PackageDBStack
packagedb PackageId
pid)
IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \_ -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return ""
case FilePath -> Either [InstalledPackageInfo] [FilePath]
parsePackages FilePath
output of
Left ok :: [InstalledPackageInfo]
ok -> [InstalledPackageInfo] -> IO [InstalledPackageInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledPackageInfo]
ok
_ -> Verbosity -> FilePath -> IO [InstalledPackageInfo]
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO [InstalledPackageInfo])
-> FilePath -> IO [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$ "failed to parse output of '"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> FilePath
programId (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " describe " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'"
hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
hide hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb pkgid :: PackageId
pkgid =
Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity
(HcPkgInfo
-> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
hideInvocation HcPkgInfo
hpi Verbosity
verbosity PackageDB
packagedb PackageId
pkgid)
dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
dump hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb = do
FilePath
output <- Verbosity -> ProgramInvocation -> IO FilePath
getProgramInvocationOutput Verbosity
verbosity
(HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation HcPkgInfo
hpi Verbosity
verbosity PackageDB
packagedb)
IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \e :: IOException
e -> Verbosity -> FilePath -> IO FilePath
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ ConfiguredProgram -> FilePath
programId (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " dump failed: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
e
case FilePath -> Either [InstalledPackageInfo] [FilePath]
parsePackages FilePath
output of
Left ok :: [InstalledPackageInfo]
ok -> [InstalledPackageInfo] -> IO [InstalledPackageInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledPackageInfo]
ok
_ -> Verbosity -> FilePath -> IO [InstalledPackageInfo]
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO [InstalledPackageInfo])
-> FilePath -> IO [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$ "failed to parse output of '"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> FilePath
programId (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " dump'"
parsePackages :: String -> Either [InstalledPackageInfo] [String]
parsePackages :: FilePath -> Either [InstalledPackageInfo] [FilePath]
parsePackages str :: FilePath
str =
case [Either [FilePath] ([FilePath], InstalledPackageInfo)]
-> ([[FilePath]], [([FilePath], InstalledPackageInfo)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either [FilePath] ([FilePath], InstalledPackageInfo)]
-> ([[FilePath]], [([FilePath], InstalledPackageInfo)]))
-> [Either [FilePath] ([FilePath], InstalledPackageInfo)]
-> ([[FilePath]], [([FilePath], InstalledPackageInfo)])
forall a b. (a -> b) -> a -> b
$ (FilePath -> Either [FilePath] ([FilePath], InstalledPackageInfo))
-> [FilePath]
-> [Either [FilePath] ([FilePath], InstalledPackageInfo)]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either [FilePath] ([FilePath], InstalledPackageInfo)
parseInstalledPackageInfo (FilePath -> [FilePath]
splitPkgs FilePath
str) of
([], ok :: [([FilePath], InstalledPackageInfo)]
ok) -> [InstalledPackageInfo] -> Either [InstalledPackageInfo] [FilePath]
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)
-> (FilePath -> InstalledPackageInfo -> InstalledPackageInfo)
-> Maybe FilePath
-> InstalledPackageInfo
-> InstalledPackageInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe InstalledPackageInfo -> InstalledPackageInfo
forall a. a -> a
id FilePath -> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths (InstalledPackageInfo -> Maybe FilePath
pkgRoot InstalledPackageInfo
pkg) (InstalledPackageInfo -> InstalledPackageInfo)
-> InstalledPackageInfo -> InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
pkg | (_, pkg :: InstalledPackageInfo
pkg) <- [([FilePath], InstalledPackageInfo)]
ok ]
(msgss :: [[FilePath]]
msgss, _) -> [FilePath] -> Either [InstalledPackageInfo] [FilePath]
forall a b. b -> Either a b
Right ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
msgss)
splitPkgs :: String -> [String]
splitPkgs :: FilePath -> [FilePath]
splitPkgs = [FilePath] -> [FilePath]
forall (t :: * -> *). Foldable t => [t Char] -> [t Char]
checkEmpty ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath] -> FilePath) -> [[FilePath]] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map [FilePath] -> FilePath
unlines ([[FilePath]] -> [FilePath])
-> (FilePath -> [[FilePath]]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [[FilePath]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWith ("---" FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==) ([FilePath] -> [[FilePath]])
-> (FilePath -> [FilePath]) -> FilePath -> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines
where
checkEmpty :: [t Char] -> [t Char]
checkEmpty [s :: t Char
s] | (Char -> Bool) -> t Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace t Char
s = []
checkEmpty ss :: [t Char]
ss = [t Char]
ss
splitWith :: (a -> Bool) -> [a] -> [[a]]
splitWith :: (a -> Bool) -> [a] -> [[a]]
splitWith p :: a -> Bool
p xs :: [a]
xs = [a]
ys [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: case [a]
zs of
[] -> []
_:ws :: [a]
ws -> (a -> Bool) -> [a] -> [[a]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWith a -> Bool
p [a]
ws
where (ys :: [a]
ys,zs :: [a]
zs) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
p [a]
xs
mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths pkgroot :: FilePath
pkgroot pkginfo :: InstalledPackageInfo
pkginfo =
InstalledPackageInfo
pkginfo {
importDirs :: [FilePath]
importDirs = [FilePath] -> [FilePath]
mungePaths (InstalledPackageInfo -> [FilePath]
importDirs InstalledPackageInfo
pkginfo),
includeDirs :: [FilePath]
includeDirs = [FilePath] -> [FilePath]
mungePaths (InstalledPackageInfo -> [FilePath]
includeDirs InstalledPackageInfo
pkginfo),
libraryDirs :: [FilePath]
libraryDirs = [FilePath] -> [FilePath]
mungePaths (InstalledPackageInfo -> [FilePath]
libraryDirs InstalledPackageInfo
pkginfo),
libraryDynDirs :: [FilePath]
libraryDynDirs = [FilePath] -> [FilePath]
mungePaths (InstalledPackageInfo -> [FilePath]
libraryDynDirs InstalledPackageInfo
pkginfo),
frameworkDirs :: [FilePath]
frameworkDirs = [FilePath] -> [FilePath]
mungePaths (InstalledPackageInfo -> [FilePath]
frameworkDirs InstalledPackageInfo
pkginfo),
haddockInterfaces :: [FilePath]
haddockInterfaces = [FilePath] -> [FilePath]
mungePaths (InstalledPackageInfo -> [FilePath]
haddockInterfaces InstalledPackageInfo
pkginfo),
haddockHTMLs :: [FilePath]
haddockHTMLs = [FilePath] -> [FilePath]
mungeUrls (InstalledPackageInfo -> [FilePath]
haddockHTMLs InstalledPackageInfo
pkginfo)
}
where
mungePaths :: [FilePath] -> [FilePath]
mungePaths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
mungePath
mungeUrls :: [FilePath] -> [FilePath]
mungeUrls = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
mungeUrl
mungePath :: FilePath -> FilePath
mungePath p :: FilePath
p = case FilePath -> FilePath -> Maybe FilePath
stripVarPrefix "${pkgroot}" FilePath
p of
Just p' :: FilePath
p' -> FilePath
pkgroot FilePath -> FilePath -> FilePath
</> FilePath
p'
Nothing -> FilePath
p
mungeUrl :: FilePath -> FilePath
mungeUrl p :: FilePath
p = case FilePath -> FilePath -> Maybe FilePath
stripVarPrefix "${pkgrooturl}" FilePath
p of
Just p' :: FilePath
p' -> FilePath -> FilePath -> FilePath
toUrlPath FilePath
pkgroot FilePath
p'
Nothing -> FilePath
p
toUrlPath :: FilePath -> FilePath -> FilePath
toUrlPath r :: FilePath
r p :: FilePath
p = "file:///"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
FilePath.Posix.joinPath (FilePath
r FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath -> [FilePath]
FilePath.splitDirectories FilePath
p)
stripVarPrefix :: FilePath -> FilePath -> Maybe FilePath
stripVarPrefix var :: FilePath
var p :: FilePath
p =
case FilePath -> [FilePath]
splitPath FilePath
p of
(root :: FilePath
root:path' :: [FilePath]
path') -> case FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
var FilePath
root of
Just [sep :: Char
sep] | Char -> Bool
isPathSeparator Char
sep -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just ([FilePath] -> FilePath
joinPath [FilePath]
path')
_ -> Maybe FilePath
forall a. Maybe a
Nothing
_ -> Maybe FilePath
forall a. Maybe a
Nothing
setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
setUnitId pkginfo :: InstalledPackageInfo
pkginfo@InstalledPackageInfo {
installedUnitId :: InstalledPackageInfo -> UnitId
installedUnitId = UnitId
uid,
sourcePackageId :: InstalledPackageInfo -> PackageId
sourcePackageId = PackageId
pid
} | UnitId -> FilePath
unUnitId UnitId
uid FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ""
= InstalledPackageInfo
pkginfo {
installedUnitId :: UnitId
installedUnitId = PackageId -> UnitId
mkLegacyUnitId PackageId
pid,
installedComponentId_ :: ComponentId
installedComponentId_ = FilePath -> ComponentId
mkComponentId (PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pid)
}
setUnitId pkginfo :: InstalledPackageInfo
pkginfo = InstalledPackageInfo
pkginfo
list :: HcPkgInfo -> Verbosity -> PackageDB
-> IO [PackageId]
list :: HcPkgInfo -> Verbosity -> PackageDB -> IO [PackageId]
list hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb = do
FilePath
output <- Verbosity -> ProgramInvocation -> IO FilePath
getProgramInvocationOutput Verbosity
verbosity
(HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation HcPkgInfo
hpi Verbosity
verbosity PackageDB
packagedb)
IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \_ -> Verbosity -> FilePath -> IO FilePath
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ ConfiguredProgram -> FilePath
programId (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " list failed"
case FilePath -> Maybe [PackageId]
parsePackageIds FilePath
output of
Just ok :: [PackageId]
ok -> [PackageId] -> IO [PackageId]
forall (m :: * -> *) a. Monad m => a -> m a
return [PackageId]
ok
_ -> Verbosity -> FilePath -> IO [PackageId]
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO [PackageId]) -> FilePath -> IO [PackageId]
forall a b. (a -> b) -> a -> b
$ "failed to parse output of '"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> FilePath
programId (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " list'"
where
parsePackageIds :: FilePath -> Maybe [PackageId]
parsePackageIds = (FilePath -> Maybe PackageId) -> [FilePath] -> Maybe [PackageId]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> Maybe PackageId
forall a. Parsec a => FilePath -> Maybe a
simpleParsec ([FilePath] -> Maybe [PackageId])
-> (FilePath -> [FilePath]) -> FilePath -> Maybe [PackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words
initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity path :: FilePath
path =
ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [FilePath]
args
where
args :: [FilePath]
args = ["init", FilePath
path]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity
registerInvocation
:: HcPkgInfo -> Verbosity -> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
registerInvocation :: HcPkgInfo
-> Verbosity
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
registerInvocation hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedbs :: PackageDBStack
packagedbs pkgInfo :: InstalledPackageInfo
pkgInfo registerOptions :: RegisterOptions
registerOptions =
(ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) (FilePath -> [FilePath]
args "-")) {
progInvokeInput :: Maybe FilePath
progInvokeInput = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (InstalledPackageInfo -> FilePath
showInstalledPackageInfo InstalledPackageInfo
pkgInfo),
progInvokeInputEncoding :: IOEncoding
progInvokeInputEncoding = IOEncoding
IOEncodingUTF8
}
where
cmdname :: FilePath
cmdname
| RegisterOptions -> Bool
registerAllowOverwrite RegisterOptions
registerOptions = "update"
| RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions = "update"
| Bool
otherwise = "register"
args :: FilePath -> [FilePath]
args file :: FilePath
file = [FilePath
cmdname, FilePath
file]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if HcPkgInfo -> Bool
noPkgDbStack HcPkgInfo
hpi
then [HcPkgInfo -> PackageDB -> FilePath
packageDbOpts HcPkgInfo
hpi (PackageDBStack -> PackageDB
forall a. [a] -> a
last PackageDBStack
packagedbs)]
else HcPkgInfo -> PackageDBStack -> [FilePath]
packageDbStackOpts HcPkgInfo
hpi PackageDBStack
packagedbs)
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ "--enable-multi-instance"
| RegisterOptions -> Bool
registerMultiInstance RegisterOptions
registerOptions ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ "--force-files"
| RegisterOptions -> Bool
registerSuppressFilesCheck RegisterOptions
registerOptions ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity
unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
unregisterInvocation :: HcPkgInfo
-> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
unregisterInvocation hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb pkgid :: PackageId
pkgid =
ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([FilePath] -> ProgramInvocation)
-> [FilePath] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
["unregister", HcPkgInfo -> PackageDB -> FilePath
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity
recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB
-> ProgramInvocation
recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
recacheInvocation hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb =
ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([FilePath] -> ProgramInvocation)
-> [FilePath] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
["recache", HcPkgInfo -> PackageDB -> FilePath
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity
exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
exposeInvocation :: HcPkgInfo
-> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
exposeInvocation hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb pkgid :: PackageId
pkgid =
ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([FilePath] -> ProgramInvocation)
-> [FilePath] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
["expose", HcPkgInfo -> PackageDB -> FilePath
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity
describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId
-> ProgramInvocation
describeInvocation :: HcPkgInfo
-> Verbosity -> PackageDBStack -> PackageId -> ProgramInvocation
describeInvocation hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedbs :: PackageDBStack
packagedbs pkgid :: PackageId
pkgid =
ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([FilePath] -> ProgramInvocation)
-> [FilePath] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
["describe", PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if HcPkgInfo -> Bool
noPkgDbStack HcPkgInfo
hpi
then [HcPkgInfo -> PackageDB -> FilePath
packageDbOpts HcPkgInfo
hpi (PackageDBStack -> PackageDB
forall a. [a] -> a
last PackageDBStack
packagedbs)]
else HcPkgInfo -> PackageDBStack -> [FilePath]
packageDbStackOpts HcPkgInfo
hpi PackageDBStack
packagedbs)
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity
hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
hideInvocation :: HcPkgInfo
-> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
hideInvocation hpi :: HcPkgInfo
hpi verbosity :: Verbosity
verbosity packagedb :: PackageDB
packagedb pkgid :: PackageId
pkgid =
ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) ([FilePath] -> ProgramInvocation)
-> [FilePath] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
["hide", HcPkgInfo -> PackageDB -> FilePath
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb, PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
verbosity
dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation hpi :: HcPkgInfo
hpi _verbosity :: Verbosity
_verbosity packagedb :: PackageDB
packagedb =
(ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [FilePath]
args) {
progInvokeOutputEncoding :: IOEncoding
progInvokeOutputEncoding = IOEncoding
IOEncodingUTF8
}
where
args :: [FilePath]
args = ["dump", HcPkgInfo -> PackageDB -> FilePath
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
silent
listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation hpi :: HcPkgInfo
hpi _verbosity :: Verbosity
_verbosity packagedb :: PackageDB
packagedb =
(ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation (HcPkgInfo -> ConfiguredProgram
hcPkgProgram HcPkgInfo
hpi) [FilePath]
args) {
progInvokeOutputEncoding :: IOEncoding
progInvokeOutputEncoding = IOEncoding
IOEncodingUTF8
}
where
args :: [FilePath]
args = ["list", "--simple-output", HcPkgInfo -> PackageDB -> FilePath
packageDbOpts HcPkgInfo
hpi PackageDB
packagedb]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts HcPkgInfo
hpi Verbosity
silent
packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]
packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [FilePath]
packageDbStackOpts hpi :: HcPkgInfo
hpi dbstack :: PackageDBStack
dbstack = case PackageDBStack
dbstack of
(GlobalPackageDB:UserPackageDB:dbs :: PackageDBStack
dbs) -> "--global"
FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: "--user"
FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (PackageDB -> FilePath) -> PackageDBStack -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageDB -> FilePath
specific PackageDBStack
dbs
(GlobalPackageDB:dbs :: PackageDBStack
dbs) -> "--global"
FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ("--no-user-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> FilePath
packageDbFlag HcPkgInfo
hpi)
FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (PackageDB -> FilePath) -> PackageDBStack -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageDB -> FilePath
specific PackageDBStack
dbs
_ -> [FilePath]
forall a. a
ierror
where
specific :: PackageDB -> FilePath
specific (SpecificPackageDB db :: FilePath
db) = "--" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> FilePath
packageDbFlag HcPkgInfo
hpi FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
db
specific _ = FilePath
forall a. a
ierror
ierror :: a
ierror :: a
ierror = FilePath -> a
forall a. HasCallStack => FilePath -> a
error ("internal error: unexpected package db stack: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageDBStack -> FilePath
forall a. Show a => a -> FilePath
show PackageDBStack
dbstack)
packageDbFlag :: HcPkgInfo -> String
packageDbFlag :: HcPkgInfo -> FilePath
packageDbFlag hpi :: HcPkgInfo
hpi
| HcPkgInfo -> Bool
flagPackageConf HcPkgInfo
hpi
= "package-conf"
| Bool
otherwise
= "package-db"
packageDbOpts :: HcPkgInfo -> PackageDB -> String
packageDbOpts :: HcPkgInfo -> PackageDB -> FilePath
packageDbOpts _ GlobalPackageDB = "--global"
packageDbOpts _ UserPackageDB = "--user"
packageDbOpts hpi :: HcPkgInfo
hpi (SpecificPackageDB db :: FilePath
db) = "--" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HcPkgInfo -> FilePath
packageDbFlag HcPkgInfo
hpi FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
db
verbosityOpts :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts :: HcPkgInfo -> Verbosity -> [FilePath]
verbosityOpts hpi :: HcPkgInfo
hpi v :: Verbosity
v
| HcPkgInfo -> Bool
noVerboseFlag HcPkgInfo
hpi
= []
| Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening = ["-v2"]
| Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
silent = ["-v0"]
| Bool
otherwise = []