{-# LANGUAGE CPP #-}
-- | Manage GHC package databases
module PackageDBs (
  getPackageDBArgs
#ifdef TEST
, PackageDBs (..)
, getPackageDBsFromEnv
#endif
) where

import           Imports

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

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

-- | Determine command line arguments to be passed to GHC to set databases correctly
--
-- >>> dbArgs (PackageDBs False True [])
-- ["-no-user-package-db"]
--
-- >>> dbArgs (PackageDBs True True ["somedb"])
-- ["-package-db","somedb"]
dbArgs :: PackageDBs -> [String]
dbArgs :: PackageDBs -> [String]
dbArgs (PackageDBs Bool
user Bool
global [String]
extras) =
    (if Bool
user then [String] -> [String]
forall a. a -> a
id else (String
"-no-user-package-db"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
    (if Bool
global then [String] -> [String]
forall a. a -> a
id else (String
"-no-global-package-db"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
    (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
extra -> [String
"-package-db", String
extra]) [String]
extras

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

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