module Distribution.Simple.Program.HcPkg (
HcPkgInfo(..),
init,
invoke,
register,
reregister,
unregister,
expose,
hide,
dump,
list,
initInvocation,
registerInvocation,
reregisterInvocation,
unregisterInvocation,
exposeInvocation,
hideInvocation,
dumpInvocation,
listInvocation,
) where
import Prelude hiding (init)
import Distribution.Package
( PackageId, InstalledPackageId(..) )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo, InstalledPackageInfo_(..)
, showInstalledPackageInfo
, emptyInstalledPackageInfo, fieldsInstalledPackageInfo )
import Distribution.ParseUtils
import Distribution.Simple.Compiler
( PackageDB(..), PackageDBStack )
import Distribution.Simple.Program.Types
( ConfiguredProgram(programId) )
import Distribution.Simple.Program.Run
( ProgramInvocation(..), IOEncoding(..), programInvocation
, runProgramInvocation, getProgramInvocationOutput )
import Distribution.Text
( display, simpleParse )
import Distribution.Simple.Utils
( die )
import Distribution.Verbosity
( Verbosity, deafening, silent )
import Distribution.Compat.Exception
( catchExit )
import Data.Char
( isSpace )
import Data.List
( stripPrefix )
import System.FilePath as FilePath
( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )
import qualified System.FilePath.Posix as FilePath.Posix
data HcPkgInfo = HcPkgInfo
{ hcPkgProgram :: ConfiguredProgram
, noPkgDbStack :: Bool
, noVerboseFlag :: Bool
, flagPackageConf :: Bool
}
init :: HcPkgInfo -> Verbosity -> FilePath -> IO ()
init hpi verbosity path =
runProgramInvocation verbosity (initInvocation hpi verbosity path)
invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()
invoke hpi verbosity dbStack extraArgs =
runProgramInvocation verbosity invocation
where
args = packageDbStackOpts hpi dbStack ++ extraArgs
invocation = programInvocation (hcPkgProgram hpi) args
register :: HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath
InstalledPackageInfo
-> IO ()
register hpi verbosity packagedb pkgFile =
runProgramInvocation verbosity
(registerInvocation hpi verbosity packagedb pkgFile)
reregister :: HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath
InstalledPackageInfo
-> IO ()
reregister hpi verbosity packagedb pkgFile =
runProgramInvocation verbosity
(reregisterInvocation hpi verbosity packagedb pkgFile)
unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
unregister hpi verbosity packagedb pkgid =
runProgramInvocation verbosity
(unregisterInvocation hpi verbosity packagedb pkgid)
expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
expose hpi verbosity packagedb pkgid =
runProgramInvocation verbosity
(exposeInvocation hpi verbosity packagedb pkgid)
hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
hide hpi verbosity packagedb pkgid =
runProgramInvocation verbosity
(hideInvocation hpi verbosity packagedb pkgid)
dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
dump hpi verbosity packagedb = do
output <- getProgramInvocationOutput verbosity
(dumpInvocation hpi verbosity packagedb)
`catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"
case parsePackages output of
Left ok -> return ok
_ -> die $ "failed to parse output of '"
++ programId (hcPkgProgram hpi) ++ " dump'"
where
parsePackages str =
let parsed = map parseInstalledPackageInfo' (splitPkgs str)
in case [ msg | ParseFailed msg <- parsed ] of
[] -> Left [ setInstalledPackageId
. maybe id mungePackagePaths (pkgRoot pkg)
$ pkg
| ParseOk _ pkg <- parsed ]
msgs -> Right msgs
parseInstalledPackageInfo' =
parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
splitPkgs :: String -> [String]
splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines
where
checkEmpty [s] | all isSpace s = []
checkEmpty ss = ss
splitWith :: (a -> Bool) -> [a] -> [[a]]
splitWith p xs = ys : case zs of
[] -> []
_:ws -> splitWith p ws
where (ys,zs) = break p xs
mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths pkgroot pkginfo =
pkginfo {
importDirs = mungePaths (importDirs pkginfo),
includeDirs = mungePaths (includeDirs pkginfo),
libraryDirs = mungePaths (libraryDirs pkginfo),
frameworkDirs = mungePaths (frameworkDirs pkginfo),
haddockInterfaces = mungePaths (haddockInterfaces pkginfo),
haddockHTMLs = mungeUrls (haddockHTMLs pkginfo)
}
where
mungePaths = map mungePath
mungeUrls = map mungeUrl
mungePath p = case stripVarPrefix "${pkgroot}" p of
Just p' -> pkgroot </> p'
Nothing -> p
mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of
Just p' -> toUrlPath pkgroot p'
Nothing -> p
toUrlPath r p = "file:///"
++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
stripVarPrefix var p =
case splitPath p of
(root:path') -> case stripPrefix var root of
Just [sep] | isPathSeparator sep -> Just (joinPath path')
_ -> Nothing
_ -> Nothing
setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo
setInstalledPackageId pkginfo@InstalledPackageInfo {
installedPackageId = InstalledPackageId "",
sourcePackageId = pkgid
}
= pkginfo {
installedPackageId = InstalledPackageId (display pkgid)
}
setInstalledPackageId pkginfo = pkginfo
list :: HcPkgInfo -> Verbosity -> PackageDB
-> IO [PackageId]
list hpi verbosity packagedb = do
output <- getProgramInvocationOutput verbosity
(listInvocation hpi verbosity packagedb)
`catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"
case parsePackageIds output of
Just ok -> return ok
_ -> die $ "failed to parse output of '"
++ programId (hcPkgProgram hpi) ++ " list'"
where
parsePackageIds = sequence . map simpleParse . words
initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation hpi verbosity path =
programInvocation (hcPkgProgram hpi) args
where
args = ["init", path]
++ verbosityOpts hpi verbosity
registerInvocation, reregisterInvocation
:: HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath InstalledPackageInfo
-> ProgramInvocation
registerInvocation = registerInvocation' "register"
reregisterInvocation = registerInvocation' "update"
registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack
-> Either FilePath InstalledPackageInfo
-> ProgramInvocation
registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) =
programInvocation (hcPkgProgram hpi) args
where
args = [cmdname, pkgFile]
++ (if noPkgDbStack hpi
then [packageDbOpts hpi (last packagedbs)]
else packageDbStackOpts hpi packagedbs)
++ verbosityOpts hpi verbosity
registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) =
(programInvocation (hcPkgProgram hpi) args) {
progInvokeInput = Just (showInstalledPackageInfo pkgInfo),
progInvokeInputEncoding = IOEncodingUTF8
}
where
args = [cmdname, "-"]
++ (if noPkgDbStack hpi
then [packageDbOpts hpi (last packagedbs)]
else packageDbStackOpts hpi packagedbs)
++ verbosityOpts hpi verbosity
unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
unregisterInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
["unregister", packageDbOpts hpi packagedb, display pkgid]
++ verbosityOpts hpi verbosity
exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
exposeInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
["expose", packageDbOpts hpi packagedb, display pkgid]
++ verbosityOpts hpi verbosity
hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
-> ProgramInvocation
hideInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
["hide", packageDbOpts hpi packagedb, display pkgid]
++ verbosityOpts hpi verbosity
dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation hpi _verbosity packagedb =
(programInvocation (hcPkgProgram hpi) args) {
progInvokeOutputEncoding = IOEncodingUTF8
}
where
args = ["dump", packageDbOpts hpi packagedb]
++ verbosityOpts hpi silent
listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation hpi _verbosity packagedb =
(programInvocation (hcPkgProgram hpi) args) {
progInvokeOutputEncoding = IOEncodingUTF8
}
where
args = ["list", "--simple-output", packageDbOpts hpi packagedb]
++ verbosityOpts hpi silent
packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]
packageDbStackOpts hpi dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> "--global"
: "--user"
: map specific dbs
(GlobalPackageDB:dbs) -> "--global"
: ("--no-user-" ++ packageDbFlag hpi)
: map specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
specific _ = ierror
ierror :: a
ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
packageDbFlag :: HcPkgInfo -> String
packageDbFlag hpi
| flagPackageConf hpi
= "package-conf"
| otherwise
= "package-db"
packageDbOpts :: HcPkgInfo -> PackageDB -> String
packageDbOpts _ GlobalPackageDB = "--global"
packageDbOpts _ UserPackageDB = "--user"
packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
verbosityOpts :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts hpi v
| noVerboseFlag hpi
= []
| v >= deafening = ["-v2"]
| v == silent = ["-v0"]
| otherwise = []