{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS -fno-warn-unused-do-bind #-}
module Stack.GhcPkg
(findGhcPkgId
,findGhcPkgKey
,getGlobalDB
,EnvOverride
,envHelper
,createDatabase
,unregisterGhcPkgId
,getCabalPkgVer
,findGhcPkgHaddockHtml
,findGhcPkgDepends
,findTransitiveGhcPkgDepends
,listGhcPkgDbs
,ghcPkgExeName
,mkGhcPackagePath)
where
import Control.Applicative
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 qualified Data.Map as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
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.IO (dirExists, createTree)
import Prelude hiding (FilePath)
import Stack.Constants
import Stack.Types
import System.Directory (canonicalizePath, doesDirectoryExist)
import System.FilePath (FilePath, searchPathSeparator, dropTrailingPathSeparator)
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
r <- case eres of
Left _ -> do
mapM_ (createDatabase menv wc) pkgDbs
go
Right _ -> return eres
return r
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)
findGhcPkgId :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> PackageName
-> m (Maybe GhcPkgId)
findGhcPkgId menv wc pkgDbs name = do
mpid <- findGhcPkgField menv wc pkgDbs (packageNameString name) "id"
case mpid of
Just !pid -> return (parseGhcPkgId (T.encodeUtf8 pid))
_ -> return Nothing
findGhcPkgKey :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> PackageName
-> m (Maybe Text)
findGhcPkgKey menv wc pkgDbs name =
findGhcPkgField menv wc pkgDbs (packageNameString name) "key"
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
findGhcPkgHaddockHtml :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> String
-> m (Maybe (PackageIdentifier, Path Abs Dir))
findGhcPkgHaddockHtml menv wc pkgDbs ghcPkgId = do
mpath <- findGhcPkgField menv wc pkgDbs ghcPkgId "haddock-html"
mid <- findGhcPkgField menv wc pkgDbs ghcPkgId "id"
mversion <- findGhcPkgField menv wc pkgDbs ghcPkgId "version"
let mpkgId = PackageIdentifier
<$> (mid >>= parsePackageName . T.encodeUtf8)
<*> (mversion >>= parseVersion . T.encodeUtf8)
case (,) <$> mpath <*> mpkgId of
Just (path0, pkgId) -> do
let path = T.unpack path0
exists <- liftIO $ doesDirectoryExist path
path' <- if exists
then liftIO $ canonicalizePath path
else return path
return $ fmap (pkgId,) (parseAbsDir path')
_ -> return Nothing
findTransitiveGhcPkgDepends
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> PackageIdentifier
-> m (Set PackageIdentifier)
findTransitiveGhcPkgDepends menv wc pkgDbs pkgId0 =
liftM (Set.fromList . Map.elems)
(go (packageIdentifierString pkgId0) Map.empty)
where
go pkgId res = do
deps <- findGhcPkgDepends menv wc pkgDbs pkgId
loop deps res
loop [] res = return res
loop (dep:deps) res = do
if Map.member dep res
then loop deps res
else do
let pkgId = ghcPkgIdString dep
mname <- findGhcPkgField menv wc pkgDbs pkgId "name"
mversion <- findGhcPkgField menv wc pkgDbs pkgId "version"
let mident = do
name <- mname >>= parsePackageName . T.encodeUtf8
version <- mversion >>= parseVersion . T.encodeUtf8
Just $ PackageIdentifier name version
res' = maybe id (Map.insert dep) mident res
res'' <- go pkgId res'
loop deps (Map.union res res'')
findGhcPkgDepends :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> [Path Abs Dir]
-> String
-> m [GhcPkgId]
findGhcPkgDepends menv wc pkgDbs pkgId = do
mdeps <- findGhcPkgField menv wc pkgDbs pkgId "depends"
case mdeps of
Just !deps -> return (mapMaybe (parseGhcPkgId . T.encodeUtf8) (T.words deps))
_ -> return []
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
listGhcPkgDbs
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride -> WhichCompiler -> [Path Abs Dir] -> m [PackageIdentifier]
listGhcPkgDbs menv wc pkgDbs = do
result <-
ghcPkg
menv
wc
pkgDbs
["list", "--simple-output"]
return $
case result of
Left{} -> []
Right lbs -> mapMaybe parsePackageIdentifier (S8.words lbs)
mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> Path Abs Dir -> Text
mkGhcPackagePath locals localdb deps globaldb =
T.pack $ intercalate [searchPathSeparator] $ concat
[ [toFilePathNoTrailingSlash localdb | locals]
, [toFilePathNoTrailingSlash deps]
, [toFilePathNoTrailingSlash globaldb]
]
toFilePathNoTrailingSlash :: Path loc Dir -> FilePath
toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath