Updated output for test ghci024
[ghc.git] / ghc / GhciMonad.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 GhciMonad (
14 GHCi(..), startGHCi,
15 GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,
16 GHCiOption(..), isOptionSet, setOption, unsetOption,
17 Command,
18 BreakLocation(..),
19 TickArray,
20 getDynFlags,
21
22 runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
23
24 printForUser, printForUserPartWay, prettyLocations,
25 initInterpBuffering, turnOffBuffering, flushInterpBuffers,
26 ) where
27
28 #include "HsVersions.h"
29
30 import qualified GHC
31 import GhcMonad hiding (liftIO)
32 import Outputable hiding (printForUser, printForUserPartWay)
33 import qualified Outputable
34 import Util
35 import DynFlags
36 import FastString
37 import HscTypes
38 import SrcLoc
39 import Module
40 import ObjLink
41 import Linker
42
43 import Exception
44 import Numeric
45 import Data.Array
46 import Data.IORef
47 import System.CPUTime
48 import System.Environment
49 import System.IO
50 import Control.Monad
51 import GHC.Exts
52
53 import System.Console.Haskeline (CompletionFunc, InputT)
54 import qualified System.Console.Haskeline as Haskeline
55 import Control.Monad.Trans.Class
56 import Control.Monad.IO.Class
57
58 #if __GLASGOW_HASKELL__ < 709
59 import Control.Applicative (Applicative(..))
60 #endif
61
62 -----------------------------------------------------------------------------
63 -- GHCi monad
64
65 -- the Bool means: True = we should exit GHCi (:quit)
66 type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
67
68 data GHCiState = GHCiState
69 {
70 progname :: String,
71 args :: [String],
72 prompt :: String,
73 prompt2 :: String,
74 editor :: String,
75 stop :: String,
76 options :: [GHCiOption],
77 line_number :: !Int, -- input line
78 break_ctr :: !Int,
79 breaks :: ![(Int, BreakLocation)],
80 tickarrays :: ModuleEnv TickArray,
81 -- tickarrays caches the TickArray for loaded modules,
82 -- so that we don't rebuild it each time the user sets
83 -- a breakpoint.
84 -- available ghci commands
85 ghci_commands :: [Command],
86 -- ":" at the GHCi prompt repeats the last command, so we
87 -- remember it here:
88 last_command :: Maybe Command,
89 cmdqueue :: [String],
90
91 remembered_ctx :: [InteractiveImport],
92 -- the imports that the user has asked for, via import
93 -- declarations and :module commands. This list is
94 -- persistent over :reloads (but any imports for modules
95 -- that are not loaded are temporarily ignored). After a
96 -- :load, all the home-package imports are stripped from
97 -- this list.
98
99 -- See bugs #2049, #1873, #1360
100
101 transient_ctx :: [InteractiveImport],
102 -- An import added automatically after a :load, usually of
103 -- the most recently compiled module. May be empty if
104 -- there are no modules loaded. This list is replaced by
105 -- :load, :reload, and :add. In between it may be modified
106 -- by :module.
107
108 ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc)
109
110 -- help text to display to a user
111 short_help :: String,
112 long_help :: String,
113 lastErrorLocations :: IORef [(FastString, Int)]
114 }
115
116 type TickArray = Array Int [(BreakIndex,SrcSpan)]
117
118 data GHCiOption
119 = ShowTiming -- show time/allocs after evaluation
120 | ShowType -- show the type of expressions
121 | RevertCAFs -- revert CAFs after every evaluation
122 | Multiline -- use multiline commands
123 deriving Eq
124
125 data BreakLocation
126 = BreakLocation
127 { breakModule :: !GHC.Module
128 , breakLoc :: !SrcSpan
129 , breakTick :: {-# UNPACK #-} !Int
130 , onBreakCmd :: String
131 }
132
133 instance Eq BreakLocation where
134 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
135 breakTick loc1 == breakTick loc2
136
137 prettyLocations :: [(Int, BreakLocation)] -> SDoc
138 prettyLocations [] = text "No active breakpoints."
139 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
140
141 instance Outputable BreakLocation where
142 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
143 if null (onBreakCmd loc)
144 then Outputable.empty
145 else doubleQuotes (text (onBreakCmd loc))
146
147 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
148 recordBreak brkLoc = do
149 st <- getGHCiState
150 let oldActiveBreaks = breaks st
151 -- don't store the same break point twice
152 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
153 (nm:_) -> return (True, nm)
154 [] -> do
155 let oldCounter = break_ctr st
156 newCounter = oldCounter + 1
157 setGHCiState $ st { break_ctr = newCounter,
158 breaks = (oldCounter, brkLoc) : oldActiveBreaks
159 }
160 return (False, oldCounter)
161
162 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
163
164 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
165 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
166
167 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
168 reifyGHCi f = GHCi f'
169 where
170 -- f' :: IORef GHCiState -> Ghc a
171 f' gs = reifyGhc (f'' gs)
172 -- f'' :: IORef GHCiState -> Session -> IO a
173 f'' gs s = f (s, gs)
174
175 startGHCi :: GHCi a -> GHCiState -> Ghc a
176 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
177
178 instance Functor GHCi where
179 fmap = liftM
180
181 instance Applicative GHCi where
182 pure = return
183 (<*>) = ap
184
185 instance Monad GHCi where
186 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
187 return a = GHCi $ \_ -> return a
188
189 getGHCiState :: GHCi GHCiState
190 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
191 setGHCiState :: GHCiState -> GHCi ()
192 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
193 modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi ()
194 modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f
195
196 liftGhc :: Ghc a -> GHCi a
197 liftGhc m = GHCi $ \_ -> m
198
199 instance MonadIO GHCi where
200 liftIO = liftGhc . liftIO
201
202 instance HasDynFlags GHCi where
203 getDynFlags = getSessionDynFlags
204
205 instance GhcMonad GHCi where
206 setSession s' = liftGhc $ setSession s'
207 getSession = liftGhc $ getSession
208
209 instance HasDynFlags (InputT GHCi) where
210 getDynFlags = lift getDynFlags
211
212 instance GhcMonad (InputT GHCi) where
213 setSession = lift . setSession
214 getSession = lift getSession
215
216 instance ExceptionMonad GHCi where
217 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
218 gmask f =
219 GHCi $ \s -> gmask $ \io_restore ->
220 let
221 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
222 in
223 unGHCi (f g_restore) s
224
225 instance Haskeline.MonadException Ghc where
226 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
227 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
228 in fmap (flip unGhc s) $ f run'
229
230 instance Haskeline.MonadException GHCi where
231 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
232 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
233 in fmap (flip unGHCi s) $ f run'
234
235 instance ExceptionMonad (InputT GHCi) where
236 gcatch = Haskeline.catch
237 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
238
239 isOptionSet :: GHCiOption -> GHCi Bool
240 isOptionSet opt
241 = do st <- getGHCiState
242 return (opt `elem` options st)
243
244 setOption :: GHCiOption -> GHCi ()
245 setOption opt
246 = do st <- getGHCiState
247 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
248
249 unsetOption :: GHCiOption -> GHCi ()
250 unsetOption opt
251 = do st <- getGHCiState
252 setGHCiState (st{ options = filter (/= opt) (options st) })
253
254 printForUser :: GhcMonad m => SDoc -> m ()
255 printForUser doc = do
256 unqual <- GHC.getPrintUnqual
257 dflags <- getDynFlags
258 liftIO $ Outputable.printForUser dflags stdout unqual doc
259
260 printForUserPartWay :: SDoc -> GHCi ()
261 printForUserPartWay doc = do
262 unqual <- GHC.getPrintUnqual
263 dflags <- getDynFlags
264 liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
265
266 -- | Run a single Haskell expression
267 runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
268 runStmt expr step = do
269 st <- getGHCiState
270 reifyGHCi $ \x ->
271 withProgName (progname st) $
272 withArgs (args st) $
273 reflectGHCi x $ do
274 GHC.handleSourceError (\e -> do GHC.printException e;
275 return Nothing) $ do
276 let opts = GHC.execOptions
277 { GHC.execSourceFile = progname st
278 , GHC.execLineNumber = line_number st
279 , GHC.execSingleStep = step }
280 r <- GHC.execStmt expr opts
281 return (Just r)
282
283 runDecls :: String -> GHCi (Maybe [GHC.Name])
284 runDecls decls = do
285 st <- getGHCiState
286 reifyGHCi $ \x ->
287 withProgName (progname st) $
288 withArgs (args st) $
289 reflectGHCi x $ do
290 GHC.handleSourceError (\e -> do GHC.printException e;
291 return Nothing) $ do
292 r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
293 return (Just r)
294
295 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult
296 resume canLogSpan step = do
297 st <- getGHCiState
298 reifyGHCi $ \x ->
299 withProgName (progname st) $
300 withArgs (args st) $
301 reflectGHCi x $ do
302 GHC.resumeExec canLogSpan step
303
304 -- --------------------------------------------------------------------------
305 -- timing & statistics
306
307 timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a
308 timeIt getAllocs action
309 = do b <- lift $ isOptionSet ShowTiming
310 if not b
311 then action
312 else do time1 <- liftIO $ getCPUTime
313 a <- action
314 let allocs = getAllocs a
315 time2 <- liftIO $ getCPUTime
316 dflags <- getDynFlags
317 liftIO $ printTimes dflags allocs (time2 - time1)
318 return a
319
320 printTimes :: DynFlags -> Maybe Integer -> Integer -> IO ()
321 printTimes dflags mallocs psecs
322 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
323 secs_str = showFFloat (Just 2) secs
324 putStrLn (showSDoc dflags (
325 parens (text (secs_str "") <+> text "secs" <> comma <+>
326 case mallocs of
327 Nothing -> empty
328 Just allocs ->
329 text (separateThousands allocs) <+> text "bytes")))
330 where
331 separateThousands n = reverse . sep . reverse . show $ n
332 where sep n'
333 | length n' <= 3 = n'
334 | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
335
336 -----------------------------------------------------------------------------
337 -- reverting CAFs
338
339 revertCAFs :: GHCi ()
340 revertCAFs = do
341 liftIO rts_revertCAFs
342 s <- getGHCiState
343 when (not (ghc_e s)) $ liftIO turnOffBuffering
344 -- Have to turn off buffering again, because we just
345 -- reverted stdout, stderr & stdin to their defaults.
346
347 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
348 -- Make it "safe", just in case
349
350 -----------------------------------------------------------------------------
351 -- To flush buffers for the *interpreted* computation we need
352 -- to refer to *its* stdout/stderr handles
353
354 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
355 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
356 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
357
358 -- After various attempts, I believe this is the least bad way to do
359 -- what we want. We know look up the address of the static stdin,
360 -- stdout, and stderr closures in the loaded base package, and each
361 -- time we need to refer to them we cast the pointer to a Handle.
362 -- This avoids any problems with the CAF having been reverted, because
363 -- we'll always get the current value.
364 --
365 -- The previous attempt that didn't work was to compile an expression
366 -- like "hSetBuffering stdout NoBuffering" into an expression of type
367 -- IO () and run this expression each time we needed it, but the
368 -- problem is that evaluating the expression might cache the contents
369 -- of the Handle rather than referring to it from its static address
370 -- each time. There's no safe workaround for this.
371
372 initInterpBuffering :: Ghc ()
373 initInterpBuffering = do -- make sure these are linked
374 dflags <- GHC.getSessionDynFlags
375 liftIO $ do
376 initDynLinker dflags
377
378 -- ToDo: we should really look up these names properly, but
379 -- it's a fiddle and not all the bits are exposed via the GHC
380 -- interface.
381 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
382 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
383 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
384
385 let f ref (Just ptr) = writeIORef ref ptr
386 f _ Nothing = panic "interactiveUI:setBuffering2"
387 zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
388 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
389
390 flushInterpBuffers :: GHCi ()
391 flushInterpBuffers
392 = liftIO $ do getHandle stdout_ptr >>= hFlush
393 getHandle stderr_ptr >>= hFlush
394
395 turnOffBuffering :: IO ()
396 turnOffBuffering
397 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
398 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
399
400 getHandle :: IORef (Ptr ()) -> IO Handle
401 getHandle ref = do
402 (Ptr addr) <- readIORef ref
403 case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)
404