ghc-mod/core/GhcMod/GhcPkg.hs

110 lines
3.7 KiB
Haskell
Raw Normal View History

{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}
module GhcMod.GhcPkg (
ghcPkgDbOpt
, ghcPkgDbStackOpts
, ghcDbStackOpts
, ghcDbOpt
, getPackageDbStack
2014-11-01 21:02:47 +00:00
, getPackageCachePaths
, getGhcPkgProgram
) where
2014-09-23 04:47:32 +00:00
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
2015-08-03 01:09:56 +00:00
import Control.Applicative
2014-04-30 23:48:49 +00:00
import Data.List.Split (splitOn)
import Data.Maybe
2014-09-23 04:47:32 +00:00
import Exception (handleIO)
import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
2014-04-16 02:32:36 +00:00
import System.FilePath ((</>))
2015-08-03 01:09:56 +00:00
import Prelude
import GhcMod.Types
import GhcMod.Monad.Types
import GhcMod.CabalHelper
import GhcMod.PathsAndFiles
import GhcMod.CustomPackageDb
import GhcMod.Stack
ghcVersion :: Int
ghcVersion = read cProjectVersionInt
2014-09-23 04:47:32 +00:00
----------------------------------------------------------------
-- | Get options needed to add a list of package dbs to ghc-pkg's db stack
ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
-> [String]
2014-04-16 02:52:49 +00:00
ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs
-- | Get options needed to add a list of package dbs to ghc's db stack
ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
2014-04-16 02:50:31 +00:00
-> [String]
2014-04-16 02:52:49 +00:00
ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs
2014-09-23 04:47:32 +00:00
----------------------------------------------------------------
ghcPkgDbOpt :: GhcPkgDb -> [String]
ghcPkgDbOpt GlobalDb = ["--global"]
ghcPkgDbOpt UserDb = ["--user"]
ghcPkgDbOpt (PackageDb pkgDb)
2014-04-16 02:50:31 +00:00
| ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]
| otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb]
ghcDbOpt :: GhcPkgDb -> [String]
2014-04-16 02:50:31 +00:00
ghcDbOpt GlobalDb
| ghcVersion < 706 = ["-global-package-conf"]
| otherwise = ["-global-package-db"]
ghcDbOpt UserDb
| ghcVersion < 706 = ["-user-package-conf"]
| otherwise = ["-user-package-db"]
ghcDbOpt (PackageDb pkgDb)
2014-04-16 02:50:31 +00:00
| ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]
| otherwise = ["-no-user-package-db", "-package-db", pkgDb]
2014-09-23 04:47:32 +00:00
----------------------------------------------------------------
getGhcPkgProgram :: IOish m => GhcModT m FilePath
getGhcPkgProgram = do
crdl <- cradle
progs <- optPrograms <$> options
case cradleProject crdl of
(StackProject senv) -> do
Just ghcPkg <- getStackGhcPkgPath senv
return ghcPkg
_ ->
return $ ghcPkgProgram progs
getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]
getPackageDbStack = do
crdl <- cradle
mCusPkgStack <- getCustomPkgDbStack
stack <- case cradleProject crdl of
2015-08-12 07:25:13 +00:00
PlainProject ->
return [GlobalDb, UserDb]
SandboxProject -> do
Just db <- liftIO $ getSandboxDb crdl
2015-08-12 07:25:13 +00:00
return $ [GlobalDb, db]
CabalProject ->
getCabalPackageDbStack
(StackProject StackEnv {..}) ->
return $ [GlobalDb, PackageDb seSnapshotPkgDb, PackageDb seLocalPkgDb]
return $ fromMaybe stack mCusPkgStack
getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
getPackageCachePaths sysPkgCfg = do
pkgDbStack <- getPackageDbStack
catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack
2014-09-23 04:47:32 +00:00
2014-11-01 21:02:47 +00:00
-- TODO: use PkgConfRef
2014-09-23 04:47:32 +00:00
--- Copied from ghc module `Packages' unfortunately it's not exported :/
2014-11-01 21:02:47 +00:00
resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath)
resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg
resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do
appdir <- getAppUserDataDirectory "ghc"
let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
pkgconf = dir </> "package.conf.d"
exist <- doesDirectoryExist pkgconf
return $ if exist then Just pkgconf else Nothing
where
2014-09-23 04:47:32 +00:00
[target_arch,_,target_os] = splitOn "-" cTargetPlatformString
2014-11-01 21:02:47 +00:00
resolvePackageConfig _ (PackageDb name) = return $ Just name