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