ghc-mod/Language/Haskell/GhcMod/Find.hs

168 lines
5.0 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP, BangPatterns #-}
2014-04-24 08:02:50 +00:00
module Language.Haskell.GhcMod.Find
#ifndef SPEC
(
Symbol
, SymbolDb
2014-07-17 05:04:28 +00:00
, loadSymbolDb
, lookupSymbol
, dumpSymbol
, findSymbol
2014-07-18 06:13:30 +00:00
, lookupSym
, isOutdated
)
#endif
where
2014-04-24 08:02:50 +00:00
import Control.Applicative ((<$>))
import Control.Monad (when, void)
2014-07-22 20:54:18 +00:00
import Control.Monad.Error.Class
2014-04-24 08:02:50 +00:00
import Data.Function (on)
import Data.List (groupBy, sort)
import Data.Maybe (fromMaybe)
import qualified GHC as G
2014-05-11 22:40:00 +00:00
import Language.Haskell.GhcMod.Convert
2014-09-23 04:47:32 +00:00
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Monad
2014-04-24 12:08:45 +00:00
import Language.Haskell.GhcMod.Types
2014-09-23 04:47:32 +00:00
import Language.Haskell.GhcMod.Utils
import Name (getOccString)
2014-09-23 04:47:32 +00:00
import System.Directory (doesFileExist, getModificationTime)
2014-07-19 02:50:12 +00:00
import System.FilePath ((</>), takeDirectory)
import System.IO
2014-04-24 08:02:50 +00:00
#ifndef MIN_VERSION_containers
#define MIN_VERSION_containers(x,y,z) 1
#endif
#if MIN_VERSION_containers(0,5,0)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
#else
import Data.Map (Map)
import qualified Data.Map as M
#endif
----------------------------------------------------------------
2014-07-17 05:04:28 +00:00
-- | Type of function and operation names.
2014-04-24 08:02:50 +00:00
type Symbol = String
2014-07-17 05:04:28 +00:00
-- | Database from 'Symbol' to \['ModuleString'\].
data SymbolDb = SymbolDb {
table :: Map Symbol [ModuleString]
, packageCachePath :: FilePath
, symbolDbCachePath :: FilePath
} deriving (Show)
isOutdated :: SymbolDb -> IO Bool
isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
----------------------------------------------------------------
-- | When introducing incompatible changes to the 'symbolCache' file format
-- increment this version number.
2014-08-13 16:40:23 +00:00
symbolCacheVersion :: Integer
symbolCacheVersion = 0
-- | Filename of the symbol table cache file.
symbolCache :: String
symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
----------------------------------------------------------------
2014-04-24 08:02:50 +00:00
2014-07-18 06:42:05 +00:00
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated. 'loadSymbolDb' is called internally.
findSymbol :: IOish m => Symbol -> GhcModT m String
findSymbol sym = loadSymbolDb >>= lookupSymbol sym
2014-07-17 05:04:28 +00:00
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated.
2014-07-18 06:13:30 +00:00
lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
lookupSymbol sym db = convert' $ lookupSym sym db
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
---------------------------------------------------------------
2014-07-17 05:04:28 +00:00
-- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
loadSymbolDb = do
ghcMod <- liftIO ghcModExecutable
2014-07-17 14:17:17 +00:00
file <- chop <$> readProcess' ghcMod ["dumpsym"]
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb {
table = db
, packageCachePath = takeDirectory file </> packageCache
, symbolDbCachePath = file
}
2014-04-24 08:02:50 +00:00
where
conv :: String -> (Symbol,[ModuleString])
conv = read
chop "" = ""
chop xs = init xs
----------------------------------------------------------------
-- used 'ghc-mod dumpsym'
2014-07-17 05:04:28 +00:00
-- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file
-- if the file does not exist or is invalid.
-- The file name is printed.
2014-08-06 17:37:59 +00:00
dumpSymbol :: IOish m => GhcModT m String
dumpSymbol = do
2014-09-23 04:47:32 +00:00
crdl <- cradle
dir <- liftIO $ getPackageCachePath crdl
2014-07-22 20:54:18 +00:00
let cache = dir </> symbolCache
pkgdb = dir </> packageCache
create <- liftIO $ cache `isOlderThan` pkgdb
2014-07-22 20:54:18 +00:00
when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
return $ unlines [cache]
writeSymbolCache :: FilePath
-> [(Symbol,[ModuleString])]
-> IO ()
2014-08-14 02:11:02 +00:00
writeSymbolCache cache sm =
2014-07-22 20:54:18 +00:00
void . withFile cache WriteMode $ \hdl ->
mapM (hPrint hdl) sm
isOlderThan :: FilePath -> FilePath -> IO Bool
isOlderThan cache file = do
exist <- doesFileExist cache
if not exist then
return True
else do
tCache <- getModificationTime cache
2014-07-22 20:54:18 +00:00
tFile <- getModificationTime file
return $ tCache <= tFile -- including equal just in case
2014-05-14 16:54:56 +00:00
-- | Browsing all functions in all system/user modules.
2014-07-22 20:54:18 +00:00
getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
getSymbolTable = do
2014-07-23 22:08:47 +00:00
ghcModules <- G.packageDbModules True
moduleInfos <- mapM G.getModuleInfo ghcModules
let modules = do
m <- ghcModules
let moduleName = G.moduleNameString $ G.moduleName m
-- modulePkg = G.packageIdString $ G.modulePackageId m
return moduleName
return $ collectModules
$ extractBindings `concatMap` (moduleInfos `zip` modules)
extractBindings :: (Maybe G.ModuleInfo, ModuleString)
-> [(Symbol, ModuleString)]
extractBindings (Nothing,_) = []
extractBindings (Just inf,mdlname) =
2014-07-22 20:54:18 +00:00
map (\name -> (getOccString name, mdlname)) names
where
names = G.modInfoExports inf
2014-07-23 22:08:47 +00:00
collectModules :: [(Symbol,ModuleString)]
-> [(Symbol,[ModuleString])]
collectModules = map tieup . groupBy ((==) `on` fst) . sort
where
tieup x = (head (map fst x), map snd x)