From d831d6aa59bf519ab1b5e20b02b74b48fa0ef151 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 23 Sep 2014 13:47:32 +0900 Subject: [PATCH] moving PackageDb stuff to GhcPkg. --- Language/Haskell/GhcMod/Find.hs | 39 +++++---------------------- Language/Haskell/GhcMod/GhcPkg.hs | 44 ++++++++++++++++++++++++++++++- 2 files changed, 49 insertions(+), 34 deletions(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 0cfc457..359103b 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -15,23 +15,20 @@ module Language.Haskell.GhcMod.Find #endif where -import Config (cProjectVersion,cTargetPlatformString) import Control.Applicative ((<$>)) import Control.Monad (when, void) import Control.Monad.Error.Class import Data.Function (on) import Data.List (groupBy, sort) -import Data.List.Split (splitOn) import Data.Maybe (fromMaybe) -import DynFlags (DynFlags(..), systemPackageConfig) -import Exception (handleIO) import qualified GHC as G import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils import Name (getOccString) -import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime) +import System.Directory (doesFileExist, getModificationTime) import System.FilePath ((), takeDirectory) import System.IO import System.Environment @@ -73,12 +70,6 @@ symbolCacheVersion = 0 symbolCache :: String symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache" -packageCache :: String -packageCache = "package.cache" - -packageConfDir :: String -packageConfDir = "package.conf.d" - ---------------------------------------------------------------- -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] @@ -137,20 +128,15 @@ ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when ---------------------------------------------------------------- -- used 'ghc-mod dumpsym' -getSymbolCachePath :: IOish m => GhcModT m FilePath -getSymbolCachePath = do - u:_ <- filter (/= GlobalDb) . cradlePkgDbStack <$> cradle - Just db <- (liftIO . flip resolvePackageDb u) =<< G.getSessionDynFlags - return db - `catchError` const (fail "Couldn't find non-global package database for symbol cache") - -- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file -- if the file does not exist or is invalid. -- The file name is printed. dumpSymbol :: IOish m => GhcModT m String dumpSymbol = do - dir <- getSymbolCachePath + crdl <- cradle + dflags <- G.getSessionDynFlags + dir <- liftIO $ getPackageCachePath crdl dflags let cache = dir symbolCache pkgdb = dir packageCache @@ -202,16 +188,3 @@ collectModules :: [(Symbol,ModuleString)] collectModules = map tieup . groupBy ((==) `on` fst) . sort where tieup x = (head (map fst x), map snd x) - ---- Copied from ghc module `Packages' unfortunately it's not exported :/ -resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath) -resolvePackageDb df GlobalDb = return $ Just (systemPackageConfig df) -resolvePackageDb _ (PackageDb name) = return $ Just name -resolvePackageDb _ UserDb = handleIO (\_ -> return Nothing) $ do - appdir <- getAppUserDataDirectory "ghc" - let dir = appdir (target_arch ++ '-':target_os ++ '-':cProjectVersion) - pkgconf = dir packageConfDir - exist <- doesDirectoryExist pkgconf - return $ if exist then Just pkgconf else Nothing - where - [target_arch,_,target_os] = splitOn "-" cTargetPlatformString diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 6c1f5b8..1f94fc5 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -8,9 +8,12 @@ module Language.Haskell.GhcMod.GhcPkg ( , fromInstalledPackageId' , getSandboxDb , getPackageDbStack + , getPackageCachePath + , packageCache + , packageConfDir ) where -import Config (cProjectVersionInt) +import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) import Control.Applicative ((<$>)) import Control.Exception (SomeException(..)) import qualified Control.Exception as E @@ -18,8 +21,11 @@ import Data.Char (isSpace) import Data.List (isPrefixOf, intercalate) import Data.List.Split (splitOn) import Distribution.Package (InstalledPackageId(..)) +import DynFlags (DynFlags(..), systemPackageConfig) +import Exception (handleIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils +import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.FilePath (()) ghcVersion :: Int @@ -46,6 +52,8 @@ getSandboxDbDir sconf = do parse = head . filter (key `isPrefixOf`) . lines extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen +---------------------------------------------------------------- + getPackageDbStack :: FilePath -- ^ Project Directory (where the -- cabal.sandbox.config file would be if it -- exists) @@ -54,6 +62,8 @@ getPackageDbStack cdir = (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db]) `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] +---------------------------------------------------------------- + fromInstalledPackageId' :: InstalledPackageId -> Maybe Package fromInstalledPackageId' pid = let InstalledPackageId pkg = pid @@ -68,6 +78,8 @@ fromInstalledPackageId pid = Nothing -> error $ "fromInstalledPackageId: `"++show pid++"' is not a valid package-id" +---------------------------------------------------------------- + -- | Get options needed to add a list of package dbs to ghc-pkg's db stack ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack -> [String] @@ -78,6 +90,8 @@ ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack -> [String] ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs +---------------------------------------------------------------- + ghcPkgDbOpt :: GhcPkgDb -> [String] ghcPkgDbOpt GlobalDb = ["--global"] ghcPkgDbOpt UserDb = ["--user"] @@ -95,3 +109,31 @@ ghcDbOpt UserDb ghcDbOpt (PackageDb pkgDb) | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb] | otherwise = ["-no-user-package-db", "-package-db", pkgDb] + +---------------------------------------------------------------- + +packageCache :: String +packageCache = "package.cache" + +packageConfDir :: String +packageConfDir = "package.conf.d" + +-- fixme: error handling +getPackageCachePath :: Cradle -> DynFlags -> IO FilePath +getPackageCachePath crdl df = do + let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl + Just db <- resolvePath df u + return db + +--- Copied from ghc module `Packages' unfortunately it's not exported :/ +resolvePath :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath) +resolvePath df GlobalDb = return $ Just (systemPackageConfig df) +resolvePath _ (PackageDb name) = return $ Just name +resolvePath _ UserDb = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir (target_arch ++ '-':target_os ++ '-':cProjectVersion) + pkgconf = dir packageConfDir + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing + where + [target_arch,_,target_os] = splitOn "-" cTargetPlatformString