Introduce GhciMonad and generalize types of functions in GHCi.UI
[ghc.git] / ghc / GHCi / UI / Monad.hs
1 {-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}
2 {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
3 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4
5 -----------------------------------------------------------------------------
6 --
7 -- Monadery code used in InteractiveUI
8 --
9 -- (c) The GHC Team 2005-2006
10 --
11 -----------------------------------------------------------------------------
12
13 module GHCi.UI.Monad (
14 GHCi(..), startGHCi,
15 GHCiState(..), GhciMonad(..),
16 GHCiOption(..), isOptionSet, setOption, unsetOption,
17 Command(..), CommandResult(..), cmdSuccess,
18 PromptFunction,
19 BreakLocation(..),
20 TickArray,
21 getDynFlags,
22
23 runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,
24 ActionStats(..), runAndPrintStats, runWithStats, printStats,
25
26 printForUserNeverQualify, printForUserModInfo,
27 printForUser, printForUserPartWay, prettyLocations,
28
29 compileGHCiExpr,
30 initInterpBuffering,
31 turnOffBuffering, turnOffBuffering_,
32 flushInterpBuffers,
33 mkEvalWrapper
34 ) where
35
36 #include "HsVersions.h"
37
38 import GHCi.UI.Info (ModInfo)
39 import qualified GHC
40 import GhcMonad hiding (liftIO)
41 import Outputable hiding (printForUser, printForUserPartWay)
42 import qualified Outputable
43 import DynFlags
44 import FastString
45 import HscTypes
46 import SrcLoc
47 import Module
48 import GHCi
49 import GHCi.RemoteTypes
50 import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
51 import Util
52
53 import Exception
54 import Numeric
55 import Data.Array
56 import Data.IORef
57 import Data.Time
58 import System.Environment
59 import System.IO
60 import Control.Monad
61 import Prelude hiding ((<>))
62
63 import System.Console.Haskeline (CompletionFunc, InputT)
64 import qualified System.Console.Haskeline as Haskeline
65 import Control.Monad.Trans.Class
66 import Control.Monad.IO.Class
67 import Data.Map.Strict (Map)
68 import qualified GHC.LanguageExtensions as LangExt
69
70 -----------------------------------------------------------------------------
71 -- GHCi monad
72
73 data GHCiState = GHCiState
74 {
75 progname :: String,
76 args :: [String],
77 evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@
78 prompt :: PromptFunction,
79 prompt_cont :: PromptFunction,
80 editor :: String,
81 stop :: String,
82 options :: [GHCiOption],
83 line_number :: !Int, -- ^ input line
84 break_ctr :: !Int,
85 breaks :: ![(Int, BreakLocation)],
86 tickarrays :: ModuleEnv TickArray,
87 -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
88 -- so that we don't rebuild it each time the user sets
89 -- a breakpoint.
90 ghci_commands :: [Command],
91 -- ^ available ghci commands
92 ghci_macros :: [Command],
93 -- ^ user-defined macros
94 last_command :: Maybe Command,
95 -- ^ @:@ at the GHCi prompt repeats the last command, so we
96 -- remember it here
97 cmd_wrapper :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),
98 -- ^ The command wrapper is run for each command or statement.
99 -- The 'Bool' value denotes whether the command is successful and
100 -- 'Nothing' means to exit GHCi.
101 cmdqueue :: [String],
102
103 remembered_ctx :: [InteractiveImport],
104 -- ^ The imports that the user has asked for, via import
105 -- declarations and :module commands. This list is
106 -- persistent over :reloads (but any imports for modules
107 -- that are not loaded are temporarily ignored). After a
108 -- :load, all the home-package imports are stripped from
109 -- this list.
110 --
111 -- See bugs #2049, #1873, #1360
112
113 transient_ctx :: [InteractiveImport],
114 -- ^ An import added automatically after a :load, usually of
115 -- the most recently compiled module. May be empty if
116 -- there are no modules loaded. This list is replaced by
117 -- :load, :reload, and :add. In between it may be modified
118 -- by :module.
119
120 extra_imports :: [ImportDecl GhcPs],
121 -- ^ These are "always-on" imports, added to the
122 -- context regardless of what other imports we have.
123 -- This is useful for adding imports that are required
124 -- by setGHCiMonad. Be careful adding things here:
125 -- you can create ambiguities if these imports overlap
126 -- with other things in scope.
127 --
128 -- NB. although this is not currently used by GHCi itself,
129 -- it was added to support other front-ends that are based
130 -- on the GHCi code. Potentially we could also expose
131 -- this functionality via GHCi commands.
132
133 prelude_imports :: [ImportDecl GhcPs],
134 -- ^ These imports are added to the context when
135 -- -XImplicitPrelude is on and we don't have a *-module
136 -- in the context. They can also be overridden by another
137 -- import for the same module, e.g.
138 -- "import Prelude hiding (map)"
139
140 ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)
141
142 short_help :: String,
143 -- ^ help text to display to a user
144 long_help :: String,
145 lastErrorLocations :: IORef [(FastString, Int)],
146
147 mod_infos :: !(Map ModuleName ModInfo),
148
149 flushStdHandles :: ForeignHValue,
150 -- ^ @hFlush stdout; hFlush stderr@ in the interpreter
151 noBuffering :: ForeignHValue
152 -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr
153 }
154
155 type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
156
157 -- | A GHCi command
158 data Command
159 = Command
160 { cmdName :: String
161 -- ^ Name of GHCi command (e.g. "exit")
162 , cmdAction :: String -> InputT GHCi Bool
163 -- ^ The 'Bool' value denotes whether to exit GHCi
164 , cmdHidden :: Bool
165 -- ^ Commands which are excluded from default completion
166 -- and @:help@ summary. This is usually set for commands not
167 -- useful for interactive use but rather for IDEs.
168 , cmdCompletionFunc :: CompletionFunc GHCi
169 -- ^ 'CompletionFunc' for arguments
170 }
171
172 data CommandResult
173 = CommandComplete
174 { cmdInput :: String
175 , cmdResult :: Either SomeException (Maybe Bool)
176 , cmdStats :: ActionStats
177 }
178 | CommandIncomplete
179 -- ^ Unterminated multiline command
180 deriving Show
181
182 cmdSuccess :: Haskeline.MonadException m => CommandResult -> m (Maybe Bool)
183 cmdSuccess CommandComplete{ cmdResult = Left e } = liftIO $ throwIO e
184 cmdSuccess CommandComplete{ cmdResult = Right r } = return r
185 cmdSuccess CommandIncomplete = return $ Just True
186
187 type PromptFunction = [String]
188 -> Int
189 -> GHCi SDoc
190
191 data GHCiOption
192 = ShowTiming -- show time/allocs after evaluation
193 | ShowType -- show the type of expressions
194 | RevertCAFs -- revert CAFs after every evaluation
195 | Multiline -- use multiline commands
196 | CollectInfo -- collect and cache information about
197 -- modules after load
198 deriving Eq
199
200 data BreakLocation
201 = BreakLocation
202 { breakModule :: !GHC.Module
203 , breakLoc :: !SrcSpan
204 , breakTick :: {-# UNPACK #-} !Int
205 , onBreakCmd :: String
206 }
207
208 instance Eq BreakLocation where
209 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
210 breakTick loc1 == breakTick loc2
211
212 prettyLocations :: [(Int, BreakLocation)] -> SDoc
213 prettyLocations [] = text "No active breakpoints."
214 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
215
216 instance Outputable BreakLocation where
217 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
218 if null (onBreakCmd loc)
219 then Outputable.empty
220 else doubleQuotes (text (onBreakCmd loc))
221
222 recordBreak
223 :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)
224 recordBreak brkLoc = do
225 st <- getGHCiState
226 let oldActiveBreaks = breaks st
227 -- don't store the same break point twice
228 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
229 (nm:_) -> return (True, nm)
230 [] -> do
231 let oldCounter = break_ctr st
232 newCounter = oldCounter + 1
233 setGHCiState $ st { break_ctr = newCounter,
234 breaks = (oldCounter, brkLoc) : oldActiveBreaks
235 }
236 return (False, oldCounter)
237
238 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
239
240 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
241 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
242
243 reifyGHCi :: GhciMonad m => ((Session, IORef GHCiState) -> IO a) -> m a
244 reifyGHCi f = do
245 s <- GHC.getSession
246 sRef <- liftIO $ newIORef s
247 gs <- getGHCiState
248 gsRef <- liftIO $ newIORef gs
249 ret <- liftIO (f (Session sRef, gsRef)) `gfinally` do
250 s' <- liftIO $ readIORef sRef
251 GHC.setSession s'
252 gs' <- liftIO $ readIORef gsRef
253 setGHCiState gs'
254 return ret
255
256 startGHCi :: GHCi a -> GHCiState -> Ghc a
257 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
258
259 instance Functor GHCi where
260 fmap = liftM
261
262 instance Applicative GHCi where
263 pure a = GHCi $ \_ -> pure a
264 (<*>) = ap
265
266 instance Monad GHCi where
267 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
268
269 class GhcMonad m => GhciMonad m where
270 getGHCiState :: m GHCiState
271 setGHCiState :: GHCiState -> m ()
272 modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
273
274 instance GhciMonad GHCi where
275 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
276 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
277 modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
278
279 instance GhciMonad (InputT GHCi) where
280 getGHCiState = lift getGHCiState
281 setGHCiState = lift . setGHCiState
282 modifyGHCiState = lift . modifyGHCiState
283
284 liftGhc :: Ghc a -> GHCi a
285 liftGhc m = GHCi $ \_ -> m
286
287 instance MonadIO GHCi where
288 liftIO = liftGhc . liftIO
289
290 instance HasDynFlags GHCi where
291 getDynFlags = getSessionDynFlags
292
293 instance GhcMonad GHCi where
294 setSession s' = liftGhc $ setSession s'
295 getSession = liftGhc $ getSession
296
297 instance HasDynFlags (InputT GHCi) where
298 getDynFlags = lift getDynFlags
299
300 instance GhcMonad (InputT GHCi) where
301 setSession = lift . setSession
302 getSession = lift getSession
303
304 instance ExceptionMonad GHCi where
305 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
306 gmask f =
307 GHCi $ \s -> gmask $ \io_restore ->
308 let
309 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
310 in
311 unGHCi (f g_restore) s
312
313 instance Haskeline.MonadException Ghc where
314 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
315 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
316 in fmap (flip unGhc s) $ f run'
317
318 instance Haskeline.MonadException GHCi where
319 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
320 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
321 in fmap (flip unGHCi s) $ f run'
322
323 instance ExceptionMonad (InputT GHCi) where
324 gcatch = Haskeline.catch
325 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
326
327 isOptionSet :: GhciMonad m => GHCiOption -> m Bool
328 isOptionSet opt
329 = do st <- getGHCiState
330 return (opt `elem` options st)
331
332 setOption :: GhciMonad m => GHCiOption -> m ()
333 setOption opt
334 = do st <- getGHCiState
335 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
336
337 unsetOption :: GhciMonad m => GHCiOption -> m ()
338 unsetOption opt
339 = do st <- getGHCiState
340 setGHCiState (st{ options = filter (/= opt) (options st) })
341
342 printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
343 printForUserNeverQualify doc = do
344 dflags <- getDynFlags
345 liftIO $ Outputable.printForUser dflags stdout neverQualify doc
346
347 printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
348 printForUserModInfo info doc = do
349 dflags <- getDynFlags
350 mUnqual <- GHC.mkPrintUnqualifiedForModule info
351 unqual <- maybe GHC.getPrintUnqual return mUnqual
352 liftIO $ Outputable.printForUser dflags stdout unqual doc
353
354 printForUser :: GhcMonad m => SDoc -> m ()
355 printForUser doc = do
356 unqual <- GHC.getPrintUnqual
357 dflags <- getDynFlags
358 liftIO $ Outputable.printForUser dflags stdout unqual doc
359
360 printForUserPartWay :: GhcMonad m => SDoc -> m ()
361 printForUserPartWay doc = do
362 unqual <- GHC.getPrintUnqual
363 dflags <- getDynFlags
364 liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
365
366 -- | Run a single Haskell expression
367 runStmt
368 :: GhciMonad m
369 => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)
370 runStmt stmt stmt_text step = do
371 st <- getGHCiState
372 GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
373 let opts = GHC.execOptions
374 { GHC.execSourceFile = progname st
375 , GHC.execLineNumber = line_number st
376 , GHC.execSingleStep = step
377 , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))
378 (EvalThis fhv) }
379 Just <$> GHC.execStmt' stmt stmt_text opts
380
381 runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])
382 runDecls decls = do
383 st <- getGHCiState
384 reifyGHCi $ \x ->
385 withProgName (progname st) $
386 withArgs (args st) $
387 reflectGHCi x $ do
388 GHC.handleSourceError (\e -> do GHC.printException e;
389 return Nothing) $ do
390 r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
391 return (Just r)
392
393 runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])
394 runDecls' decls = do
395 st <- getGHCiState
396 reifyGHCi $ \x ->
397 withProgName (progname st) $
398 withArgs (args st) $
399 reflectGHCi x $
400 GHC.handleSourceError
401 (\e -> do GHC.printException e;
402 return Nothing)
403 (Just <$> GHC.runParsedDecls decls)
404
405 resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult
406 resume canLogSpan step = do
407 st <- getGHCiState
408 reifyGHCi $ \x ->
409 withProgName (progname st) $
410 withArgs (args st) $
411 reflectGHCi x $ do
412 GHC.resumeExec canLogSpan step
413
414 -- --------------------------------------------------------------------------
415 -- timing & statistics
416
417 data ActionStats = ActionStats
418 { actionAllocs :: Maybe Integer
419 , actionElapsedTime :: Double
420 } deriving Show
421
422 runAndPrintStats
423 :: GhciMonad m
424 => (a -> Maybe Integer)
425 -> m a
426 -> m (ActionStats, Either SomeException a)
427 runAndPrintStats getAllocs action = do
428 result <- runWithStats getAllocs action
429 case result of
430 (stats, Right{}) -> do
431 showTiming <- isOptionSet ShowTiming
432 when showTiming $ do
433 dflags <- getDynFlags
434 liftIO $ printStats dflags stats
435 _ -> return ()
436 return result
437
438 runWithStats
439 :: ExceptionMonad m
440 => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)
441 runWithStats getAllocs action = do
442 t0 <- liftIO getCurrentTime
443 result <- gtry action
444 let allocs = either (const Nothing) getAllocs result
445 t1 <- liftIO getCurrentTime
446 let elapsedTime = realToFrac $ t1 `diffUTCTime` t0
447 return (ActionStats allocs elapsedTime, result)
448
449 printStats :: DynFlags -> ActionStats -> IO ()
450 printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
451 = do let secs_str = showFFloat (Just 2) secs
452 putStrLn (showSDoc dflags (
453 parens (text (secs_str "") <+> text "secs" <> comma <+>
454 case mallocs of
455 Nothing -> empty
456 Just allocs ->
457 text (separateThousands allocs) <+> text "bytes")))
458 where
459 separateThousands n = reverse . sep . reverse . show $ n
460 where sep n'
461 | n' `lengthAtMost` 3 = n'
462 | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
463
464 -----------------------------------------------------------------------------
465 -- reverting CAFs
466
467 revertCAFs :: GhciMonad m => m ()
468 revertCAFs = do
469 liftIO rts_revertCAFs
470 s <- getGHCiState
471 when (not (ghc_e s)) turnOffBuffering
472 -- Have to turn off buffering again, because we just
473 -- reverted stdout, stderr & stdin to their defaults.
474
475 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
476 -- Make it "safe", just in case
477
478 -----------------------------------------------------------------------------
479 -- To flush buffers for the *interpreted* computation we need
480 -- to refer to *its* stdout/stderr handles
481
482 -- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
483 initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
484 initInterpBuffering = do
485 nobuf <- compileGHCiExpr $
486 "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++
487 " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++
488 " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"
489 flush <- compileGHCiExpr $
490 "do { System.IO.hFlush System.IO.stdout; " ++
491 " System.IO.hFlush System.IO.stderr }"
492 return (nobuf, flush)
493
494 -- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
495 flushInterpBuffers :: GhciMonad m => m ()
496 flushInterpBuffers = do
497 st <- getGHCiState
498 hsc_env <- GHC.getSession
499 liftIO $ evalIO hsc_env (flushStdHandles st)
500
501 -- | Turn off buffering for stdin, stdout, and stderr in the interpreter
502 turnOffBuffering :: GhciMonad m => m ()
503 turnOffBuffering = do
504 st <- getGHCiState
505 turnOffBuffering_ (noBuffering st)
506
507 turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
508 turnOffBuffering_ fhv = do
509 hsc_env <- getSession
510 liftIO $ evalIO hsc_env fhv
511
512 mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
513 mkEvalWrapper progname args =
514 compileGHCiExpr $
515 "\\m -> System.Environment.withProgName " ++ show progname ++
516 "(System.Environment.withArgs " ++ show args ++ " m)"
517
518 compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
519 compileGHCiExpr expr =
520 withTempSession mkTempSession $ GHC.compileExprRemote expr
521 where
522 mkTempSession hsc_env = hsc_env
523 { hsc_dflags = (hsc_dflags hsc_env) {
524 -- Running GHCi's internal expression is incompatible with -XSafe.
525 -- We temporarily disable any Safe Haskell settings while running
526 -- GHCi internal expressions. (see #12509)
527 safeHaskell = Sf_None
528 }
529 -- RebindableSyntax can wreak havoc with GHCi in several ways
530 -- (see #13385 and #14342 for examples), so we temporarily
531 -- disable it too.
532 `xopt_unset` LangExt.RebindableSyntax
533 -- We heavily depend on -fimplicit-import-qualified to compile expr
534 -- with fully qualified names without imports.
535 `gopt_set` Opt_ImplicitImportQualified
536 }