Use lengthIs and friends in more places
[ghc.git] / ghc / GHCi / UI / Monad.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 GHCi.UI.Monad (
14 GHCi(..), startGHCi,
15 GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,
16 GHCiOption(..), isOptionSet, setOption, unsetOption,
17 Command(..),
18 PromptFunction,
19 BreakLocation(..),
20 TickArray,
21 getDynFlags,
22
23 runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
24
25 printForUserNeverQualify, printForUserModInfo,
26 printForUser, printForUserPartWay, prettyLocations,
27 initInterpBuffering,
28 turnOffBuffering, turnOffBuffering_,
29 flushInterpBuffers,
30 mkEvalWrapper
31 ) where
32
33 #include "HsVersions.h"
34
35 import GHCi.UI.Info (ModInfo)
36 import qualified GHC
37 import GhcMonad hiding (liftIO)
38 import Outputable hiding (printForUser, printForUserPartWay)
39 import qualified Outputable
40 import DynFlags
41 import FastString
42 import HscTypes
43 import SrcLoc
44 import Module
45 import GHCi
46 import GHCi.RemoteTypes
47 import HsSyn (ImportDecl)
48 import RdrName (RdrName)
49 import Util
50
51 import Exception
52 import Numeric
53 import Data.Array
54 import Data.IORef
55 import Data.Time
56 import System.Environment
57 import System.IO
58 import Control.Monad
59
60 import System.Console.Haskeline (CompletionFunc, InputT)
61 import qualified System.Console.Haskeline as Haskeline
62 import Control.Monad.Trans.Class
63 import Control.Monad.IO.Class
64 import Data.Map.Strict (Map)
65
66 -----------------------------------------------------------------------------
67 -- GHCi monad
68
69 data GHCiState = GHCiState
70 {
71 progname :: String,
72 args :: [String],
73 evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@
74 prompt :: PromptFunction,
75 prompt_cont :: PromptFunction,
76 editor :: String,
77 stop :: String,
78 options :: [GHCiOption],
79 line_number :: !Int, -- ^ input line
80 break_ctr :: !Int,
81 breaks :: ![(Int, BreakLocation)],
82 tickarrays :: ModuleEnv TickArray,
83 -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
84 -- so that we don't rebuild it each time the user sets
85 -- a breakpoint.
86 ghci_commands :: [Command],
87 -- ^ available ghci commands
88 ghci_macros :: [Command],
89 -- ^ user-defined macros
90 last_command :: Maybe Command,
91 -- ^ @:@ at the GHCi prompt repeats the last command, so we
92 -- remember it here
93 cmdqueue :: [String],
94
95 remembered_ctx :: [InteractiveImport],
96 -- ^ The imports that the user has asked for, via import
97 -- declarations and :module commands. This list is
98 -- persistent over :reloads (but any imports for modules
99 -- that are not loaded are temporarily ignored). After a
100 -- :load, all the home-package imports are stripped from
101 -- this list.
102 --
103 -- See bugs #2049, #1873, #1360
104
105 transient_ctx :: [InteractiveImport],
106 -- ^ An import added automatically after a :load, usually of
107 -- the most recently compiled module. May be empty if
108 -- there are no modules loaded. This list is replaced by
109 -- :load, :reload, and :add. In between it may be modified
110 -- by :module.
111
112 extra_imports :: [ImportDecl RdrName],
113 -- ^ These are "always-on" imports, added to the
114 -- context regardless of what other imports we have.
115 -- This is useful for adding imports that are required
116 -- by setGHCiMonad. Be careful adding things here:
117 -- you can create ambiguities if these imports overlap
118 -- with other things in scope.
119 --
120 -- NB. although this is not currently used by GHCi itself,
121 -- it was added to support other front-ends that are based
122 -- on the GHCi code. Potentially we could also expose
123 -- this functionality via GHCi commands.
124
125 prelude_imports :: [ImportDecl RdrName],
126 -- ^ These imports are added to the context when
127 -- -XImplicitPrelude is on and we don't have a *-module
128 -- in the context. They can also be overridden by another
129 -- import for the same module, e.g.
130 -- "import Prelude hiding (map)"
131
132 ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)
133
134 short_help :: String,
135 -- ^ help text to display to a user
136 long_help :: String,
137 lastErrorLocations :: IORef [(FastString, Int)],
138
139 mod_infos :: !(Map ModuleName ModInfo),
140
141 flushStdHandles :: ForeignHValue,
142 -- ^ @hFlush stdout; hFlush stderr@ in the interpreter
143 noBuffering :: ForeignHValue
144 -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr
145 }
146
147 type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
148
149 -- | A GHCi command
150 data Command
151 = Command
152 { cmdName :: String
153 -- ^ Name of GHCi command (e.g. "exit")
154 , cmdAction :: String -> InputT GHCi Bool
155 -- ^ The 'Bool' value denotes whether to exit GHCi
156 , cmdHidden :: Bool
157 -- ^ Commands which are excluded from default completion
158 -- and @:help@ summary. This is usually set for commands not
159 -- useful for interactive use but rather for IDEs.
160 , cmdCompletionFunc :: CompletionFunc GHCi
161 -- ^ 'CompletionFunc' for arguments
162 }
163
164 type PromptFunction = [String]
165 -> Int
166 -> GHCi SDoc
167
168 data GHCiOption
169 = ShowTiming -- show time/allocs after evaluation
170 | ShowType -- show the type of expressions
171 | RevertCAFs -- revert CAFs after every evaluation
172 | Multiline -- use multiline commands
173 | CollectInfo -- collect and cache information about
174 -- modules after load
175 deriving Eq
176
177 data BreakLocation
178 = BreakLocation
179 { breakModule :: !GHC.Module
180 , breakLoc :: !SrcSpan
181 , breakTick :: {-# UNPACK #-} !Int
182 , onBreakCmd :: String
183 }
184
185 instance Eq BreakLocation where
186 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
187 breakTick loc1 == breakTick loc2
188
189 prettyLocations :: [(Int, BreakLocation)] -> SDoc
190 prettyLocations [] = text "No active breakpoints."
191 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
192
193 instance Outputable BreakLocation where
194 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
195 if null (onBreakCmd loc)
196 then Outputable.empty
197 else doubleQuotes (text (onBreakCmd loc))
198
199 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
200 recordBreak brkLoc = do
201 st <- getGHCiState
202 let oldActiveBreaks = breaks st
203 -- don't store the same break point twice
204 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
205 (nm:_) -> return (True, nm)
206 [] -> do
207 let oldCounter = break_ctr st
208 newCounter = oldCounter + 1
209 setGHCiState $ st { break_ctr = newCounter,
210 breaks = (oldCounter, brkLoc) : oldActiveBreaks
211 }
212 return (False, oldCounter)
213
214 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
215
216 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
217 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
218
219 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
220 reifyGHCi f = GHCi f'
221 where
222 -- f' :: IORef GHCiState -> Ghc a
223 f' gs = reifyGhc (f'' gs)
224 -- f'' :: IORef GHCiState -> Session -> IO a
225 f'' gs s = f (s, gs)
226
227 startGHCi :: GHCi a -> GHCiState -> Ghc a
228 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
229
230 instance Functor GHCi where
231 fmap = liftM
232
233 instance Applicative GHCi where
234 pure a = GHCi $ \_ -> pure a
235 (<*>) = ap
236
237 instance Monad GHCi where
238 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
239
240 class HasGhciState m where
241 getGHCiState :: m GHCiState
242 setGHCiState :: GHCiState -> m ()
243 modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
244
245 instance HasGhciState GHCi where
246 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
247 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
248 modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
249
250 instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where
251 getGHCiState = lift getGHCiState
252 setGHCiState = lift . setGHCiState
253 modifyGHCiState = lift . modifyGHCiState
254
255 liftGhc :: Ghc a -> GHCi a
256 liftGhc m = GHCi $ \_ -> m
257
258 instance MonadIO GHCi where
259 liftIO = liftGhc . liftIO
260
261 instance HasDynFlags GHCi where
262 getDynFlags = getSessionDynFlags
263
264 instance GhcMonad GHCi where
265 setSession s' = liftGhc $ setSession s'
266 getSession = liftGhc $ getSession
267
268 instance HasDynFlags (InputT GHCi) where
269 getDynFlags = lift getDynFlags
270
271 instance GhcMonad (InputT GHCi) where
272 setSession = lift . setSession
273 getSession = lift getSession
274
275 instance ExceptionMonad GHCi where
276 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
277 gmask f =
278 GHCi $ \s -> gmask $ \io_restore ->
279 let
280 g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
281 in
282 unGHCi (f g_restore) s
283
284 instance Haskeline.MonadException Ghc where
285 controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
286 run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
287 in fmap (flip unGhc s) $ f run'
288
289 instance Haskeline.MonadException GHCi where
290 controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
291 run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
292 in fmap (flip unGHCi s) $ f run'
293
294 instance ExceptionMonad (InputT GHCi) where
295 gcatch = Haskeline.catch
296 gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
297
298 isOptionSet :: GHCiOption -> GHCi Bool
299 isOptionSet opt
300 = do st <- getGHCiState
301 return (opt `elem` options st)
302
303 setOption :: GHCiOption -> GHCi ()
304 setOption opt
305 = do st <- getGHCiState
306 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
307
308 unsetOption :: GHCiOption -> GHCi ()
309 unsetOption opt
310 = do st <- getGHCiState
311 setGHCiState (st{ options = filter (/= opt) (options st) })
312
313 printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
314 printForUserNeverQualify doc = do
315 dflags <- getDynFlags
316 liftIO $ Outputable.printForUser dflags stdout neverQualify doc
317
318 printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
319 printForUserModInfo info doc = do
320 dflags <- getDynFlags
321 mUnqual <- GHC.mkPrintUnqualifiedForModule info
322 unqual <- maybe GHC.getPrintUnqual return mUnqual
323 liftIO $ Outputable.printForUser dflags stdout unqual doc
324
325 printForUser :: GhcMonad m => SDoc -> m ()
326 printForUser doc = do
327 unqual <- GHC.getPrintUnqual
328 dflags <- getDynFlags
329 liftIO $ Outputable.printForUser dflags stdout unqual doc
330
331 printForUserPartWay :: SDoc -> GHCi ()
332 printForUserPartWay doc = do
333 unqual <- GHC.getPrintUnqual
334 dflags <- getDynFlags
335 liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
336
337 -- | Run a single Haskell expression
338 runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
339 runStmt expr step = do
340 st <- getGHCiState
341 GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
342 let opts = GHC.execOptions
343 { GHC.execSourceFile = progname st
344 , GHC.execLineNumber = line_number st
345 , GHC.execSingleStep = step
346 , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))
347 (EvalThis fhv) }
348 Just <$> GHC.execStmt expr opts
349
350 runDecls :: String -> GHCi (Maybe [GHC.Name])
351 runDecls decls = do
352 st <- getGHCiState
353 reifyGHCi $ \x ->
354 withProgName (progname st) $
355 withArgs (args st) $
356 reflectGHCi x $ do
357 GHC.handleSourceError (\e -> do GHC.printException e;
358 return Nothing) $ do
359 r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
360 return (Just r)
361
362 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult
363 resume canLogSpan step = do
364 st <- getGHCiState
365 reifyGHCi $ \x ->
366 withProgName (progname st) $
367 withArgs (args st) $
368 reflectGHCi x $ do
369 GHC.resumeExec canLogSpan step
370
371 -- --------------------------------------------------------------------------
372 -- timing & statistics
373
374 timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a
375 timeIt getAllocs action
376 = do b <- lift $ isOptionSet ShowTiming
377 if not b
378 then action
379 else do time1 <- liftIO $ getCurrentTime
380 a <- action
381 let allocs = getAllocs a
382 time2 <- liftIO $ getCurrentTime
383 dflags <- getDynFlags
384 let period = time2 `diffUTCTime` time1
385 liftIO $ printTimes dflags allocs (realToFrac period)
386 return a
387
388 printTimes :: DynFlags -> Maybe Integer -> Double -> IO ()
389 printTimes dflags mallocs secs
390 = do let secs_str = showFFloat (Just 2) secs
391 putStrLn (showSDoc dflags (
392 parens (text (secs_str "") <+> text "secs" <> comma <+>
393 case mallocs of
394 Nothing -> empty
395 Just allocs ->
396 text (separateThousands allocs) <+> text "bytes")))
397 where
398 separateThousands n = reverse . sep . reverse . show $ n
399 where sep n'
400 | n' `lengthAtMost` 3 = n'
401 | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
402
403 -----------------------------------------------------------------------------
404 -- reverting CAFs
405
406 revertCAFs :: GHCi ()
407 revertCAFs = do
408 liftIO rts_revertCAFs
409 s <- getGHCiState
410 when (not (ghc_e s)) turnOffBuffering
411 -- Have to turn off buffering again, because we just
412 -- reverted stdout, stderr & stdin to their defaults.
413
414 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
415 -- Make it "safe", just in case
416
417 -----------------------------------------------------------------------------
418 -- To flush buffers for the *interpreted* computation we need
419 -- to refer to *its* stdout/stderr handles
420
421 -- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
422 initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
423 initInterpBuffering = do
424 -- We take great care not to use do-notation in the expressions below, as
425 -- they are fragile in the presence of RebindableSyntax (Trac #13385).
426 nobuf <- GHC.compileExprRemote $
427 " System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering" ++
428 "`GHC.Base.thenIO` System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
429 "`GHC.Base.thenIO` System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
430 flush <- GHC.compileExprRemote $
431 " System.IO.hFlush System.IO.stdout" ++
432 "`GHC.Base.thenIO` System.IO.hFlush System.IO.stderr"
433 return (nobuf, flush)
434
435 -- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
436 flushInterpBuffers :: GHCi ()
437 flushInterpBuffers = do
438 st <- getGHCiState
439 hsc_env <- GHC.getSession
440 liftIO $ evalIO hsc_env (flushStdHandles st)
441
442 -- | Turn off buffering for stdin, stdout, and stderr in the interpreter
443 turnOffBuffering :: GHCi ()
444 turnOffBuffering = do
445 st <- getGHCiState
446 turnOffBuffering_ (noBuffering st)
447
448 turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
449 turnOffBuffering_ fhv = do
450 hsc_env <- getSession
451 liftIO $ evalIO hsc_env fhv
452
453 mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
454 mkEvalWrapper progname args =
455 GHC.compileExprRemote $
456 "\\m -> System.Environment.withProgName " ++ show progname ++
457 "(System.Environment.withArgs " ++ show args ++ " m)"