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