ghc-mod/Language/Haskell/GhcMod/Find.hs
2015-08-14 06:48:56 +02:00

149 lines
4.6 KiB
Haskell

{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
module Language.Haskell.GhcMod.Find
#ifndef SPEC
( Symbol
, SymbolDb
, loadSymbolDb
, lookupSymbol
, dumpSymbol
, findSymbol
, lookupSym
, isOutdated
)
#endif
where
import Control.Applicative
import Control.Monad (when, void)
import Data.Function (on)
import Data.List (groupBy, sort)
import qualified GHC as G
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap (listVisibleModules)
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
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, getModificationTime)
import System.FilePath ((</>))
import System.IO
import Prelude
import Data.Map (Map)
import qualified Data.Map as M
----------------------------------------------------------------
-- | Type of function and operation names.
type Symbol = String
-- | 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
----------------------------------------------------------------
-- | 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
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated.
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
---------------------------------------------------------------
-- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb
loadSymbolDb dir = do
ghcMod <- liftIO ghcModExecutable
readProc <- gmReadProcess
file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb
{ table = db
, symbolDbCachePath = file
}
where
conv :: String -> (Symbol, [ModuleString])
conv = read
chop :: String -> String
chop "" = ""
chop xs = init xs
----------------------------------------------------------------
-- used 'ghc-mod dumpsym'
-- | 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 => FilePath -> GhcModT m String
dumpSymbol dir = do
create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
runGmPkgGhc $ do
when create $
liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
return $ unlines [cache]
where
cache = dir </> symbolCacheFile
writeSymbolCache :: FilePath
-> [(Symbol, [ModuleString])]
-> IO ()
writeSymbolCache cache sm =
void . withFile cache WriteMode $ \hdl ->
mapM (hPrint hdl) sm
-- | 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 <- getModificationTime cache
return $ any (tCache <=) $ map tfTime files -- including equal just in case
-- | Browsing all functions in all system modules.
getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
getGlobalSymbolTable = do
df <- G.getSessionDynFlags
let mods = listVisibleModules df
moduleInfos <- mapM G.getModuleInfo mods
return $ collectModules
$ extractBindings `concatMap` (moduleInfos `zip` mods)
extractBindings :: (Maybe G.ModuleInfo, G.Module)
-> [(Symbol, ModuleString)]
extractBindings (Nothing, _) = []
extractBindings (Just inf, mdl) =
map (\name -> (getOccString name, modStr)) names
where
names = G.modInfoExports inf
modStr = ModuleString $ moduleNameString $ moduleName mdl
collectModules :: [(Symbol, ModuleString)]
-> [(Symbol, [ModuleString])]
collectModules = map tieup . groupBy ((==) `on` fst) . sort
where
tieup x = (head (map fst x), map snd x)