Merge branch 'btr-find' of https://github.com/atom-haskell/ghc-mod into release-5.5.0.0

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

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

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

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 #-}
+{-# 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

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

@@ -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

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

test/CradleSpec.hs

@@ -8,6 +8,7 @@ import System.Directory (canonicalizePath)
 import System.FilePath (pathSeparator)
 import Test.Hspec
 import TestUtils
+import Prelude
 
 import Dir
 

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"]