110 lines
3.8 KiB
Haskell
110 lines
3.8 KiB
Haskell
{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}
|
|
module Language.Haskell.GhcMod.GhcPkg (
|
|
ghcPkgDbOpt
|
|
, ghcPkgDbStackOpts
|
|
, ghcDbStackOpts
|
|
, ghcDbOpt
|
|
, getPackageDbStack
|
|
, getPackageCachePaths
|
|
, getGhcPkgProgram
|
|
) where
|
|
|
|
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
|
|
import Control.Applicative
|
|
import Data.List.Split (splitOn)
|
|
import Data.Maybe
|
|
import Exception (handleIO)
|
|
import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
|
|
import System.FilePath ((</>))
|
|
import Prelude
|
|
|
|
import Language.Haskell.GhcMod.Types
|
|
import Language.Haskell.GhcMod.Monad.Types
|
|
import Language.Haskell.GhcMod.CabalHelper
|
|
import Language.Haskell.GhcMod.PathsAndFiles
|
|
import Language.Haskell.GhcMod.CustomPackageDb
|
|
import Language.Haskell.GhcMod.Stack
|
|
|
|
ghcVersion :: Int
|
|
ghcVersion = read cProjectVersionInt
|
|
|
|
----------------------------------------------------------------
|
|
|
|
-- | Get options needed to add a list of package dbs to ghc-pkg's db stack
|
|
ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
|
|
-> [String]
|
|
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
|
|
-> [String]
|
|
ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs
|
|
|
|
----------------------------------------------------------------
|
|
|
|
ghcPkgDbOpt :: GhcPkgDb -> [String]
|
|
ghcPkgDbOpt GlobalDb = ["--global"]
|
|
ghcPkgDbOpt UserDb = ["--user"]
|
|
ghcPkgDbOpt (PackageDb pkgDb)
|
|
| ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]
|
|
| otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb]
|
|
|
|
ghcDbOpt :: GhcPkgDb -> [String]
|
|
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)
|
|
| ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]
|
|
| otherwise = ["-no-user-package-db", "-package-db", pkgDb]
|
|
|
|
----------------------------------------------------------------
|
|
|
|
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
|
|
PlainProject ->
|
|
return [GlobalDb, UserDb]
|
|
SandboxProject -> do
|
|
Just db <- liftIO $ getSandboxDb crdl
|
|
return $ [GlobalDb, db]
|
|
CabalProject ->
|
|
getCabalPackageDbStack
|
|
(StackProject StackEnv {..}) ->
|
|
return $ map PackageDb [seSnapshotPkgDb, seLocalPkgDb]
|
|
return $ fromMaybe stack mCusPkgStack
|
|
|
|
getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
|
|
getPackageCachePaths sysPkgCfg = do
|
|
pkgDbStack <- getPackageDbStack
|
|
catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack
|
|
|
|
-- TODO: use PkgConfRef
|
|
--- Copied from ghc module `Packages' unfortunately it's not exported :/
|
|
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
|
|
[target_arch,_,target_os] = splitOn "-" cTargetPlatformString
|
|
resolvePackageConfig _ (PackageDb name) = return $ Just name
|