moving PackageDb stuff to GhcPkg.
This commit is contained in:
Kazu Yamamoto
parent
dfbb9de8b5
commit
d831d6aa59
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue