diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 23462aa..35ec1c0 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 2659c5a..d4ae862 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/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 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 diff --git a/Language/Haskell/GhcMod/LightGhc.hs b/Language/Haskell/GhcMod/LightGhc.hs index 6c53716..8978991 100644 --- a/Language/Haskell/GhcMod/LightGhc.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7b5c857..bac9e69 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/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") diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 407beef..f73e01f 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/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) } diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs index fda45a2..f5ceef2 100644 --- a/test/TargetSpec.hs +++ b/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