diff options
| -rw-r--r-- | ghc/GhciMonad.hs | 20 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 63 |
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 |