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 Outputable
19 import Panic hiding (showException)
22 import HscTypes hiding (liftIO)
28 import qualified MonadUtils
35 import Data.Int ( Int64 )
39 import System.Environment
41 import Control.Monad as Monad
44 import System.Console.Haskeline (CompletionFunc, InputT)
45 import qualified System.Console.Haskeline as Haskeline
46 import Control.Monad.Trans as Trans
48 -----------------------------------------------------------------------------
51 type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
53 data GHCiState = GHCiState
60 options :: [GHCiOption],
61 prelude :: GHC.Module,
63 breaks :: ![(Int, BreakLocation)],
64 tickarrays :: ModuleEnv TickArray,
65 -- tickarrays caches the TickArray for loaded modules,
66 -- so that we don't rebuild it each time the user sets
68 -- ":" at the GHCi prompt repeats the last command, so we
70 last_command :: Maybe Command,
72 remembered_ctx :: [(CtxtCmd, [String], [String])],
73 -- we remember the :module commands between :loads, so that
74 -- on a :reload we can replay them. See bugs #2049,
75 -- \#1873, #1360. Previously we tried to remember modules that
76 -- were supposed to be in the context but currently had errors,
77 -- but this was complicated. Just replaying the :module commands
78 -- seems to be the right thing.
79 ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
87 type TickArray = Array Int [(BreakIndex,SrcSpan)]
90 = ShowTiming -- show time/allocs after evaluation
91 | ShowType -- show the type of expressions
92 | RevertCAFs -- revert CAFs after every evaluation
97 { breakModule :: !GHC.Module
98 , breakLoc :: !SrcSpan
99 , breakTick :: {-# UNPACK #-} !Int
100 , onBreakCmd :: String
103 instance Eq BreakLocation where
104 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
105 breakTick loc1 == breakTick loc2
107 prettyLocations :: [(Int, BreakLocation)] -> SDoc
108 prettyLocations [] = text "No active breakpoints."
109 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
111 instance Outputable BreakLocation where
112 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
113 if null (onBreakCmd loc)
115 else doubleQuotes (text (onBreakCmd loc))
117 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
118 recordBreak brkLoc = do
120 let oldActiveBreaks = breaks st
121 -- don't store the same break point twice
122 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
123 (nm:_) -> return (True, nm)
125 let oldCounter = break_ctr st
126 newCounter = oldCounter + 1
127 setGHCiState $ st { break_ctr = newCounter,
128 breaks = (oldCounter, brkLoc) : oldActiveBreaks
130 return (False, oldCounter)
132 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
134 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
135 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
137 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
138 reifyGHCi f = GHCi f'
140 -- f' :: IORef GHCiState -> Ghc a
141 f' gs = reifyGhc (f'' gs)
142 -- f'' :: IORef GHCiState -> Session -> IO a
145 startGHCi :: GHCi a -> GHCiState -> Ghc a
146 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
148 instance Monad GHCi where
149 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
150 return a = GHCi $ \_ -> return a
152 instance Functor GHCi where
153 fmap f m = m >>= return . f
155 ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
156 ghciHandleGhcException = handleGhcException
158 getGHCiState :: GHCi GHCiState
159 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
160 setGHCiState :: GHCiState -> GHCi ()
161 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
163 liftGhc :: Ghc a -> GHCi a
164 liftGhc m = GHCi $ \_ -> m
166 instance MonadUtils.MonadIO GHCi where
167 liftIO = liftGhc . MonadUtils.liftIO
169 instance Trans.MonadIO Ghc where
170 liftIO = MonadUtils.liftIO
172 instance GhcMonad GHCi where
173 setSession s' = liftGhc $ setSession s'
174 getSession = liftGhc $ getSession
176 instance GhcMonad (InputT GHCi) where
177 setSession = lift . setSession
178 getSession = lift getSession
180 instance MonadUtils.MonadIO (InputT GHCi) where
181 liftIO = Trans.liftIO
183 instance WarnLogMonad (InputT GHCi) where
184 setWarnings = lift . setWarnings
185 getWarnings = lift getWarnings
187 instance ExceptionMonad GHCi where
188 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
189 gblock (GHCi m) = GHCi $ \r -> gblock (m r)
190 gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
192 instance WarnLogMonad GHCi where
193 setWarnings warns = liftGhc $ setWarnings warns
194 getWarnings = liftGhc $ getWarnings
196 instance MonadIO GHCi where
199 instance Haskeline.MonadException GHCi where
204 instance ExceptionMonad (InputT GHCi) where
205 gcatch = Haskeline.catch
206 gblock = Haskeline.block
207 gunblock = Haskeline.unblock
209 -- for convenience...
210 getPrelude :: GHCi Module
211 getPrelude = getGHCiState >>= return . prelude
213 getDynFlags :: GhcMonad m => m DynFlags
215 GHC.getSessionDynFlags
217 setDynFlags :: DynFlags -> GHCi [PackageId]
218 setDynFlags dflags = do
219 GHC.setSessionDynFlags dflags
221 isOptionSet :: GHCiOption -> GHCi Bool
223 = do st <- getGHCiState
224 return (opt `elem` options st)
226 setOption :: GHCiOption -> GHCi ()
228 = do st <- getGHCiState
229 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
231 unsetOption :: GHCiOption -> GHCi ()
233 = do st <- getGHCiState
234 setGHCiState (st{ options = filter (/= opt) (options st) })
237 io = MonadUtils.liftIO
239 printForUser :: GhcMonad m => SDoc -> m ()
240 printForUser doc = do
241 unqual <- GHC.getPrintUnqual
242 MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc
244 printForUserPartWay :: SDoc -> GHCi ()
245 printForUserPartWay doc = do
246 unqual <- GHC.getPrintUnqual
247 io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
249 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
250 runStmt expr step = do
253 withProgName (progname st) $
256 GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
257 return GHC.RunFailed) $ do
258 GHC.runStmt expr step
260 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
261 resume canLogSpan step = do
264 withProgName (progname st) $
267 GHC.resume canLogSpan step
269 -- --------------------------------------------------------------------------
270 -- timing & statistics
272 timeIt :: InputT GHCi a -> InputT GHCi a
274 = do b <- lift $ isOptionSet ShowTiming
277 else do allocs1 <- liftIO $ getAllocations
278 time1 <- liftIO $ getCPUTime
280 allocs2 <- liftIO $ getAllocations
281 time2 <- liftIO $ getCPUTime
282 liftIO $ printTimes (fromIntegral (allocs2 - allocs1))
286 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
287 -- defined in ghc/rts/Stats.c
289 printTimes :: Integer -> Integer -> IO ()
290 printTimes allocs psecs
291 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
292 secs_str = showFFloat (Just 2) secs
294 parens (text (secs_str "") <+> text "secs" <> comma <+>
295 text (show allocs) <+> text "bytes")))
297 -----------------------------------------------------------------------------
300 revertCAFs :: GHCi ()
304 when (not (ghc_e s)) $ io turnOffBuffering
305 -- Have to turn off buffering again, because we just
306 -- reverted stdout, stderr & stdin to their defaults.
308 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
309 -- Make it "safe", just in case
311 -----------------------------------------------------------------------------
312 -- To flush buffers for the *interpreted* computation we need
313 -- to refer to *its* stdout/stderr handles
315 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
316 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
317 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
319 -- After various attempts, I believe this is the least bad way to do
320 -- what we want. We know look up the address of the static stdin,
321 -- stdout, and stderr closures in the loaded base package, and each
322 -- time we need to refer to them we cast the pointer to a Handle.
323 -- This avoids any problems with the CAF having been reverted, because
324 -- we'll always get the current value.
326 -- The previous attempt that didn't work was to compile an expression
327 -- like "hSetBuffering stdout NoBuffering" into an expression of type
328 -- IO () and run this expression each time we needed it, but the
329 -- problem is that evaluating the expression might cache the contents
330 -- of the Handle rather than referring to it from its static address
331 -- each time. There's no safe workaround for this.
333 initInterpBuffering :: Ghc ()
334 initInterpBuffering = do -- make sure these are linked
335 dflags <- GHC.getSessionDynFlags
339 -- ToDo: we should really look up these names properly, but
340 -- it's a fiddle and not all the bits are exposed via the GHC
342 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
343 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
344 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
346 let f ref (Just ptr) = writeIORef ref ptr
347 f _ Nothing = panic "interactiveUI:setBuffering2"
348 zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
349 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
351 flushInterpBuffers :: GHCi ()
353 = io $ do getHandle stdout_ptr >>= hFlush
354 getHandle stderr_ptr >>= hFlush
356 turnOffBuffering :: IO ()
358 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
359 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
361 getHandle :: IORef (Ptr ()) -> IO Handle
363 (Ptr addr) <- readIORef ref
364 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)