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