From da1c1bebb28a586419f87c3f421c6d3de4194dc1 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 5 Jan 2016 13:38:25 +0300 Subject: [PATCH 1/6] Use stdout pipe instead of temp.files in Find --- Language/Haskell/GhcMod/Find.hs | 96 ++++++++++++--------------------- System/Directory/ModTime.hs | 4 +- src/GHCMod.hs | 5 +- src/GHCMod/Options/Commands.hs | 7 ++- test/FindSpec.hs | 3 +- 5 files changed, 41 insertions(+), 74 deletions(-) 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"] From 553389ed7b0ecfa83293d652a977c450b4de344c Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 6 Jan 2016 19:22:49 +0300 Subject: [PATCH 2/6] Try adding a standalone deriving read instance --- System/Directory/ModTime.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/System/Directory/ModTime.hs b/System/Directory/ModTime.hs index 1f9d8f9..de8c855 100644 --- a/System/Directory/ModTime.hs +++ b/System/Directory/ModTime.hs @@ -13,7 +13,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, StandaloneDeriving #-} module System.Directory.ModTime where import Control.Applicative @@ -40,6 +40,7 @@ instance Binary ModTime where #else +deriving instance Read ClockTime newtype ModTime = ModTime ClockTime deriving (Eq, Ord, Show, Read) getCurrentModTime = ModTime <$> getClockTime From b9c796421f8081717cd6eb99e2b0734ad8339394 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sat, 9 Jan 2016 17:19:00 +0300 Subject: [PATCH 3/6] Silence GHC>=7.10 warning --- test/CradleSpec.hs | 1 + 1 file changed, 1 insertion(+) 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 From 68689bfcfd7b1b0a2fa9f7c289676d30dd51c64e Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sat, 9 Jan 2016 17:27:21 +0300 Subject: [PATCH 4/6] 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 From c9a832de0f92f988d05b1220bea3eb1ea9d060ab Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sat, 9 Jan 2016 17:43:51 +0300 Subject: [PATCH 5/6] NFData fix for ClockTime on GHC 7.4 --- System/Directory/ModTime.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/System/Directory/ModTime.hs b/System/Directory/ModTime.hs index 563a366..0e38eae 100644 --- a/System/Directory/ModTime.hs +++ b/System/Directory/ModTime.hs @@ -42,7 +42,7 @@ instance Binary ModTime where #else newtype ModTime = ModTime ClockTime - deriving (Eq, Ord, NFData) + deriving (Eq, Ord) getCurrentModTime = ModTime <$> getClockTime instance Binary ModTime where @@ -51,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 From 4ff819906d65bbde215f950b906be9c49eccec23 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sat, 9 Jan 2016 18:51:18 +0300 Subject: [PATCH 6/6] NFData ByteString instance for GHC-7.4 --- Language/Haskell/GhcMod/Gap.hs | 11 +++++++++++ Language/Haskell/GhcMod/Output.hs | 1 + 2 files changed, 12 insertions(+) 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 ae6b832..f8dfa4b 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/Language/Haskell/GhcMod/Output.hs @@ -55,6 +55,7 @@ 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