GhcPkg.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Hhp.GhcPkg (
    ghcPkgList,
    ghcPkgListEx,
    ghcPkgDbOpt,
    ghcPkgDbStackOpts,
    ghcDbStackOpts,
    ghcDbOpt,
    getSandboxDb,
    getPackageDbStack,
) where

import GHC.Settings.Config (cProjectVersionInt) -- ghc version

import Control.Exception (SomeException (..))
import qualified Control.Exception as E
import Data.Char (isAlphaNum, isSpace)
import Data.List (dropWhileEnd, intercalate, isPrefixOf)
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,
    between,
    char,
    choice,
    eof,
    many1,
    sepBy1,
    string,
 )
import qualified Text.ParserCombinators.ReadP as P

import Hhp.Types

ghcVersion :: Int
ghcVersion = read cProjectVersionInt

-- | Get path to sandbox package db
getSandboxDb
    :: FilePath
    -- ^ Path to the cabal package root directory
    -- (containing the @cabal.sandbox.config@ file)
    -> IO FilePath
getSandboxDb cdir = getSandboxDbDir (cdir </> "cabal.sandbox.config")

-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
--   Exception is thrown if the sandbox config file is broken.
getSandboxDbDir
    :: FilePath
    -- ^ Path to the @cabal.sandbox.config@ file
    -> IO FilePath
getSandboxDbDir sconf = do
    -- Be strict to ensure that an error can be caught.
    !path <- extractValue . parse <$> readFile sconf
    return path
  where
    key = "package-db:"
    keyLen = length key

    parse = unsafeHead . filter (key `isPrefixOf`) . lines
    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen

getPackageDbStack
    :: FilePath
    -- ^ Project Directory (where the
    -- cabal.sandbox.config file would be if it
    -- exists)
    -> IO [GhcPkgDb]
getPackageDbStack cdir =
    (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])
        `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]

-- | List packages in one or more ghc package store
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` "_-."

-- | Get options needed to add a list of package dbs to ghc-pkg's db stack
ghcPkgDbStackOpts
    :: [GhcPkgDb]
    -- ^ Package db stack
    -> [String]
ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs

-- | Get options needed to add a list of package dbs to ghc's db stack
ghcDbStackOpts
    :: [GhcPkgDb]
    -- ^ Package db stack
    -> [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]