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

197 lines
5.8 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}
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
-- * Load 'SymbolDb' asynchronously
, AsyncSymbolDb
, newAsyncSymbolDb
, getAsyncSymbolDb
)
#endif
where
2014-04-24 08:02:50 +00:00
import qualified GHC as G
import FastString
import Module
import OccName
import HscTypes
import Exception
2014-05-11 22:40:00 +00:00
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Output
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
import Language.Haskell.GhcMod.LightGhc
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans.Control
import Control.Concurrent
import Data.List
import Data.Binary
import Data.Function
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.IORef
import System.Directory.ModTime
2016-01-10 20:48:03 +00:00
import System.IO.Unsafe
import GHC.Generics (Generic)
2014-04-24 08:02:50 +00:00
2016-01-09 22:39:04 +00:00
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
2015-08-03 01:09:56 +00:00
import Prelude
2014-04-24 08:02:50 +00:00
----------------------------------------------------------------
2014-07-17 05:04:28 +00:00
-- | Type of function and operation names.
2016-01-09 22:39:04 +00:00
type Symbol = BS.ByteString
type ModuleNameBS = BS.ByteString
2014-07-17 05:04:28 +00:00
-- | Database from 'Symbol' to \['ModuleString'\].
data SymbolDb = SymbolDb
{ sdTable :: Map Symbol (Set ModuleNameBS)
2016-01-09 21:23:20 +00:00
, sdTimestamp :: ModTime
} deriving (Generic)
instance Binary SymbolDb
instance NFData SymbolDb
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
isOutdated db =
2016-01-09 21:23:20 +00:00
isOlderThan (sdTimestamp 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 => String -> 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.
lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String
lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db
2014-07-18 06:13:30 +00:00
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db
---------------------------------------------------------------
2014-07-17 05:04:28 +00:00
-- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: IOish m => GhcModT m SymbolDb
loadSymbolDb = do
2015-06-01 14:54:50 +00:00
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 $ (liftIO . getGlobalSymbolTable) =<< G.getSession
liftIO . LBS.putStr $ encode SymbolDb {
sdTable = st
2016-01-09 21:23:20 +00:00
, sdTimestamp = ts
}
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 :: ModTime -> [TimedFile] -> Bool
isOlderThan tCache files =
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.
getGlobalSymbolTable :: HscEnv -> IO (Map Symbol (Set ModuleNameBS))
getGlobalSymbolTable hsc_env =
foldM (extend hsc_env) M.empty $ listVisibleModules $ hsc_dflags hsc_env
extend :: HscEnv
-> Map Symbol (Set ModuleNameBS)
-> Module
-> IO (Map Symbol (Set ModuleNameBS))
extend hsc_env mm mdl = do
eps <- readIORef $ hsc_EPS hsc_env
modinfo <- unsafeInterleaveIO $ runLightGhc hsc_env $ do
G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps)
return $ M.unionWith S.union mm $ extractBindings modinfo mdl
extractBindings :: Maybe G.ModuleInfo
-> G.Module
-> Map Symbol (Set ModuleNameBS)
extractBindings Nothing _ = M.empty
extractBindings (Just inf) mdl = M.fromList $ do
name <- G.modInfoExports inf
let sym = fastStringToByteString $ occNameFS $ G.getOccName name
mdls = S.singleton $ fastStringToByteString $ moduleNameFS $ moduleName mdl
return (sym, mdls)
2016-01-09 22:39:04 +00:00
mkFastStringByteString' :: BS.ByteString -> FastString
#if !MIN_VERSION_ghc(7,8,0)
fastStringToByteString :: FastString -> BS.ByteString
fastStringToByteString = BS.pack . bytesFS
mkFastStringByteString' = mkFastStringByteList . BS.unpack
#elif __GLASGOW_HASKELL__ == 708
mkFastStringByteString' = unsafePerformIO . mkFastStringByteString
#else
mkFastStringByteString' = mkFastStringByteString
#endif
----------------------------------------------------------------
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
2016-01-04 05:02:30 +00:00
db <- liftIO $ handleEx <$> takeMVar mv
outdated <- isOutdated db
if outdated
then do
asyncLoadSymbolDb mv
2016-01-04 05:02:30 +00:00
liftIO $ handleEx <$> readMVar mv
else do
liftIO $ putMVar mv $ Right db
return db
where
2016-01-04 05:02:30 +00:00
handleEx edb =
case edb of
Left ex -> throw ex
2016-01-04 05:02:30 +00:00
Right db -> db