Use Binary for 'find' communication channel

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.

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

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

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 <http://www.gnu.org/licenses/>.
-{-# 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

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

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