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