diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 16c9a6a..b356efa 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -46,6 +46,7 @@ module Language.Haskell.GhcMod ( , dumpSymbol -- * SymbolDb , loadSymbolDb + , isOutdated ) where import Language.Haskell.GhcMod.Boot diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 2a09664..0cfc457 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, BangPatterns #-} module Language.Haskell.GhcMod.Find #ifndef SPEC @@ -10,6 +10,7 @@ module Language.Haskell.GhcMod.Find , dumpSymbol , findSymbol , lookupSym + , isOutdated ) #endif where @@ -52,8 +53,14 @@ import qualified Data.Map as M -- | Type of function and operation names. type Symbol = String -- | Database from 'Symbol' to \['ModuleString'\]. -newtype SymbolDb = SymbolDb (Map Symbol [ModuleString]) - deriving (Show) +data SymbolDb = SymbolDb { + table :: Map Symbol [ModuleString] + , packageCachePath :: FilePath + , symbolDbCachePath :: FilePath + } deriving (Show) + +isOutdated :: SymbolDb -> IO Bool +isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db ---------------------------------------------------------------- @@ -85,13 +92,27 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String lookupSymbol sym db = convert' $ lookupSym sym db lookupSym :: Symbol -> SymbolDb -> [ModuleString] -lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db +lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db --------------------------------------------------------------- -- | Loading a file and creates 'SymbolDb'. loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb -loadSymbolDb = SymbolDb <$> readSymbolDb +loadSymbolDb = do + ghcMod <- liftIO ghcModExecutable + file <- chop <$> readProcess' ghcMod ["dumpsym"] + !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) + return $ SymbolDb { + table = db + , packageCachePath = takeDirectory file packageCache + , symbolDbCachePath = file + } + where + conv :: String -> (Symbol,[ModuleString]) + conv = read + chop "" = "" + chop xs = init xs + -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 -- this is a guess but >=7.6 uses 'getExecutablePath'. @@ -113,17 +134,6 @@ ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when getExecutablePath' = return "" # endif -readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString]) -readSymbolDb = do - ghcMod <- liftIO ghcModExecutable - file <- chop <$> readProcess' ghcMod ["dumpsym"] - M.fromAscList . map conv . lines <$> liftIO (readFile file) - where - conv :: String -> (Symbol,[ModuleString]) - conv = read - chop "" = "" - chop xs = init xs - ---------------------------------------------------------------- -- used 'ghc-mod dumpsym' @@ -144,7 +154,7 @@ dumpSymbol = do let cache = dir symbolCache pkgdb = dir packageCache - create <- liftIO $ cache `isNewerThan` pkgdb + create <- liftIO $ cache `isOlderThan` pkgdb when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable return $ unlines [cache] @@ -155,15 +165,15 @@ writeSymbolCache cache sm = void . withFile cache WriteMode $ \hdl -> mapM (hPrint hdl) sm -isNewerThan :: FilePath -> FilePath -> IO Bool -isNewerThan ref file = do - exist <- doesFileExist ref +isOlderThan :: FilePath -> FilePath -> IO Bool +isOlderThan cache file = do + exist <- doesFileExist cache if not exist then return True else do - tRef <- getModificationTime ref + tCache <- getModificationTime cache tFile <- getModificationTime file - return $ tRef <= tFile -- including equal just in case + return $ tCache <= tFile -- including equal just in case -- | Browsing all functions in all system/user modules. getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])] diff --git a/src/GHCModi.hs b/src/GHCModi.hs index befbef9..04bcdec 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -25,6 +25,7 @@ import Control.Exception (SomeException(..), Exception) import qualified Control.Exception as E import Control.Monad (when) import CoreMonad (liftIO) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (intercalate) import Data.List.Split (splitOn) import Data.Typeable (Typeable) @@ -35,8 +36,8 @@ import Paths_ghc_mod import System.Console.GetOpt import System.Directory (setCurrentDirectory) import System.Environment (getArgs) -import System.IO (hFlush,stdout) import System.Exit (ExitCode, exitFailure) +import System.IO (hFlush,stdout) import Utils @@ -97,8 +98,9 @@ main = E.handle cmdHandler $ let rootdir = cradleRootDir cradle0 -- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? setCurrentDirectory rootdir - symDb <- async $ runGhcModT opt loadSymbolDb - (res, _) <- runGhcModT opt $ loop symDb + -- Asynchronous db loading starts here. + symdbreq <- newSymDbReq opt + (res, _) <- runGhcModT opt $ loop symdbreq case res of Right () -> return () @@ -129,13 +131,13 @@ replace needle replacement = intercalate replacement . splitOn needle ---------------------------------------------------------------- loop :: IOish m => SymDbReq -> GhcModT m () -loop symDbReq = do +loop symdbreq = do cmdArg <- liftIO getLine let (cmd,arg') = break (== ' ') cmdArg arg = dropWhile (== ' ') arg' (ret,ok) <- case cmd of "check" -> checkStx arg - "find" -> findSym arg symDbReq + "find" -> findSym arg symdbreq "lint" -> lintStx arg "info" -> showInfo arg "type" -> showType arg @@ -154,7 +156,7 @@ loop symDbReq = do else do liftIO $ putStrLn $ notGood ret liftIO $ hFlush stdout - when ok $ loop symDbReq + when ok $ loop symdbreq ---------------------------------------------------------------- @@ -167,12 +169,38 @@ checkStx file = do ---------------------------------------------------------------- -type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog) +type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) +data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) -findSym :: IOish m => String -> SymDbReq - -> GhcModT m (String, Bool) -findSym sym dbReq = do - db <- hoistGhcModT =<< liftIO (wait dbReq) +newSymDbReq :: Options -> IO SymDbReq +newSymDbReq opt = do + let act = runGhcModT opt loadSymbolDb + req <- async act + ref <- newIORef req + return $ SymDbReq ref act + +getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb +getDb (SymDbReq ref _) = do + req <- liftIO $ readIORef ref + -- 'wait' really waits for the asynchronous action at the fist time. + -- Then it reads a cached value from the second time. + hoistGhcModT =<< liftIO (wait req) + +checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb +checkDb (SymDbReq ref act) db = do + outdated <- liftIO $ isOutdated db + if outdated then do + -- async and wait here is unnecessary because this is essentially + -- synchronous. But Async can be used a cache. + req <- liftIO $ async act + liftIO $ writeIORef ref req + hoistGhcModT =<< liftIO (wait req) + else + return db + +findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool) +findSym sym symdbreq = do + db <- getDb symdbreq >>= checkDb symdbreq ret <- lookupSymbol sym db return (ret, True)