diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 382bb08..325d90b 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} +{-# LANGUAGE CPP, BangPatterns #-} module Language.Haskell.GhcMod.Find #ifndef SPEC @@ -22,7 +22,6 @@ import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Output -import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World @@ -32,6 +31,7 @@ import Name import Module import Exception +import Control.Arrow import Control.Applicative import Control.Monad import Control.Monad.Trans.Control @@ -40,10 +40,7 @@ import Data.Function import Data.List import Data.Map (Map) import qualified Data.Map as M -import System.Directory import System.Directory.ModTime -import System.FilePath (()) -import System.IO import Prelude ---------------------------------------------------------------- @@ -53,21 +50,19 @@ type Symbol = String -- | Database from 'Symbol' to \['ModuleString'\]. data SymbolDb = SymbolDb { table :: Map Symbol [ModuleString] - , symbolDbCachePath :: FilePath - } deriving (Show) + , timestamp :: ModTime + } deriving (Show, Read) isOutdated :: IOish m => SymbolDb -> GhcModT m Bool isOutdated db = - (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches + 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 = do - tmpdir <- cradleTempDir <$> cradle - loadSymbolDb tmpdir >>= lookupSymbol sym +findSymbol sym = loadSymbolDb >>= lookupSymbol sym -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. @@ -80,57 +75,33 @@ lookupSym sym db = M.findWithDefault [] sym $ table db --------------------------------------------------------------- -- | Loading a file and creates 'SymbolDb'. -loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb -loadSymbolDb dir = do +loadSymbolDb :: IOish m => GhcModT m SymbolDb +loadSymbolDb = 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 + (!db, !ts) <- first M.fromAscList . read <$> liftIO + (readProc ghcMod ["--verbose", "error", "dumpsym"] "") + return SymbolDb { + table = db + , timestamp = ts } - 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 +-- | Dumps a tuple of +-- (\[('Symbol',\['ModuleString'\])\], 'ModTime') to stdout +dumpSymbol :: IOish m => GhcModT m String +dumpSymbol = do + timestamp <- liftIO getCurrentModTime + st <- runGmPkgGhc getGlobalSymbolTable + return . show $ (st, timestamp) -- | 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 +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])] @@ -158,30 +129,29 @@ collectModules = map tieup . groupBy ((==) `on` fst) . sort ---------------------------------------------------------------- -data AsyncSymbolDb = AsyncSymbolDb FilePath (MVar (Either SomeException SymbolDb)) +data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb)) asyncLoadSymbolDb :: IOish m - => FilePath - -> MVar (Either SomeException SymbolDb) + => MVar (Either SomeException SymbolDb) -> GhcModT m () -asyncLoadSymbolDb tmpdir mv = void $ +asyncLoadSymbolDb mv = void $ liftBaseWith $ \run -> forkIO $ void $ run $ do - edb <- gtry $ loadSymbolDb tmpdir + edb <- gtry loadSymbolDb liftIO $ putMVar mv edb -newAsyncSymbolDb :: IOish m => FilePath -> GhcModT m AsyncSymbolDb -newAsyncSymbolDb tmpdir = do +newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb +newAsyncSymbolDb = do mv <- liftIO newEmptyMVar - asyncLoadSymbolDb tmpdir mv - return $ AsyncSymbolDb tmpdir mv + asyncLoadSymbolDb mv + return $ AsyncSymbolDb mv getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb -getAsyncSymbolDb (AsyncSymbolDb tmpdir mv) = do +getAsyncSymbolDb (AsyncSymbolDb mv) = do db <- liftIO $ handleEx <$> takeMVar mv outdated <- isOutdated db if outdated then do - asyncLoadSymbolDb tmpdir mv + asyncLoadSymbolDb mv liftIO $ handleEx <$> readMVar mv else do liftIO $ putMVar mv $ Right db diff --git a/System/Directory/ModTime.hs b/System/Directory/ModTime.hs index 8a4eeee..1f9d8f9 100644 --- a/System/Directory/ModTime.hs +++ b/System/Directory/ModTime.hs @@ -29,7 +29,7 @@ import Prelude #if MIN_VERSION_directory(1,2,0) newtype ModTime = ModTime UTCTime - deriving (Eq, Ord) + deriving (Eq, Ord, Show, Read) getCurrentModTime = ModTime <$> getCurrentTime instance Binary ModTime where @@ -41,7 +41,7 @@ instance Binary ModTime where #else newtype ModTime = ModTime ClockTime - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) getCurrentModTime = ModTime <$> getClockTime instance Binary ModTime where diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 40340fc..cab9cb8 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -49,8 +49,7 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $ legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do prepareCabalHelper - tmpdir <- cradleTempDir <$> cradle - asyncSymbolDb <- newAsyncSymbolDb tmpdir + asyncSymbolDb <- newAsyncSymbolDb world <- getCurrentWorld legacyInteractiveLoop asyncSymbolDb world @@ -137,7 +136,7 @@ ghcCommands (CmdBoot) = boot -- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" ghcCommands (CmdModules detail) = modules detail -ghcCommands (CmdDumpSym tmpdir) = dumpSymbol tmpdir +ghcCommands (CmdDumpSym) = dumpSymbol ghcCommands (CmdFind symb) = findSymbol symb ghcCommands (CmdDoc m) = pkgDoc m ghcCommands (CmdLint opts file) = lint opts file diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index 3848a2c..2e1f60a 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -42,7 +42,7 @@ data GhcModCommands = | CmdRoot | CmdLegacyInteractive | CmdModules Bool - | CmdDumpSym FilePath + | CmdDumpSym | CmdFind Symbol | CmdDoc Module | CmdLint LintOpts FilePath @@ -110,7 +110,7 @@ commands = $$ info modulesArgSpec $$ progDesc "List all visible modules" <> command "dumpsym" - $$ info dumpSymArgSpec idm + $$ info (pure CmdDumpSym) idm <> command "find" $$ info findArgSpec $$ progDesc "List all modules that define SYMBOL" @@ -226,7 +226,7 @@ locArgSpec x = x <*> argument int (metavar "COL") ) -modulesArgSpec, dumpSymArgSpec, docArgSpec, findArgSpec, +modulesArgSpec, docArgSpec, findArgSpec, lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec, infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, sigArgSpec, refineArgSpec, debugComponentArgSpec, @@ -237,7 +237,6 @@ modulesArgSpec = CmdModules $$ long "detailed" <=> short 'd' <=> help "Print package modules belong to" -dumpSymArgSpec = CmdDumpSym <$> strArg "TMPDIR" findArgSpec = CmdFind <$> strArg "SYMBOL" docArgSpec = CmdDoc <$> strArg "MODULE" lintArgSpec = CmdLint diff --git a/test/FindSpec.hs b/test/FindSpec.hs index 99fe3aa..8c2f477 100644 --- a/test/FindSpec.hs +++ b/test/FindSpec.hs @@ -1,7 +1,6 @@ module FindSpec where import Language.Haskell.GhcMod.Find -import Control.Monad import Test.Hspec import TestUtils @@ -9,5 +8,5 @@ spec :: Spec spec = do describe "db <- loadSymbolDb" $ do it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do - db <- runD $ loadSymbolDb =<< (cradleTempDir `liftM` cradle) + db <- runD $ loadSymbolDb lookupSym "head" db `shouldContain` [ModuleString "Data.List"]