ghc-mod/Language/Haskell/GhcMod/Find.hs
2016-01-09 17:27:21 +03:00

168 lines
4.8 KiB
Haskell

{-# LANGUAGE CPP, DeriveGeneric #-}
module Language.Haskell.GhcMod.Find
#ifndef SPEC
( Symbol
, SymbolDb
, loadSymbolDb
, lookupSymbol
, dumpSymbol
, findSymbol
, lookupSym
, isOutdated
-- * Load 'SymbolDb' asynchronously
, AsyncSymbolDb
, newAsyncSymbolDb
, getAsyncSymbolDb
)
#endif
where
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import qualified GHC as G
import Name
import Module
import Exception
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Control
import Control.Concurrent
import Control.DeepSeq
import Data.Function
import Data.List
import qualified Data.ByteString.Lazy as BS
import Data.Binary
import GHC.Generics (Generic)
import Data.Map (Map)
import qualified Data.Map as M
import System.Directory.ModTime
import Prelude
----------------------------------------------------------------
-- | Type of function and operation names.
type Symbol = String
-- | Database from 'Symbol' to \['ModuleString'\].
data SymbolDb = SymbolDb
{ table :: Map Symbol [ModuleString]
, timestamp :: ModTime
} deriving (Generic)
instance Binary SymbolDb
instance NFData SymbolDb
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
isOutdated db =
isOlderThan (timestamp 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 = loadSymbolDb >>= 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 => GhcModT m SymbolDb
loadSymbolDb = do
ghcMod <- liftIO ghcModExecutable
readProc <- gmReadProcess'
out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] ""
return $!! decode out
----------------------------------------------------------------
-- used 'ghc-mod dumpsym'
-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout
dumpSymbol :: IOish m => GhcModT m ()
dumpSymbol = do
ts <- liftIO getCurrentModTime
st <- runGmPkgGhc getGlobalSymbolTable
liftIO . BS.putStr $ encode SymbolDb {
table = M.fromAscList st
, timestamp = ts
}
-- | Check whether given file is older than any file from the given set.
-- Returns True if given file does not exist.
isOlderThan :: ModTime -> [TimedFile] -> Bool
isOlderThan tCache files =
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)
----------------------------------------------------------------
data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb))
asyncLoadSymbolDb :: IOish m
=> MVar (Either SomeException SymbolDb)
-> GhcModT m ()
asyncLoadSymbolDb mv = void $
liftBaseWith $ \run -> forkIO $ void $ run $ do
edb <- gtry loadSymbolDb
liftIO $ putMVar mv edb
newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb
newAsyncSymbolDb = do
mv <- liftIO newEmptyMVar
asyncLoadSymbolDb mv
return $ AsyncSymbolDb mv
getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb
getAsyncSymbolDb (AsyncSymbolDb mv) = do
db <- liftIO $ handleEx <$> takeMVar mv
outdated <- isOutdated db
if outdated
then do
asyncLoadSymbolDb mv
liftIO $ handleEx <$> readMVar mv
else do
liftIO $ putMVar mv $ Right db
return db
where
handleEx edb =
case edb of
Left ex -> throw ex
Right db -> db