{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.GhcPkg
(getGlobalDB
,findGhcPkgField
,createDatabase
,unregisterGhcPkgIds
,ghcPkgPathEnvVar
,mkGhcPackagePath)
where
import Stack.Prelude
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Path (parent, (</>))
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import Stack.Constants
import Stack.Types.Config (GhcPkgExe (..))
import Stack.Types.GhcPkgId
import Stack.Types.Compiler
import System.FilePath (searchPathSeparator)
import RIO.Process
getGlobalDB
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> RIO env (Path Abs Dir)
getGlobalDB pkgexe = do
logDebug "Getting global package database location"
bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO return
let fp = S8.unpack $ stripTrailingColon $ firstLine bs
liftIO $ resolveDir' fp
where
stripTrailingColon bs
| S8.null bs = bs
| S8.last bs == ':' = S8.init bs
| otherwise = bs
firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')
ghcPkg
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException S8.ByteString)
ghcPkg pkgexe@(GhcPkgExe pkgPath) pkgDbs args = do
eres <- go
case eres of
Left _ -> do
mapM_ (createDatabase pkgexe) pkgDbs
go
Right _ -> return eres
where
pkg = toFilePath pkgPath
go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_
args' = packageDbFlags pkgDbs ++ args
createDatabase
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> Path Abs Dir
-> RIO env ()
createDatabase (GhcPkgExe pkgPath) db = do
exists <- doesFileExist (db </> relFilePackageCache)
unless exists $ do
dirExists <- doesDirExist db
args <- if dirExists
then do
logWarn $
"The package database located at " <>
fromString (toFilePath db) <>
" is corrupted (missing its package.cache file)."
logWarn "Proceeding with a recache"
return ["--package-db", toFilePath db, "recache"]
else do
ensureDir (parent db)
return ["init", toFilePath db]
void $ proc (toFilePath pkgPath) args $ \pc ->
readProcess_ pc `onException`
logError ("Unable to create package database at " <> fromString (toFilePath db))
ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH"
ghcPkgPathEnvVar Ghcjs = "GHCJS_PACKAGE_PATH"
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags pkgDbs =
"--no-user-package-db"
: map (\x -> "--package-db=" ++ toFilePath x) pkgDbs
findGhcPkgField
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir]
-> String
-> Text
-> RIO env (Maybe Text)
findGhcPkgField pkgexe pkgDbs name field = do
result <-
ghcPkg
pkgexe
pkgDbs
["field", "--simple-output", name, T.unpack field]
return $
case result of
Left{} -> Nothing
Right bs ->
fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs
unregisterGhcPkgIds
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds pkgexe pkgDb epgids = do
eres <- ghcPkg pkgexe [pkgDb] args
case eres of
Left e -> logWarn $ displayShow e
Right _ -> return ()
where
args = "unregister" : "--user" : "--force" :
concatMap (either
(\ident -> [packageIdentifierString ident])
(\gid -> ["--ipid", ghcPkgIdString gid]))
epgids
mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
mkGhcPackagePath locals localdb deps extras globaldb =
T.pack $ intercalate [searchPathSeparator] $ concat
[ [toFilePathNoTrailingSep localdb | locals]
, [toFilePathNoTrailingSep deps]
, [toFilePathNoTrailingSep db | db <- reverse extras]
, [toFilePathNoTrailingSep globaldb]
]