1 {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 -----------------------------------------------------------------------------
6 -- Monadery code used in InteractiveUI
8 -- (c) The GHC Team 2005-2006
10 -----------------------------------------------------------------------------
12 module GhciMonad where
14 #include "HsVersions.h"
17 import Outputable hiding (printForUser, printForUserPartWay)
18 import qualified Pretty
19 import qualified Outputable
20 import Panic hiding (showException)
23 import HscTypes hiding (liftIO)
29 import qualified MonadUtils
30 import qualified ErrUtils
37 import Data.Int ( Int64 )
41 import System.Environment
43 import Control.Monad as Monad
46 import System.Console.Haskeline (CompletionFunc, InputT)
47 import qualified System.Console.Haskeline as Haskeline
48 import System.Console.Haskeline.Encoding
49 import Control.Monad.Trans as Trans
50 import qualified Data.ByteString as B
52 -----------------------------------------------------------------------------
55 type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
57 data GHCiState = GHCiState
64 options :: [GHCiOption],
65 prelude :: GHC.Module,
67 breaks :: ![(Int, BreakLocation)],
68 tickarrays :: ModuleEnv TickArray,
69 -- tickarrays caches the TickArray for loaded modules,
70 -- so that we don't rebuild it each time the user sets
72 -- ":" at the GHCi prompt repeats the last command, so we
74 last_command :: Maybe Command,
76 remembered_ctx :: [(CtxtCmd, [String], [String])],
77 -- we remember the :module commands between :loads, so that
78 -- on a :reload we can replay them. See bugs #2049,
79 -- \#1873, #1360. Previously we tried to remember modules that
80 -- were supposed to be in the context but currently had errors,
81 -- but this was complicated. Just replaying the :module commands
82 -- seems to be the right thing.
83 ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
91 type TickArray = Array Int [(BreakIndex,SrcSpan)]
94 = ShowTiming -- show time/allocs after evaluation
95 | ShowType -- show the type of expressions
96 | RevertCAFs -- revert CAFs after every evaluation
101 { breakModule :: !GHC.Module
102 , breakLoc :: !SrcSpan
103 , breakTick :: {-# UNPACK #-} !Int
104 , onBreakCmd :: String
107 instance Eq BreakLocation where
108 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
109 breakTick loc1 == breakTick loc2
111 prettyLocations :: [(Int, BreakLocation)] -> SDoc
112 prettyLocations [] = text "No active breakpoints."
113 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
115 instance Outputable BreakLocation where
116 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
117 if null (onBreakCmd loc)
119 else doubleQuotes (text (onBreakCmd loc))
121 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
122 recordBreak brkLoc = do
124 let oldActiveBreaks = breaks st
125 -- don't store the same break point twice
126 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
127 (nm:_) -> return (True, nm)
129 let oldCounter = break_ctr st
130 newCounter = oldCounter + 1
131 setGHCiState $ st { break_ctr = newCounter,
132 breaks = (oldCounter, brkLoc) : oldActiveBreaks
134 return (False, oldCounter)
136 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
138 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
139 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
141 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
142 reifyGHCi f = GHCi f'
144 -- f' :: IORef GHCiState -> Ghc a
145 f' gs = reifyGhc (f'' gs)
146 -- f'' :: IORef GHCiState -> Session -> IO a
149 startGHCi :: GHCi a -> GHCiState -> Ghc a
150 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
152 instance Monad GHCi where
153 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
154 return a = GHCi $ \_ -> return a
156 instance Functor GHCi where
157 fmap f m = m >>= return . f
159 ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
160 ghciHandleGhcException = handleGhcException
162 getGHCiState :: GHCi GHCiState
163 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
164 setGHCiState :: GHCiState -> GHCi ()
165 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
167 liftGhc :: Ghc a -> GHCi a
168 liftGhc m = GHCi $ \_ -> m
170 instance MonadUtils.MonadIO GHCi where
171 liftIO = liftGhc . MonadUtils.liftIO
173 instance Trans.MonadIO Ghc where
174 liftIO = MonadUtils.liftIO
176 instance GhcMonad GHCi where
177 setSession s' = liftGhc $ setSession s'
178 getSession = liftGhc $ getSession
180 instance GhcMonad (InputT GHCi) where
181 setSession = lift . setSession
182 getSession = lift getSession
184 instance MonadUtils.MonadIO (InputT GHCi) where
185 liftIO = Trans.liftIO
187 instance WarnLogMonad (InputT GHCi) where
188 setWarnings = lift . setWarnings
189 getWarnings = lift getWarnings
191 instance ExceptionMonad GHCi where
192 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
193 gblock (GHCi m) = GHCi $ \r -> gblock (m r)
194 gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
196 instance WarnLogMonad GHCi where
197 setWarnings warns = liftGhc $ setWarnings warns
198 getWarnings = liftGhc $ getWarnings
200 instance MonadIO GHCi where
203 instance Haskeline.MonadException GHCi where
208 instance ExceptionMonad (InputT GHCi) where
209 gcatch = Haskeline.catch
210 gblock = Haskeline.block
211 gunblock = Haskeline.unblock
213 -- for convenience...
214 getPrelude :: GHCi Module
215 getPrelude = getGHCiState >>= return . prelude
217 getDynFlags :: GhcMonad m => m DynFlags
219 GHC.getSessionDynFlags
221 setDynFlags :: DynFlags -> GHCi [PackageId]
222 setDynFlags dflags = do
223 GHC.setSessionDynFlags dflags
225 isOptionSet :: GHCiOption -> GHCi Bool
227 = do st <- getGHCiState
228 return (opt `elem` options st)
230 setOption :: GHCiOption -> GHCi ()
232 = do st <- getGHCiState
233 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
235 unsetOption :: GHCiOption -> GHCi ()
237 = do st <- getGHCiState
238 setGHCiState (st{ options = filter (/= opt) (options st) })
241 io = MonadUtils.liftIO
243 printForUser :: SDoc -> GHCi ()
244 printForUser doc = do
245 unqual <- GHC.getPrintUnqual
246 io $ Outputable.printForUser stdout unqual doc
248 printForUser' :: SDoc -> InputT GHCi ()
249 printForUser' doc = do
250 unqual <- GHC.getPrintUnqual
251 Haskeline.outputStrLn $ showSDocForUser unqual doc
253 printForUserPartWay :: SDoc -> GHCi ()
254 printForUserPartWay doc = do
255 unqual <- GHC.getPrintUnqual
256 io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
258 -- We set log_action to write encoded output.
259 -- This fails whenever GHC tries to mention an (already encoded) filename,
260 -- but I don't know how to work around that.
261 setLogAction :: InputT GHCi ()
263 encoder <- getEncoder
264 dflags <- GHC.getSessionDynFlags
265 GHC.setSessionDynFlags dflags {log_action = logAction encoder}
268 logAction encoder severity srcSpan style msg = case severity of
269 GHC.SevInfo -> printEncErrs encoder (msg style)
270 GHC.SevFatal -> printEncErrs encoder (msg style)
273 printEncErrs encoder (ErrUtils.mkLocMessage srcSpan msg style)
274 printEncErrs encoder doc = do
275 str <- encoder (Pretty.showDocWith Pretty.PageMode doc)
276 B.hPutStrLn stderr str
279 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
280 runStmt expr step = do
283 withProgName (progname st) $
286 GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
287 return GHC.RunFailed) $ do
288 GHC.runStmt expr step
290 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
291 resume canLogSpan step = GHC.resume canLogSpan step
293 -- --------------------------------------------------------------------------
294 -- timing & statistics
296 timeIt :: InputT GHCi a -> InputT GHCi a
298 = do b <- lift $ isOptionSet ShowTiming
301 else do allocs1 <- liftIO $ getAllocations
302 time1 <- liftIO $ getCPUTime
304 allocs2 <- liftIO $ getAllocations
305 time2 <- liftIO $ getCPUTime
306 liftIO $ printTimes (fromIntegral (allocs2 - allocs1))
310 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
311 -- defined in ghc/rts/Stats.c
313 printTimes :: Integer -> Integer -> IO ()
314 printTimes allocs psecs
315 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
316 secs_str = showFFloat (Just 2) secs
318 parens (text (secs_str "") <+> text "secs" <> comma <+>
319 text (show allocs) <+> text "bytes")))
321 -----------------------------------------------------------------------------
324 revertCAFs :: GHCi ()
328 when (not (ghc_e s)) $ io turnOffBuffering
329 -- Have to turn off buffering again, because we just
330 -- reverted stdout, stderr & stdin to their defaults.
332 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
333 -- Make it "safe", just in case
335 -----------------------------------------------------------------------------
336 -- To flush buffers for the *interpreted* computation we need
337 -- to refer to *its* stdout/stderr handles
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 ())
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.
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.
357 initInterpBuffering :: Ghc ()
358 initInterpBuffering = do -- make sure these are linked
359 dflags <- GHC.getSessionDynFlags
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
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"
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]
376 flushInterpBuffers :: GHCi ()
378 = io $ do getHandle stdout_ptr >>= hFlush
379 getHandle stderr_ptr >>= hFlush
381 turnOffBuffering :: IO ()
383 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
384 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
386 getHandle :: IORef (Ptr ()) -> IO Handle
388 (Ptr addr) <- readIORef ref
389 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)