{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
-- | Manage GHC package databases
module PackageDBs
    ( PackageDBs (..)
    , ArgStyle (..)
    , dbArgs
    , buildArgStyle
    , getPackageDBsFromEnv
    , getPackageDBArgs
    ) where

import System.Environment (getEnvironment)
import System.FilePath (splitSearchPath, searchPathSeparator)

-- | Full stack of GHC package databases
data PackageDBs = PackageDBs
    { PackageDBs -> Bool
includeUser :: Bool
    -- | Unsupported on GHC < 7.6
    , PackageDBs -> Bool
includeGlobal :: Bool
    , PackageDBs -> [FilePath]
extraDBs :: [FilePath]
    }
    deriving (Int -> PackageDBs -> ShowS
[PackageDBs] -> ShowS
PackageDBs -> FilePath
(Int -> PackageDBs -> ShowS)
-> (PackageDBs -> FilePath)
-> ([PackageDBs] -> ShowS)
-> Show PackageDBs
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PackageDBs] -> ShowS
$cshowList :: [PackageDBs] -> ShowS
show :: PackageDBs -> FilePath
$cshow :: PackageDBs -> FilePath
showsPrec :: Int -> PackageDBs -> ShowS
$cshowsPrec :: Int -> PackageDBs -> ShowS
Show, PackageDBs -> PackageDBs -> Bool
(PackageDBs -> PackageDBs -> Bool)
-> (PackageDBs -> PackageDBs -> Bool) -> Eq PackageDBs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageDBs -> PackageDBs -> Bool
$c/= :: PackageDBs -> PackageDBs -> Bool
== :: PackageDBs -> PackageDBs -> Bool
$c== :: PackageDBs -> PackageDBs -> Bool
Eq)

-- | Package database handling switched between GHC 7.4 and 7.6
data ArgStyle = Pre76 | Post76
    deriving (Int -> ArgStyle -> ShowS
[ArgStyle] -> ShowS
ArgStyle -> FilePath
(Int -> ArgStyle -> ShowS)
-> (ArgStyle -> FilePath) -> ([ArgStyle] -> ShowS) -> Show ArgStyle
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ArgStyle] -> ShowS
$cshowList :: [ArgStyle] -> ShowS
show :: ArgStyle -> FilePath
$cshow :: ArgStyle -> FilePath
showsPrec :: Int -> ArgStyle -> ShowS
$cshowsPrec :: Int -> ArgStyle -> ShowS
Show, ArgStyle -> ArgStyle -> Bool
(ArgStyle -> ArgStyle -> Bool)
-> (ArgStyle -> ArgStyle -> Bool) -> Eq ArgStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgStyle -> ArgStyle -> Bool
$c/= :: ArgStyle -> ArgStyle -> Bool
== :: ArgStyle -> ArgStyle -> Bool
$c== :: ArgStyle -> ArgStyle -> Bool
Eq)

-- | Determine command line arguments to be passed to GHC to set databases correctly
--
-- >>> dbArgs Post76 (PackageDBs False True [])
-- ["-no-user-package-db"]
--
-- >>> dbArgs Pre76 (PackageDBs True True ["somedb"])
-- ["-package-conf","somedb"]
dbArgs :: ArgStyle -> PackageDBs -> [String]
dbArgs :: ArgStyle -> PackageDBs -> [FilePath]
dbArgs ArgStyle
Post76 (PackageDBs Bool
user Bool
global [FilePath]
extras) =
    (if Bool
user then [FilePath] -> [FilePath]
forall a. a -> a
id else (FilePath
"-no-user-package-db"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
    (if Bool
global then [FilePath] -> [FilePath]
forall a. a -> a
id else (FilePath
"-no-global-package-db"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
    (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FilePath
extra -> [FilePath
"-package-db", FilePath
extra]) [FilePath]
extras
dbArgs ArgStyle
Pre76 (PackageDBs Bool
_ Bool
False [FilePath]
_) =
    FilePath -> [FilePath]
forall a. HasCallStack => FilePath -> a
error FilePath
"Global package database must be included with GHC < 7.6"
dbArgs ArgStyle
Pre76 (PackageDBs Bool
user Bool
True [FilePath]
extras) =
    (if Bool
user then [FilePath] -> [FilePath]
forall a. a -> a
id else (FilePath
"-no-user-package-conf"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
    (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FilePath
extra -> [FilePath
"-package-conf", FilePath
extra]) [FilePath]
extras

-- | The argument style to be used with the current GHC version
buildArgStyle :: ArgStyle
#if __GLASGOW_HASKELL__ >= 706
buildArgStyle :: ArgStyle
buildArgStyle = ArgStyle
Post76
#else
buildArgStyle = Pre76
#endif

-- | Determine the PackageDBs based on the environment.
getPackageDBsFromEnv :: IO PackageDBs
getPackageDBsFromEnv :: IO PackageDBs
getPackageDBsFromEnv = do
    [(FilePath, FilePath)]
env <- IO [(FilePath, FilePath)]
getEnvironment
    PackageDBs -> IO PackageDBs
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDBs -> IO PackageDBs) -> PackageDBs -> IO PackageDBs
forall a b. (a -> b) -> a -> b
$ case () of
        ()
            | Just FilePath
packageDBs <- FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"GHC_PACKAGE_PATH" [(FilePath, FilePath)]
env
                -> FilePath -> PackageDBs
fromEnvMulti FilePath
packageDBs
            | Bool
otherwise
                -> Bool -> Bool -> [FilePath] -> PackageDBs
PackageDBs Bool
True Bool
True []
  where
    fromEnvMulti :: FilePath -> PackageDBs
fromEnvMulti FilePath
s = PackageDBs :: Bool -> Bool -> [FilePath] -> PackageDBs
PackageDBs
        { includeUser :: Bool
includeUser = Bool
False
        , includeGlobal :: Bool
includeGlobal = Bool
global
        , extraDBs :: [FilePath]
extraDBs = FilePath -> [FilePath]
splitSearchPath FilePath
s'
        }
      where
        (FilePath
s', Bool
global) =
            case ShowS
forall a. [a] -> [a]
reverse FilePath
s of
                Char
c:FilePath
rest | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
searchPathSeparator -> (ShowS
forall a. [a] -> [a]
reverse FilePath
rest, Bool
True)
                FilePath
_ -> (FilePath
s, Bool
False)

-- | Get the package DB flags for the current GHC version and from the
-- environment.
getPackageDBArgs :: IO [String]
getPackageDBArgs :: IO [FilePath]
getPackageDBArgs = do
      PackageDBs
dbs <- IO PackageDBs
getPackageDBsFromEnv
      [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ ArgStyle -> PackageDBs -> [FilePath]
dbArgs ArgStyle
buildArgStyle PackageDBs
dbs