Fix Trac #7560.
[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 getDynFlags,
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
41 import Exception
42 import Numeric
43 import Data.Array
44 import Data.Int ( Int64 )
45 import Data.IORef
46 import System.CPUTime
47 import System.Environment
48 import System.IO
49 import Control.Monad
50 import GHC.Exts
51
52 import System.Console.Haskeline (CompletionFunc, InputT)
53 import qualified System.Console.Haskeline as Haskeline
54 import Control.Monad.Trans.Class
55 import Control.Monad.IO.Class
56
57 -----------------------------------------------------------------------------
58 -- GHCi monad
59
60 type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
61
62 data GHCiState = GHCiState
63 {
64 progname :: String,
65 args :: [String],
66 prompt :: String,
67 def_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 -- available ghci commands
79 ghci_commands :: [Command],
80 -- ":" at the GHCi prompt repeats the last command, so we
81 -- remember is here:
82 last_command :: Maybe Command,
83 cmdqueue :: [String],
84
85 remembered_ctx :: [InteractiveImport],
86 -- the imports that the user has asked for, via import
87 -- declarations and :module commands. This list is
88 -- persistent over :reloads (but any imports for modules
89 -- that are not loaded are temporarily ignored). After a
90 -- :load, all the home-package imports are stripped from
91 -- this list.
92
93 -- See bugs #2049, #1873, #1360
94
95 transient_ctx :: [InteractiveImport],
96 -- An import added automatically after a :load, usually of
97 -- the most recently compiled module. May be empty if
98 -- there are no modules loaded. This list is replaced by
99 -- :load, :reload, and :add. In between it may be modified
100 -- by :module.
101
102 ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc)
103
104 -- help text to display to a user
105 short_help :: String,
106 long_help :: String
107 }
108
109 type TickArray = Array Int [(BreakIndex,SrcSpan)]
110
111 data GHCiOption
112 = ShowTiming -- show time/allocs after evaluation
113 | ShowType -- show the type of expressions
114 | RevertCAFs -- revert CAFs after every evaluation
115 | Multiline -- use multiline commands
116 deriving Eq
117
118 data BreakLocation
119 = BreakLocation
120 { breakModule :: !GHC.Module
121 , breakLoc :: !SrcSpan
122 , breakTick :: {-# UNPACK #-} !Int
123 , onBreakCmd :: String
124 }
125
126 instance Eq BreakLocation where
127 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
128 breakTick loc1 == breakTick loc2
129
130 prettyLocations :: [(Int, BreakLocation)] -> SDoc
131 prettyLocations [] = text "No active breakpoints."
132 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
133
134 instance Outputable BreakLocation where
135 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
136 if null (onBreakCmd loc)
137 then empty
138 else doubleQuotes (text (onBreakCmd loc))
139
140 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
141 recordBreak brkLoc = do
142 st <- getGHCiState
143 let oldActiveBreaks = breaks st
144 -- don't store the same break point twice
145 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
146 (nm:_) -> return (True, nm)
147 [] -> do
148 let oldCounter = break_ctr st
149 newCounter = oldCounter + 1
150 setGHCiState $ st { break_ctr = newCounter,
151 breaks = (oldCounter, brkLoc) : oldActiveBreaks
152 }
153 return (False, oldCounter)
154
155 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
156
157 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
158 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
159
160 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
161 reifyGHCi f = GHCi f'
162 where
163 -- f' :: IORef GHCiState -> Ghc a
164 f' gs = reifyGhc (f'' gs)
165 -- f'' :: IORef GHCiState -> Session -> IO a
166 f'' gs s = f (s, gs)
167
168 startGHCi :: GHCi a -> GHCiState -> Ghc a
169 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
170
171 instance Monad GHCi where
172 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
173 return a = GHCi $ \_ -> return a
174
175 instance Functor GHCi where
176 fmap f m = m >>= return . f
177
178 getGHCiState :: GHCi GHCiState
179 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
180 setGHCiState :: GHCiState -> GHCi ()
181 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
182 modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi ()
183 modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f
184
185 liftGhc :: Ghc a -> GHCi a
186 liftGhc m = GHCi $ \_ -> m
187
188 instance MonadIO GHCi where
189 liftIO = liftGhc . liftIO
190
191 instance HasDynFlags GHCi where
192 getDynFlags = getSessionDynFlags
193
194 instance GhcMonad GHCi where
195 setSession s' = liftGhc $ setSession s'
196 getSession = liftGhc $ getSession
197
198 instance HasDynFlags (InputT GHCi) where
199 getDynFlags = lift getDynFlags
200
201 instance GhcMonad (InputT GHCi) where
202 setSession = lift . setSession
203 getSession = lift getSession
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 Haskeline.MonadException Ghc where
217 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
218 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
219 in fmap (flip unGhc s) $ f run'
220
221 instance Haskeline.MonadException GHCi where
222 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
223 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
224 in fmap (flip unGHCi s) $ f run'
225
226 instance ExceptionMonad (InputT GHCi) where
227 gcatch = Haskeline.catch
228 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
229
230 gblock = Haskeline.liftIOOp_ gblock
231 gunblock = Haskeline.liftIOOp_ gunblock
232
233 isOptionSet :: GHCiOption -> GHCi Bool
234 isOptionSet opt
235 = do st <- getGHCiState
236 return (opt `elem` options st)
237
238 setOption :: GHCiOption -> GHCi ()
239 setOption opt
240 = do st <- getGHCiState
241 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
242
243 unsetOption :: GHCiOption -> GHCi ()
244 unsetOption opt
245 = do st <- getGHCiState
246 setGHCiState (st{ options = filter (/= opt) (options st) })
247
248 printForUser :: GhcMonad m => SDoc -> m ()
249 printForUser doc = do
250 unqual <- GHC.getPrintUnqual
251 dflags <- getDynFlags
252 liftIO $ Outputable.printForUser dflags stdout unqual doc
253
254 printForUserPartWay :: SDoc -> GHCi ()
255 printForUserPartWay doc = do
256 unqual <- GHC.getPrintUnqual
257 dflags <- getDynFlags
258 liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
259
260 -- | Run a single Haskell expression
261 runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
262 runStmt expr step = do
263 st <- getGHCiState
264 reifyGHCi $ \x ->
265 withProgName (progname st) $
266 withArgs (args st) $
267 reflectGHCi x $ do
268 GHC.handleSourceError (\e -> do GHC.printException e;
269 return Nothing) $ do
270 r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
271 return (Just r)
272
273 runDecls :: String -> GHCi [GHC.Name]
274 runDecls decls = do
275 st <- getGHCiState
276 reifyGHCi $ \x ->
277 withProgName (progname st) $
278 withArgs (args st) $
279 reflectGHCi x $ do
280 GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do
281 GHC.runDeclsWithLocation (progname st) (line_number st) decls
282
283 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
284 resume canLogSpan step = do
285 st <- getGHCiState
286 reifyGHCi $ \x ->
287 withProgName (progname st) $
288 withArgs (args st) $
289 reflectGHCi x $ do
290 GHC.resume canLogSpan step
291
292 -- --------------------------------------------------------------------------
293 -- timing & statistics
294
295 timeIt :: InputT GHCi a -> InputT GHCi a
296 timeIt action
297 = do b <- lift $ isOptionSet ShowTiming
298 if not b
299 then action
300 else do allocs1 <- liftIO $ getAllocations
301 time1 <- liftIO $ getCPUTime
302 a <- action
303 allocs2 <- liftIO $ getAllocations
304 time2 <- liftIO $ getCPUTime
305 dflags <- getDynFlags
306 liftIO $ printTimes dflags (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 :: DynFlags -> Integer -> Integer -> IO ()
314 printTimes dflags allocs psecs
315 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
316 secs_str = showFFloat (Just 2) secs
317 putStrLn (showSDoc dflags (
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