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