Commit e2b81b09 authored by Christiaan Baaij's avatar Christiaan Baaij
Browse files

Enable installation into empty user package database

parent 1ac8c314
......@@ -45,6 +45,7 @@ module Distribution.Simple.GHC (
ghcLibDir,
ghcDynamic,
ghcGlobalPackageDB,
pkgRoot
) where
import qualified Distribution.Simple.GHC.IPI641 as IPI641
......@@ -112,12 +113,14 @@ import Data.List
import qualified Data.Map as M ( Map, fromList, lookup )
import Data.Maybe ( catMaybes, fromMaybe, maybeToList )
import Data.Monoid ( Monoid(..) )
import Data.Version ( showVersion )
import System.Directory
( getDirectoryContents, doesFileExist, getTemporaryDirectory,
canonicalizePath )
canonicalizePath, getAppUserDataDirectory, createDirectoryIfMissing )
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension,
splitExtension )
import qualified System.Info
import System.IO (hClose, hPutStrLn)
import System.Environment (getEnv)
import Distribution.Compat.Exception (catchExit, catchIO)
......@@ -1422,6 +1425,25 @@ registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do
let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)
HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)
pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot verbosity lbi = pkgRoot'
where
pkgRoot' GlobalPackageDB =
let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
in fmap takeDirectory (ghcGlobalPackageDB verbosity ghcProg)
pkgRoot' UserPackageDB = do
appDir <- getAppUserDataDirectory "ghc"
let ver = compilerVersion (compiler lbi)
subdir = System.Info.arch ++ '-':System.Info.os ++ '-':showVersion ver
rootDir = appDir </> subdir
-- We must create the root directory for the user package database if it
-- does not yet exists. Otherwise '${pkgroot}' will resolve to a
-- directory at the time of 'ghc-pkg register', and registration will
-- fail.
createDirectoryIfMissing True rootDir
return rootDir
pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)
-- -----------------------------------------------------------------------------
-- Utils
......
......@@ -19,7 +19,6 @@ module Distribution.Simple.Program.HcPkg (
hide,
dump,
list,
pkgRoot,
-- * Program invocations
initInvocation,
......@@ -272,49 +271,6 @@ list verbosity hcPkg packagedb = do
where
parsePackageIds = sequence . map simpleParse . words
-- | Call @hc-pkg@ to get the location of PackageDB.
pkgRoot :: Verbosity -> ConfiguredProgram -> PackageDB -> IO (Maybe FilePath)
pkgRoot _ _ (SpecificPackageDB fp) = return (Just fp)
pkgRoot verbosity hcPkg packagedb = do
output <- getProgramInvocationOutput verbosity
(dumpInvocation hcPkg verbosity packagedb)
`catchExit` \_ -> die $ programId hcPkg ++ " pkgRoot failed"
case parsePkgRoot output of
Left ok -> return ok
_ -> die $ "failed to parse output of '"
++ programId hcPkg ++ " pkgRoot'"
where
parsePkgRoot str = case splitPkgs str of
[] -> Left Nothing
(pkg:_) -> case parsePkgRoot' pkg of
ParseOk _ pkgroot -> Left pkgroot
ParseFailed msg -> Right msg
parsePkgRoot' = parseFieldsFlat [pkgrootField] Nothing
where
pkgrootField =
simpleField "pkgroot"
showFilePath parseFilePathQ
(fromMaybe "") (\x _ -> Just x)
--TODO: this could be a lot faster. We're doing normaliseLineEndings twice
-- and converting back and forth with lines/unlines.
splitPkgs :: String -> [String]
splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines
where
-- Handle the case of there being no packages at all.
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
--------------------------
-- The program invocations
--
......
......@@ -207,12 +207,9 @@ relocRegistrationInfo :: Verbosity
-> IO InstalledPackageInfo
relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb =
case (compilerFlavor (compiler lbi)) of
GHC -> do let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)
fsM <- HcPkg.pkgRoot verbosity ghcPkg packageDb
case fsM of
Just fs -> return (relocatableInstalledPackageInfo
pkg ipid lib lbi clbi fs)
Nothing -> die "Cannot register relocatable package with empty ${pkgroot}"
GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb
return (relocatableInstalledPackageInfo
pkg ipid lib lbi clbi fs)
_ -> die "Distribution.Simple.Register.relocRegistrationInfo: \
\not implemented for this compiler"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment