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

150 lines
4.6 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
2014-04-24 08:02:50 +00:00
module Language.Haskell.GhcMod.Find
#ifndef SPEC
2015-06-01 14:54:50 +00:00
( 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
2015-08-03 01:09:56 +00:00
import Control.Applicative
import Control.Monad (when, void)
2014-04-24 08:02:50 +00:00
import Data.Function (on)
import Data.List (groupBy, sort)
import qualified GHC as G
2014-05-11 22:40:00 +00:00
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap (listVisibleModules)
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.PathsAndFiles
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 Language.Haskell.GhcMod.World (timedPackageCaches)
import Language.Haskell.GhcMod.Output
import Name (getOccString)
import Module (moduleName)
import System.Directory (doesFileExist)
import System.Directory.ModTime
import System.FilePath ((</>))
import System.IO
2015-08-03 01:09:56 +00:00
import Prelude
2014-04-24 08:02:50 +00:00
2015-03-05 15:50:06 +00:00
import Data.Map (Map)
import qualified Data.Map as M
2014-04-24 08:02:50 +00:00
----------------------------------------------------------------
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]
, symbolDbCachePath :: FilePath
} deriving (Show)
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
isOutdated db =
(liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
----------------------------------------------------------------
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 = do
tmpdir <- cradleTempDir <$> cradle
loadSymbolDb tmpdir >>= 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 = M.findWithDefault [] sym $ table db
---------------------------------------------------------------
2014-07-17 05:04:28 +00:00
-- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb
loadSymbolDb dir = do
2015-06-01 14:54:50 +00:00
ghcMod <- liftIO ghcModExecutable
readProc <- gmReadProcess
file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""
2015-06-01 14:54:50 +00:00
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb
{ table = db
, symbolDbCachePath = file
}
2014-04-24 08:02:50 +00:00
where
2015-06-01 14:54:50 +00:00
conv :: String -> (Symbol, [ModuleString])
conv = read
chop :: String -> String
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 => FilePath -> GhcModT m String
dumpSymbol dir = do
create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
runGmPkgGhc $ do
when create $
liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
2014-07-22 20:54:18 +00:00
return $ unlines [cache]
where
cache = dir </> symbolCacheFile
2014-07-22 20:54:18 +00:00
writeSymbolCache :: FilePath
2015-06-01 14:54:50 +00:00
-> [(Symbol, [ModuleString])]
2014-07-22 20:54:18 +00:00
-> 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 ->
2015-06-01 14:54:50 +00:00
mapM (hPrint hdl) sm
2014-07-22 20:54:18 +00:00
-- | Check whether given file is older than any file from the given set.
-- Returns True if given file does not exist.
isOlderThan :: FilePath -> [TimedFile] -> IO Bool
isOlderThan cache files = do
exist <- doesFileExist cache
if not exist
then return True
else do
tCache <- getModTime cache
return $ any (tCache <=) $ map tfTime files -- including equal just in case
2014-05-14 16:54:56 +00:00
-- | Browsing all functions in all system modules.
2015-06-01 14:54:50 +00:00
getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
getGlobalSymbolTable = do
2015-06-01 14:54:50 +00:00
df <- G.getSessionDynFlags
let mods = listVisibleModules df
moduleInfos <- mapM G.getModuleInfo mods
return $ collectModules
$ extractBindings `concatMap` (moduleInfos `zip` mods)
2014-07-23 22:08:47 +00:00
2015-01-16 14:47:56 +00:00
extractBindings :: (Maybe G.ModuleInfo, G.Module)
2014-07-23 22:08:47 +00:00
-> [(Symbol, ModuleString)]
2015-06-01 14:54:50 +00:00
extractBindings (Nothing, _) = []
extractBindings (Just inf, mdl) =
map (\name -> (getOccString name, modStr)) names
where
names = G.modInfoExports inf
modStr = ModuleString $ moduleNameString $ moduleName mdl
2015-06-01 14:54:50 +00:00
collectModules :: [(Symbol, ModuleString)]
-> [(Symbol, [ModuleString])]
2014-07-23 22:08:47 +00:00
collectModules = map tieup . groupBy ((==) `on` fst) . sort
where
tieup x = (head (map fst x), map snd x)