{-# LANGUAGE BangPatterns, ScopedTypeVariables, 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 (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

-- | 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 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 -- ^ 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 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]


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

-- | 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 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 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]