Merge release-5.5.0.0 into master (using imerge)

Language/Haskell/GhcMod/Browse.hs

@@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.Browse (
     BrowseOpts(..)
   ) where
 
+import Safe
 import Control.Applicative
 import Control.Exception (SomeException(..))
 import Data.Char
@@ -49,7 +50,7 @@ browse opts pkgmdl = do
     goHomeModule = runGmlT [Right mdlname] $ do
       processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing
 
-    tryModuleInfo m = fromJust <$> G.getModuleInfo m
+    tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m
 
     (mpkg, mdl) = splitPkgMdl pkgmdl
     mdlname = G.mkModuleName mdl

Language/Haskell/GhcMod/CabalHelper.hs

@@ -113,32 +113,30 @@ getComponents = chCached $ \distdir -> Cached {
                  , (a', c) <- lc
                  , a == a'
                  ]
-runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b
-runCHQuery a = do
+
+getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv
+getQueryEnv = do
   crdl <- cradle
+  progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
+  readProc <- gmReadProcess
   let projdir = cradleRootDir crdl
       distdir = projdir </> cradleDistDir crdl
+  return (defaultQueryEnv projdir distdir) {
+                  qeReadProcess = readProc
+                , qePrograms = helperProgs progs
+                }
 
-  opts <- options
-  progs <- patchStackPrograms crdl (optPrograms opts)
-
-  readProc <- gmReadProcess
-
-  let qe = (defaultQueryEnv projdir distdir) {
-               qeReadProcess = readProc
-             , qePrograms = helperProgs progs
-             }
+runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b
+runCHQuery a = do
+  qe <- getQueryEnv
   runQuery qe a
 
 
 prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
 prepareCabalHelper = do
   crdl <- cradle
-  let projdir = cradleRootDir crdl
-      distdir = projdir </> cradleDistDir crdl
-  readProc <- gmReadProcess
   when (isCabalHelperProject $ cradleProject crdl) $
-       withCabal $ liftIO $ prepare readProc projdir distdir
+       withCabal $ prepare' =<< getQueryEnv
 
 withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
 withAutogen action = do
@@ -155,15 +153,14 @@ withAutogen action = do
 
     when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do
       gmLog GmDebug "" $ strDoc $ "autogen files out of sync"
-      writeAutogen projdir distdir
+      writeAutogen
 
     action
 
  where
-   writeAutogen projdir distdir = do
-     readProc <- gmReadProcess
+   writeAutogen = do
      gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
-     liftIO $ writeAutogenFiles readProc projdir distdir
+     writeAutogenFiles' =<< getQueryEnv
 
 
 withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a

Language/Haskell/GhcMod/Cradle.hs

@@ -17,18 +17,17 @@ import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Stack
 import Language.Haskell.GhcMod.Logging
+import Language.Haskell.GhcMod.Error
 
-
+import Safe
 import Control.Applicative
-import Control.Monad
 import Control.Monad.Trans.Maybe
 import Data.Maybe
 import System.Directory
 import System.FilePath
 import Prelude
 import Control.Monad.Trans.Journal (runJournalT)
 
-
 ----------------------------------------------------------------
 
 -- | Finding 'Cradle'.
@@ -40,15 +39,15 @@ findCradle = findCradle' =<< liftIO getCurrentDirectory
 
 findCradleNoLog  :: forall m. (IOish m, GmOut m) => m Cradle
 findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
-    
+
 findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
 findCradle' dir = run $
     msum [ stackCradle dir
          , cabalCradle dir
          , sandboxCradle dir
          , plainCradle dir
          ]
- where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
+ where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
 
 findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
 findSpecCradle dir = do
@@ -99,9 +98,9 @@ stackCradle wdir = do
 
     -- If dist/setup-config already exists the user probably wants to use cabal
     -- rather than stack, or maybe that's just me ;)
-    whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ do
-                      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
-                      mzero
+    whenM (liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist") $ do
+      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
+      mzero
 
     senv <- MaybeT $ getStackEnv cabalDir
 

Language/Haskell/GhcMod/Find.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, TupleSections #-}
+{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}
 
 module Language.Haskell.GhcMod.Find
 #ifndef SPEC
@@ -18,47 +18,47 @@ module Language.Haskell.GhcMod.Find
 #endif
   where
 
-import Control.Applicative
-import Control.Monad
-import Control.Exception
-import Control.Concurrent
-import Data.List
-import Data.Binary
-import Data.IORef
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
 import qualified GHC as G
 import FastString
 import Module
 import OccName
 import HscTypes
+import Exception
+
 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
-import Language.Haskell.GhcMod.Target
 import Language.Haskell.GhcMod.LightGhc
 
-import Exception
-
+import Control.Applicative
+import Control.DeepSeq
+import Control.Monad
 import Control.Monad.Trans.Control
+import Control.Concurrent
+
+import Data.List
+import Data.Binary
 import Data.Function
-import System.Directory
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import Data.IORef
+
 import System.Directory.ModTime
-import System.FilePath ((</>))
-import System.IO
 import System.IO.Unsafe
-import Prelude
+
+import GHC.Generics (Generic)
 
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Set (Set)
 import qualified Data.Set as S
 
+import Prelude
+
 ----------------------------------------------------------------
 
 -- | Type of function and operation names.
@@ -67,85 +67,60 @@ type ModuleNameBS = BS.ByteString
 
 -- | Database from 'Symbol' to \['ModuleString'\].
 data SymbolDb = SymbolDb
-  { table             :: Map Symbol [ModuleNameBS]
-  , symbolDbCachePath :: FilePath
-  }
+  { sdTable             :: Map Symbol (Set ModuleNameBS)
+  , sdTimestamp         :: ModTime
+  } deriving (Generic)
+
+instance Binary SymbolDb
+instance NFData SymbolDb
 
 isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
 isOutdated db =
-  (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
+  isOlderThan (sdTimestamp db) <$> timedPackageCaches
 
 ----------------------------------------------------------------
 
 -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
 --   which will be concatenated. 'loadSymbolDb' is called internally.
 findSymbol :: IOish m => String -> 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.
 lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String
 lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db
 
 lookupSym :: Symbol -> SymbolDb -> [ModuleString]
-lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ M.findWithDefault [] sym $ table db
+lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable 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.fromList . decode <$> liftIO (LBS.readFile file)
-  return $ SymbolDb
-    { table             = db
-    , symbolDbCachePath = file
-    }
-  where
-    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
-  pkgOpts <- packageGhcOptions
-  when create $ liftIO $ do
-    withLightHscEnv pkgOpts $ \env -> do
-      writeSymbolCache cache =<< getGlobalSymbolTable env
-
-  return $ unlines [cache]
-  where
-    cache = dir </> symbolCacheFile
-
-writeSymbolCache :: FilePath
-                 -> Map Symbol (Set ModuleNameBS)
-                 -> IO ()
-writeSymbolCache cache sm =
-  void . withFile cache WriteMode $ \hdl ->
-    LBS.hPutStr hdl (encode sm)
+-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout
+dumpSymbol :: IOish m => GhcModT m ()
+dumpSymbol = do
+  ts <- liftIO getCurrentModTime
+  st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession
+  liftIO . LBS.putStr $ encode SymbolDb {
+      sdTable = st
+    , sdTimestamp = 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 :: HscEnv -> IO (Map Symbol (Set ModuleNameBS))
@@ -187,30 +162,29 @@ mkFastStringByteString' = mkFastStringByteString
 
 ----------------------------------------------------------------
 
-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