{-# 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 :: Int
ghcVersion = String -> Int
forall a. Read a => String -> a
read String
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 :: String -> IO String
getSandboxDb String
cdir = String -> IO String
getSandboxDbDir (String
cdir String -> String -> String
</> String
"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 :: String -> IO String
getSandboxDbDir String
sconf = do
    -- Be strict to ensure that an error can be caught.
    !String
path <- String -> String
extractValue (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
parse (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
sconf
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
  where
    key :: String
key = String
"package-db:"
    keyLen :: Int
keyLen = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
key

    parse :: String -> String
parse = [String] -> String
forall a. [a] -> a
unsafeHead ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
key String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    extractValue :: String -> String
extractValue = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
keyLen

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

-- | List packages in one or more ghc package store
ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName]
ghcPkgList :: [GhcPkgDb] -> IO [String]
ghcPkgList [GhcPkgDb]
dbs = ((String, String, String) -> String)
-> [(String, String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, String) -> String
forall {a} {b} {c}. (a, b, c) -> a
fst3 ([(String, String, String)] -> [String])
-> IO [(String, String, String)] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GhcPkgDb] -> IO [(String, String, String)]
ghcPkgListEx [GhcPkgDb]
dbs
  where
    fst3 :: (a, b, c) -> a
fst3 (a
x, b
_, c
_) = a
x

ghcPkgListEx :: [GhcPkgDb] -> IO [Package]
ghcPkgListEx :: [GhcPkgDb] -> IO [(String, String, String)]
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
            String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ghc-pkg " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
opts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (exit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
        ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    [(String, String, String)] -> IO [(String, String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String, String)] -> IO [(String, String, String)])
-> [(String, String, String)] -> IO [(String, String, String)]
forall a b. (a -> b) -> a -> b
$ [String] -> [(String, String, String)]
parseGhcPkgOutput ([String] -> [(String, String, String)])
-> [String] -> [(String, String, String)]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
output
  where
    opts :: [String]
opts = [String
"list", String
"-v"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [GhcPkgDb] -> [String]
ghcPkgDbStackOpts [GhcPkgDb]
dbs

parseGhcPkgOutput :: [String] -> [Package]
parseGhcPkgOutput :: [String] -> [(String, String, String)]
parseGhcPkgOutput [] = []
parseGhcPkgOutput (String
l : [String]
ls) =
    [String] -> [(String, String, String)]
parseGhcPkgOutput [String]
ls [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++ case String
l of
        [] -> []
        Char
h : String
_
            | Char -> Bool
isSpace Char
h -> Maybe (String, String, String) -> [(String, String, String)]
forall a. Maybe a -> [a]
maybeToList (Maybe (String, String, String) -> [(String, String, String)])
-> Maybe (String, String, String) -> [(String, String, String)]
forall a b. (a -> b) -> a -> b
$ String -> Maybe (String, String, String)
packageLine String
l
            | Bool
otherwise -> []

packageLine :: String -> Maybe Package
packageLine :: String -> Maybe (String, String, String)
packageLine String
l =
    case [((PackageState, (String, String, String)), String)]
-> Maybe ((PackageState, (String, String, String)), String)
forall a. [a] -> Maybe a
listToMaybe ([((PackageState, (String, String, String)), String)]
 -> Maybe ((PackageState, (String, String, String)), String))
-> [((PackageState, (String, String, String)), String)]
-> Maybe ((PackageState, (String, String, String)), String)
forall a b. (a -> b) -> a -> b
$ ReadP (PackageState, (String, String, String))
-> ReadS (PackageState, (String, String, String))
forall a. ReadP a -> ReadS a
P.readP_to_S ReadP (PackageState, (String, String, String))
packageLineP String
l of
        Just ((PackageState
Normal, (String, String, String)
p), String
_) -> (String, String, String) -> Maybe (String, String, String)
forall a. a -> Maybe a
Just (String, String, String)
p
        Just ((PackageState
Hidden, (String, String, String)
p), String
_) -> (String, String, String) -> Maybe (String, String, String)
forall a. a -> Maybe a
Just (String, String, String)
p
        Maybe ((PackageState, (String, String, String)), String)
_ -> Maybe (String, String, String)
forall a. Maybe a
Nothing

data PackageState = Normal | Hidden | Broken deriving (PackageState -> PackageState -> Bool
(PackageState -> PackageState -> Bool)
-> (PackageState -> PackageState -> Bool) -> Eq PackageState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PackageState -> PackageState -> Bool
== :: PackageState -> PackageState -> Bool
$c/= :: PackageState -> PackageState -> Bool
/= :: PackageState -> PackageState -> Bool
Eq, Int -> PackageState -> String -> String
[PackageState] -> String -> String
PackageState -> String
(Int -> PackageState -> String -> String)
-> (PackageState -> String)
-> ([PackageState] -> String -> String)
-> Show PackageState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PackageState -> String -> String
showsPrec :: Int -> PackageState -> String -> String
$cshow :: PackageState -> String
show :: PackageState -> String
$cshowList :: [PackageState] -> String -> String
showList :: [PackageState] -> String -> String
Show)

packageLineP :: ReadP (PackageState, Package)
packageLineP :: ReadP (PackageState, (String, String, String))
packageLineP = do
    ReadP ()
P.skipSpaces
    (PackageState, (String, String, String))
p <-
        [ReadP (PackageState, (String, String, String))]
-> ReadP (PackageState, (String, String, String))
forall a. [ReadP a] -> ReadP a
choice
            [ (PackageState
Hidden,) ((String, String, String)
 -> (PackageState, (String, String, String)))
-> ReadP (String, String, String)
-> ReadP (PackageState, (String, String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Char
-> ReadP Char
-> ReadP (String, String, String)
-> ReadP (String, String, String)
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'(') (Char -> ReadP Char
char Char
')') ReadP (String, String, String)
packageP
            , (PackageState
Broken,) ((String, String, String)
 -> (PackageState, (String, String, String)))
-> ReadP (String, String, String)
-> ReadP (PackageState, (String, String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Char
-> ReadP Char
-> ReadP (String, String, String)
-> ReadP (String, String, String)
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'{') (Char -> ReadP Char
char Char
'}') ReadP (String, String, String)
packageP
            , (PackageState
Normal,) ((String, String, String)
 -> (PackageState, (String, String, String)))
-> ReadP (String, String, String)
-> ReadP (PackageState, (String, String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP (String, String, String)
packageP
            ]
    ReadP ()
eof
    (PackageState, (String, String, String))
-> ReadP (PackageState, (String, String, String))
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageState, (String, String, String))
p

packageP :: ReadP (PackageBaseName, PackageVersion, PackageId)
packageP :: ReadP (String, String, String)
packageP = do
    pkgSpec :: (String, String)
pkgSpec@(String
name, String
ver) <- ReadP (String, String)
packageSpecP
    ReadP ()
P.skipSpaces
    String
i <- ReadP Char -> ReadP Char -> ReadP String -> ReadP String
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'(') (Char -> ReadP Char
char Char
')') (ReadP String -> ReadP String) -> ReadP String -> ReadP String
forall a b. (a -> b) -> a -> b
$ (String, String) -> ReadP String
packageIdSpecP (String, String)
pkgSpec
    (String, String, String) -> ReadP (String, String, String)
forall a. a -> ReadP a
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 <- ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
many1 ReadP Char
packageCompCharP ReadP String -> ReadP Char -> ReadP [String]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`sepBy1` Char -> ReadP Char
char Char
'-'
    (String, String) -> ReadP (String, String)
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
init [String]
fs), [String] -> String
forall a. HasCallStack => [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 ReadP String -> ReadP Char -> ReadP Char
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
char Char
'-' ReadP Char -> ReadP String -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ReadP String
string String
ver
    [ReadP String] -> ReadP String
forall a. [ReadP a] -> ReadP a
choice
        [ Char -> ReadP Char
char Char
'-' ReadP Char -> ReadP String -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
P.satisfy Char -> Bool
isAlphaNum)
        , String -> ReadP String
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
        ]

packageCompCharP :: ReadP Char
packageCompCharP :: ReadP Char
packageCompCharP =
    (Char -> Bool) -> ReadP Char
P.satisfy ((Char -> Bool) -> ReadP Char) -> (Char -> Bool) -> ReadP Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"_-."

-- | Get options needed to add a list of package dbs to ghc-pkg's db stack
ghcPkgDbStackOpts
    :: [GhcPkgDb]
    -- ^ Package db stack
    -> [String]
ghcPkgDbStackOpts :: [GhcPkgDb] -> [String]
ghcPkgDbStackOpts [GhcPkgDb]
dbs = GhcPkgDb -> [String]
ghcPkgDbOpt (GhcPkgDb -> [String]) -> [GhcPkgDb] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
`concatMap` [GhcPkgDb]
dbs

-- | Get options needed to add a list of package dbs to ghc's db stack
ghcDbStackOpts
    :: [GhcPkgDb]
    -- ^ Package db stack
    -> [String]
ghcDbStackOpts :: [GhcPkgDb] -> [String]
ghcDbStackOpts [GhcPkgDb]
dbs = GhcPkgDb -> [String]
ghcDbOpt (GhcPkgDb -> [String]) -> [GhcPkgDb] -> [String]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
706 = [String
"--no-user-package-conf", String
"--package-conf=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgDb]
    | Bool
otherwise = [String
"--no-user-package-db", String
"--package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgDb]

ghcDbOpt :: GhcPkgDb -> [String]
ghcDbOpt :: GhcPkgDb -> [String]
ghcDbOpt GhcPkgDb
GlobalDb
    | Int
ghcVersion Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
706 = [String
"-global-package-conf"]
    | Bool
otherwise = [String
"-global-package-db"]
ghcDbOpt GhcPkgDb
UserDb
    | Int
ghcVersion Int -> Int -> Bool
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 Int -> Int -> Bool
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]