{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}
module Hhp.GhcPkg (
ghcPkgList
, ghcPkgListEx
, ghcPkgDbOpt
, ghcPkgDbStackOpts
, ghcDbStackOpts
, ghcDbOpt
, getSandboxDb
, getPackageDbStack
) where
import 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 = read cProjectVersionInt
getSandboxDb :: FilePath
-> IO FilePath
getSandboxDb cdir = getSandboxDbDir (cdir </> "cabal.sandbox.config")
getSandboxDbDir :: FilePath
-> IO FilePath
getSandboxDbDir sconf = do
!path <- extractValue . parse <$> readFile sconf
return path
where
key = "package-db:"
keyLen = length key
parse = head . filter (key `isPrefixOf`) . lines
extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
getPackageDbStack :: FilePath
-> IO [GhcPkgDb]
getPackageDbStack cdir =
(getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])
`E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]
ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName]
ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs
where fst3 (x,_,_) = x
ghcPkgListEx :: [GhcPkgDb] -> IO [Package]
ghcPkgListEx dbs = do
(rv,output,err) <- readProcessWithExitCode "ghc-pkg" opts ""
case rv of
ExitFailure val -> do
hPutStrLn stderr err
fail $ "ghc-pkg " ++ unwords opts ++ " (exit " ++ show val ++ ")"
ExitSuccess -> return ()
return $ parseGhcPkgOutput $ lines output
where
opts = ["list", "-v"] ++ ghcPkgDbStackOpts dbs
parseGhcPkgOutput :: [String] -> [Package]
parseGhcPkgOutput [] = []
parseGhcPkgOutput (l:ls) =
parseGhcPkgOutput ls ++ case l of
[] -> []
h:_ | isSpace h -> maybeToList $ packageLine l
| otherwise -> []
packageLine :: String -> Maybe Package
packageLine l =
case listToMaybe $ P.readP_to_S packageLineP l of
Just ((Normal,p),_) -> Just p
Just ((Hidden,p),_) -> Just p
_ -> Nothing
data PackageState = Normal | Hidden | Broken deriving (Eq,Show)
packageLineP :: ReadP (PackageState, Package)
packageLineP = do
P.skipSpaces
p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP
, (Broken,) <$> between (char '{') (char '}') packageP
, (Normal,) <$> packageP ]
eof
return p
packageP :: ReadP (PackageBaseName, PackageVersion, PackageId)
packageP = do
pkgSpec@(name,ver) <- packageSpecP
P.skipSpaces
i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec
return (name,ver,i)
packageSpecP :: ReadP (PackageBaseName,PackageVersion)
packageSpecP = do
fs <- many1 packageCompCharP `sepBy1` char '-'
return (intercalate "-" (init fs), last fs)
packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId
packageIdSpecP (name,ver) = do
_ <- string name >> char '-' >> string ver
choice [ char '-' >> many1 (P.satisfy isAlphaNum)
, return ""]
packageCompCharP :: ReadP Char
packageCompCharP =
P.satisfy $ \c -> isAlphaNum c || c `elem` "_-."
ghcPkgDbStackOpts :: [GhcPkgDb]
-> [String]
ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs
ghcDbStackOpts :: [GhcPkgDb]
-> [String]
ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs
ghcPkgDbOpt :: GhcPkgDb -> [String]
ghcPkgDbOpt GlobalDb = ["--global"]
ghcPkgDbOpt UserDb = ["--user"]
ghcPkgDbOpt (PackageDb pkgDb)
| ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]
| otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb]
ghcDbOpt :: GhcPkgDb -> [String]
ghcDbOpt GlobalDb
| ghcVersion < 706 = ["-global-package-conf"]
| otherwise = ["-global-package-db"]
ghcDbOpt UserDb
| ghcVersion < 706 = ["-user-package-conf"]
| otherwise = ["-user-package-db"]
ghcDbOpt (PackageDb pkgDb)
| ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]
| otherwise = ["-no-user-package-db", "-package-db", pkgDb]