FindPackageDBs.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Halive.FindPackageDBs where
import Data.Maybe

import Control.Monad.IO.Class
import Data.Char
import Data.List
import System.Directory
import System.FilePath
import System.Process
import Control.Exception
import DynFlags

-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
--   Exception is thrown if the sandbox config file is broken.
extractKey :: String -> String -> Maybe FilePath
extractKey key conf = extractValue <$> parse conf
  where
    keyLen = length key

    parse = listToMaybe . filter (key `isPrefixOf`) . lines
    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
-- From ghc-mod
mightExist :: FilePath -> IO (Maybe FilePath)
mightExist f = do
    exists <- doesFileExist f
    return $ if exists then (Just f) else (Nothing)

addExtraPkgConfs :: [FilePath] -> DynFlags -> DynFlags
addExtraPkgConfs pkgConfs dflags = dflags
    { packageDBFlags =
        let newPkgConfs = map (PackageDB . PkgConfFile) pkgConfs
        in newPkgConfs ++ packageDBFlags dflags
    }


------------------------
---------- Cabal Sandbox
------------------------

-- | Get path to sandbox's package DB via the cabal.sandbox.config file
getSandboxDb :: IO (Maybe FilePath)
getSandboxDb = do
    currentDir <- getCurrentDirectory
    config <- traverse readFile =<< mightExist (currentDir </> "cabal.sandbox.config")
    return $ (extractKey "package-db:" =<< config)

updateDynFlagsWithCabalSandbox :: MonadIO m => DynFlags -> m DynFlags
updateDynFlagsWithCabalSandbox dflags =
    liftIO getSandboxDb >>= \case
        Nothing -> return dflags
        Just sandboxDB -> do
            let pkgs = map (PackageDB . PkgConfFile) [sandboxDB]
            return dflags { packageDBFlags = pkgs ++  packageDBFlags dflags }

------------------------
---------- Stack project
------------------------

-- | Get path to the project's snapshot and local package DBs via 'stack path'
getStackDb :: IO (Maybe [FilePath])
getStackDb = do
    pathInfo <- readProcess "stack" ["path"] "" `catch` (\(_e::IOException) -> return [])
    return . Just . catMaybes $ map (flip extractKey pathInfo)
        ["global-pkg-db:", "local-pkg-db:", "snapshot-pkg-db:"]

updateDynFlagsWithStackDB :: MonadIO m => DynFlags -> m DynFlags
updateDynFlagsWithStackDB dflags =
    liftIO getStackDb >>= \case
        Nothing -> return dflags
        Just stackDBs -> do
            let pkgs = map (PackageDB . PkgConfFile) stackDBs
            return dflags { packageDBFlags = pkgs ++ packageDBFlags dflags }

updateDynFlagsWithGlobalDB :: MonadIO m => DynFlags -> m DynFlags
updateDynFlagsWithGlobalDB dflags = do
    xs <- liftIO $ lines <$> readProcess "ghc" ["--print-global-package-db"] ""
        `catch` (\(_e :: SomeException) -> return [])
    case xs of
        [pkgconf] -> do
          let flgs = PackageDB (PkgConfFile pkgconf) : packageDBFlags dflags
          return dflags { packageDBFlags = flgs }
        _ -> return dflags