Make stdout and stderr line-buffered
[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 prompt2 :: 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 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 Haskeline.MonadException Ghc where
215 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
216 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
217 in fmap (flip unGhc s) $ f run'
218
219 instance Haskeline.MonadException GHCi where
220 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
221 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
222 in fmap (flip unGHCi s) $ f run'
223
224 instance ExceptionMonad (InputT GHCi) where
225 gcatch = Haskeline.catch
226 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
227
228 isOptionSet :: GHCiOption -> GHCi Bool
229 isOptionSet opt
230 = do st <- getGHCiState
231 return (opt `elem` options st)
232
233 setOption :: GHCiOption -> GHCi ()
234 setOption opt
235 = do st <- getGHCiState
236 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
237
238 unsetOption :: GHCiOption -> GHCi ()
239 unsetOption opt
240 = do st <- getGHCiState
241 setGHCiState (st{ options = filter (/= opt) (options st) })
242
243 printForUser :: GhcMonad m => SDoc -> m ()
244 printForUser doc = do
245 unqual <- GHC.getPrintUnqual
246 dflags <- getDynFlags
247 liftIO $ Outputable.printForUser dflags stdout unqual doc
248
249 printForUserPartWay :: SDoc -> GHCi ()
250 printForUserPartWay doc = do
251 unqual <- GHC.getPrintUnqual
252 dflags <- getDynFlags
253 liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
254
255 -- | Run a single Haskell expression
256 runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
257 runStmt expr step = do
258 st <- getGHCiState
259 reifyGHCi $ \x ->
260 withProgName (progname st) $
261 withArgs (args st) $
262 reflectGHCi x $ do
263 GHC.handleSourceError (\e -> do GHC.printException e;
264 return Nothing) $ do
265 r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
266 return (Just r)
267
268 runDecls :: String -> GHCi [GHC.Name]
269 runDecls decls = do
270 st <- getGHCiState
271 reifyGHCi $ \x ->
272 withProgName (progname st) $
273 withArgs (args st) $
274 reflectGHCi x $ do
275 GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do
276 GHC.runDeclsWithLocation (progname st) (line_number st) decls
277
278 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
279 resume canLogSpan step = do
280 st <- getGHCiState
281 reifyGHCi $ \x ->
282 withProgName (progname st) $
283 withArgs (args st) $
284 reflectGHCi x $ do
285 GHC.resume canLogSpan step
286
287 -- --------------------------------------------------------------------------
288 -- timing & statistics
289
290 timeIt :: InputT GHCi a -> InputT GHCi a
291 timeIt action
292 = do b <- lift $ isOptionSet ShowTiming
293 if not b
294 then action
295 else do allocs1 <- liftIO $ getAllocations
296 time1 <- liftIO $ getCPUTime
297 a <- action
298 allocs2 <- liftIO $ getAllocations
299 time2 <- liftIO $ getCPUTime
300 dflags <- getDynFlags
301 liftIO $ printTimes dflags (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 :: DynFlags -> Integer -> Integer -> IO ()
309 printTimes dflags allocs psecs
310 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
311 secs_str = showFFloat (Just 2) secs
312 putStrLn (showSDoc dflags (
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)
384