diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 763384e..516ffa2 100644 --- a/Language/Haskell/GhcMod.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7b1fc6c..93afccc 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index ce66c08..43a2e8a 100644 --- a/src/GHCMod.hs +++ b/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 diff --git a/src/Misc.hs b/src/Misc.hs index 6b6fbcf..dc63ed0 100644 --- a/src/Misc.hs +++ b/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)