{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS -fno-warn-unused-do-bind #-}
module Stack.GhcPkg
(getGlobalDB
,EnvOverride
,envHelper
,createDatabase
,unregisterGhcPkgId
,getCabalPkgVer
,ghcPkgExeName
,mkGhcPackagePath)
where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as S8
import Data.Either
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir)
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO (dirExists, createTree)
import Prelude hiding (FilePath)
import Stack.Constants
import Stack.Types
import System.Directory (canonicalizePath)
import System.FilePath (searchPathSeparator)
import System.Process.Read
getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride -> WhichCompiler -> m (Path Abs Dir)
getGlobalDB menv wc = do
bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwM return
let fp = S8.unpack $ stripTrailingColon $ firstLine bs
liftIO (canonicalizePath fp) >>= parseAbsDir
where
stripTrailingColon bs
| S8.null bs = bs
| S8.last bs == ':' = S8.init bs
| otherwise = bs
firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')
ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> [String]
-> m (Either ReadProcessException S8.ByteString)
ghcPkg menv wc pkgDbs args = do
eres <- go
case eres of
Left _ -> do
mapM_ (createDatabase menv wc) pkgDbs
go
Right _ -> return eres
where
go = tryProcessStdout Nothing menv (ghcPkgExeName wc) args'
args' = packageDbFlags pkgDbs ++ args
createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride -> WhichCompiler -> Path Abs Dir -> m ()
createDatabase menv wc db = do
exists <- dirExists db
unless exists $ do
createTree (parent db)
_ <- tryProcessStdout Nothing menv (ghcPkgExeName wc) ["init", toFilePath db]
return ()
ghcPkgExeName :: WhichCompiler -> String
ghcPkgExeName Ghc = "ghc-pkg"
ghcPkgExeName Ghcjs = "ghcjs-pkg"
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags pkgDbs =
"--no-user-package-db"
: map (\x -> "--package-db=" ++ toFilePath x) pkgDbs
findGhcPkgField
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> String
-> Text
-> m (Maybe Text)
findGhcPkgField menv wc pkgDbs name field = do
result <-
ghcPkg
menv
wc
pkgDbs
["field", "--simple-output", name, T.unpack field]
return $
case result of
Left{} -> Nothing
Right lbs ->
fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs
where
stripCR t = fromMaybe t (T.stripSuffix "\r" t)
findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> PackageName
-> m (Maybe Version)
findGhcPkgVersion menv wc pkgDbs name = do
mv <- findGhcPkgField menv wc pkgDbs (packageNameString name) "version"
case mv of
Just !v -> return (parseVersion (T.encodeUtf8 v))
_ -> return Nothing
unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> CompilerVersion
-> Path Abs Dir
-> GhcPkgId
-> PackageIdentifier
-> m ()
unregisterGhcPkgId menv wc cv pkgDb gid ident = do
eres <- ghcPkg menv wc [pkgDb] args
case eres of
Left e -> $logWarn $ T.pack $ show e
Right _ -> return ()
where
args = "unregister" : "--user" : "--force" :
(case cv of
GhcVersion v | v < $(mkVersion "7.9") ->
[packageIdentifierString ident]
_ -> ["--ipid", ghcPkgIdString gid])
getCabalPkgVer :: (MonadThrow m, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride -> WhichCompiler -> m Version
getCabalPkgVer menv wc =
findGhcPkgVersion
menv
wc
[]
cabalPackageName >>=
maybe (throwM $ Couldn'tFindPkgId cabalPackageName) return
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]
]