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 GhcMonad hiding (liftIO)
18 import Outputable hiding (printForUser, printForUserPartWay)
19 import qualified Outputable
20 import Panic hiding (showException)
29 import qualified MonadUtils
34 import Data.Int ( Int64 )
37 import System.Environment
39 import Control.Monad as Monad
42 import System.Console.Haskeline (CompletionFunc, InputT)
43 import qualified System.Console.Haskeline as Haskeline
44 import Control.Monad.Trans as Trans
46 -----------------------------------------------------------------------------
49 type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
51 data GHCiState = GHCiState
58 options :: [GHCiOption],
59 prelude :: GHC.Module,
61 breaks :: ![(Int, BreakLocation)],
62 tickarrays :: ModuleEnv TickArray,
63 -- tickarrays caches the TickArray for loaded modules,
64 -- so that we don't rebuild it each time the user sets
66 -- ":" at the GHCi prompt repeats the last command, so we
68 last_command :: Maybe Command,
70 remembered_ctx :: [CtxtCmd],
71 -- we remember the :module commands between :loads, so that
72 -- on a :reload we can replay them. See bugs #2049,
73 -- \#1873, #1360. Previously we tried to remember modules that
74 -- were supposed to be in the context but currently had errors,
75 -- but this was complicated. Just replaying the :module commands
76 -- seems to be the right thing.
77 ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
80 data CtxtCmd -- In each case, the first [String] are the starred modules
81 -- and the second are the unstarred ones
82 = SetContext [String] [String]
83 | AddModules [String] [String]
84 | RemModules [String] [String]
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
93 | Multiline -- use multiline commands
98 { breakModule :: !GHC.Module
99 , breakLoc :: !SrcSpan
100 , breakTick :: {-# UNPACK #-} !Int
101 , onBreakCmd :: String
104 instance Eq BreakLocation where
105 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
106 breakTick loc1 == breakTick loc2
108 prettyLocations :: [(Int, BreakLocation)] -> SDoc
109 prettyLocations [] = text "No active breakpoints."
110 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
112 instance Outputable BreakLocation where
113 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
114 if null (onBreakCmd loc)
116 else doubleQuotes (text (onBreakCmd loc))
118 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
119 recordBreak brkLoc = do
121 let oldActiveBreaks = breaks st
122 -- don't store the same break point twice
123 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
124 (nm:_) -> return (True, nm)
126 let oldCounter = break_ctr st
127 newCounter = oldCounter + 1
128 setGHCiState $ st { break_ctr = newCounter,
129 breaks = (oldCounter, brkLoc) : oldActiveBreaks
131 return (False, oldCounter)
133 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
135 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
136 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
138 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
139 reifyGHCi f = GHCi f'
141 -- f' :: IORef GHCiState -> Ghc a
142 f' gs = reifyGhc (f'' gs)
143 -- f'' :: IORef GHCiState -> Session -> IO a
146 startGHCi :: GHCi a -> GHCiState -> Ghc a
147 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
149 instance Monad GHCi where
150 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
151 return a = GHCi $ \_ -> return a
153 instance Functor GHCi where
154 fmap f m = m >>= return . f
156 ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
157 ghciHandleGhcException = handleGhcException
159 getGHCiState :: GHCi GHCiState
160 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
161 setGHCiState :: GHCiState -> GHCi ()
162 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
164 liftGhc :: Ghc a -> GHCi a
165 liftGhc m = GHCi $ \_ -> m
167 instance MonadUtils.MonadIO GHCi where
168 liftIO = liftGhc . MonadUtils.liftIO
170 instance Trans.MonadIO Ghc where
171 liftIO = MonadUtils.liftIO
173 instance GhcMonad GHCi where
174 setSession s' = liftGhc $ setSession s'
175 getSession = liftGhc $ getSession
177 instance GhcMonad (InputT GHCi) where
178 setSession = lift . setSession
179 getSession = lift getSession
181 instance MonadUtils.MonadIO (InputT GHCi) where
182 liftIO = Trans.liftIO
184 instance ExceptionMonad GHCi where
185 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
186 gblock (GHCi m) = GHCi $ \r -> gblock (m r)
187 gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
189 GHCi $ \s -> gmask $ \io_restore ->
191 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
193 unGHCi (f g_restore) s
195 instance MonadIO GHCi where
196 liftIO = MonadUtils.liftIO
198 instance Haskeline.MonadException GHCi where
202 -- XXX when Haskeline's MonadException changes, we can drop our
203 -- deprecated block/unblock methods
205 instance ExceptionMonad (InputT GHCi) where
206 gcatch = Haskeline.catch
207 gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
208 gblock = Haskeline.block
209 gunblock = Haskeline.unblock
211 -- for convenience...
212 getPrelude :: GHCi Module
213 getPrelude = getGHCiState >>= return . prelude
215 getDynFlags :: GhcMonad m => m DynFlags
217 GHC.getSessionDynFlags
219 setDynFlags :: DynFlags -> GHCi [PackageId]
220 setDynFlags dflags = do
221 GHC.setSessionDynFlags dflags
223 isOptionSet :: GHCiOption -> GHCi Bool
225 = do st <- getGHCiState
226 return (opt `elem` options st)
228 setOption :: GHCiOption -> GHCi ()
230 = do st <- getGHCiState
231 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
233 unsetOption :: GHCiOption -> GHCi ()
235 = do st <- getGHCiState
236 setGHCiState (st{ options = filter (/= opt) (options st) })
238 printForUser :: GhcMonad m => SDoc -> m ()
239 printForUser doc = do
240 unqual <- GHC.getPrintUnqual
241 MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc
243 printForUserPartWay :: SDoc -> GHCi ()
244 printForUserPartWay doc = do
245 unqual <- GHC.getPrintUnqual
246 liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
248 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
249 runStmt expr step = do
252 withProgName (progname st) $
255 GHC.handleSourceError (\e -> do GHC.printException e
256 return GHC.RunFailed) $ do
257 GHC.runStmt expr step
259 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
260 resume canLogSpan step = do
263 withProgName (progname st) $
266 GHC.resume canLogSpan step
268 -- --------------------------------------------------------------------------
269 -- timing & statistics
271 timeIt :: InputT GHCi a -> InputT GHCi a
273 = do b <- lift $ isOptionSet ShowTiming
276 else do allocs1 <- liftIO $ getAllocations
277 time1 <- liftIO $ getCPUTime
279 allocs2 <- liftIO $ getAllocations
280 time2 <- liftIO $ getCPUTime
281 liftIO $ printTimes (fromIntegral (allocs2 - allocs1))
285 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
286 -- defined in ghc/rts/Stats.c
288 printTimes :: Integer -> Integer -> IO ()
289 printTimes allocs psecs
290 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
291 secs_str = showFFloat (Just 2) secs
293 parens (text (secs_str "") <+> text "secs" <> comma <+>
294 text (show allocs) <+> text "bytes")))
296 -----------------------------------------------------------------------------
299 revertCAFs :: GHCi ()
301 liftIO rts_revertCAFs
303 when (not (ghc_e s)) $ liftIO turnOffBuffering
304 -- Have to turn off buffering again, because we just
305 -- reverted stdout, stderr & stdin to their defaults.
307 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
308 -- Make it "safe", just in case
310 -----------------------------------------------------------------------------
311 -- To flush buffers for the *interpreted* computation we need
312 -- to refer to *its* stdout/stderr handles
314 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
315 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
316 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
318 -- After various attempts, I believe this is the least bad way to do
319 -- what we want. We know look up the address of the static stdin,
320 -- stdout, and stderr closures in the loaded base package, and each
321 -- time we need to refer to them we cast the pointer to a Handle.
322 -- This avoids any problems with the CAF having been reverted, because
323 -- we'll always get the current value.
325 -- The previous attempt that didn't work was to compile an expression
326 -- like "hSetBuffering stdout NoBuffering" into an expression of type
327 -- IO () and run this expression each time we needed it, but the
328 -- problem is that evaluating the expression might cache the contents
329 -- of the Handle rather than referring to it from its static address
330 -- each time. There's no safe workaround for this.
332 initInterpBuffering :: Ghc ()
333 initInterpBuffering = do -- make sure these are linked
334 dflags <- GHC.getSessionDynFlags
338 -- ToDo: we should really look up these names properly, but
339 -- it's a fiddle and not all the bits are exposed via the GHC
341 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
342 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
343 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
345 let f ref (Just ptr) = writeIORef ref ptr
346 f _ Nothing = panic "interactiveUI:setBuffering2"
347 zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
348 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
350 flushInterpBuffers :: GHCi ()
352 = liftIO $ do getHandle stdout_ptr >>= hFlush
353 getHandle stderr_ptr >>= hFlush
355 turnOffBuffering :: IO ()
357 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
358 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
360 getHandle :: IORef (Ptr ()) -> IO Handle
362 (Ptr addr) <- readIORef ref
363 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)