Introduce HasGhciState class and refactor use-sites

This allows to reach the GhciState without having to keep
track how many Monad transformer layers sit on top of the
GHCi monad.

While at it, this also refactors code to make more use of the
existing `modifyGHCiState` operation.

This is a preparatory refactoring for #10874

Differential Revision: https://phabricator.haskell.org/D1582

2 files changed, 39 insertions, 44 deletions

diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index 28c5657d77..c094b0844c 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -181,12 +181,20 @@ instance Applicative GHCi where
 instance Monad GHCi where
   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 
-getGHCiState :: GHCi GHCiState
-getGHCiState   = GHCi $ \r -> liftIO $ readIORef r
-setGHCiState :: GHCiState -> GHCi ()
-setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
-modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi ()
-modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f
+class HasGhciState m where
+    getGHCiState    :: m GHCiState
+    setGHCiState    :: GHCiState -> m ()
+    modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
+
+instance HasGhciState GHCi where
+    getGHCiState      = GHCi $ \r -> liftIO $ readIORef r
+    setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s
+    modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
+
+instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where
+    getGHCiState    = lift getGHCiState
+    setGHCiState    = lift . setGHCiState
+    modifyGHCiState = lift . modifyGHCiState
 
 liftGhc :: Ghc a -> GHCi a
 liftGhc m = GHCi $ \_ -> m
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 24e3c99eb4..02a8670ef1 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -620,10 +620,9 @@ checkPerms file =
 #endif
 
 incrementLineNo :: InputT GHCi ()
-incrementLineNo = do
-   st <- lift $ getGHCiState
-   let ln = 1+(line_number st)
-   lift $ setGHCiState st{line_number=ln}
+incrementLineNo = modifyGHCiState incLineNo
+  where
+    incLineNo st = st { line_number = line_number st + 1 }
 
 fileLoop :: Handle -> InputT GHCi (Maybe String)
 fileLoop hdl = do
@@ -766,10 +765,11 @@ runOneCommand eh gCmd = do
                                      ":{" -> multiLineCmd q
                                      _    -> return (Just c) )
     multiLineCmd q = do
-      st <- lift getGHCiState
+      st <- getGHCiState
       let p = prompt st
-      lift $ setGHCiState st{ prompt = prompt2 st }
-      mb_cmd <- collectCommand q "" `GHC.gfinally` lift (getGHCiState >>= \st' -> setGHCiState st' { prompt = p })
+      setGHCiState st{ prompt = prompt2 st }
+      mb_cmd <- collectCommand q "" `GHC.gfinally`
+                modifyGHCiState (\st' -> st' { prompt = p })
       return mb_cmd
     -- we can't use removeSpaces for the sublines here, so
     -- multiline commands are somewhat more brittle against
@@ -806,7 +806,7 @@ runOneCommand eh gCmd = do
       ml <- lift $ isOptionSet Multiline
       if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
         then do
-          fst_line_num <- lift (line_number <$> getGHCiState)
+          fst_line_num <- line_number <$> getGHCiState
           mb_stmt <- checkInputForLayout stmt gCmd
           case mb_stmt of
             Nothing      -> return $ Just True
