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