1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
5 -----------------------------------------------------------------------------
7 -- GHC Interactive User Interface
9 -- (c) The GHC Team 2005-2006
11 -----------------------------------------------------------------------------
13 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
15 #include "HsVersions.h"
17 import qualified GhciMonad
18 import GhciMonad hiding (runStmt)
23 import qualified GHC hiding (resume, runStmt)
24 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
26 BreakIndex, Resume, SingleStep,
27 Ghc, handleSourceError )
32 -- import PackageConfig
35 import HscTypes ( implicitTyThings, handleFlagWarnings )
36 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
37 import Outputable hiding (printForUser, printForUserPartWay)
38 import Module -- for ModuleEnv
42 -- Other random utilities
45 import BasicTypes hiding (isTopLevel)
46 import Panic hiding (showException)
52 import Maybes ( orElse, expectJust )
57 #ifndef mingw32_HOST_OS
58 import System.Posix hiding (getEnv)
60 import qualified System.Win32
63 import System.Console.Haskeline as Haskeline
64 import qualified System.Console.Haskeline.Encoding as Encoding
65 import Control.Monad.Trans
69 import Exception hiding (catch, block, unblock)
71 -- import Control.Concurrent
73 import System.FilePath
74 import qualified Data.ByteString.Char8 as BS
78 import System.Environment
79 import System.Exit ( exitWith, ExitCode(..) )
80 import System.Directory
82 import System.IO.Error as IO
85 import Control.Monad as Monad
88 import GHC.Exts ( unsafeCoerce# )
90 #if __GLASGOW_HASKELL__ >= 611
91 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
92 import GHC.IO.Handle ( hFlushAll )
94 import GHC.IOBase ( IOErrorType(InvalidArgument) )
99 import Data.IORef ( IORef, readIORef, writeIORef )
101 -----------------------------------------------------------------------------
103 ghciWelcomeMsg :: String
104 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
105 ": http://www.haskell.org/ghc/ :? for help"
107 cmdName :: Command -> String
110 GLOBAL_VAR(macros_ref, [], [Command])
112 builtin_commands :: [Command]
114 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
115 ("?", keepGoing help, noCompletion),
116 ("add", keepGoingPaths addModule, completeFilename),
117 ("abandon", keepGoing abandonCmd, noCompletion),
118 ("break", keepGoing breakCmd, completeIdentifier),
119 ("back", keepGoing backCmd, noCompletion),
120 ("browse", keepGoing' (browseCmd False), completeModule),
121 ("browse!", keepGoing' (browseCmd True), completeModule),
122 ("cd", keepGoing' changeDirectory, completeFilename),
123 ("check", keepGoing' checkModule, completeHomeModule),
124 ("continue", keepGoing continueCmd, noCompletion),
125 ("cmd", keepGoing cmdCmd, completeExpression),
126 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
127 ("def", keepGoing (defineMacro False), completeExpression),
128 ("def!", keepGoing (defineMacro True), completeExpression),
129 ("delete", keepGoing deleteCmd, noCompletion),
130 ("e", keepGoing editFile, completeFilename),
131 ("edit", keepGoing editFile, completeFilename),
132 ("etags", keepGoing createETagsFileCmd, completeFilename),
133 ("force", keepGoing forceCmd, completeExpression),
134 ("forward", keepGoing forwardCmd, noCompletion),
135 ("help", keepGoing help, noCompletion),
136 ("history", keepGoing historyCmd, noCompletion),
137 ("info", keepGoing' info, completeIdentifier),
138 ("kind", keepGoing' kindOfType, completeIdentifier),
139 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
140 ("list", keepGoing' listCmd, noCompletion),
141 ("module", keepGoing setContext, completeModule),
142 ("main", keepGoing runMain, completeFilename),
143 ("print", keepGoing printCmd, completeExpression),
144 ("quit", quit, noCompletion),
145 ("reload", keepGoing' reloadModule, noCompletion),
146 ("run", keepGoing runRun, completeFilename),
147 ("set", keepGoing setCmd, completeSetOptions),
148 ("show", keepGoing showCmd, completeShowOptions),
149 ("sprint", keepGoing sprintCmd, completeExpression),
150 ("step", keepGoing stepCmd, completeIdentifier),
151 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
152 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
153 ("type", keepGoing' typeOfExpr, completeExpression),
154 ("trace", keepGoing traceCmd, completeExpression),
155 ("undef", keepGoing undefineMacro, completeMacro),
156 ("unset", keepGoing unsetOptions, completeSetOptions)
160 -- We initialize readline (in the interactiveUI function) to use
161 -- word_break_chars as the default set of completion word break characters.
162 -- This can be overridden for a particular command (for example, filename
163 -- expansion shouldn't consider '/' to be a word break) by setting the third
164 -- entry in the Command tuple above.
166 -- NOTE: in order for us to override the default correctly, any custom entry
167 -- must be a SUBSET of word_break_chars.
168 word_break_chars :: String
169 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
170 specials = "(),;[]`{}"
172 in spaces ++ specials ++ symbols
174 flagWordBreakChars :: String
175 flagWordBreakChars = " \t\n"
178 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
179 keepGoing a str = keepGoing' (lift . a) str
181 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
182 keepGoing' a str = a str >> return False
184 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
186 = do case toArgs str of
187 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
191 shortHelpText :: String
192 shortHelpText = "use :? for help.\n"
196 " Commands available from the prompt:\n" ++
198 " <statement> evaluate/run <statement>\n" ++
199 " : repeat last command\n" ++
200 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
201 " :add [*]<module> ... add module(s) to the current target set\n" ++
202 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
203 " (!: more details; *: all top-level names)\n" ++
204 " :cd <dir> change directory to <dir>\n" ++
205 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
206 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
207 " :def <cmd> <expr> define a command :<cmd>\n" ++
208 " :edit <file> edit file\n" ++
209 " :edit edit last module\n" ++
210 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
211 " :help, :? display this list of commands\n" ++
212 " :info [<name> ...] display information about the given names\n" ++
213 " :kind <type> show the kind of <type>\n" ++
214 " :load [*]<module> ... load module(s) and their dependents\n" ++
215 " :main [<arguments> ...] run the main function with the given arguments\n" ++
216 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
217 " :quit exit GHCi\n" ++
218 " :reload reload the current module set\n" ++
219 " :run function [<arguments> ...] run the function with the given arguments\n" ++
220 " :type <expr> show the type of <expr>\n" ++
221 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
222 " :!<command> run the shell command <command>\n" ++
224 " -- Commands for debugging:\n" ++
226 " :abandon at a breakpoint, abandon current computation\n" ++
227 " :back go back in the history (after :trace)\n" ++
228 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
229 " :break <name> set a breakpoint on the specified function\n" ++
230 " :continue resume after a breakpoint\n" ++
231 " :delete <number> delete the specified breakpoint\n" ++
232 " :delete * delete all breakpoints\n" ++
233 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
234 " :forward go forward in the history (after :back)\n" ++
235 " :history [<n>] after :trace, show the execution history\n" ++
236 " :list show the source code around current breakpoint\n" ++
237 " :list identifier show the source code for <identifier>\n" ++
238 " :list [<module>] <line> show the source code around line number <line>\n" ++
239 " :print [<name> ...] prints a value without forcing its computation\n" ++
240 " :sprint [<name> ...] simplifed version of :print\n" ++
241 " :step single-step after stopping at a breakpoint\n"++
242 " :step <expr> single-step into <expr>\n"++
243 " :steplocal single-step within the current top-level binding\n"++
244 " :stepmodule single-step restricted to the current module\n"++
245 " :trace trace after stopping at a breakpoint\n"++
246 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
249 " -- Commands for changing settings:\n" ++
251 " :set <option> ... set options\n" ++
252 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
253 " :set prog <progname> set the value returned by System.getProgName\n" ++
254 " :set prompt <prompt> set the prompt used in GHCi\n" ++
255 " :set editor <cmd> set the command used for :edit\n" ++
256 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
257 " :unset <option> ... unset options\n" ++
259 " Options for ':set' and ':unset':\n" ++
261 " +r revert top-level expressions after each evaluation\n" ++
262 " +s print timing/memory stats after each evaluation\n" ++
263 " +t print type after evaluation\n" ++
264 " -<flags> most GHC command line flags can also be set here\n" ++
265 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
266 " for GHCi-specific flags, see User's Guide,\n"++
267 " Flag reference, Interactive-mode options\n" ++
269 " -- Commands for displaying information:\n" ++
271 " :show bindings show the current bindings made at the prompt\n" ++
272 " :show breaks show the active breakpoints\n" ++
273 " :show context show the breakpoint context\n" ++
274 " :show modules show the currently loaded modules\n" ++
275 " :show packages show the currently active package flags\n" ++
276 " :show languages show the currently active language flags\n" ++
277 " :show <setting> show value of <setting>, which is one of\n" ++
278 " [args, prog, prompt, editor, stop]\n" ++
281 findEditor :: IO String
286 win <- System.Win32.getWindowsDirectory
287 return (win </> "notepad.exe")
292 foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
294 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
296 interactiveUI srcs maybe_exprs = do
297 -- although GHCi compiles with -prof, it is not usable: the byte-code
298 -- compiler and interpreter don't work with profiling. So we check for
299 -- this up front and emit a helpful error message (#2197)
300 i <- liftIO $ isProfiled
302 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
304 -- HACK! If we happen to get into an infinite loop (eg the user
305 -- types 'let x=x in x' at the prompt), then the thread will block
306 -- on a blackhole, and become unreachable during GC. The GC will
307 -- detect that it is unreachable and send it the NonTermination
308 -- exception. However, since the thread is unreachable, everything
309 -- it refers to might be finalized, including the standard Handles.
310 -- This sounds like a bug, but we don't have a good solution right
312 _ <- liftIO $ newStablePtr stdin
313 _ <- liftIO $ newStablePtr stdout
314 _ <- liftIO $ newStablePtr stderr
316 -- Initialise buffering for the *interpreted* I/O system
319 liftIO $ when (isNothing maybe_exprs) $ do
320 -- Only for GHCi (not runghc and ghc -e):
322 -- Turn buffering off for the compiled program's stdout/stderr
324 -- Turn buffering off for GHCi's stdout
326 hSetBuffering stdout NoBuffering
327 -- We don't want the cmd line to buffer any input that might be
328 -- intended for the program, so unbuffer stdin.
329 hSetBuffering stdin NoBuffering
330 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611
331 -- On Unix, stdin will use the locale encoding. The IO library
332 -- doesn't do this on Windows (yet), so for now we use UTF-8,
333 -- for consistency with GHC 6.10 and to make the tests work.
334 hSetEncoding stdin utf8
337 -- initial context is just the Prelude
338 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
339 GHC.setContext [] [prel_mod]
341 default_editor <- liftIO $ findEditor
343 startGHCi (runGHCi srcs maybe_exprs)
344 GHCiState{ progname = "<interactive>",
348 editor = default_editor,
349 -- session = session,
354 tickarrays = emptyModuleEnv,
355 last_command = Nothing,
358 ghc_e = isJust maybe_exprs
363 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
364 withGhcAppData right left = do
365 either_dir <- IO.try (getAppUserDataDirectory "ghc")
367 Right dir -> right dir
370 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
371 runGHCi paths maybe_exprs = do
373 read_dot_files = not opt_IgnoreDotGhci
375 current_dir = return (Just ".ghci")
377 app_user_dir = io $ withGhcAppData
378 (\dir -> return (Just (dir </> "ghci.conf")))
382 either_dir <- io $ IO.try (getEnv "HOME")
384 Right home -> return (Just (home </> ".ghci"))
387 sourceConfigFile :: FilePath -> GHCi ()
388 sourceConfigFile file = do
389 exists <- io $ doesFileExist file
391 dir_ok <- io $ checkPerms (getDirectory file)
392 file_ok <- io $ checkPerms file
393 when (dir_ok && file_ok) $ do
394 either_hdl <- io $ IO.try (openFile file ReadMode)
397 -- NOTE: this assumes that runInputT won't affect the terminal;
398 -- can we assume this will always be the case?
399 -- This would be a good place for runFileInputT.
400 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
402 runCommands $ fileLoop hdl
404 getDirectory f = case takeDirectory f of "" -> "."; d -> d
406 when (read_dot_files) $ do
407 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
408 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
409 mapM_ sourceConfigFile (nub cfgs)
410 -- nub, because we don't want to read .ghci twice if the
413 -- Perform a :load for files given on the GHCi command line
414 -- When in -e mode, if the load fails then we want to stop
415 -- immediately rather than going on to evaluate the expression.
416 when (not (null paths)) $ do
417 ok <- ghciHandle (\e -> do showException e; return Failed) $
418 -- TODO: this is a hack.
419 runInputTWithPrefs defaultPrefs defaultSettings $ do
420 let (filePaths, phases) = unzip paths
421 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
422 loadModule (zip filePaths' phases)
423 when (isJust maybe_exprs && failed ok) $
424 io (exitWith (ExitFailure 1))
426 -- if verbosity is greater than 0, or we are connected to a
427 -- terminal, display the prompt in the interactive loop.
428 is_tty <- io (hIsTerminalDevice stdin)
429 dflags <- getDynFlags
430 let show_prompt = verbosity dflags > 0 || is_tty
435 -- enter the interactive loop
436 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
438 -- just evaluate the expression we were given
439 enqueueCommands exprs
440 let handle e = do st <- getGHCiState
441 -- Jump through some hoops to get the
442 -- current progname in the exception text:
443 -- <progname>: <exception>
444 io $ withProgName (progname st)
445 -- this used to be topHandlerFastExit, see #2228
447 runInputTWithPrefs defaultPrefs defaultSettings $ do
449 runCommands' handle (return Nothing)
452 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
454 runGHCiInput :: InputT GHCi a -> GHCi a
456 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
458 let settings = setComplete ghciCompleteWord
459 $ defaultSettings {historyFile = histFile}
460 runInputT settings $ do
464 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
465 nextInputLine show_prompt is_tty
467 prompt <- if show_prompt then lift mkPrompt else return ""
470 when show_prompt $ lift mkPrompt >>= liftIO . putStr
473 -- NOTE: We only read .ghci files if they are owned by the current user,
474 -- and aren't world writable. Otherwise, we could be accidentally
475 -- running code planted by a malicious third party.
477 -- Furthermore, We only read ./.ghci if . is owned by the current user
478 -- and isn't writable by anyone else. I think this is sufficient: we
479 -- don't need to check .. and ../.. etc. because "." always refers to
480 -- the same directory while a process is running.
482 checkPerms :: String -> IO Bool
483 #ifdef mingw32_HOST_OS
488 handleIO (\_ -> return False) $ do
489 st <- getFileStatus name
491 if fileOwner st /= me then do
492 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
495 let mode = fileMode st
496 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
497 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
499 putStrLn $ "*** WARNING: " ++ name ++
500 " is writable by someone else, IGNORING!"
505 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
507 l <- liftIO $ IO.try $ hGetLine hdl
509 Left e | isEOFError e -> return Nothing
510 | InvalidArgument <- etype -> return Nothing
511 | otherwise -> liftIO $ ioError e
512 where etype = ioeGetErrorType e
513 -- treat InvalidArgument in the same way as EOF:
514 -- this can happen if the user closed stdin, or
515 -- perhaps did getContents which closes stdin at
517 Right l -> return (Just l)
519 mkPrompt :: GHCi String
521 (toplevs,exports) <- GHC.getContext
522 resumes <- GHC.getResumeContext
523 -- st <- getGHCiState
529 let ix = GHC.resumeHistoryIx r
531 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
533 let hist = GHC.resumeHistory r !! (ix-1)
534 span <- GHC.getHistorySpan hist
535 return (brackets (ppr (negate ix) <> char ':'
536 <+> ppr span) <> space)
538 dots | _:rs <- resumes, not (null rs) = text "... "
545 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
546 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
547 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
548 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
549 hsep (map (ppr . GHC.moduleName) exports)
551 deflt_prompt = dots <> context_bit <> modules_bit
553 f ('%':'s':xs) = deflt_prompt <> f xs
554 f ('%':'%':xs) = char '%' <> f xs
555 f (x:xs) = char x <> f xs
559 return (showSDoc (f (prompt st)))
562 queryQueue :: GHCi (Maybe String)
567 c:cs -> do setGHCiState st{ cmdqueue = cs }
570 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
571 runCommands = runCommands' handler
573 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
574 -> InputT GHCi (Maybe String) -> InputT GHCi ()
575 runCommands' eh getCmd = do
576 b <- handleGhcException (\e -> case e of
577 Interrupted -> return False
578 _other -> liftIO (print e) >> return True)
579 (runOneCommand eh getCmd)
580 if b then return () else runCommands' eh getCmd
582 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
584 runOneCommand eh getCmd = do
585 mb_cmd <- noSpace (lift queryQueue)
586 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
588 Nothing -> return True
589 Just c -> ghciHandle (lift . eh) $
590 handleSourceError printErrorAndKeepGoing
593 printErrorAndKeepGoing err = do
594 GHC.printExceptionAndWarnings err
597 noSpace q = q >>= maybe (return Nothing)
598 (\c->case removeSpaces c of
600 ":{" -> multiLineCmd q
601 c -> return (Just c) )
603 st <- lift getGHCiState
605 lift $ setGHCiState st{ prompt = "%s| " }
606 mb_cmd <- collectCommand q ""
607 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
609 -- we can't use removeSpaces for the sublines here, so
610 -- multiline commands are somewhat more brittle against
611 -- fileformat errors (such as \r in dos input on unix),
612 -- we get rid of any extra spaces for the ":}" test;
613 -- we also avoid silent failure if ":}" is not found;
614 -- and since there is no (?) valid occurrence of \r (as
615 -- opposed to its String representation, "\r") inside a
616 -- ghci command, we replace any such with ' ' (argh:-(
617 collectCommand q c = q >>=
618 maybe (liftIO (ioError collectError))
619 (\l->if removeSpaces l == ":}"
620 then return (Just $ removeSpaces c)
621 else collectCommand q (c++map normSpace l))
622 where normSpace '\r' = ' '
624 -- QUESTION: is userError the one to use here?
625 collectError = userError "unterminated multiline command :{ .. :}"
626 doCommand (':' : cmd) = specialCommand cmd
627 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
630 enqueueCommands :: [String] -> GHCi ()
631 enqueueCommands cmds = do
633 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
636 runStmt :: String -> SingleStep -> GHCi Bool
638 | null (filter (not.isSpace) stmt) = return False
639 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
642 #if __GLASGOW_HASKELL__ >= 611
643 -- In the new IO library, read handles buffer data even if the Handle
644 -- is set to NoBuffering. This causes problems for GHCi where there
645 -- are really two stdin Handles. So we flush any bufferred data in
646 -- GHCi's stdin Handle here (only relevant if stdin is attached to
647 -- a file, otherwise the read buffer can't be flushed).
648 _ <- liftIO $ IO.try $ hFlushAll stdin
650 result <- GhciMonad.runStmt stmt step
651 afterRunStmt (const True) result
653 --afterRunStmt :: GHC.RunResult -> GHCi Bool
654 -- False <=> the statement failed to compile
655 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
656 afterRunStmt _ (GHC.RunException e) = throw e
657 afterRunStmt step_here run_result = do
658 resumes <- GHC.getResumeContext
660 GHC.RunOk names -> do
661 show_types <- isOptionSet ShowType
662 when show_types $ printTypeOfNames names
663 GHC.RunBreak _ names mb_info
664 | isNothing mb_info ||
665 step_here (GHC.resumeSpan $ head resumes) -> do
666 mb_id_loc <- toBreakIdAndLocation mb_info
667 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
669 then printStoppedAtBreakInfo (head resumes) names
670 else enqueueCommands [breakCmd]
671 -- run the command set with ":set stop <cmd>"
673 enqueueCommands [stop st]
675 | otherwise -> resume step_here GHC.SingleStep >>=
676 afterRunStmt step_here >> return ()
680 io installSignalHandlers
681 b <- isOptionSet RevertCAFs
684 return (case run_result of GHC.RunOk _ -> True; _ -> False)
686 toBreakIdAndLocation ::
687 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
688 toBreakIdAndLocation Nothing = return Nothing
689 toBreakIdAndLocation (Just info) = do
690 let mod = GHC.breakInfo_module info
691 nm = GHC.breakInfo_number info
693 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
694 breakModule loc == mod,
695 breakTick loc == nm ]
697 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
698 printStoppedAtBreakInfo resume names = do
699 printForUser $ ptext (sLit "Stopped at") <+>
700 ppr (GHC.resumeSpan resume)
701 -- printTypeOfNames session names
702 let namesSorted = sortBy compareNames names
703 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
704 docs <- pprTypeAndContents [id | AnId id <- tythings]
705 printForUserPartWay docs
707 printTypeOfNames :: [Name] -> GHCi ()
708 printTypeOfNames names
709 = mapM_ (printTypeOfName ) $ sortBy compareNames names
711 compareNames :: Name -> Name -> Ordering
712 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
713 where compareWith n = (getOccString n, getSrcSpan n)
715 printTypeOfName :: Name -> GHCi ()
717 = do maybe_tything <- GHC.lookupName n
718 case maybe_tything of
720 Just thing -> printTyThing thing
723 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
725 specialCommand :: String -> InputT GHCi Bool
726 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
727 specialCommand str = do
728 let (cmd,rest) = break isSpace str
729 maybe_cmd <- lift $ lookupCommand cmd
731 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
733 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
737 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
741 lookupCommand :: String -> GHCi (MaybeCommand)
742 lookupCommand "" = do
744 case last_command st of
745 Just c -> return $ GotCommand c
746 Nothing -> return NoLastCommand
747 lookupCommand str = do
748 mc <- io $ lookupCommand' str
750 setGHCiState st{ last_command = mc }
752 Just c -> GotCommand c
753 Nothing -> BadCommand
755 lookupCommand' :: String -> IO (Maybe Command)
756 lookupCommand' str = do
757 macros <- readIORef macros_ref
758 let cmds = builtin_commands ++ macros
759 -- look for exact match first, then the first prefix match
760 return $ case [ c | c <- cmds, str == cmdName c ] of
762 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
766 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
767 getCurrentBreakSpan = do
768 resumes <- GHC.getResumeContext
772 let ix = GHC.resumeHistoryIx r
774 then return (Just (GHC.resumeSpan r))
776 let hist = GHC.resumeHistory r !! (ix-1)
777 span <- GHC.getHistorySpan hist
780 getCurrentBreakModule :: GHCi (Maybe Module)
781 getCurrentBreakModule = do
782 resumes <- GHC.getResumeContext
786 let ix = GHC.resumeHistoryIx r
788 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
790 let hist = GHC.resumeHistory r !! (ix-1)
791 return $ Just $ GHC.getHistoryModule hist
793 -----------------------------------------------------------------------------
796 noArgs :: GHCi () -> String -> GHCi ()
798 noArgs _ _ = io $ putStrLn "This command takes no arguments"
800 help :: String -> GHCi ()
801 help _ = io (putStr helpText)
803 info :: String -> InputT GHCi ()
804 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
805 info s = handleSourceError GHC.printExceptionAndWarnings $ do
806 { let names = words s
807 ; dflags <- getDynFlags
808 ; let pefas = dopt Opt_PrintExplicitForalls dflags
809 ; mapM_ (infoThing pefas) names }
811 infoThing pefas str = do
812 names <- GHC.parseName str
813 mb_stuffs <- mapM GHC.getInfo names
814 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
815 unqual <- GHC.getPrintUnqual
816 outputStrLn $ showSDocForUser unqual $
817 vcat (intersperse (text "") $
818 map (pprInfo pefas) filtered)
820 -- Filter out names whose parent is also there Good
821 -- example is '[]', which is both a type and data
822 -- constructor in the same type
823 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
824 filterOutChildren get_thing xs
825 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
827 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
829 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
830 pprInfo pefas (thing, fixity, insts)
831 = pprTyThingInContextLoc pefas thing
832 $$ show_fixity fixity
833 $$ vcat (map GHC.pprInstance insts)
836 | fix == GHC.defaultFixity = empty
837 | otherwise = ppr fix <+> ppr (GHC.getName thing)
839 runMain :: String -> GHCi ()
840 runMain s = case toArgs s of
841 Left err -> io (hPutStrLn stderr err)
843 do dflags <- getDynFlags
844 case mainFunIs dflags of
845 Nothing -> doWithArgs args "main"
846 Just f -> doWithArgs args f
848 runRun :: String -> GHCi ()
849 runRun s = case toCmdArgs s of
850 Left err -> io (hPutStrLn stderr err)
851 Right (cmd, args) -> doWithArgs args cmd
853 doWithArgs :: [String] -> String -> GHCi ()
854 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
855 show args ++ " (" ++ cmd ++ ")"]
857 addModule :: [FilePath] -> InputT GHCi ()
859 lift revertCAFs -- always revert CAFs on load/add.
860 files <- mapM expandPath files
861 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
862 -- remove old targets with the same id; e.g. for :add *M
863 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
864 mapM_ GHC.addTarget targets
865 prev_context <- GHC.getContext
866 ok <- trySuccess $ GHC.load LoadAllTargets
867 afterLoad ok False prev_context
869 changeDirectory :: String -> InputT GHCi ()
870 changeDirectory "" = do
871 -- :cd on its own changes to the user's home directory
872 either_dir <- liftIO $ IO.try getHomeDirectory
875 Right dir -> changeDirectory dir
876 changeDirectory dir = do
877 graph <- GHC.getModuleGraph
878 when (not (null graph)) $
879 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
880 prev_context <- GHC.getContext
882 _ <- GHC.load LoadAllTargets
883 lift $ setContextAfterLoad prev_context False []
884 GHC.workingDirectoryChanged
885 dir <- expandPath dir
886 liftIO $ setCurrentDirectory dir
888 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
890 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
894 editFile :: String -> GHCi ()
896 do file <- if null str then chooseEditFile else return str
900 $ ghcError (CmdLineError "editor not set, use :set editor")
901 _ <- io $ system (cmd ++ ' ':file)
904 -- The user didn't specify a file so we pick one for them.
905 -- Our strategy is to pick the first module that failed to load,
906 -- or otherwise the first target.
908 -- XXX: Can we figure out what happened if the depndecy analysis fails
909 -- (e.g., because the porgrammeer mistyped the name of a module)?
910 -- XXX: Can we figure out the location of an error to pass to the editor?
911 -- XXX: if we could figure out the list of errors that occured during the
912 -- last load/reaload, then we could start the editor focused on the first
914 chooseEditFile :: GHCi String
916 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
918 graph <- GHC.getModuleGraph
919 failed_graph <- filterM hasFailed graph
920 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
922 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
925 case pick (order failed_graph) of
926 Just file -> return file
928 do targets <- GHC.getTargets
929 case msum (map fromTarget targets) of
930 Just file -> return file
931 Nothing -> ghcError (CmdLineError "No files to edit.")
933 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
934 fromTarget _ = Nothing -- when would we get a module target?
936 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
937 defineMacro overwrite s = do
938 let (macro_name, definition) = break isSpace s
939 macros <- io (readIORef macros_ref)
940 let defined = map cmdName macros
943 then io $ putStrLn "no macros defined"
944 else io $ putStr ("the following macros are defined:\n" ++
947 if (not overwrite && macro_name `elem` defined)
948 then ghcError (CmdLineError
949 ("macro '" ++ macro_name ++ "' is already defined"))
952 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
954 -- give the expression a type signature, so we can be sure we're getting
955 -- something of the right type.
956 let new_expr = '(' : definition ++ ") :: String -> IO String"
958 -- compile the expression
959 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
960 hv <- GHC.compileExpr new_expr
961 io (writeIORef macros_ref --
962 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
964 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
966 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
967 -- make sure we force any exceptions in the result, while we are still
968 -- inside the exception handler for commands:
969 seqList str (return ())
970 enqueueCommands (lines str)
973 undefineMacro :: String -> GHCi ()
974 undefineMacro str = mapM_ undef (words str)
975 where undef macro_name = do
976 cmds <- io (readIORef macros_ref)
977 if (macro_name `notElem` map cmdName cmds)
978 then ghcError (CmdLineError
979 ("macro '" ++ macro_name ++ "' is not defined"))
981 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
983 cmdCmd :: String -> GHCi ()
985 let expr = '(' : str ++ ") :: IO String"
986 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
987 hv <- GHC.compileExpr expr
988 cmds <- io $ (unsafeCoerce# hv :: IO String)
989 enqueueCommands (lines cmds)
992 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
993 loadModule fs = timeIt (loadModule' fs)
995 loadModule_ :: [FilePath] -> InputT GHCi ()
996 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
998 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
999 loadModule' files = do
1000 prev_context <- GHC.getContext
1004 lift discardActiveBreakPoints
1006 _ <- GHC.load LoadAllTargets
1008 let (filenames, phases) = unzip files
1009 exp_filenames <- mapM expandPath filenames
1010 let files' = zip exp_filenames phases
1011 targets <- mapM (uncurry GHC.guessTarget) files'
1013 -- NOTE: we used to do the dependency anal first, so that if it
1014 -- fails we didn't throw away the current set of modules. This would
1015 -- require some re-working of the GHC interface, so we'll leave it
1016 -- as a ToDo for now.
1018 GHC.setTargets targets
1019 doLoad False prev_context LoadAllTargets
1021 checkModule :: String -> InputT GHCi ()
1023 let modl = GHC.mkModuleName m
1024 prev_context <- GHC.getContext
1025 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1026 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1027 outputStrLn (showSDoc (
1028 case GHC.moduleInfo r of
1029 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1031 (local,global) = ASSERT( all isExternalName scope )
1032 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1034 (text "global names: " <+> ppr global) $$
1035 (text "local names: " <+> ppr local)
1038 afterLoad (successIf ok) False prev_context
1040 reloadModule :: String -> InputT GHCi ()
1042 prev_context <- GHC.getContext
1043 _ <- doLoad True prev_context $
1044 if null m then LoadAllTargets
1045 else LoadUpTo (GHC.mkModuleName m)
1048 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1049 doLoad retain_context prev_context howmuch = do
1050 -- turn off breakpoints before we load: we can't turn them off later, because
1051 -- the ModBreaks will have gone away.
1052 lift discardActiveBreakPoints
1053 ok <- trySuccess $ GHC.load howmuch
1054 afterLoad ok retain_context prev_context
1057 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1058 afterLoad ok retain_context prev_context = do
1059 lift revertCAFs -- always revert CAFs on load.
1060 lift discardTickArrays
1061 loaded_mod_summaries <- getLoadedModules
1062 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1063 loaded_mod_names = map GHC.moduleName loaded_mods
1064 modulesLoadedMsg ok loaded_mod_names
1066 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1069 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1070 setContextAfterLoad prev keep_ctxt [] = do
1071 prel_mod <- getPrelude
1072 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1073 setContextAfterLoad prev keep_ctxt ms = do
1074 -- load a target if one is available, otherwise load the topmost module.
1075 targets <- GHC.getTargets
1076 case [ m | Just m <- map (findTarget ms) targets ] of
1078 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1079 load_this (last graph')
1084 = case filter (`matches` t) ms of
1088 summary `matches` Target (TargetModule m) _ _
1089 = GHC.ms_mod_name summary == m
1090 summary `matches` Target (TargetFile f _) _ _
1091 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1095 load_this summary | m <- GHC.ms_mod summary = do
1096 b <- GHC.moduleIsInterpreted m
1097 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1099 prel_mod <- getPrelude
1100 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1102 -- | Keep any package modules (except Prelude) when changing the context.
1103 setContextKeepingPackageModules
1104 :: ([Module],[Module]) -- previous context
1105 -> Bool -- re-execute :module commands
1106 -> ([Module],[Module]) -- new context
1108 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1109 let (_,bs0) = prev_context
1110 prel_mod <- getPrelude
1111 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1112 let bs1 = if null as then nub (prel_mod : bs) else bs
1113 GHC.setContext as (nub (bs1 ++ pkg_modules))
1117 mapM_ (playCtxtCmd False) (remembered_ctx st)
1120 setGHCiState st{ remembered_ctx = [] }
1122 isHomeModule :: Module -> Bool
1123 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1125 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1126 modulesLoadedMsg ok mods = do
1127 dflags <- getDynFlags
1128 when (verbosity dflags > 0) $ do
1130 | null mods = text "none."
1131 | otherwise = hsep (
1132 punctuate comma (map ppr mods)) <> text "."
1135 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1137 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1140 typeOfExpr :: String -> InputT GHCi ()
1142 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1143 ty <- GHC.exprType str
1144 dflags <- getDynFlags
1145 let pefas = dopt Opt_PrintExplicitForalls dflags
1146 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1148 kindOfType :: String -> InputT GHCi ()
1150 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1151 ty <- GHC.typeKind str
1152 printForUser' $ text str <+> dcolon <+> ppr ty
1154 quit :: String -> InputT GHCi Bool
1155 quit _ = return True
1157 shellEscape :: String -> GHCi Bool
1158 shellEscape str = io (system str >> return False)
1160 -----------------------------------------------------------------------------
1161 -- Browsing a module's contents
1163 browseCmd :: Bool -> String -> InputT GHCi ()
1166 ['*':s] | looksLikeModuleName s -> do
1167 m <- lift $ wantInterpretedModule s
1168 browseModule bang m False
1169 [s] | looksLikeModuleName s -> do
1170 m <- lift $ lookupModule s
1171 browseModule bang m True
1173 (as,bs) <- GHC.getContext
1174 -- Guess which module the user wants to browse. Pick
1175 -- modules that are interpreted first. The most
1176 -- recently-added module occurs last, it seems.
1178 (as@(_:_), _) -> browseModule bang (last as) True
1179 ([], bs@(_:_)) -> browseModule bang (last bs) True
1180 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1181 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1183 -- without bang, show items in context of their parents and omit children
1184 -- with bang, show class methods and data constructors separately, and
1185 -- indicate import modules, to aid qualifying unqualified names
1186 -- with sorted, sort items alphabetically
1187 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1188 browseModule bang modl exports_only = do
1189 -- :browse! reports qualifiers wrt current context
1190 current_unqual <- GHC.getPrintUnqual
1191 -- Temporarily set the context to the module we're interested in,
1192 -- just so we can get an appropriate PrintUnqualified
1193 (as,bs) <- GHC.getContext
1194 prel_mod <- lift getPrelude
1195 if exports_only then GHC.setContext [] [prel_mod,modl]
1196 else GHC.setContext [modl] []
1197 target_unqual <- GHC.getPrintUnqual
1198 GHC.setContext as bs
1200 let unqual = if bang then current_unqual else target_unqual
1202 mb_mod_info <- GHC.getModuleInfo modl
1204 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1205 GHC.moduleNameString (GHC.moduleName modl)))
1207 dflags <- getDynFlags
1209 | exports_only = GHC.modInfoExports mod_info
1210 | otherwise = GHC.modInfoTopLevelScope mod_info
1213 -- sort alphabetically name, but putting
1214 -- locally-defined identifiers first.
1215 -- We would like to improve this; see #1799.
1216 sorted_names = loc_sort local ++ occ_sort external
1218 (local,external) = ASSERT( all isExternalName names )
1219 partition ((==modl) . nameModule) names
1220 occ_sort = sortBy (compare `on` nameOccName)
1221 -- try to sort by src location. If the first name in
1222 -- our list has a good source location, then they all should.
1224 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1225 = sortBy (compare `on` nameSrcSpan) names
1229 mb_things <- mapM GHC.lookupName sorted_names
1230 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1232 rdr_env <- GHC.getGRE
1234 let pefas = dopt Opt_PrintExplicitForalls dflags
1235 things | bang = catMaybes mb_things
1236 | otherwise = filtered_things
1237 pretty | bang = pprTyThing
1238 | otherwise = pprTyThingInContext
1240 labels [] = text "-- not currently imported"
1241 labels l = text $ intercalate "\n" $ map qualifier l
1242 qualifier = maybe "-- defined locally"
1243 (("-- imported via "++) . intercalate ", "
1244 . map GHC.moduleNameString)
1245 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1246 modNames = map (importInfo . GHC.getName) things
1248 -- annotate groups of imports with their import modules
1249 -- the default ordering is somewhat arbitrary, so we group
1250 -- by header and sort groups; the names themselves should
1251 -- really come in order of source appearance.. (trac #1799)
1252 annotate mts = concatMap (\(m,ts)->labels m:ts)
1253 $ sortBy cmpQualifiers $ group mts
1254 where cmpQualifiers =
1255 compare `on` (map (fmap (map moduleNameFS)) . fst)
1257 group mts@((m,_):_) = (m,map snd g) : group ng
1258 where (g,ng) = partition ((==m).fst) mts
1260 let prettyThings = map (pretty pefas) things
1261 prettyThings' | bang = annotate $ zip modNames prettyThings
1262 | otherwise = prettyThings
1263 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1264 -- ToDo: modInfoInstances currently throws an exception for
1265 -- package modules. When it works, we can do this:
1266 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1268 -----------------------------------------------------------------------------
1269 -- Setting the module context
1271 setContext :: String -> GHCi ()
1273 | all sensible strs = do
1274 playCtxtCmd True (cmd, as, bs)
1276 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1277 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1279 (cmd, strs, as, bs) =
1281 '+':stuff -> rest AddModules stuff
1282 '-':stuff -> rest RemModules stuff
1283 stuff -> rest SetContext stuff
1285 rest cmd stuff = (cmd, strs, as, bs)
1286 where strs = words stuff
1287 (as,bs) = partitionWith starred strs
1289 sensible ('*':m) = looksLikeModuleName m
1290 sensible m = looksLikeModuleName m
1292 starred ('*':m) = Left m
1295 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1296 playCtxtCmd fail (cmd, as, bs)
1298 (as',bs') <- do_checks fail
1299 (prev_as,prev_bs) <- GHC.getContext
1303 prel_mod <- getPrelude
1304 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1308 let as_to_add = as' \\ (prev_as ++ prev_bs)
1309 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1310 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1312 let new_as = prev_as \\ (as' ++ bs')
1313 new_bs = prev_bs \\ (as' ++ bs')
1314 return (new_as, new_bs)
1315 GHC.setContext new_as new_bs
1318 as' <- mapM wantInterpretedModule as
1319 bs' <- mapM lookupModule bs
1321 do_checks False = do
1322 as' <- mapM (trymaybe . wantInterpretedModule) as
1323 bs' <- mapM (trymaybe . lookupModule) bs
1324 return (catMaybes as', catMaybes bs')
1329 Left _ -> return Nothing
1330 Right a -> return (Just a)
1332 ----------------------------------------------------------------------------
1335 -- set options in the interpreter. Syntax is exactly the same as the
1336 -- ghc command line, except that certain options aren't available (-C,
1339 -- This is pretty fragile: most options won't work as expected. ToDo:
1340 -- figure out which ones & disallow them.
1342 setCmd :: String -> GHCi ()
1344 = do st <- getGHCiState
1345 let opts = options st
1346 io $ putStrLn (showSDoc (
1347 text "options currently set: " <>
1350 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1352 dflags <- getDynFlags
1353 io $ putStrLn (showSDoc (
1354 vcat (text "GHCi-specific dynamic flag settings:"
1355 :map (flagSetting dflags) ghciFlags)
1357 io $ putStrLn (showSDoc (
1358 vcat (text "other dynamic, non-language, flag settings:"
1359 :map (flagSetting dflags) nonLanguageDynFlags)
1361 where flagSetting dflags (str, f, _)
1362 | dopt f dflags = text " " <> text "-f" <> text str
1363 | otherwise = text " " <> text "-fno-" <> text str
1364 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1366 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1368 flags = [Opt_PrintExplicitForalls
1369 ,Opt_PrintBindResult
1370 ,Opt_BreakOnException
1372 ,Opt_PrintEvldWithShow
1375 = case getCmd str of
1376 Right ("args", rest) ->
1378 Left err -> io (hPutStrLn stderr err)
1379 Right args -> setArgs args
1380 Right ("prog", rest) ->
1382 Right [prog] -> setProg prog
1383 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1384 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1385 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1386 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1387 _ -> case toArgs str of
1388 Left err -> io (hPutStrLn stderr err)
1389 Right wds -> setOptions wds
1391 setArgs, setOptions :: [String] -> GHCi ()
1392 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1396 setGHCiState st{ args = args }
1400 setGHCiState st{ progname = prog }
1404 setGHCiState st{ editor = cmd }
1406 setStop str@(c:_) | isDigit c
1407 = do let (nm_str,rest) = break (not.isDigit) str
1410 let old_breaks = breaks st
1411 if all ((/= nm) . fst) old_breaks
1412 then printForUser (text "Breakpoint" <+> ppr nm <+>
1413 text "does not exist")
1415 let new_breaks = map fn old_breaks
1416 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1417 | otherwise = (i,loc)
1418 setGHCiState st{ breaks = new_breaks }
1421 setGHCiState st{ stop = cmd }
1423 setPrompt value = do
1426 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1428 '\"' : _ -> case reads value of
1429 [(value', xs)] | all isSpace xs ->
1430 setGHCiState (st { prompt = value' })
1432 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1433 _ -> setGHCiState (st { prompt = value })
1436 do -- first, deal with the GHCi opts (+s, +t, etc.)
1437 let (plus_opts, minus_opts) = partitionWith isPlus wds
1438 mapM_ setOpt plus_opts
1439 -- then, dynamic flags
1440 newDynFlags minus_opts
1442 newDynFlags :: [String] -> GHCi ()
1443 newDynFlags minus_opts = do
1444 dflags <- getDynFlags
1445 let pkg_flags = packageFlags dflags
1446 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1447 handleFlagWarnings dflags' warns
1449 if (not (null leftovers))
1450 then ghcError $ errorsToGhcException leftovers
1453 new_pkgs <- setDynFlags dflags'
1455 -- if the package flags changed, we should reset the context
1456 -- and link the new packages.
1457 dflags <- getDynFlags
1458 when (packageFlags dflags /= pkg_flags) $ do
1459 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1461 _ <- GHC.load LoadAllTargets
1462 io (linkPackages dflags new_pkgs)
1463 -- package flags changed, we can't re-use any of the old context
1464 setContextAfterLoad ([],[]) False []
1468 unsetOptions :: String -> GHCi ()
1470 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1471 let opts = words str
1472 (minus_opts, rest1) = partition isMinus opts
1473 (plus_opts, rest2) = partitionWith isPlus rest1
1475 if (not (null rest2))
1476 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1479 mapM_ unsetOpt plus_opts
1481 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1482 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1484 no_flags <- mapM no_flag minus_opts
1485 newDynFlags no_flags
1487 isMinus :: String -> Bool
1488 isMinus ('-':_) = True
1491 isPlus :: String -> Either String String
1492 isPlus ('+':opt) = Left opt
1493 isPlus other = Right other
1495 setOpt, unsetOpt :: String -> GHCi ()
1498 = case strToGHCiOpt str of
1499 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1500 Just o -> setOption o
1503 = case strToGHCiOpt str of
1504 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1505 Just o -> unsetOption o
1507 strToGHCiOpt :: String -> (Maybe GHCiOption)
1508 strToGHCiOpt "s" = Just ShowTiming
1509 strToGHCiOpt "t" = Just ShowType
1510 strToGHCiOpt "r" = Just RevertCAFs
1511 strToGHCiOpt _ = Nothing
1513 optToStr :: GHCiOption -> String
1514 optToStr ShowTiming = "s"
1515 optToStr ShowType = "t"
1516 optToStr RevertCAFs = "r"
1518 -- ---------------------------------------------------------------------------
1521 showCmd :: String -> GHCi ()
1525 ["args"] -> io $ putStrLn (show (args st))
1526 ["prog"] -> io $ putStrLn (show (progname st))
1527 ["prompt"] -> io $ putStrLn (show (prompt st))
1528 ["editor"] -> io $ putStrLn (show (editor st))
1529 ["stop"] -> io $ putStrLn (show (stop st))
1530 ["modules" ] -> showModules
1531 ["bindings"] -> showBindings
1532 ["linker"] -> io showLinkerState
1533 ["breaks"] -> showBkptTable
1534 ["context"] -> showContext
1535 ["packages"] -> showPackages
1536 ["languages"] -> showLanguages
1537 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1538 " | breaks | context | packages | languages ]"))
1540 showModules :: GHCi ()
1542 loaded_mods <- getLoadedModules
1543 -- we want *loaded* modules only, see #1734
1544 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1545 mapM_ show_one loaded_mods
1547 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1548 getLoadedModules = do
1549 graph <- GHC.getModuleGraph
1550 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1552 showBindings :: GHCi ()
1554 bindings <- GHC.getBindings
1555 docs <- pprTypeAndContents
1556 [ id | AnId id <- sortBy compareTyThings bindings]
1557 printForUserPartWay docs
1559 compareTyThings :: TyThing -> TyThing -> Ordering
1560 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1562 printTyThing :: TyThing -> GHCi ()
1563 printTyThing tyth = do dflags <- getDynFlags
1564 let pefas = dopt Opt_PrintExplicitForalls dflags
1565 printForUser (pprTyThing pefas tyth)
1567 showBkptTable :: GHCi ()
1570 printForUser $ prettyLocations (breaks st)
1572 showContext :: GHCi ()
1574 resumes <- GHC.getResumeContext
1575 printForUser $ vcat (map pp_resume (reverse resumes))
1578 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1579 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1581 showPackages :: GHCi ()
1583 pkg_flags <- fmap packageFlags getDynFlags
1584 io $ putStrLn $ showSDoc $ vcat $
1585 text ("active package flags:"++if null pkg_flags then " none" else "")
1586 : map showFlag pkg_flags
1587 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1588 io $ putStrLn $ showSDoc $ vcat $
1589 text "packages currently loaded:"
1590 : map (nest 2 . text . packageIdString)
1591 (sortBy (compare `on` packageIdFS) pkg_ids)
1592 where showFlag (ExposePackage p) = text $ " -package " ++ p
1593 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1594 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1596 showLanguages :: GHCi ()
1598 dflags <- getDynFlags
1599 io $ putStrLn $ showSDoc $ vcat $
1600 text "active language flags:" :
1601 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1603 -- -----------------------------------------------------------------------------
1606 completeCmd, completeMacro, completeIdentifier, completeModule,
1607 completeHomeModule, completeSetOptions, completeShowOptions,
1608 completeHomeModuleOrFile, completeExpression
1609 :: CompletionFunc GHCi
1611 ghciCompleteWord :: CompletionFunc GHCi
1612 ghciCompleteWord line@(left,_) = case firstWord of
1613 ':':cmd | null rest -> completeCmd line
1615 completion <- lookupCompletion cmd
1617 "import" -> completeModule line
1618 _ -> completeExpression line
1620 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1621 lookupCompletion ('!':_) = return completeFilename
1622 lookupCompletion c = do
1623 maybe_cmd <- liftIO $ lookupCommand' c
1625 Just (_,_,f) -> return f
1626 Nothing -> return completeFilename
1628 completeCmd = wrapCompleter " " $ \w -> do
1629 cmds <- liftIO $ readIORef macros_ref
1630 return (filter (w `isPrefixOf`) (map (':':)
1631 (map cmdName (builtin_commands ++ cmds))))
1633 completeMacro = wrapIdentCompleter $ \w -> do
1634 cmds <- liftIO $ readIORef macros_ref
1635 return (filter (w `isPrefixOf`) (map cmdName cmds))
1637 completeIdentifier = wrapIdentCompleter $ \w -> do
1638 rdrs <- GHC.getRdrNamesInScope
1639 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1641 completeModule = wrapIdentCompleter $ \w -> do
1642 dflags <- GHC.getSessionDynFlags
1643 let pkg_mods = allExposedModules dflags
1644 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1645 return $ filter (w `isPrefixOf`)
1646 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1648 completeHomeModule = wrapIdentCompleter listHomeModules
1650 listHomeModules :: String -> GHCi [String]
1651 listHomeModules w = do
1652 g <- GHC.getModuleGraph
1653 let home_mods = map GHC.ms_mod_name g
1654 return $ sort $ filter (w `isPrefixOf`)
1655 $ map (showSDoc.ppr) home_mods
1657 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1658 return (filter (w `isPrefixOf`) options)
1659 where options = "args":"prog":"prompt":"editor":"stop":flagList
1660 flagList = map head $ group $ sort allFlags
1662 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1663 return (filter (w `isPrefixOf`) options)
1664 where options = ["args", "prog", "prompt", "editor", "stop",
1665 "modules", "bindings", "linker", "breaks",
1666 "context", "packages", "languages"]
1668 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1669 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1672 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1673 unionComplete f1 f2 line = do
1678 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1679 wrapCompleter breakChars fun = completeWord Nothing breakChars
1680 $ fmap (map simpleCompletion) . fmap sort . fun
1682 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1683 wrapIdentCompleter = wrapCompleter word_break_chars
1685 allExposedModules :: DynFlags -> [ModuleName]
1686 allExposedModules dflags
1687 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1689 pkg_db = pkgIdMap (pkgState dflags)
1691 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1694 -- ---------------------------------------------------------------------------
1695 -- User code exception handling
1697 -- This is the exception handler for exceptions generated by the
1698 -- user's code and exceptions coming from children sessions;
1699 -- it normally just prints out the exception. The
1700 -- handler must be recursive, in case showing the exception causes
1701 -- more exceptions to be raised.
1703 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1704 -- raising another exception. We therefore don't put the recursive
1705 -- handler arond the flushing operation, so if stderr is closed
1706 -- GHCi will just die gracefully rather than going into an infinite loop.
1707 handler :: SomeException -> GHCi Bool
1709 handler exception = do
1711 io installSignalHandlers
1712 ghciHandle handler (showException exception >> return False)
1714 showException :: SomeException -> GHCi ()
1716 io $ case fromException se of
1717 Just Interrupted -> putStrLn "Interrupted."
1718 -- omit the location for CmdLineError:
1719 Just (CmdLineError s) -> putStrLn s
1721 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1722 Just other_ghc_ex -> print other_ghc_ex
1723 Nothing -> putStrLn ("*** Exception: " ++ show se)
1725 -----------------------------------------------------------------------------
1726 -- recursive exception handlers
1728 -- Don't forget to unblock async exceptions in the handler, or if we're
1729 -- in an exception loop (eg. let a = error a in a) the ^C exception
1730 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1732 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1733 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1735 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1736 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1738 -- ----------------------------------------------------------------------------
1741 -- TODO: won't work if home dir is encoded.
1742 -- (changeDirectory may not work either in that case.)
1743 expandPath :: MonadIO m => String -> InputT m String
1744 expandPath path = do
1745 exp_path <- liftIO $ expandPathIO path
1746 enc <- fmap BS.unpack $ Encoding.encode exp_path
1749 expandPathIO :: String -> IO String
1751 case dropWhile isSpace path of
1753 tilde <- getHomeDirectory -- will fail if HOME not defined
1754 return (tilde ++ '/':d)
1758 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1759 wantInterpretedModule str = do
1760 modl <- lookupModule str
1761 dflags <- getDynFlags
1762 when (GHC.modulePackageId modl /= thisPackage dflags) $
1763 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1764 is_interpreted <- GHC.moduleIsInterpreted modl
1765 when (not is_interpreted) $
1766 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1769 wantNameFromInterpretedModule :: GHC.GhcMonad m
1770 => (Name -> SDoc -> m ())
1774 wantNameFromInterpretedModule noCanDo str and_then =
1775 handleSourceError (GHC.printExceptionAndWarnings) $ do
1776 names <- GHC.parseName str
1780 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1781 if not (GHC.isExternalName n)
1782 then noCanDo n $ ppr n <>
1783 text " is not defined in an interpreted module"
1785 is_interpreted <- GHC.moduleIsInterpreted modl
1786 if not is_interpreted
1787 then noCanDo n $ text "module " <> ppr modl <>
1788 text " is not interpreted"
1791 -- -----------------------------------------------------------------------------
1792 -- commands for debugger
1794 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1795 sprintCmd = pprintCommand False False
1796 printCmd = pprintCommand True False
1797 forceCmd = pprintCommand False True
1799 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1800 pprintCommand bind force str = do
1801 pprintClosureCommand bind force str
1803 stepCmd :: String -> GHCi ()
1804 stepCmd [] = doContinue (const True) GHC.SingleStep
1805 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1807 stepLocalCmd :: String -> GHCi ()
1808 stepLocalCmd [] = do
1809 mb_span <- getCurrentBreakSpan
1811 Nothing -> stepCmd []
1813 Just mod <- getCurrentBreakModule
1814 current_toplevel_decl <- enclosingTickSpan mod loc
1815 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1817 stepLocalCmd expression = stepCmd expression
1819 stepModuleCmd :: String -> GHCi ()
1820 stepModuleCmd [] = do
1821 mb_span <- getCurrentBreakSpan
1823 Nothing -> stepCmd []
1825 Just span <- getCurrentBreakSpan
1826 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1827 doContinue f GHC.SingleStep
1829 stepModuleCmd expression = stepCmd expression
1831 -- | Returns the span of the largest tick containing the srcspan given
1832 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1833 enclosingTickSpan mod src = do
1834 ticks <- getTickArray mod
1835 let line = srcSpanStartLine src
1836 ASSERT (inRange (bounds ticks) line) do
1837 let enclosing_spans = [ span | (_,span) <- ticks ! line
1838 , srcSpanEnd span >= srcSpanEnd src]
1839 return . head . sortBy leftmost_largest $ enclosing_spans
1841 traceCmd :: String -> GHCi ()
1842 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1843 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1845 continueCmd :: String -> GHCi ()
1846 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1848 -- doContinue :: SingleStep -> GHCi ()
1849 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1850 doContinue pred step = do
1851 runResult <- resume pred step
1852 _ <- afterRunStmt pred runResult
1855 abandonCmd :: String -> GHCi ()
1856 abandonCmd = noArgs $ do
1857 b <- GHC.abandon -- the prompt will change to indicate the new context
1858 when (not b) $ io $ putStrLn "There is no computation running."
1861 deleteCmd :: String -> GHCi ()
1862 deleteCmd argLine = do
1863 deleteSwitch $ words argLine
1865 deleteSwitch :: [String] -> GHCi ()
1867 io $ putStrLn "The delete command requires at least one argument."
1868 -- delete all break points
1869 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1870 deleteSwitch idents = do
1871 mapM_ deleteOneBreak idents
1873 deleteOneBreak :: String -> GHCi ()
1875 | all isDigit str = deleteBreak (read str)
1876 | otherwise = return ()
1878 historyCmd :: String -> GHCi ()
1880 | null arg = history 20
1881 | all isDigit arg = history (read arg)
1882 | otherwise = io $ putStrLn "Syntax: :history [num]"
1885 resumes <- GHC.getResumeContext
1887 [] -> io $ putStrLn "Not stopped at a breakpoint"
1889 let hist = GHC.resumeHistory r
1890 (took,rest) = splitAt num hist
1892 [] -> io $ putStrLn $
1893 "Empty history. Perhaps you forgot to use :trace?"
1895 spans <- mapM GHC.getHistorySpan took
1896 let nums = map (printf "-%-3d:") [(1::Int)..]
1897 names = map GHC.historyEnclosingDecl took
1898 printForUser (vcat(zipWith3
1899 (\x y z -> x <+> y <+> z)
1901 (map (bold . ppr) names)
1902 (map (parens . ppr) spans)))
1903 io $ putStrLn $ if null rest then "<end of history>" else "..."
1905 bold :: SDoc -> SDoc
1906 bold c | do_bold = text start_bold <> c <> text end_bold
1909 backCmd :: String -> GHCi ()
1910 backCmd = noArgs $ do
1911 (names, _, span) <- GHC.back
1912 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1913 printTypeOfNames names
1914 -- run the command set with ":set stop <cmd>"
1916 enqueueCommands [stop st]
1918 forwardCmd :: String -> GHCi ()
1919 forwardCmd = noArgs $ do
1920 (names, ix, span) <- GHC.forward
1921 printForUser $ (if (ix == 0)
1922 then ptext (sLit "Stopped at")
1923 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1924 printTypeOfNames names
1925 -- run the command set with ":set stop <cmd>"
1927 enqueueCommands [stop st]
1929 -- handle the "break" command
1930 breakCmd :: String -> GHCi ()
1931 breakCmd argLine = do
1932 breakSwitch $ words argLine
1934 breakSwitch :: [String] -> GHCi ()
1936 io $ putStrLn "The break command requires at least one argument."
1937 breakSwitch (arg1:rest)
1938 | looksLikeModuleName arg1 && not (null rest) = do
1939 mod <- wantInterpretedModule arg1
1940 breakByModule mod rest
1941 | all isDigit arg1 = do
1942 (toplevel, _) <- GHC.getContext
1944 (mod : _) -> breakByModuleLine mod (read arg1) rest
1946 io $ putStrLn "Cannot find default module for breakpoint."
1947 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1948 | otherwise = do -- try parsing it as an identifier
1949 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1950 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1951 if GHC.isGoodSrcLoc loc
1952 then ASSERT( isExternalName name )
1953 findBreakAndSet (GHC.nameModule name) $
1954 findBreakByCoord (Just (GHC.srcLocFile loc))
1955 (GHC.srcLocLine loc,
1957 else noCanDo name $ text "can't find its location: " <> ppr loc
1959 noCanDo n why = printForUser $
1960 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1962 breakByModule :: Module -> [String] -> GHCi ()
1963 breakByModule mod (arg1:rest)
1964 | all isDigit arg1 = do -- looks like a line number
1965 breakByModuleLine mod (read arg1) rest
1969 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1970 breakByModuleLine mod line args
1971 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1972 | [col] <- args, all isDigit col =
1973 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1974 | otherwise = breakSyntax
1977 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1979 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1980 findBreakAndSet mod lookupTickTree = do
1981 tickArray <- getTickArray mod
1982 (breakArray, _) <- getModBreak mod
1983 case lookupTickTree tickArray of
1984 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1985 Just (tick, span) -> do
1986 success <- io $ setBreakFlag True breakArray tick
1990 recordBreak $ BreakLocation
1997 text "Breakpoint " <> ppr nm <>
1999 then text " was already set at " <> ppr span
2000 else text " activated at " <> ppr span
2002 printForUser $ text "Breakpoint could not be activated at"
2005 -- When a line number is specified, the current policy for choosing
2006 -- the best breakpoint is this:
2007 -- - the leftmost complete subexpression on the specified line, or
2008 -- - the leftmost subexpression starting on the specified line, or
2009 -- - the rightmost subexpression enclosing the specified line
2011 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2012 findBreakByLine line arr
2013 | not (inRange (bounds arr) line) = Nothing
2015 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2016 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2017 listToMaybe (sortBy (rightmost `on` snd) ticks)
2021 starts_here = [ tick | tick@(_,span) <- ticks,
2022 GHC.srcSpanStartLine span == line ]
2024 (complete,incomplete) = partition ends_here starts_here
2025 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2027 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2028 -> Maybe (BreakIndex,SrcSpan)
2029 findBreakByCoord mb_file (line, col) arr
2030 | not (inRange (bounds arr) line) = Nothing
2032 listToMaybe (sortBy (rightmost `on` snd) contains ++
2033 sortBy (leftmost_smallest `on` snd) after_here)
2037 -- the ticks that span this coordinate
2038 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2039 is_correct_file span ]
2041 is_correct_file span
2042 | Just f <- mb_file = GHC.srcSpanFile span == f
2045 after_here = [ tick | tick@(_,span) <- ticks,
2046 GHC.srcSpanStartLine span == line,
2047 GHC.srcSpanStartCol span >= col ]
2049 -- For now, use ANSI bold on terminals that we know support it.
2050 -- Otherwise, we add a line of carets under the active expression instead.
2051 -- In particular, on Windows and when running the testsuite (which sets
2052 -- TERM to vt100 for other reasons) we get carets.
2053 -- We really ought to use a proper termcap/terminfo library.
2055 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2056 where mTerm = System.Environment.getEnv "TERM"
2057 `catchIO` \_ -> return "TERM not set"
2059 start_bold :: String
2060 start_bold = "\ESC[1m"
2062 end_bold = "\ESC[0m"
2064 listCmd :: String -> InputT GHCi ()
2066 mb_span <- lift getCurrentBreakSpan
2069 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2071 | GHC.isGoodSrcSpan span -> listAround span True
2073 do resumes <- GHC.getResumeContext
2075 [] -> panic "No resumes"
2077 do let traceIt = case GHC.resumeHistory r of
2078 [] -> text "rerunning with :trace,"
2080 doWhat = traceIt <+> text ":back then :list"
2081 printForUser' (text "Unable to list source for" <+>
2083 $$ text "Try" <+> doWhat)
2084 listCmd str = list2 (words str)
2086 list2 :: [String] -> InputT GHCi ()
2087 list2 [arg] | all isDigit arg = do
2088 (toplevel, _) <- GHC.getContext
2090 [] -> outputStrLn "No module to list"
2091 (mod : _) -> listModuleLine mod (read arg)
2092 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2093 mod <- wantInterpretedModule arg1
2094 listModuleLine mod (read arg2)
2096 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2097 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2098 if GHC.isGoodSrcLoc loc
2100 tickArray <- ASSERT( isExternalName name )
2101 lift $ getTickArray (GHC.nameModule name)
2102 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2103 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2106 Nothing -> listAround (GHC.srcLocSpan loc) False
2107 Just (_,span) -> listAround span False
2109 noCanDo name $ text "can't find its location: " <>
2112 noCanDo n why = printForUser' $
2113 text "cannot list source code for " <> ppr n <> text ": " <> why
2115 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2117 listModuleLine :: Module -> Int -> InputT GHCi ()
2118 listModuleLine modl line = do
2119 graph <- GHC.getModuleGraph
2120 let this = filter ((== modl) . GHC.ms_mod) graph
2122 [] -> panic "listModuleLine"
2124 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2125 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2126 listAround (GHC.srcLocSpan loc) False
2128 -- | list a section of a source file around a particular SrcSpan.
2129 -- If the highlight flag is True, also highlight the span using
2130 -- start_bold\/end_bold.
2132 -- GHC files are UTF-8, so we can implement this by:
2133 -- 1) read the file in as a BS and syntax highlight it as before
2134 -- 2) convert the BS to String using utf-string, and write it out.
2135 -- It would be better if we could convert directly between UTF-8 and the
2136 -- console encoding, of course.
2137 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2138 listAround span do_highlight = do
2139 contents <- liftIO $ BS.readFile (unpackFS file)
2141 lines = BS.split '\n' contents
2142 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2143 drop (line1 - 1 - pad_before) $ lines
2144 fst_line = max 1 (line1 - pad_before)
2145 line_nos = [ fst_line .. ]
2147 highlighted | do_highlight = zipWith highlight line_nos these_lines
2148 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2150 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2151 prefixed = zipWith ($) highlighted bs_line_nos
2153 let output = BS.intercalate (BS.pack "\n") prefixed
2154 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2155 $ \(p,n) -> utf8DecodeString (castPtr p) n
2156 outputStrLn utf8Decoded
2158 file = GHC.srcSpanFile span
2159 line1 = GHC.srcSpanStartLine span
2160 col1 = GHC.srcSpanStartCol span
2161 line2 = GHC.srcSpanEndLine span
2162 col2 = GHC.srcSpanEndCol span
2164 pad_before | line1 == 1 = 0
2168 highlight | do_bold = highlight_bold
2169 | otherwise = highlight_carets
2171 highlight_bold no line prefix
2172 | no == line1 && no == line2
2173 = let (a,r) = BS.splitAt col1 line
2174 (b,c) = BS.splitAt (col2-col1) r
2176 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2178 = let (a,b) = BS.splitAt col1 line in
2179 BS.concat [prefix, a, BS.pack start_bold, b]
2181 = let (a,b) = BS.splitAt col2 line in
2182 BS.concat [prefix, a, BS.pack end_bold, b]
2183 | otherwise = BS.concat [prefix, line]
2185 highlight_carets no line prefix
2186 | no == line1 && no == line2
2187 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2188 BS.replicate (col2-col1) '^']
2190 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2193 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2195 | otherwise = BS.concat [prefix, line]
2197 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2198 nl = BS.singleton '\n'
2200 -- --------------------------------------------------------------------------
2203 getTickArray :: Module -> GHCi TickArray
2204 getTickArray modl = do
2206 let arrmap = tickarrays st
2207 case lookupModuleEnv arrmap modl of
2208 Just arr -> return arr
2210 (_breakArray, ticks) <- getModBreak modl
2211 let arr = mkTickArray (assocs ticks)
2212 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2215 discardTickArrays :: GHCi ()
2216 discardTickArrays = do
2218 setGHCiState st{tickarrays = emptyModuleEnv}
2220 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2222 = accumArray (flip (:)) [] (1, max_line)
2223 [ (line, (nm,span)) | (nm,span) <- ticks,
2224 line <- srcSpanLines span ]
2226 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2227 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2228 GHC.srcSpanEndLine span ]
2230 lookupModule :: GHC.GhcMonad m => String -> m Module
2231 lookupModule modName
2232 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2234 -- don't reset the counter back to zero?
2235 discardActiveBreakPoints :: GHCi ()
2236 discardActiveBreakPoints = do
2238 mapM_ (turnOffBreak.snd) (breaks st)
2239 setGHCiState $ st { breaks = [] }
2241 deleteBreak :: Int -> GHCi ()
2242 deleteBreak identity = do
2244 let oldLocations = breaks st
2245 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2247 then printForUser (text "Breakpoint" <+> ppr identity <+>
2248 text "does not exist")
2250 mapM_ (turnOffBreak.snd) this
2251 setGHCiState $ st { breaks = rest }
2253 turnOffBreak :: BreakLocation -> GHCi Bool
2254 turnOffBreak loc = do
2255 (arr, _) <- getModBreak (breakModule loc)
2256 io $ setBreakFlag False arr (breakTick loc)
2258 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2259 getModBreak mod = do
2260 Just mod_info <- GHC.getModuleInfo mod
2261 let modBreaks = GHC.modInfoModBreaks mod_info
2262 let array = GHC.modBreaks_flags modBreaks
2263 let ticks = GHC.modBreaks_locs modBreaks
2264 return (array, ticks)
2266 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2267 setBreakFlag toggle array index
2268 | toggle = GHC.setBreakOn array index
2269 | otherwise = GHC.setBreakOff array index