{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}
module Hhp.GhcPkg (
ghcPkgList
, ghcPkgListEx
, ghcPkgDbOpt
, ghcPkgDbStackOpts
, ghcDbStackOpts
, ghcDbOpt
, getSandboxDb
, getPackageDbStack
) where
import GHC.Settings.Config (cProjectVersionInt)
import Control.Exception (SomeException(..))
import qualified Control.Exception as E
import Data.Char (isSpace,isAlphaNum)
import Data.List (isPrefixOf, intercalate, dropWhileEnd)
import Data.Maybe (listToMaybe, maybeToList)
import System.Exit (ExitCode(..))
import System.FilePath ((</>))
import System.IO (hPutStrLn,stderr)
import System.Process (readProcessWithExitCode)
import Text.ParserCombinators.ReadP (ReadP, char, between, sepBy1, many1, string, choice, eof)
import qualified Text.ParserCombinators.ReadP as P
import Hhp.Types
ghcVersion :: Int
ghcVersion :: Int
ghcVersion = forall a. Read a => String -> a
read String
cProjectVersionInt
getSandboxDb :: FilePath
-> IO FilePath
getSandboxDb :: String -> IO String
getSandboxDb String
cdir = String -> IO String
getSandboxDbDir (String
cdir String -> String -> String
</> String
"cabal.sandbox.config")
getSandboxDbDir :: FilePath
-> IO FilePath
getSandboxDbDir :: String -> IO String
getSandboxDbDir String
sconf = do
!String
path <- String -> String
extractValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
parse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
sconf
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
where
key :: String
key = String
"package-db:"
keyLen :: Int
keyLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
key
parse :: String -> String
parse = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (String
key forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
extractValue :: String -> String
extractValue = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
keyLen
getPackageDbStack :: FilePath
-> IO [GhcPkgDb]
getPackageDbStack :: String -> IO [GhcPkgDb]
getPackageDbStack String
cdir =
(String -> IO String
getSandboxDb String
cdir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
db -> forall (m :: * -> *) a. Monad m => a -> m a
return [GhcPkgDb
GlobalDb, String -> GhcPkgDb
PackageDb String
db])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return [GhcPkgDb
GlobalDb, GhcPkgDb
UserDb]
ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName]
ghcPkgList :: [GhcPkgDb] -> IO [String]
ghcPkgList [GhcPkgDb]
dbs = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fst3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GhcPkgDb] -> IO [Package]
ghcPkgListEx [GhcPkgDb]
dbs
where fst3 :: (a, b, c) -> a
fst3 (a
x,b
_,c
_) = a
x
ghcPkgListEx :: [GhcPkgDb] -> IO [Package]
ghcPkgListEx :: [GhcPkgDb] -> IO [Package]
ghcPkgListEx [GhcPkgDb]
dbs = do
(ExitCode
rv,String
output,String
err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"ghc-pkg" [String]
opts String
""
case ExitCode
rv of
ExitFailure Int
val -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"ghc-pkg " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
opts forall a. [a] -> [a] -> [a]
++ String
" (exit " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
val forall a. [a] -> [a] -> [a]
++ String
")"
ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> [Package]
parseGhcPkgOutput forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
output
where
opts :: [String]
opts = [String
"list", String
"-v"] forall a. [a] -> [a] -> [a]
++ [GhcPkgDb] -> [String]
ghcPkgDbStackOpts [GhcPkgDb]
dbs
parseGhcPkgOutput :: [String] -> [Package]
parseGhcPkgOutput :: [String] -> [Package]
parseGhcPkgOutput [] = []
parseGhcPkgOutput (String
l:[String]
ls) =
[String] -> [Package]
parseGhcPkgOutput [String]
ls forall a. [a] -> [a] -> [a]
++ case String
l of
[] -> []
Char
h:String
_ | Char -> Bool
isSpace Char
h -> forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ String -> Maybe Package
packageLine String
l
| Bool
otherwise -> []
packageLine :: String -> Maybe Package
packageLine :: String -> Maybe Package
packageLine String
l =
case forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. ReadP a -> ReadS a
P.readP_to_S ReadP (PackageState, Package)
packageLineP String
l of
Just ((PackageState
Normal,Package
p),String
_) -> forall a. a -> Maybe a
Just Package
p
Just ((PackageState
Hidden,Package
p),String
_) -> forall a. a -> Maybe a
Just Package
p
Maybe ((PackageState, Package), String)
_ -> forall a. Maybe a
Nothing
data PackageState = Normal | Hidden | Broken deriving (PackageState -> PackageState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageState -> PackageState -> Bool
$c/= :: PackageState -> PackageState -> Bool
== :: PackageState -> PackageState -> Bool
$c== :: PackageState -> PackageState -> Bool
Eq,Int -> PackageState -> String -> String
[PackageState] -> String -> String
PackageState -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PackageState] -> String -> String
$cshowList :: [PackageState] -> String -> String
show :: PackageState -> String
$cshow :: PackageState -> String
showsPrec :: Int -> PackageState -> String -> String
$cshowsPrec :: Int -> PackageState -> String -> String
Show)
packageLineP :: ReadP (PackageState, Package)
packageLineP :: ReadP (PackageState, Package)
packageLineP = do
ReadP ()
P.skipSpaces
(PackageState, Package)
p <- forall a. [ReadP a] -> ReadP a
choice [ (PackageState
Hidden,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'(') (Char -> ReadP Char
char Char
')') ReadP Package
packageP
, (PackageState
Broken,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'{') (Char -> ReadP Char
char Char
'}') ReadP Package
packageP
, (PackageState
Normal,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Package
packageP ]
ReadP ()
eof
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageState, Package)
p
packageP :: ReadP (PackageBaseName, PackageVersion, PackageId)
packageP :: ReadP Package
packageP = do
pkgSpec :: (String, String)
pkgSpec@(String
name,String
ver) <- ReadP (String, String)
packageSpecP
ReadP ()
P.skipSpaces
String
i <- forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'(') (Char -> ReadP Char
char Char
')') forall a b. (a -> b) -> a -> b
$ (String, String) -> ReadP String
packageIdSpecP (String, String)
pkgSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name,String
ver,String
i)
packageSpecP :: ReadP (PackageBaseName,PackageVersion)
packageSpecP :: ReadP (String, String)
packageSpecP = do
[String]
fs <- forall a. ReadP a -> ReadP [a]
many1 ReadP Char
packageCompCharP forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`sepBy1` Char -> ReadP Char
char Char
'-'
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [[a]] -> [a]
intercalate String
"-" (forall a. [a] -> [a]
init [String]
fs), forall a. [a] -> a
last [String]
fs)
packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId
packageIdSpecP :: (String, String) -> ReadP String
packageIdSpecP (String
name,String
ver) = do
String
_ <- String -> ReadP String
string String
name forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ReadP String
string String
ver
forall a. [ReadP a] -> ReadP a
choice [ Char -> ReadP Char
char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
P.satisfy Char -> Bool
isAlphaNum)
, forall (m :: * -> *) a. Monad m => a -> m a
return String
""]
packageCompCharP :: ReadP Char
packageCompCharP :: ReadP Char
packageCompCharP =
(Char -> Bool) -> ReadP Char
P.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"_-."
ghcPkgDbStackOpts :: [GhcPkgDb]
-> [String]
ghcPkgDbStackOpts :: [GhcPkgDb] -> [String]
ghcPkgDbStackOpts [GhcPkgDb]
dbs = GhcPkgDb -> [String]
ghcPkgDbOpt forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
`concatMap` [GhcPkgDb]
dbs
ghcDbStackOpts :: [GhcPkgDb]
-> [String]
ghcDbStackOpts :: [GhcPkgDb] -> [String]
ghcDbStackOpts [GhcPkgDb]
dbs = GhcPkgDb -> [String]
ghcDbOpt forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
`concatMap` [GhcPkgDb]
dbs
ghcPkgDbOpt :: GhcPkgDb -> [String]
ghcPkgDbOpt :: GhcPkgDb -> [String]
ghcPkgDbOpt GhcPkgDb
GlobalDb = [String
"--global"]
ghcPkgDbOpt GhcPkgDb
UserDb = [String
"--user"]
ghcPkgDbOpt (PackageDb String
pkgDb)
| Int
ghcVersion forall a. Ord a => a -> a -> Bool
< Int
706 = [String
"--no-user-package-conf", String
"--package-conf=" forall a. [a] -> [a] -> [a]
++ String
pkgDb]
| Bool
otherwise = [String
"--no-user-package-db", String
"--package-db=" forall a. [a] -> [a] -> [a]
++ String
pkgDb]
ghcDbOpt :: GhcPkgDb -> [String]
ghcDbOpt :: GhcPkgDb -> [String]
ghcDbOpt GhcPkgDb
GlobalDb
| Int
ghcVersion forall a. Ord a => a -> a -> Bool
< Int
706 = [String
"-global-package-conf"]
| Bool
otherwise = [String
"-global-package-db"]
ghcDbOpt GhcPkgDb
UserDb
| Int
ghcVersion forall a. Ord a => a -> a -> Bool
< Int
706 = [String
"-user-package-conf"]
| Bool
otherwise = [String
"-user-package-db"]
ghcDbOpt (PackageDb String
pkgDb)
| Int
ghcVersion forall a. Ord a => a -> a -> Bool
< Int
706 = [String
"-no-user-package-conf", String
"-package-conf", String
pkgDb]
| Bool
otherwise = [String
"-no-user-package-db", String
"-package-db", String
pkgDb]