@@ -816,7 +816,7 @@ runOneCommand eh gCmd = do
                 runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
               return $ Just (runSuccess result)
         else do -- single line input and :{ - multiline input
-          last_line_num <- lift (line_number <$> getGHCiState)
+          last_line_num <- line_number <$> getGHCiState
           -- reconstruct first line num from last line num and stmt
           let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
                            | otherwise = last_line_num -- single line input
@@ -851,16 +851,16 @@ checkInputForLayout :: String -> InputT GHCi (Maybe String)
 checkInputForLayout stmt getStmt = do
    dflags' <- lift $ getDynFlags
    let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
-   st0 <- lift $ getGHCiState
+   st0 <- getGHCiState
    let buf'   =  stringToStringBuffer stmt
        loc    = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
        pstate = Lexer.mkPState dflags buf' loc
    case Lexer.unP goToEnd pstate of
      (Lexer.POk _ False) -> return $ Just stmt
      _other              -> do
-       st1 <- lift getGHCiState
+       st1 <- getGHCiState
        let p = prompt st1
-       lift $ setGHCiState st1{ prompt = prompt2 st1 }
+       setGHCiState st1{ prompt = prompt2 st1 }
        mb_stmt <- ghciHandle (\ex -> case fromException ex of
                             Just UserInterrupt -> return Nothing
                             _ -> case fromException ex of
@@ -869,7 +869,7 @@ checkInputForLayout stmt getStmt = do
                                       return Nothing
                                  _other -> liftIO (Exception.throwIO ex))
                      getStmt
-       lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
+       modifyGHCiState (\st' -> st' { prompt = p })
        -- the recursive call does not recycle parser state
        -- as we use a new string buffer
        case mb_stmt of
@@ -1017,7 +1017,7 @@ specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
 specialCommand str = do
   let (cmd,rest) = break isSpace str
   maybe_cmd <- lift $ lookupCommand cmd
-  htxt <- lift $ short_help `fmap` getGHCiState
+  htxt <- short_help <$> getGHCiState
   case maybe_cmd of
     GotCommand (_,f,_) -> f (dropWhile isSpace rest)
     BadCommand ->
@@ -1040,8 +1040,7 @@ lookupCommand "" = do
       Nothing -> return NoLastCommand
 lookupCommand str = do
   mc <- lookupCommand' str
-  st <- getGHCiState
-  setGHCiState st{ last_command = mc }
+  modifyGHCiState (\st -> st { last_command = mc })
   return $ case mc of
            Just c -> GotCommand c
            Nothing -> BadCommand
@@ -1221,7 +1220,7 @@ trySuccess act =
 editFile :: String -> InputT GHCi ()
 editFile str =
   do file <- if null str then lift chooseEditFile else expandPath str
-     st <- lift getGHCiState
+     st <- getGHCiState
      errs <- liftIO $ readIORef $ lastErrorLocations st
      let cmd = editor st
      when (null cmd)
@@ -1613,14 +1612,14 @@ runScript filename = do
     Left _err    -> throwGhcException (CmdLineError $ "IO error:  \""++filename++"\" "
                       ++(ioeGetErrorString _err))
     Right script -> do
-      st <- lift $ getGHCiState
+      st <- getGHCiState
       let prog = progname st
           line = line_number st
-      lift $ setGHCiState st{progname=filename',line_number=0}
+      setGHCiState st{progname=filename',line_number=0}
       scriptLoop script
       liftIO $ hClose script
-      new_st <- lift $ getGHCiState
-      lift $ setGHCiState new_st{progname=prog,line_number=line}
+      new_st <- getGHCiState
+      setGHCiState new_st{progname=prog,line_number=line}
   where scriptLoop script = do
           res <- runOneCommand handler $ fileLoop script
           case res of
@@ -2110,17 +2109,9 @@ showDynFlags show_all dflags = do
 setArgs, setOptions :: [String] -> GHCi ()
 setProg, setEditor, setStop :: String -> GHCi ()
 
-setArgs args = do
-  st <- getGHCiState
-  setGHCiState st{ GhciMonad.args = args }
-
-setProg prog = do
-  st <- getGHCiState
-  setGHCiState st{ progname = prog }
-
-setEditor cmd = do
-  st <- getGHCiState
-  setGHCiState st{ editor = cmd }
+setArgs args = modifyGHCiState (\st -> st { GhciMonad.args = args })
+setProg prog = modifyGHCiState (\st -> st { progname = prog })
+setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })
 
 setStop str@(c:_) | isDigit c
   = do let (nm_str,rest) = break (not.isDigit) str
@@ -2135,9 +2126,7 @@ setStop str@(c:_) | isDigit c
            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
                       | otherwise = (i,loc)
        setGHCiState st{ breaks = new_breaks }
-setStop cmd = do
-  st <- getGHCiState
-  setGHCiState st{ stop = cmd }
+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })
 
 setPrompt :: String -> GHCi ()
 setPrompt = setPrompt_ f err
@@ -3110,9 +3099,7 @@ getTickArray modl = do
         return arr
 
 discardTickArrays :: GHCi ()
-discardTickArrays = do
-   st <- getGHCiState
-   setGHCiState st{tickarrays = emptyModuleEnv}
+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
 
 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
 mkTickArray ticks