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