{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module PackageDBs
( PackageDBs (..)
, ArgStyle (..)
, dbArgs
, buildArgStyle
, getPackageDBsFromEnv
, getPackageDBArgs
) where
import System.Environment (getEnvironment)
import System.FilePath (splitSearchPath, searchPathSeparator)
data PackageDBs = PackageDBs
{ PackageDBs -> Bool
includeUser :: Bool
, PackageDBs -> Bool
includeGlobal :: Bool
, :: [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)
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)
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
buildArgStyle :: ArgStyle
#if __GLASGOW_HASKELL__ >= 706
buildArgStyle :: ArgStyle
buildArgStyle = ArgStyle
Post76
#else
buildArgStyle = Pre76
#endif
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)
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