Add a class HasDynFlags(getDynFlags)
[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 HasDynFlags GHCi where
187 getDynFlags = getSessionDynFlags
188
189 instance GhcMonad GHCi where
190 setSession s' = liftGhc $ setSession s'
191 getSession = liftGhc $ getSession
192
193 instance HasDynFlags (InputT GHCi) where
194 getDynFlags = lift getDynFlags
195
196 instance GhcMonad (InputT GHCi) where
197 setSession = lift . setSession
198 getSession = lift getSession
199
200 instance MonadUtils.MonadIO (InputT GHCi) where
201 liftIO = Trans.liftIO
202
203 instance ExceptionMonad GHCi where
204 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
205 gblock (GHCi m) = GHCi $ \r -> gblock (m r)
206 gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
207 gmask f =
208 GHCi $ \s -> gmask $ \io_restore ->
209 let
210 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
211 in
212 unGHCi (f g_restore) s
213
214 instance MonadIO GHCi where
215 liftIO = MonadUtils.liftIO
216
217 instance Haskeline.MonadException GHCi where
218 catch = gcatch
219 block = gblock
220 unblock = gunblock
221 -- XXX when Haskeline's MonadException changes, we can drop our
222 -- deprecated block/unblock methods
223
224 instance ExceptionMonad (InputT GHCi) where
225 gcatch = Haskeline.catch
226 gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
227 gblock = Haskeline.block
228 gunblock = Haskeline.unblock
229
230 setDynFlags :: DynFlags -> GHCi [PackageId]
231 setDynFlags dflags = do
232 GHC.setSessionDynFlags dflags
233
234 isOptionSet :: GHCiOption -> GHCi Bool
235 isOptionSet opt
236 = do st <- getGHCiState
237 return (opt `elem` options st)
238
239 setOption :: GHCiOption -> GHCi ()
240 setOption opt
241 = do st <- getGHCiState
242 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
243
244 unsetOption :: GHCiOption -> GHCi ()
245 unsetOption opt
246 = do st <- getGHCiState
247 setGHCiState (st{ options = filter (/= opt) (options st) })
248
249 printForUser :: GhcMonad m => SDoc -> m ()
250 printForUser doc = do
251 unqual <- GHC.getPrintUnqual
252 MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc
253
254 printForUserPartWay :: SDoc -> GHCi ()
255 printForUserPartWay doc = do
256 unqual <- GHC.getPrintUnqual
257 liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
258
259 runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
260 runStmt expr step = do
261 st <- getGHCiState
262 reifyGHCi $ \x ->
263 withProgName (progname st) $
264 withArgs (args st) $
265 reflectGHCi x $ do
266 GHC.handleSourceError (\e -> do GHC.printException e;
267 return Nothing) $ do
268 r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
269 return (Just r)
270
271 runDecls :: String -> GHCi [GHC.Name]
272 runDecls decls = do
273 st <- getGHCiState
274 reifyGHCi $ \x ->
275 withProgName (progname st) $
276 withArgs (args st) $
277 reflectGHCi x $ do
278 GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do
279 GHC.runDeclsWithLocation (progname st) (line_number st) decls
280
281 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
282 resume canLogSpan step = do
283 st <- getGHCiState
284 reifyGHCi $ \x ->
285 withProgName (progname st) $
286 withArgs (args st) $
287 reflectGHCi x $ do
288 GHC.resume canLogSpan step
289
290 -- --------------------------------------------------------------------------
291 -- timing & statistics
292
293 timeIt :: InputT GHCi a -> InputT GHCi a
294 timeIt action
295 = do b <- lift $ isOptionSet ShowTiming
296 if not b
297 then action
298 else do allocs1 <- liftIO $ getAllocations
299 time1 <- liftIO $ getCPUTime
300 a <- action
301 allocs2 <- liftIO $ getAllocations
302 time2 <- liftIO $ getCPUTime
303 liftIO $ printTimes (fromIntegral (allocs2 - allocs1))
304 (time2 - time1)
305 return a
306
307 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
308 -- defined in ghc/rts/Stats.c
309
310 printTimes :: Integer -> Integer -> IO ()
311 printTimes allocs psecs
312 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
313 secs_str = showFFloat (Just 2) secs
314 putStrLn (showSDoc (
315 parens (text (secs_str "") <+> text "secs" <> comma <+>
316 text (show allocs) <+> text "bytes")))
317
318 -----------------------------------------------------------------------------
319 -- reverting CAFs
320
321 revertCAFs :: GHCi ()
322 revertCAFs = do
323 liftIO rts_revertCAFs
324 s <- getGHCiState
325 when (not (ghc_e s)) $ liftIO turnOffBuffering
326 -- Have to turn off buffering again, because we just
327 -- reverted stdout, stderr & stdin to their defaults.
328
329 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
330 -- Make it "safe", just in case
331
332 -----------------------------------------------------------------------------
333 -- To flush buffers for the *interpreted* computation we need
334 -- to refer to *its* stdout/stderr handles
335
336 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
337 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
338 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
339
340 -- After various attempts, I believe this is the least bad way to do
341 -- what we want. We know look up the address of the static stdin,
342 -- stdout, and stderr closures in the loaded base package, and each
343 -- time we need to refer to them we cast the pointer to a Handle.
344 -- This avoids any problems with the CAF having been reverted, because
345 -- we'll always get the current value.
346 --
347 -- The previous attempt that didn't work was to compile an expression
348 -- like "hSetBuffering stdout NoBuffering" into an expression of type
349 -- IO () and run this expression each time we needed it, but the
350 -- problem is that evaluating the expression might cache the contents
351 -- of the Handle rather than referring to it from its static address
352 -- each time. There's no safe workaround for this.
353
354 initInterpBuffering :: Ghc ()
355 initInterpBuffering = do -- make sure these are linked
356 dflags <- GHC.getSessionDynFlags
357 liftIO $ do
358 initDynLinker dflags
359
360 -- ToDo: we should really look up these names properly, but
361 -- it's a fiddle and not all the bits are exposed via the GHC
362 -- interface.
363 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
364 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
365 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
366
367 let f ref (Just ptr) = writeIORef ref ptr
368 f _ Nothing = panic "interactiveUI:setBuffering2"
369 zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
370 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
371
372 flushInterpBuffers :: GHCi ()
373 flushInterpBuffers
374 = liftIO $ do getHandle stdout_ptr >>= hFlush
375 getHandle stderr_ptr >>= hFlush
376
377 turnOffBuffering :: IO ()
378 turnOffBuffering
379 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
380 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
381
382 getHandle :: IORef (Ptr ()) -> IO Handle
383 getHandle ref = do
384 (Ptr addr) <- readIORef ref
385 case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)