Commit e08974e8 authored by Zejun Wu's avatar Zejun Wu Committed by Ben Gamari

Introduce GhciMonad and generalize types of functions in GHCi.UI

Summary:
Introduce `GhciMonad`, which is bascially `GhcMonad` + `HasGhciState`.
Generalize the commands and help functions defined in `GHCi.UI` so they
can be used as both `GHCi a` and `InputT GHCi a`.

The long term plan is to move reusable bits to ghci library and make it
easier to build a customized interactive ui which carries customized state
and provides customized commands.

Most changes are trivial in this diff by relaxing the type constraint or
add/remove lift as necessary. The non-trivial changes are:

* Change `HasGhciState` to `GhciMonad` and expose it.
* Implementation of `reifyGHCi`.

Test Plan:
  ./validate

Reviewers: simonmar, hvr, bgamari

Reviewed By: simonmar

Subscribers: rwbarton, carter

Differential Revision: https://phabricator.haskell.org/D5433
parent 1be81c50
This diff is collapsed.
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
module GHCi.UI.Monad ( module GHCi.UI.Monad (
GHCi(..), startGHCi, GHCi(..), startGHCi,
GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState, GHCiState(..), GhciMonad(..),
GHCiOption(..), isOptionSet, setOption, unsetOption, GHCiOption(..), isOptionSet, setOption, unsetOption,
Command(..), CommandResult(..), cmdSuccess, Command(..), CommandResult(..), cmdSuccess,
PromptFunction, PromptFunction,
...@@ -219,7 +219,8 @@ instance Outputable BreakLocation where ...@@ -219,7 +219,8 @@ instance Outputable BreakLocation where
then Outputable.empty then Outputable.empty
else doubleQuotes (text (onBreakCmd loc)) else doubleQuotes (text (onBreakCmd loc))
recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) recordBreak
:: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)
recordBreak brkLoc = do recordBreak brkLoc = do
st <- getGHCiState st <- getGHCiState
let oldActiveBreaks = breaks st let oldActiveBreaks = breaks st
...@@ -239,13 +240,18 @@ newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } ...@@ -239,13 +240,18 @@ newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a reifyGHCi :: GhciMonad m => ((Session, IORef GHCiState) -> IO a) -> m a
reifyGHCi f = GHCi f' reifyGHCi f = do
where s <- GHC.getSession
-- f' :: IORef GHCiState -> Ghc a sRef <- liftIO $ newIORef s
f' gs = reifyGhc (f'' gs) gs <- getGHCiState
-- f'' :: IORef GHCiState -> Session -> IO a gsRef <- liftIO $ newIORef gs
f'' gs s = f (s, gs) ret <- liftIO (f (Session sRef, gsRef)) `gfinally` do
s' <- liftIO $ readIORef sRef
GHC.setSession s'
gs' <- liftIO $ readIORef gsRef
setGHCiState gs'
return ret
startGHCi :: GHCi a -> GHCiState -> Ghc a startGHCi :: GHCi a -> GHCiState -> Ghc a
startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
...@@ -260,20 +266,20 @@ instance Applicative GHCi where ...@@ -260,20 +266,20 @@ instance Applicative GHCi where
instance Monad GHCi where instance Monad GHCi where
(GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
class HasGhciState m where class GhcMonad m => GhciMonad m where
getGHCiState :: m GHCiState getGHCiState :: m GHCiState
setGHCiState :: GHCiState -> m () setGHCiState :: GHCiState -> m ()
modifyGHCiState :: (GHCiState -> GHCiState) -> m () modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
instance HasGhciState GHCi where instance GhciMonad GHCi where
getGHCiState = GHCi $ \r -> liftIO $ readIORef r getGHCiState = GHCi $ \r -> liftIO $ readIORef r
setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where instance GhciMonad (InputT GHCi) where
getGHCiState = lift getGHCiState getGHCiState = lift getGHCiState
setGHCiState = lift . setGHCiState setGHCiState = lift . setGHCiState
modifyGHCiState = lift . modifyGHCiState modifyGHCiState = lift . modifyGHCiState
liftGhc :: Ghc a -> GHCi a liftGhc :: Ghc a -> GHCi a
liftGhc m = GHCi $ \_ -> m liftGhc m = GHCi $ \_ -> m
...@@ -318,17 +324,17 @@ instance ExceptionMonad (InputT GHCi) where ...@@ -318,17 +324,17 @@ instance ExceptionMonad (InputT GHCi) where
gcatch = Haskeline.catch gcatch = Haskeline.catch
gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_) gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
isOptionSet :: GHCiOption -> GHCi Bool isOptionSet :: GhciMonad m => GHCiOption -> m Bool
isOptionSet opt isOptionSet opt
= do st <- getGHCiState = do st <- getGHCiState
return (opt `elem` options st) return (opt `elem` options st)
setOption :: GHCiOption -> GHCi () setOption :: GhciMonad m => GHCiOption -> m ()
setOption opt setOption opt
= do st <- getGHCiState = do st <- getGHCiState
setGHCiState (st{ options = opt : filter (/= opt) (options st) }) setGHCiState (st{ options = opt : filter (/= opt) (options st) })
unsetOption :: GHCiOption -> GHCi () unsetOption :: GhciMonad m => GHCiOption -> m ()
unsetOption opt unsetOption opt
= do st <- getGHCiState = do st <- getGHCiState
setGHCiState (st{ options = filter (/= opt) (options st) }) setGHCiState (st{ options = filter (/= opt) (options st) })
...@@ -351,14 +357,16 @@ printForUser doc = do ...@@ -351,14 +357,16 @@ printForUser doc = do
dflags <- getDynFlags dflags <- getDynFlags
liftIO $ Outputable.printForUser dflags stdout unqual doc liftIO $ Outputable.printForUser dflags stdout unqual doc
printForUserPartWay :: SDoc -> GHCi () printForUserPartWay :: GhcMonad m => SDoc -> m ()
printForUserPartWay doc = do printForUserPartWay doc = do
unqual <- GHC.getPrintUnqual unqual <- GHC.getPrintUnqual
dflags <- getDynFlags dflags <- getDynFlags
liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
-- | Run a single Haskell expression -- | Run a single Haskell expression
runStmt :: GhciLStmt GhcPs -> String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult) runStmt
:: GhciMonad m
=> GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)
runStmt stmt stmt_text step = do runStmt stmt stmt_text step = do
st <- getGHCiState st <- getGHCiState
GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
...@@ -370,7 +378,7 @@ runStmt stmt stmt_text step = do ...@@ -370,7 +378,7 @@ runStmt stmt stmt_text step = do
(EvalThis fhv) } (EvalThis fhv) }
Just <$> GHC.execStmt' stmt stmt_text opts Just <$> GHC.execStmt' stmt stmt_text opts
runDecls :: String -> GHCi (Maybe [GHC.Name]) runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])
runDecls decls = do runDecls decls = do
st <- getGHCiState st <- getGHCiState
reifyGHCi $ \x -> reifyGHCi $ \x ->
...@@ -382,7 +390,7 @@ runDecls decls = do ...@@ -382,7 +390,7 @@ runDecls decls = do
r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
return (Just r) return (Just r)
runDecls' :: [LHsDecl GhcPs] -> GHCi (Maybe [GHC.Name]) runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])
runDecls' decls = do runDecls' decls = do
st <- getGHCiState st <- getGHCiState
reifyGHCi $ \x -> reifyGHCi $ \x ->
...@@ -394,7 +402,7 @@ runDecls' decls = do ...@@ -394,7 +402,7 @@ runDecls' decls = do
return Nothing) return Nothing)
(Just <$> GHC.runParsedDecls decls) (Just <$> GHC.runParsedDecls decls)
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult
resume canLogSpan step = do resume canLogSpan step = do
st <- getGHCiState st <- getGHCiState
reifyGHCi $ \x -> reifyGHCi $ \x ->
...@@ -412,14 +420,15 @@ data ActionStats = ActionStats ...@@ -412,14 +420,15 @@ data ActionStats = ActionStats
} deriving Show } deriving Show
runAndPrintStats runAndPrintStats
:: (a -> Maybe Integer) :: GhciMonad m
-> InputT GHCi a => (a -> Maybe Integer)
-> InputT GHCi (ActionStats, Either SomeException a) -> m a
-> m (ActionStats, Either SomeException a)
runAndPrintStats getAllocs action = do runAndPrintStats getAllocs action = do
result <- runWithStats getAllocs action result <- runWithStats getAllocs action
case result of case result of
(stats, Right{}) -> do (stats, Right{}) -> do
showTiming <- lift $ isOptionSet ShowTiming showTiming <- isOptionSet ShowTiming
when showTiming $ do when showTiming $ do
dflags <- getDynFlags dflags <- getDynFlags
liftIO $ printStats dflags stats liftIO $ printStats dflags stats
...@@ -455,7 +464,7 @@ printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs} ...@@ -455,7 +464,7 @@ printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- reverting CAFs -- reverting CAFs
revertCAFs :: GHCi () revertCAFs :: GhciMonad m => m ()
revertCAFs = do revertCAFs = do
liftIO rts_revertCAFs liftIO rts_revertCAFs
s <- getGHCiState s <- getGHCiState
...@@ -483,14 +492,14 @@ initInterpBuffering = do ...@@ -483,14 +492,14 @@ initInterpBuffering = do
return (nobuf, flush) return (nobuf, flush)
-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter -- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
flushInterpBuffers :: GHCi () flushInterpBuffers :: GhciMonad m => m ()
flushInterpBuffers = do flushInterpBuffers = do
st <- getGHCiState st <- getGHCiState
hsc_env <- GHC.getSession hsc_env <- GHC.getSession
liftIO $ evalIO hsc_env (flushStdHandles st) liftIO $ evalIO hsc_env (flushStdHandles st)
-- | Turn off buffering for stdin, stdout, and stderr in the interpreter -- | Turn off buffering for stdin, stdout, and stderr in the interpreter
turnOffBuffering :: GHCi () turnOffBuffering :: GhciMonad m => m ()
turnOffBuffering = do turnOffBuffering = do
st <- getGHCiState st <- getGHCiState
turnOffBuffering_ (noBuffering st) turnOffBuffering_ (noBuffering st)
......
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