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