    {-# 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)
    import qualified Sandbox
    import Control.Exception (try, SomeException)
    import System.Directory (getCurrentDirectory)

    -- | 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 Post76 (PackageDBs user :: Bool
    user global :: Bool
    global extras :: [FilePath]
    extras) =
        (if Bool
    user then [FilePath] -> [FilePath]
    forall a. a -> a
    id else ("-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 ("-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 (\extra :: FilePath
    extra -> ["-package-db", FilePath
    extra]) [FilePath]
    extras
    dbArgs Pre76 (PackageDBs _ False _) =
        FilePath -> [FilePath]
    forall a. HasCallStack => FilePath -> a
    error "Global package database must be included with GHC < 7.6"
    dbArgs Pre76 (PackageDBs user :: Bool
    user True extras :: [FilePath]
    extras) =
        (if Bool
    user then [FilePath] -> [FilePath]
    forall a. a -> a
    id else ("-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 (\extra :: FilePath
    extra -> ["-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 and cabal sandbox
    -- information
    getPackageDBsFromEnv :: IO PackageDBs
    getPackageDBsFromEnv :: IO PackageDBs
    getPackageDBsFromEnv = do
        [(FilePath, FilePath)]
    env <- IO [(FilePath, FilePath)]
    getEnvironment
        case () of
            ()
                | Just sandboxes :: FilePath
    sandboxes <- FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup "HASKELL_PACKAGE_SANDBOXES" [(FilePath, FilePath)]
    env
                    -> 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
    $ FilePath -> PackageDBs
    fromEnvMulti FilePath
    sandboxes
                | Just extra :: FilePath
    extra <- FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup "HASKELL_PACKAGE_SANDBOX" [(FilePath, FilePath)]
    env
                    -> PackageDBs -> IO PackageDBs
    forall (m :: * -> *) a. Monad m => a -> m a
    return PackageDBs :: Bool -> Bool -> [FilePath] -> PackageDBs
    PackageDBs
                        { includeUser :: Bool
    includeUser = Bool
    True
                        , includeGlobal :: Bool
    includeGlobal = Bool
    True
                        , extraDBs :: [FilePath]
    extraDBs = [FilePath
    extra]
                        }
                | Just sandboxes :: FilePath
    sandboxes <- FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup "GHC_PACKAGE_PATH" [(FilePath, FilePath)]
    env
                    -> 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
    $ FilePath -> PackageDBs
    fromEnvMulti FilePath
    sandboxes
                | Bool
    otherwise -> do
                    Either SomeException FilePath
    eres <- IO FilePath -> IO (Either SomeException FilePath)
    forall e a. Exception e => IO a -> IO (Either e a)
    try (IO FilePath -> IO (Either SomeException FilePath))
    -> IO FilePath -> IO (Either SomeException FilePath)
    forall a b. (a -> b) -> a -> b
    $ IO FilePath
    getCurrentDirectory
                              IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= FilePath -> IO FilePath
    Sandbox.getSandboxConfigFile
                              IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= FilePath -> IO FilePath
    Sandbox.getPackageDbDir
                    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 Either SomeException FilePath
    eres :: Either SomeException FilePath of
                        Left _ -> Bool -> Bool -> [FilePath] -> PackageDBs
    PackageDBs Bool
    True Bool
    True []
                        Right db :: FilePath
    db -> Bool -> Bool -> [FilePath] -> PackageDBs
    PackageDBs Bool
    False Bool
    True [FilePath
    db]
      where
        fromEnvMulti :: FilePath -> PackageDBs
    fromEnvMulti s :: 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
            (s' :: FilePath
    s', global :: Bool
    global) =
                case ShowS
    forall a. [a] -> [a]
    reverse FilePath
    s of
                    c :: Char
    c:rest :: 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
    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