Fix session caching, #807

also:
- cleanup LightGhc
- make the new DynFlags to compare against in a clean HscEnv

Language/Haskell/GhcMod/Find.hs

@@ -135,7 +135,7 @@ loadSymbolDb = do
 dumpSymbol :: IOish m => GhcModT m ()
 dumpSymbol = do
   ts <- liftIO getCurrentModTime
-  st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession
+  st <- runGmPkgGhc $ getGlobalSymbolTable
   liftIO . LBS.putStr $ encode SymbolDb {
       sdTable = st
     , sdTimestamp = ts
@@ -148,19 +148,20 @@ 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))
-getGlobalSymbolTable hsc_env =
-  foldM (extend hsc_env) M.empty $ listVisibleModules $ hsc_dflags hsc_env
+getGlobalSymbolTable :: (G.GhcMonad m, MonadIO m)
+                     => m (Map Symbol (Set ModuleNameBS))
+getGlobalSymbolTable =
+  foldM extend M.empty =<< (listVisibleModules <$> G.getSessionDynFlags)
 
-extend :: HscEnv
-       -> Map Symbol (Set ModuleNameBS)
+extend :: (G.GhcMonad m, MonadIO m)
+       => Map Symbol (Set ModuleNameBS)
        -> Module
-       -> IO (Map Symbol (Set ModuleNameBS))
-extend hsc_env mm mdl = do
-  eps <- readIORef $ hsc_EPS hsc_env
-  modinfo <- unsafeInterleaveIO $ runLightGhc hsc_env $ do
+       -> m (Map Symbol (Set ModuleNameBS))
+extend mm mdl = do
+  hsc_env <- G.getSession
+  eps <- liftIO $ readIORef $ hsc_EPS hsc_env
+  modinfo <- liftIO $ unsafeInterleaveIO $ runLightGhc hsc_env $ do
     G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps)
-
   return $ M.unionWith S.union mm $ extractBindings modinfo mdl
 
 extractBindings :: Maybe G.ModuleInfo

Language/Haskell/GhcMod/Gap.hs

@@ -47,6 +47,7 @@ module Language.Haskell.GhcMod.Gap (
   , parseModuleHeader
   , mkErrStyle'
   , everythingStagedWithContext
+  , withCleanupSession
   ) where
 
 import Control.Applicative hiding (empty)
@@ -72,6 +73,8 @@ import StringBuffer
 import TcType
 import Var (varType)
 import System.Directory
+import SysTools
+import GHCi (stopIServ)
 
 import qualified Name
 import qualified InstEnv
