From 68689bfcfd7b1b0a2fa9f7c289676d30dd51c64e Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sat, 9 Jan 2016 17:27:21 +0300 Subject: [PATCH] Use Binary for 'find' communication channel --- Language/Haskell/GhcMod/Find.hs | 34 +++++++++++++++++-------------- Language/Haskell/GhcMod/Output.hs | 29 ++++++++++++++++++-------- Language/Haskell/GhcMod/Types.hs | 6 ++++-- System/Directory/ModTime.hs | 8 ++++---- ghc-mod.cabal | 1 + src/GHCMod.hs | 2 +- 6 files changed, 50 insertions(+), 30 deletions(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 325d90b..753d8e3 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE CPP, DeriveGeneric #-} module Language.Haskell.GhcMod.Find #ifndef SPEC @@ -31,13 +31,16 @@ import Name import Module import Exception -import Control.Arrow 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 @@ -51,7 +54,10 @@ type Symbol = String data SymbolDb = SymbolDb { table :: Map Symbol [ModuleString] , timestamp :: ModTime - } deriving (Show, Read) + } deriving (Generic) + +instance Binary SymbolDb +instance NFData SymbolDb isOutdated :: IOish m => SymbolDb -> GhcModT m Bool isOutdated db = @@ -78,24 +84,22 @@ lookupSym sym db = M.findWithDefault [] sym $ table db loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do ghcMod <- liftIO ghcModExecutable - readProc <- gmReadProcess - (!db, !ts) <- first M.fromAscList . read <$> liftIO - (readProc ghcMod ["--verbose", "error", "dumpsym"] "") - return SymbolDb { - table = db - , timestamp = ts - } + readProc <- gmReadProcess' + out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] "" + return $!! decode out ---------------------------------------------------------------- -- used 'ghc-mod dumpsym' --- | Dumps a tuple of --- (\[('Symbol',\['ModuleString'\])\], 'ModTime') to stdout -dumpSymbol :: IOish m => GhcModT m String +-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout +dumpSymbol :: IOish m => GhcModT m () dumpSymbol = do - timestamp <- liftIO getCurrentModTime + ts <- liftIO getCurrentModTime st <- runGmPkgGhc getGlobalSymbolTable - return . show $ (st, timestamp) + 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. diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index 7b56330..ae6b832 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 @@ -52,6 +56,15 @@ import Prelude import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..)) import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..)) +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' ()) outputFns = @@ -108,6 +121,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 +191,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 +208,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 de8c855..563a366 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, StandaloneDeriving #-} +{-# 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, Show, Read) + deriving (Eq, Ord, NFData) getCurrentModTime = ModTime <$> getCurrentTime instance Binary ModTime where @@ -40,9 +41,8 @@ instance Binary ModTime where #else -deriving instance Read ClockTime newtype ModTime = ModTime ClockTime - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, NFData) getCurrentModTime = ModTime <$> getClockTime instance Binary ModTime where 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 cab9cb8..c7a937c 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -136,7 +136,7 @@ ghcCommands (CmdBoot) = boot -- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" ghcCommands (CmdModules detail) = modules detail -ghcCommands (CmdDumpSym) = dumpSymbol +ghcCommands (CmdDumpSym) = dumpSymbol >> return "" ghcCommands (CmdFind symb) = findSymbol symb ghcCommands (CmdDoc m) = pkgDoc m ghcCommands (CmdLint opts file) = lint opts file