Refine fix for #7667.
[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.Applicative (Applicative(..))
50 import Control.Monad
51 import GHC.Exts
52
53 import System.Console.Haskeline (CompletionFunc, InputT)
54 import qualified System.Console.Haskeline as Haskeline
55 import Control.Monad.Trans.Class
56 import Control.Monad.IO.Class
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 prompt2 :: String,
69 editor :: String,
70 stop :: String,
71 options :: [GHCiOption],
72 line_number :: !Int, -- input line
73 break_ctr :: !Int,
74 breaks :: ![(Int, BreakLocation)],
75 tickarrays :: ModuleEnv TickArray,
76 -- tickarrays caches the TickArray for loaded modules,
77 -- so that we don't rebuild it each time the user sets
78 -- a breakpoint.
79 -- available ghci commands
80 ghci_commands :: [Command],
81 -- ":" at the GHCi prompt repeats the last command, so we
82 -- remember is here:
83 last_command :: Maybe Command,
84 cmdqueue :: [String],
85
86 remembered_ctx :: [InteractiveImport],
87 -- the imports that the user has asked for, via import
88 -- declarations and :module commands. This list is
89 -- persistent over :reloads (but any imports for modules
90 -- that are not loaded are temporarily ignored). After a
91 -- :load, all the home-package imports are stripped from
92 -- this list.
93
94 -- See bugs #2049, #1873, #1360
95
96 transient_ctx :: [InteractiveImport],
97 -- An import added automatically after a :load, usually of
98 -- the most recently compiled module. May be empty if
99 -- there are no modules loaded. This list is replaced by
100 -- :load, :reload, and :add. In between it may be modified
101 -- by :module.
102
103 ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc)
104
105 -- help text to display to a user
106 short_help :: String,
107 long_help :: String
108 }
109
110 type TickArray = Array Int [(BreakIndex,SrcSpan)]
111
112 data GHCiOption
113 = ShowTiming -- show time/allocs after evaluation
114 | ShowType -- show the type of expressions
115 | RevertCAFs -- revert CAFs after every evaluation
116 | Multiline -- use multiline commands
117 deriving Eq
118
119 data BreakLocation
120 = BreakLocation
121 { breakModule :: !GHC.Module
122 , breakLoc :: !SrcSpan
123 , breakTick :: {-# UNPACK #-} !Int
124 , onBreakCmd :: String
125 }
126
127 instance Eq BreakLocation where
128 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
129 breakTick loc1 == breakTick loc2
130
131 prettyLocations :: [(Int, BreakLocation)] -> SDoc
132 prettyLocations [] = text "No active breakpoints."
133 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
134
135 instance Outputable BreakLocation where
136 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
137 if null (onBreakCmd loc)
138 then empty
139 else doubleQuotes (text (onBreakCmd loc))
140
141 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
142 recordBreak brkLoc = do
143 st <- getGHCiState
144 let oldActiveBreaks = breaks st
145 -- don't store the same break point twice
146 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
147 (nm:_) -> return (True, nm)
148 [] -> do
149 let oldCounter = break_ctr st
150 newCounter = oldCounter + 1
151 setGHCiState $ st { break_ctr = newCounter,
152 breaks = (oldCounter, brkLoc) : oldActiveBreaks
153 }
154 return (False, oldCounter)
155
156 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
157
158 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
159 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
160
161 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
162 reifyGHCi f = GHCi f'
163 where
164 -- f' :: IORef GHCiState -> Ghc a
165 f' gs = reifyGhc (f'' gs)
166 -- f'' :: IORef GHCiState -> Session -> IO a
167 f'' gs s = f (s, gs)
168
169 startGHCi :: GHCi a -> GHCiState -> Ghc a
170 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
171
172 instance Functor GHCi where
173 fmap = liftM
174
175 instance Applicative GHCi where
176 pure = return
177 (<*>) = ap
178
179 instance Monad GHCi where
180 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
181 return a = GHCi $ \_ -> return a
182
183 getGHCiState :: GHCi GHCiState
184 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
185 setGHCiState :: GHCiState -> GHCi ()
186 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
187 modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi ()
188 modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f
189
190 liftGhc :: Ghc a -> GHCi a
191 liftGhc m = GHCi $ \_ -> m
192
193 instance MonadIO GHCi where
194 liftIO = liftGhc . liftIO
195
196 instance HasDynFlags GHCi where
197 getDynFlags = getSessionDynFlags
198
199 instance GhcMonad GHCi where
200 setSession s' = liftGhc $ setSession s'
201 getSession = liftGhc $ getSession
202
203 instance HasDynFlags (InputT GHCi) where
204 getDynFlags = lift getDynFlags
205
206 instance GhcMonad (InputT GHCi) where
207 setSession = lift . setSession
208 getSession = lift getSession
209
210 instance ExceptionMonad GHCi where
211 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
212 gmask f =
213 GHCi $ \s -> gmask $ \io_restore ->
214 let
215 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
216 in
217 unGHCi (f g_restore) s
218
219 instance Haskeline.MonadException Ghc where
220 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
221 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
222 in fmap (flip unGhc s) $ f run'
223
224 instance Haskeline.MonadException GHCi where
225 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
226 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
227 in fmap (flip unGHCi s) $ f run'
228
229 instance ExceptionMonad (InputT GHCi) where
230 gcatch = Haskeline.catch
231 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
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