@@ -665,3 +668,20 @@ everythingStagedWithContext stage s0 f z q x
 #endif
         fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool
         (r, s') = q x s0
+
+withCleanupSession :: GhcMonad m => m a -> m a
+#if __GLASGOW_HASKELL__ >= 800
+withCleanupSession ghc = ghc `gfinally` cleanup
+  where
+   cleanup = do
+      hsc_env <- getSession
+      let dflags = hsc_dflags hsc_env
+      liftIO $ do
+          cleanTempFiles dflags
+          cleanTempDirs dflags
+          stopIServ hsc_env
+#else
+withCleanupSession action = do
+  df <- getSessionDynFlags
+  GHC.defaultCleanupHandler df action
+#endif

Language/Haskell/GhcMod/LightGhc.hs

@@ -1,5 +1,6 @@
 module Language.Haskell.GhcMod.LightGhc where
 
+import Control.Monad
 import Control.Monad.Reader (runReaderT)
 import Data.IORef
 
@@ -14,35 +15,46 @@ import HscTypes
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.DynFlags
+import qualified Language.Haskell.GhcMod.Gap as Gap
 
-withLightHscEnv :: forall m a. IOish m
-    => [GHCOption] -> (HscEnv -> m a) -> m a
-withLightHscEnv opts action = gbracket initEnv teardownEnv action
- where
-   teardownEnv :: HscEnv -> m ()
-   teardownEnv env = liftIO $ do
-       let dflags = hsc_dflags env
-       cleanTempFiles dflags
-       cleanTempDirs dflags
-
-   initEnv :: m HscEnv
-   initEnv = liftIO $ do
+-- We have to be more careful about tearing down 'HscEnv's since GHC 8 added an
+-- out of process GHCI server which has to be shutdown.
+newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv
+newLightEnv mdf = do
+  df <- liftIO $ do
      initStaticOpts
      settings <- initSysTools (Just libdir)
-     dflags  <- initDynFlags (defaultDynFlags settings)
-     env <- newHscEnv dflags
-     dflags' <- runLightGhc env $ do
+     initDynFlags $ defaultDynFlags settings
+
+  hsc_env <- liftIO $ newHscEnv df
+  df' <- runLightGhc hsc_env $ mdf df
+  return $ hsc_env {
+      hsc_dflags = df',
+      hsc_IC = (hsc_IC hsc_env) { ic_dflags = df' }
+    }
+
+teardownLightEnv :: MonadIO m => HscEnv -> m ()
+teardownLightEnv env = runLightGhc env $ do
+  Gap.withCleanupSession $ return ()
+
+withLightHscEnv'
+    :: IOish m => (DynFlags -> LightGhc DynFlags) -> (HscEnv -> m a) -> m a
+withLightHscEnv' mdf action = gbracket (newLightEnv mdf) teardownLightEnv action
+
+withLightHscEnv :: IOish m => [GHCOption] -> (HscEnv -> m a) -> m a
+withLightHscEnv opts = withLightHscEnv' (f <=< liftIO . newHscEnv)
+ where
+   f env = runLightGhc env $ do
          -- HomeModuleGraph and probably all other clients get into all sorts of
          -- trouble if the package state isn't initialized here
          _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags
          getSessionDynFlags
-     newHscEnv dflags'
 
-runLightGhc :: HscEnv -> LightGhc a -> IO a
-runLightGhc env action = do
+runLightGhc :: MonadIO m => HscEnv -> LightGhc a -> m a
+runLightGhc env action = liftIO $ do
   renv <- newIORef env
   flip runReaderT renv $ unLightGhc action
 
-runLightGhc' :: IORef HscEnv -> LightGhc a -> IO a
-runLightGhc' renv action = do
+runLightGhc' :: MonadIO m => IORef HscEnv -> LightGhc a -> m a
+runLightGhc' renv action = liftIO $ do
   flip runReaderT renv $ unLightGhc action

Language/Haskell/GhcMod/Target.hs

@@ -27,6 +27,7 @@ import GHC.LanguageExtensions
 import GHC.Paths (libdir)
 import SysTools
 import DynFlags
+import HscTypes
 
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.Monad.Types
@@ -69,39 +70,44 @@ runGmPkgGhc action = do
     withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
 
 initSession :: IOish m
-            => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m ()
+            => [GHCOption]
+            -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
+            -> GhcModT m ()
 initSession opts mdf = do
    s <- gmsGet
    case gmGhcSession s of
      Nothing -> do
          gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"
          putNewSession s
-     Just GmGhcSession {..} -> do
-         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
+     Just (GmGhcSession hsc_env_ref) -> do
          crdl <- cradle
-         changed <- liftIO $ runLightGhc' gmgsSession $ do
-           df <- getSessionDynFlags
-           ndf <- initDF crdl
-           return $ ndf `eqDynFlags` df
+
+         df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref
+         changed <-
+             withLightHscEnv' (initDF crdl) $ \hsc_env ->
+               return $ not $ (hsc_dflags hsc_env) `eqDynFlags` df
 
          if changed
-            then putNewSession s
-            else return ()
+            then do
+              gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
+              teardownSession hsc_env_ref
+              putNewSession s
+            else
+              gmLog GmDebug "initSession" $ text "Session already initialized"
  where
-   initDF Cradle { cradleTempDir } = do
-       let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
-       _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
-       getSessionDynFlags
+   initDF Cradle { cradleTempDir } df =
+       setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
 
+   teardownSession hsc_env_ref = do
+     hsc_env <- liftIO $ readIORef hsc_env_ref
+     teardownLightEnv hsc_env
+
+   putNewSession :: IOish m => GhcModState -> GhcModT m ()
    putNewSession s = do
-     rghc <- (liftIO . newIORef =<< newSession)
-     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
-
-   newSession = do
      crdl <- cradle
-     liftIO $ runGhc (Just libdir) $ do
-       _ <- initDF crdl
-       getSession
+     nhsc_env_ref <- liftIO . newIORef =<< newLightEnv (initDF crdl)
+     runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags
+     gmsPut s { gmGhcSession = Just $ GmGhcSession nhsc_env_ref }
 
 
 -- | Drop the currently active GHC session, the next that requires a GHC session
@@ -110,7 +116,7 @@ dropSession :: IOish m => GhcModT m ()
 dropSession = do
   s <- gmsGet
   case gmGhcSession s of
-    Just (GmGhcSession _opts ref) -> do
+    Just (GmGhcSession ref) -> do
       -- TODO: This is still not enough, there seem to still be references to
       -- GHC's state around afterwards.
       liftIO $ writeIORef ref (error "HscEnv: session was dropped")

Language/Haskell/GhcMod/Types.hs

@@ -188,7 +188,6 @@ instance Monoid GhcModLog where
         GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
 
 data GmGhcSession = GmGhcSession {
-      gmgsOptions :: ![GHCOption],
       gmgsSession :: !(IORef HscEnv)
     }
 

test/TargetSpec.hs

@@ -22,20 +22,20 @@ spec = do
               runLightGhc env (return ()) `shouldReturn` ()
 
         it "has modules in scope" $ do
-            withLightHscEnv [] $ \env ->
+            (withLightHscEnv [] $ \env ->
               runLightGhc env $ do
                dflags <- getSessionDynFlags
                let i = intersect (listVisibleModuleNames dflags)
                                  ["Control.Applicative", "Control.Arrow"
                                  ,"Control.Exception", "GHC.Exts", "GHC.Float"]
-               liftIO $ i `shouldSatisfy` not . null
+               liftIO $ i `shouldSatisfy` not . null) :: IO ()
 
         it "can get module info" $ do
-            withLightHscEnv [] $ \env ->
+            (withLightHscEnv [] $ \env ->
               runLightGhc env $ do
                 mdl <- findModule "Data.List" Nothing
                 mmi <- getModuleInfo mdl
-                liftIO $ isJust mmi `shouldBe` True
+                liftIO $ isJust mmi `shouldBe` True) :: IO ()
 
 
     describe "resolveModule" $ do