Fix re-init of ghc-modi session after environment change

Using `dropSession` instead of a weird exception cludge

Language/Haskell/GhcMod.hs

@@ -28,6 +28,7 @@ module Language.Haskell.GhcMod (
   -- * Monad utilities
   , runGhcModT
   , withOptions
+  , dropSession
   -- * 'GhcMod' utilities
   , boot
   , browse
@@ -73,3 +74,4 @@ import Language.Haskell.GhcMod.Modules
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.PkgDoc
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Target

Language/Haskell/GhcMod/Target.hs

@@ -110,6 +110,8 @@ initSession opts mdf = do
        _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
        getSession
 
+-- | Drop the currently active GHC session, the next that requires a GHC session
+-- will initialize a new one.
 dropSession :: IOish m => GhcModT m ()
 dropSession = do
   s <- gmsGet
@@ -120,10 +122,10 @@ dropSession = do
       liftIO $ writeIORef ref (error "HscEnv: session was dropped")
       -- Not available on ghc<7.8; didn't really help anyways
       -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped")
-
+      gmsPut s { gmGhcSession = Nothing }
 
     Nothing -> return ()
-  gmsPut s { gmGhcSession = Nothing }
+
 
 runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a
 runGmlT fns action = runGmlT' fns return action

src/GHCMod.hs

@@ -341,12 +341,11 @@ progMain (globalOptions,cmdArgs) = do
 
 -- ghc-modi
 legacyInteractive :: IOish m => GhcModT m ()
-legacyInteractive =
-  liftIO emptyNewUnGetLine >>= \ref -> do
+legacyInteractive = do
     opt <- options
     symdbreq <- liftIO $ newSymDbReq opt
     world <- liftIO . getCurrentWorld =<< cradle
-    legacyInteractiveLoop symdbreq ref world
+    legacyInteractiveLoop symdbreq world
 
 bug :: String -> IO ()
 bug msg = do
@@ -363,19 +362,18 @@ replace :: String -> String -> String -> String
 replace needle replacement = intercalate replacement . splitOn needle
 
 legacyInteractiveLoop :: IOish m
-                      => SymDbReq -> UnGetLine -> World -> GhcModT m ()
-legacyInteractiveLoop symdbreq ref world = do
+                      => SymDbReq -> World -> GhcModT m ()
+legacyInteractiveLoop symdbreq world = do
     liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
 
     -- blocking
-    cmdArg <- liftIO $ getCommand ref
+    cmdArg <- liftIO $ getLine
 
     -- after blocking, we need to see if the world has changed.
 
     changed <- liftIO . didWorldChange world =<< cradle
     when changed $ do
-        liftIO $ ungetCommand ref cmdArg
-        throw Restart
+        dropSession
 
     let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
         arg = concat args'
@@ -405,7 +403,7 @@ legacyInteractiveLoop symdbreq ref world = do
         _        -> fatalError $ "unknown command: `" ++ cmd ++ "'"
 
     liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout
-    legacyInteractiveLoop symdbreq ref world
+    legacyInteractiveLoop symdbreq world
 
 globalCommands :: [String] -> Maybe String
 globalCommands []      = Nothing

src/Misc.hs

@@ -1,13 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable, CPP #-}
 
 module Misc (
-    GHCModiError(..)
-  , Restart(..)
-  , UnGetLine
-  , emptyNewUnGetLine
-  , ungetCommand
-  , getCommand
-  , SymDbReq
+    SymDbReq
   , newSymDbReq
   , getDb
   , checkDb
@@ -26,37 +20,6 @@ import Language.Haskell.GhcMod.Internal
 
 ----------------------------------------------------------------
 
-data GHCModiError = CmdArg [String] deriving (Show, Typeable)
-
-instance Exception GHCModiError
-
-----------------------------------------------------------------
-
-data Restart = Restart deriving (Show, Typeable)
-
-instance Exception Restart
-
-----------------------------------------------------------------
-
-newtype UnGetLine = UnGetLine (IORef (Maybe String))
-
-emptyNewUnGetLine :: IO UnGetLine
-emptyNewUnGetLine = UnGetLine <$> newIORef Nothing
-
-ungetCommand :: UnGetLine -> String -> IO ()
-ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd)
-
-getCommand :: UnGetLine -> IO String
-getCommand (UnGetLine ref) = do
-    mcmd <- readIORef ref
-    case mcmd of
-        Nothing -> getLine
-        Just cmd -> do
-            writeIORef ref Nothing
-            return cmd
-
-----------------------------------------------------------------
-
 type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
 data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)