{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module PackageDBs
( PackageDBs (..)
, ArgStyle (..)
, dbArgs
, buildArgStyle
, getPackageDBsFromEnv
, getPackageDBArgs
) where
import System.Environment (getEnvironment)
import System.FilePath (splitSearchPath, searchPathSeparator)
import qualified Sandbox
import Control.Exception (try, SomeException)
import System.Directory (getCurrentDirectory)
data PackageDBs = PackageDBs
{ includeUser :: Bool
, includeGlobal :: Bool
, extraDBs :: [FilePath]
}
deriving (Show, Eq)
data ArgStyle = Pre76 | Post76
deriving (Show, Eq)
dbArgs :: ArgStyle -> PackageDBs -> [String]
dbArgs Post76 (PackageDBs user global extras) =
(if user then id else ("-no-user-package-db":)) $
(if global then id else ("-no-global-package-db":)) $
concatMap (\extra -> ["-package-db", extra]) extras
dbArgs Pre76 (PackageDBs _ False _) =
error "Global package database must be included with GHC < 7.6"
dbArgs Pre76 (PackageDBs user True extras) =
(if user then id else ("-no-user-package-conf":)) $
concatMap (\extra -> ["-package-conf", extra]) extras
buildArgStyle :: ArgStyle
#if __GLASGOW_HASKELL__ >= 706
buildArgStyle = Post76
#else
buildArgStyle = Pre76
#endif
getPackageDBsFromEnv :: IO PackageDBs
getPackageDBsFromEnv = do
env <- getEnvironment
case () of
()
| Just sandboxes <- lookup "HASKELL_PACKAGE_SANDBOXES" env
-> return $ fromEnvMulti sandboxes
| Just extra <- lookup "HASKELL_PACKAGE_SANDBOX" env
-> return PackageDBs
{ includeUser = True
, includeGlobal = True
, extraDBs = [extra]
}
| Just sandboxes <- lookup "GHC_PACKAGE_PATH" env
-> return $ fromEnvMulti sandboxes
| otherwise -> do
eres <- try $ getCurrentDirectory
>>= Sandbox.getSandboxConfigFile
>>= Sandbox.getPackageDbDir
return $ case eres :: Either SomeException FilePath of
Left _ -> PackageDBs True True []
Right db -> PackageDBs False True [db]
where
fromEnvMulti s = PackageDBs
{ includeUser = False
, includeGlobal = global
, extraDBs = splitSearchPath s'
}
where
(s', global) =
case reverse s of
c:rest | c == searchPathSeparator -> (reverse rest, True)
_ -> (s, False)
getPackageDBArgs :: IO [String]
getPackageDBArgs = do
dbs <- getPackageDBsFromEnv
return $ dbArgs buildArgStyle dbs