diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 382bb08..753d8e3 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} +{-# LANGUAGE CPP, DeriveGeneric #-} 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 @@ -36,14 +35,15 @@ 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 import System.Directory.ModTime -import System.FilePath (()) -import System.IO import Prelude ---------------------------------------------------------------- @@ -53,21 +53,22 @@ type Symbol = String -- | Database from 'Symbol' to \['ModuleString'\]. data SymbolDb = SymbolDb { table :: Map Symbol [ModuleString] - , symbolDbCachePath :: FilePath - } deriving (Show) + , timestamp :: ModTime + } deriving (Generic) + +instance Binary SymbolDb +instance NFData SymbolDb 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 +81,31 @@ 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 - } - where - conv :: String -> (Symbol, [ModuleString]) - conv = read - chop :: String -> String - chop "" = "" - chop xs = init xs + readProc <- gmReadProcess' + out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] "" + return $!! decode out ---------------------------------------------------------------- -- 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 '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 :: 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 +133,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/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 79c63de..48337e0 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -101,6 +101,11 @@ import Module import qualified Data.IntSet as I (IntSet, empty) #endif +#if __GLASGOW_HASKELL__ < 706 +import Control.DeepSeq (NFData(rnf)) +import Data.ByteString.Lazy.Internal (ByteString(..)) +#endif + import Bag import Lexer as L import Parser @@ -564,3 +569,9 @@ mkErrStyle' = Outputable.mkErrStyle #else mkErrStyle' _ = Outputable.mkErrStyle #endif + +#if __GLASGOW_HASKELL__ < 706 +instance NFData ByteString where + rnf Empty = () + rnf (Chunk _ b) = rnf b +#endif diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index 7b56330..f8dfa4b 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/Language/Haskell/GhcMod/Output.hs @@ -17,6 +17,7 @@ -- Derived from process:System.Process -- Copyright (c) The University of Glasgow 2004-2008 +{-# LANGUAGE FlexibleInstances #-} module Language.Haskell.GhcMod.Output ( gmPutStr , gmErrStr @@ -27,12 +28,15 @@ module Language.Haskell.GhcMod.Output ( , gmErrStrIO , gmReadProcess + , gmReadProcess' , stdoutGateway , flushStdoutGateway ) where import Data.List +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS import qualified Data.Label as L import qualified Data.Label.Base as LB import System.IO @@ -51,6 +55,16 @@ import Prelude import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..)) import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..)) +import Language.Haskell.GhcMod.Gap () + +class ProcessOutput a where + hGetContents' :: Handle -> IO a + +instance ProcessOutput String where + hGetContents' = hGetContents + +instance ProcessOutput ByteString where + hGetContents' = BS.hGetContents outputFns :: (GmOut m, MonadIO m') => m (String -> m' (), String -> m' ()) @@ -108,6 +122,9 @@ gmReadProcess = do Nothing -> return $ readProcess +gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString) +gmReadProcess' = readProcessStderrChan + flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO () flushStdoutGateway c = do mv <- newEmptyMVar @@ -175,17 +192,14 @@ zoom l (StateT a) = return (a', L.set l s' f) readProcessStderrChan :: - GmOut m => m (FilePath -> [String] -> String -> IO String) + (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a) readProcessStderrChan = do (_, e :: String -> IO ()) <- outputFns return $ readProcessStderrChan' e -readProcessStderrChan' :: - (String -> IO ()) -> FilePath -> [String] -> String -> IO String -readProcessStderrChan' pute = go pute - where - go :: (String -> IO ()) -> FilePath -> [String] -> String -> IO String - go putErr exe args input = do +readProcessStderrChan' :: (ProcessOutput a, NFData a) => + (String -> IO ()) -> FilePath -> [String] -> String -> IO a +readProcessStderrChan' putErr exe args input = do let cp = (proc exe args) { std_out = CreatePipe , std_err = CreatePipe @@ -195,7 +209,7 @@ readProcessStderrChan' pute = go pute _ <- forkIO $ reader e - output <- hGetContents o + output <- hGetContents' o withForkWait (evaluate $ rnf output) $ \waitOut -> do -- now write any input diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 51d4c3c..779c5c9 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes, - StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-} + StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell, + GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types @@ -15,6 +16,7 @@ import Control.Exception (Exception) import Control.Applicative import Control.Concurrent import Control.Monad +import Control.DeepSeq import Data.Binary import Data.Binary.Generic import Data.Map (Map) @@ -232,7 +234,7 @@ newtype Expression = Expression { getExpression :: String } -- | Module name. newtype ModuleString = ModuleString { getModuleString :: String } - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord, Binary, NFData) data GmLogLevel = GmSilent diff --git a/System/Directory/ModTime.hs b/System/Directory/ModTime.hs index 8a4eeee..0e38eae 100644 --- a/System/Directory/ModTime.hs +++ b/System/Directory/ModTime.hs @@ -13,10 +13,11 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module System.Directory.ModTime where import Control.Applicative +import Control.DeepSeq import Data.Binary #if MIN_VERSION_directory(1,2,0) import Data.Time (UTCTime(..), Day(..), getCurrentTime) @@ -29,7 +30,7 @@ import Prelude #if MIN_VERSION_directory(1,2,0) newtype ModTime = ModTime UTCTime - deriving (Eq, Ord) + deriving (Eq, Ord, NFData) getCurrentModTime = ModTime <$> getCurrentTime instance Binary ModTime where @@ -41,7 +42,7 @@ instance Binary ModTime where #else newtype ModTime = ModTime ClockTime - deriving (Eq, Ord, Show) + deriving (Eq, Ord) getCurrentModTime = ModTime <$> getClockTime instance Binary ModTime where @@ -50,6 +51,10 @@ instance Binary ModTime where get = ModTime <$> (TOD <$> get <*> get) +instance NFData ModTime where + rnf (ModTime (TOD s ps)) = + s `seq` ps `seq` (ModTime $! TOD s ps) `seq` () + #endif getCurrentModTime :: IO ModTime diff --git a/ghc-mod.cabal b/ghc-mod.cabal index fec548d..04364b3 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -231,6 +231,7 @@ Executable ghc-modi HS-Source-Dirs: src, . Build-Depends: base < 5 && >= 4.0 , binary < 0.8 && >= 0.5.1.0 + , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 , process < 1.3 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 40340fc..c7a937c 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 >> return "" 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/CradleSpec.hs b/test/CradleSpec.hs index 9068ec7..6396437 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -8,6 +8,7 @@ import System.Directory (canonicalizePath) import System.FilePath (pathSeparator) import Test.Hspec import TestUtils +import Prelude import Dir 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"]