Introduce ghci command wrapper
[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(..), setGHCiState, getGHCiState, modifyGHCiState,
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 :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
223 recordBreak brkLoc = do
224 st <- getGHCiState
225 let oldActiveBreaks = breaks st
226 -- don't store the same break point twice
227 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
228 (nm:_) -> return (True, nm)
229 [] -> do
230 let oldCounter = break_ctr st
231 newCounter = oldCounter + 1
232 setGHCiState $ st { break_ctr = newCounter,
233 breaks = (oldCounter, brkLoc) : oldActiveBreaks
234 }
235 return (False, oldCounter)
236
237 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
238
239 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
240 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
241
242 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
243 reifyGHCi f = GHCi f'
244 where
245 -- f' :: IORef GHCiState -> Ghc a
246 f' gs = reifyGhc (f'' gs)
247 -- f'' :: IORef GHCiState -> Session -> IO a
248 f'' gs s = f (s, gs)
249
250 startGHCi :: GHCi a -> GHCiState -> Ghc a
251 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
252
253 instance Functor GHCi where
254 fmap = liftM
255
256 instance Applicative GHCi where
257 pure a = GHCi $ \_ -> pure a
258 (<*>) = ap
259
260 instance Monad GHCi where
261 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
262
263 class HasGhciState m where
264 getGHCiState :: m GHCiState
265 setGHCiState :: GHCiState -> m ()
266 modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
267
268 instance HasGhciState GHCi where
269 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
270 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
271 modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
272
273 instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where
274 getGHCiState = lift getGHCiState
275 setGHCiState = lift . setGHCiState
276 modifyGHCiState = lift . modifyGHCiState
277
278 liftGhc :: Ghc a -> GHCi a
279 liftGhc m = GHCi $ \_ -> m
280
281 instance MonadIO GHCi where
282 liftIO = liftGhc . liftIO
283
284 instance HasDynFlags GHCi where
285 getDynFlags = getSessionDynFlags
286
287 instance GhcMonad GHCi where
288 setSession s' = liftGhc $ setSession s'
289 getSession = liftGhc $ getSession
290
291 instance HasDynFlags (InputT GHCi) where
292 getDynFlags = lift getDynFlags
293
294 instance GhcMonad (InputT GHCi) where
295 setSession = lift . setSession
296 getSession = lift getSession
297
298 instance ExceptionMonad GHCi where
299 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
300 gmask f =
301 GHCi $ \s -> gmask $ \io_restore ->
302 let
303 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
304 in
305 unGHCi (f g_restore) s
306
307 instance Haskeline.MonadException Ghc where
308 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
309 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
310 in fmap (flip unGhc s) $ f run'
311
312 instance Haskeline.MonadException GHCi where
313 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
314 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
315 in fmap (flip unGHCi s) $ f run'
316
317 instance ExceptionMonad (InputT GHCi) where
318 gcatch = Haskeline.catch
319 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
320
321 isOptionSet :: GHCiOption -> GHCi Bool
322 isOptionSet opt
323 = do st <- getGHCiState
324 return (opt `elem` options st)
325
326 setOption :: GHCiOption -> GHCi ()
327 setOption opt
328 = do st <- getGHCiState
329 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
330
331 unsetOption :: GHCiOption -> GHCi ()
332 unsetOption opt
333 = do st <- getGHCiState
334 setGHCiState (st{ options = filter (/= opt) (options st) })
335
336 printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
337 printForUserNeverQualify doc = do
338 dflags <- getDynFlags
339 liftIO $ Outputable.printForUser dflags stdout neverQualify doc
340
341 printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
342 printForUserModInfo info doc = do
343 dflags <- getDynFlags
344 mUnqual <- GHC.mkPrintUnqualifiedForModule info
345 unqual <- maybe GHC.getPrintUnqual return mUnqual
346 liftIO $ Outputable.printForUser dflags stdout unqual doc
347
348 printForUser :: GhcMonad m => SDoc -> m ()
349 printForUser doc = do
350 unqual <- GHC.getPrintUnqual
351 dflags <- getDynFlags
352 liftIO $ Outputable.printForUser dflags stdout unqual doc
353
354 printForUserPartWay :: SDoc -> GHCi ()
355 printForUserPartWay doc = do
356 unqual <- GHC.getPrintUnqual
357 dflags <- getDynFlags
358 liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
359
360 -- | Run a single Haskell expression
361 runStmt :: GhciLStmt GhcPs -> String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
362 runStmt stmt stmt_text step = do
363 st <- getGHCiState
364 GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
365 let opts = GHC.execOptions
366 { GHC.execSourceFile = progname st
367 , GHC.execLineNumber = line_number st
368 , GHC.execSingleStep = step
369 , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))
370 (EvalThis fhv) }
371 Just <$> GHC.execStmt' stmt stmt_text opts
372
373 runDecls :: String -> GHCi (Maybe [GHC.Name])
374 runDecls decls = do
375 st <- getGHCiState
376 reifyGHCi $ \x ->
377 withProgName (progname st) $
378 withArgs (args st) $
379 reflectGHCi x $ do
380 GHC.handleSourceError (\e -> do GHC.printException e;
381 return Nothing) $ do
382 r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
383 return (Just r)
384
385 runDecls' :: [LHsDecl GhcPs] -> GHCi (Maybe [GHC.Name])
386 runDecls' decls = do
387 st <- getGHCiState
388 reifyGHCi $ \x ->
389 withProgName (progname st) $
390 withArgs (args st) $
391 reflectGHCi x $
392 GHC.handleSourceError
393 (\e -> do GHC.printException e;
394 return Nothing)
395 (Just <$> GHC.runParsedDecls decls)
396
397 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult
398 resume canLogSpan step = do
399 st <- getGHCiState
400 reifyGHCi $ \x ->
401 withProgName (progname st) $
402 withArgs (args st) $
403 reflectGHCi x $ do
404 GHC.resumeExec canLogSpan step
405
406 -- --------------------------------------------------------------------------
407 -- timing & statistics
408
409 data ActionStats = ActionStats
410 { actionAllocs :: Maybe Integer
411 , actionElapsedTime :: Double
412 } deriving Show
413
414 runAndPrintStats
415 :: (a -> Maybe Integer)
416 -> InputT GHCi a
417 -> InputT GHCi (ActionStats, Either SomeException a)
418 runAndPrintStats getAllocs action = do
419 result <- runWithStats getAllocs action
420 case result of
421 (stats, Right{}) -> do
422 showTiming <- lift $ isOptionSet ShowTiming
423 when showTiming $ do
424 dflags <- getDynFlags
425 liftIO $ printStats dflags stats
426 _ -> return ()
427 return result
428
429 runWithStats
430 :: ExceptionMonad m
431 => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)
432 runWithStats getAllocs action = do
433 t0 <- liftIO getCurrentTime
434 result <- gtry action
435 let allocs = either (const Nothing) getAllocs result
436 t1 <- liftIO getCurrentTime
437 let elapsedTime = realToFrac $ t1 `diffUTCTime` t0
438 return (ActionStats allocs elapsedTime, result)
439
440 printStats :: DynFlags -> ActionStats -> IO ()
441 printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
442 = do let secs_str = showFFloat (Just 2) secs
443 putStrLn (showSDoc dflags (
444 parens (text (secs_str "") <+> text "secs" <> comma <+>
445 case mallocs of
446 Nothing -> empty
447 Just allocs ->
448 text (separateThousands allocs) <+> text "bytes")))
449 where
450 separateThousands n = reverse . sep . reverse . show $ n
451 where sep n'
452 | n' `lengthAtMost` 3 = n'
453 | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
454
455 -----------------------------------------------------------------------------
456 -- reverting CAFs
457
458 revertCAFs :: GHCi ()
459 revertCAFs = do
460 liftIO rts_revertCAFs
461 s <- getGHCiState
462 when (not (ghc_e s)) turnOffBuffering
463 -- Have to turn off buffering again, because we just
464 -- reverted stdout, stderr & stdin to their defaults.
465
466 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
467 -- Make it "safe", just in case
468
469 -----------------------------------------------------------------------------
470 -- To flush buffers for the *interpreted* computation we need
471 -- to refer to *its* stdout/stderr handles
472
473 -- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
474 initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
475 initInterpBuffering = do
476 nobuf <- compileGHCiExpr $
477 "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++
478 " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++
479 " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"
480 flush <- compileGHCiExpr $
481 "do { System.IO.hFlush System.IO.stdout; " ++
482 " System.IO.hFlush System.IO.stderr }"
483 return (nobuf, flush)
484
485 -- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
486 flushInterpBuffers :: GHCi ()
487 flushInterpBuffers = do
488 st <- getGHCiState
489 hsc_env <- GHC.getSession
490 liftIO $ evalIO hsc_env (flushStdHandles st)
491
492 -- | Turn off buffering for stdin, stdout, and stderr in the interpreter
493 turnOffBuffering :: GHCi ()
494 turnOffBuffering = do
495 st <- getGHCiState
496 turnOffBuffering_ (noBuffering st)
497
498 turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
499 turnOffBuffering_ fhv = do
500 hsc_env <- getSession
501 liftIO $ evalIO hsc_env fhv
502
503 mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
504 mkEvalWrapper progname args =
505 compileGHCiExpr $
506 "\\m -> System.Environment.withProgName " ++ show progname ++
507 "(System.Environment.withArgs " ++ show args ++ " m)"
508
509 compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
510 compileGHCiExpr expr =
511 withTempSession mkTempSession $ GHC.compileExprRemote expr
512 where
513 mkTempSession hsc_env = hsc_env
514 { hsc_dflags = (hsc_dflags hsc_env)
515 -- RebindableSyntax can wreak havoc with GHCi in several ways
516 -- (see #13385 and #14342 for examples), so we take care to disable it
517 -- for the duration of running expressions that are internal to GHCi.
518 `xopt_unset` LangExt.RebindableSyntax
519 -- We heavily depend on -fimplicit-import-qualified to compile expr
520 -- with fully qualified names without imports.
521 `gopt_set` Opt_ImplicitImportQualified
522 }