Commit 2f6e87a4 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

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
parent 834f9a46
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment