1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS -#include "Linker.h" #-}
5 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
6 -----------------------------------------------------------------------------
8 -- GHC Interactive User Interface
10 -- (c) The GHC Team 2005-2006
12 -----------------------------------------------------------------------------
14 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
16 #include "HsVersions.h"
18 import qualified GhciMonad
19 import GhciMonad hiding (runStmt)
24 import qualified GHC hiding (resume, runStmt)
25 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
26 Module, ModuleName, TyThing(..), Phase,
27 BreakIndex, SrcSpan, Resume, SingleStep,
28 Ghc, handleSourceError )
36 import HscTypes ( implicitTyThings, handleFlagWarnings )
37 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38 import Outputable hiding (printForUser, printForUserPartWay)
39 import Module -- for ModuleEnv
44 -- Other random utilities
47 import BasicTypes hiding (isTopLevel)
48 import Panic hiding (showException)
54 import Maybes ( orElse, expectJust )
58 #ifndef mingw32_HOST_OS
59 import System.Posix hiding (getEnv)
61 import qualified System.Win32
64 import System.Console.Haskeline as Haskeline
65 import qualified System.Console.Haskeline.Encoding as Encoding
66 import Control.Monad.Trans
70 import Exception hiding (catch, block, unblock)
71 import qualified Exception
73 -- import Control.Concurrent
75 import System.FilePath
76 import qualified Data.ByteString.Char8 as BS
80 import System.Environment
81 import System.Exit ( exitWith, ExitCode(..) )
82 import System.Directory
84 import System.IO.Error as IO
87 import Control.Monad as Monad
90 import GHC.Exts ( unsafeCoerce# )
91 import GHC.IOBase ( IOErrorType(InvalidArgument) )
94 import Data.IORef ( IORef, readIORef, writeIORef )
96 -----------------------------------------------------------------------------
98 ghciWelcomeMsg :: String
99 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
100 ": http://www.haskell.org/ghc/ :? for help"
102 cmdName :: Command -> String
105 GLOBAL_VAR(macros_ref, [], [Command])
107 builtin_commands :: [Command]
109 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
110 ("?", keepGoing help, noCompletion),
111 ("add", keepGoingPaths addModule, completeFilename),
112 ("abandon", keepGoing abandonCmd, noCompletion),
113 ("break", keepGoing breakCmd, completeIdentifier),
114 ("back", keepGoing backCmd, noCompletion),
115 ("browse", keepGoing' (browseCmd False), completeModule),
116 ("browse!", keepGoing' (browseCmd True), completeModule),
117 ("cd", keepGoing' changeDirectory, completeFilename),
118 ("check", keepGoing' checkModule, completeHomeModule),
119 ("continue", keepGoing continueCmd, noCompletion),
120 ("cmd", keepGoing cmdCmd, completeExpression),
121 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
122 ("def", keepGoing (defineMacro False), completeExpression),
123 ("def!", keepGoing (defineMacro True), completeExpression),
124 ("delete", keepGoing deleteCmd, noCompletion),
125 ("e", keepGoing editFile, completeFilename),
126 ("edit", keepGoing editFile, completeFilename),
127 ("etags", keepGoing createETagsFileCmd, completeFilename),
128 ("force", keepGoing forceCmd, completeExpression),
129 ("forward", keepGoing forwardCmd, noCompletion),
130 ("help", keepGoing help, noCompletion),
131 ("history", keepGoing historyCmd, noCompletion),
132 ("info", keepGoing' info, completeIdentifier),
133 ("kind", keepGoing' kindOfType, completeIdentifier),
134 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
135 ("list", keepGoing' listCmd, noCompletion),
136 ("module", keepGoing setContext, completeModule),
137 ("main", keepGoing runMain, completeFilename),
138 ("print", keepGoing printCmd, completeExpression),
139 ("quit", quit, noCompletion),
140 ("reload", keepGoing' reloadModule, noCompletion),
141 ("run", keepGoing runRun, completeFilename),
142 ("set", keepGoing setCmd, completeSetOptions),
143 ("show", keepGoing showCmd, completeShowOptions),
144 ("sprint", keepGoing sprintCmd, completeExpression),
145 ("step", keepGoing stepCmd, completeIdentifier),
146 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
147 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
148 ("type", keepGoing' typeOfExpr, completeExpression),
149 ("trace", keepGoing traceCmd, completeExpression),
150 ("undef", keepGoing undefineMacro, completeMacro),
151 ("unset", keepGoing unsetOptions, completeSetOptions)
155 -- We initialize readline (in the interactiveUI function) to use
156 -- word_break_chars as the default set of completion word break characters.
157 -- This can be overridden for a particular command (for example, filename
158 -- expansion shouldn't consider '/' to be a word break) by setting the third
159 -- entry in the Command tuple above.
161 -- NOTE: in order for us to override the default correctly, any custom entry
162 -- must be a SUBSET of word_break_chars.
163 word_break_chars :: String
164 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
165 specials = "(),;[]`{}"
167 in spaces ++ specials ++ symbols
169 flagWordBreakChars :: String
170 flagWordBreakChars = " \t\n"
173 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
174 keepGoing a str = keepGoing' (lift . a) str
176 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
177 keepGoing' a str = a str >> return False
179 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
181 = do case toArgs str of
182 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
186 shortHelpText :: String
187 shortHelpText = "use :? for help.\n"
191 " Commands available from the prompt:\n" ++
193 " <statement> evaluate/run <statement>\n" ++
194 " : repeat last command\n" ++
195 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
196 " :add [*]<module> ... add module(s) to the current target set\n" ++
197 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
198 " (!: more details; *: all top-level names)\n" ++
199 " :cd <dir> change directory to <dir>\n" ++
200 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
201 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
202 " :def <cmd> <expr> define a command :<cmd>\n" ++
203 " :edit <file> edit file\n" ++
204 " :edit edit last module\n" ++
205 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
206 " :help, :? display this list of commands\n" ++
207 " :info [<name> ...] display information about the given names\n" ++
208 " :kind <type> show the kind of <type>\n" ++
209 " :load [*]<module> ... load module(s) and their dependents\n" ++
210 " :main [<arguments> ...] run the main function with the given arguments\n" ++
211 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
212 " :quit exit GHCi\n" ++
213 " :reload reload the current module set\n" ++
214 " :run function [<arguments> ...] run the function with the given arguments\n" ++
215 " :type <expr> show the type of <expr>\n" ++
216 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
217 " :!<command> run the shell command <command>\n" ++
219 " -- Commands for debugging:\n" ++
221 " :abandon at a breakpoint, abandon current computation\n" ++
222 " :back go back in the history (after :trace)\n" ++
223 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
224 " :break <name> set a breakpoint on the specified function\n" ++
225 " :continue resume after a breakpoint\n" ++
226 " :delete <number> delete the specified breakpoint\n" ++
227 " :delete * delete all breakpoints\n" ++
228 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
229 " :forward go forward in the history (after :back)\n" ++
230 " :history [<n>] after :trace, show the execution history\n" ++
231 " :list show the source code around current breakpoint\n" ++
232 " :list identifier show the source code for <identifier>\n" ++
233 " :list [<module>] <line> show the source code around line number <line>\n" ++
234 " :print [<name> ...] prints a value without forcing its computation\n" ++
235 " :sprint [<name> ...] simplifed version of :print\n" ++
236 " :step single-step after stopping at a breakpoint\n"++
237 " :step <expr> single-step into <expr>\n"++
238 " :steplocal single-step within the current top-level binding\n"++
239 " :stepmodule single-step restricted to the current module\n"++
240 " :trace trace after stopping at a breakpoint\n"++
241 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
244 " -- Commands for changing settings:\n" ++
246 " :set <option> ... set options\n" ++
247 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
248 " :set prog <progname> set the value returned by System.getProgName\n" ++
249 " :set prompt <prompt> set the prompt used in GHCi\n" ++
250 " :set editor <cmd> set the command used for :edit\n" ++
251 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
252 " :unset <option> ... unset options\n" ++
254 " Options for ':set' and ':unset':\n" ++
256 " +r revert top-level expressions after each evaluation\n" ++
257 " +s print timing/memory stats after each evaluation\n" ++
258 " +t print type after evaluation\n" ++
259 " -<flags> most GHC command line flags can also be set here\n" ++
260 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
261 " for GHCi-specific flags, see User's Guide,\n"++
262 " Flag reference, Interactive-mode options\n" ++
264 " -- Commands for displaying information:\n" ++
266 " :show bindings show the current bindings made at the prompt\n" ++
267 " :show breaks show the active breakpoints\n" ++
268 " :show context show the breakpoint context\n" ++
269 " :show modules show the currently loaded modules\n" ++
270 " :show packages show the currently active package flags\n" ++
271 " :show languages show the currently active language flags\n" ++
272 " :show <setting> show value of <setting>, which is one of\n" ++
273 " [args, prog, prompt, editor, stop]\n" ++
276 findEditor :: IO String
281 win <- System.Win32.getWindowsDirectory
282 return (win </> "notepad.exe")
287 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
289 interactiveUI srcs maybe_exprs = do
290 -- although GHCi compiles with -prof, it is not usable: the byte-code
291 -- compiler and interpreter don't work with profiling. So we check for
292 -- this up front and emit a helpful error message (#2197)
293 m <- liftIO $ lookupSymbol "PushCostCentre"
295 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
297 -- HACK! If we happen to get into an infinite loop (eg the user
298 -- types 'let x=x in x' at the prompt), then the thread will block
299 -- on a blackhole, and become unreachable during GC. The GC will
300 -- detect that it is unreachable and send it the NonTermination
301 -- exception. However, since the thread is unreachable, everything
302 -- it refers to might be finalized, including the standard Handles.
303 -- This sounds like a bug, but we don't have a good solution right
305 liftIO $ newStablePtr stdin
306 liftIO $ newStablePtr stdout
307 liftIO $ newStablePtr stderr
309 -- Initialise buffering for the *interpreted* I/O system
312 liftIO $ when (isNothing maybe_exprs) $ do
313 -- Only for GHCi (not runghc and ghc -e):
315 -- Turn buffering off for the compiled program's stdout/stderr
317 -- Turn buffering off for GHCi's stdout
319 hSetBuffering stdout NoBuffering
320 -- We don't want the cmd line to buffer any input that might be
321 -- intended for the program, so unbuffer stdin.
322 hSetBuffering stdin NoBuffering
324 -- initial context is just the Prelude
325 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
326 GHC.setContext [] [prel_mod]
328 default_editor <- liftIO $ findEditor
330 startGHCi (runGHCi srcs maybe_exprs)
331 GHCiState{ progname = "<interactive>",
335 editor = default_editor,
336 -- session = session,
341 tickarrays = emptyModuleEnv,
342 last_command = Nothing,
345 ghc_e = isJust maybe_exprs
350 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
351 withGhcAppData right left = do
352 either_dir <- IO.try (getAppUserDataDirectory "ghc")
354 Right dir -> right dir
357 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
358 runGHCi paths maybe_exprs = do
360 read_dot_files = not opt_IgnoreDotGhci
362 current_dir = return (Just ".ghci")
364 app_user_dir = io $ withGhcAppData
365 (\dir -> return (Just (dir </> "ghci.conf")))
369 either_dir <- io $ IO.try (getEnv "HOME")
371 Right home -> return (Just (home </> ".ghci"))
374 sourceConfigFile :: FilePath -> GHCi ()
375 sourceConfigFile file = do
376 exists <- io $ doesFileExist file
378 dir_ok <- io $ checkPerms (getDirectory file)
379 file_ok <- io $ checkPerms file
380 when (dir_ok && file_ok) $ do
381 either_hdl <- io $ IO.try (openFile file ReadMode)
384 -- NOTE: this assumes that runInputT won't affect the terminal;
385 -- can we assume this will always be the case?
386 -- This would be a good place for runFileInputT.
387 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
389 runCommands $ fileLoop hdl
391 getDirectory f = case takeDirectory f of "" -> "."; d -> d
393 when (read_dot_files) $ do
394 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
395 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
396 mapM_ sourceConfigFile (nub cfgs)
397 -- nub, because we don't want to read .ghci twice if the
400 -- Perform a :load for files given on the GHCi command line
401 -- When in -e mode, if the load fails then we want to stop
402 -- immediately rather than going on to evaluate the expression.
403 when (not (null paths)) $ do
404 ok <- ghciHandle (\e -> do showException e; return Failed) $
405 -- TODO: this is a hack.
406 runInputTWithPrefs defaultPrefs defaultSettings $ do
407 let (filePaths, phases) = unzip paths
408 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
409 loadModule (zip filePaths' phases)
410 when (isJust maybe_exprs && failed ok) $
411 io (exitWith (ExitFailure 1))
413 -- if verbosity is greater than 0, or we are connected to a
414 -- terminal, display the prompt in the interactive loop.
415 is_tty <- io (hIsTerminalDevice stdin)
416 dflags <- getDynFlags
417 let show_prompt = verbosity dflags > 0 || is_tty
422 -- enter the interactive loop
423 runGHCiInput $ runCommands $ haskelineLoop show_prompt
425 -- just evaluate the expression we were given
426 enqueueCommands exprs
427 let handle e = do st <- getGHCiState
428 -- Jump through some hoops to get the
429 -- current progname in the exception text:
430 -- <progname>: <exception>
431 io $ withProgName (progname st)
432 -- this used to be topHandlerFastExit, see #2228
434 runInputTWithPrefs defaultPrefs defaultSettings $ do
436 runCommands' handle (return Nothing)
439 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
441 runGHCiInput :: InputT GHCi a -> GHCi a
443 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
445 let settings = setComplete ghciCompleteWord
446 $ defaultSettings {historyFile = histFile}
447 runInputT settings $ do
451 -- TODO really bad name
452 haskelineLoop :: Bool -> InputT GHCi (Maybe String)
453 haskelineLoop show_prompt = do
454 prompt <- if show_prompt then lift mkPrompt else return ""
455 l <- getInputLine prompt
459 -- NOTE: We only read .ghci files if they are owned by the current user,
460 -- and aren't world writable. Otherwise, we could be accidentally
461 -- running code planted by a malicious third party.
463 -- Furthermore, We only read ./.ghci if . is owned by the current user
464 -- and isn't writable by anyone else. I think this is sufficient: we
465 -- don't need to check .. and ../.. etc. because "." always refers to
466 -- the same directory while a process is running.
468 checkPerms :: String -> IO Bool
469 #ifdef mingw32_HOST_OS
474 handleIO (\_ -> return False) $ do
475 st <- getFileStatus name
477 if fileOwner st /= me then do
478 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
481 let mode = fileMode st
482 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
483 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
485 putStrLn $ "*** WARNING: " ++ name ++
486 " is writable by someone else, IGNORING!"
491 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
493 l <- liftIO $ IO.try (BS.hGetLine hdl)
495 Left e | isEOFError e -> return Nothing
496 | InvalidArgument <- etype -> return Nothing
497 | otherwise -> liftIO $ ioError e
498 where etype = ioeGetErrorType e
499 -- treat InvalidArgument in the same way as EOF:
500 -- this can happen if the user closed stdin, or
501 -- perhaps did getContents which closes stdin at
503 Right l -> fmap Just (Encoding.decode l)
505 mkPrompt :: GHCi String
507 (toplevs,exports) <- GHC.getContext
508 resumes <- GHC.getResumeContext
509 -- st <- getGHCiState
515 let ix = GHC.resumeHistoryIx r
517 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
519 let hist = GHC.resumeHistory r !! (ix-1)
520 span <- GHC.getHistorySpan hist
521 return (brackets (ppr (negate ix) <> char ':'
522 <+> ppr span) <> space)
524 dots | _:rs <- resumes, not (null rs) = text "... "
531 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
532 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
533 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
534 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
535 hsep (map (ppr . GHC.moduleName) exports)
537 deflt_prompt = dots <> context_bit <> modules_bit
539 f ('%':'s':xs) = deflt_prompt <> f xs
540 f ('%':'%':xs) = char '%' <> f xs
541 f (x:xs) = char x <> f xs
545 return (showSDoc (f (prompt st)))
548 queryQueue :: GHCi (Maybe String)
553 c:cs -> do setGHCiState st{ cmdqueue = cs }
556 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
557 runCommands = runCommands' handler
559 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
560 -> InputT GHCi (Maybe String) -> InputT GHCi ()
561 runCommands' eh getCmd = do
562 b <- handleGhcException (\e -> case e of
563 Interrupted -> return False
564 _other -> liftIO (print e) >> return True)
565 (runOneCommand eh getCmd)
566 if b then return () else runCommands' eh getCmd
568 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
570 runOneCommand eh getCmd = do
571 mb_cmd <- noSpace (lift queryQueue)
572 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
574 Nothing -> return True
575 Just c -> ghciHandle (lift . eh) $
576 handleSourceError printErrorAndKeepGoing
579 printErrorAndKeepGoing err = do
580 GHC.printExceptionAndWarnings err
583 noSpace q = q >>= maybe (return Nothing)
584 (\c->case removeSpaces c of
586 ":{" -> multiLineCmd q
587 c -> return (Just c) )
589 st <- lift getGHCiState
591 lift $ setGHCiState st{ prompt = "%s| " }
592 mb_cmd <- collectCommand q ""
593 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
595 -- we can't use removeSpaces for the sublines here, so
596 -- multiline commands are somewhat more brittle against
597 -- fileformat errors (such as \r in dos input on unix),
598 -- we get rid of any extra spaces for the ":}" test;
599 -- we also avoid silent failure if ":}" is not found;
600 -- and since there is no (?) valid occurrence of \r (as
601 -- opposed to its String representation, "\r") inside a
602 -- ghci command, we replace any such with ' ' (argh:-(
603 collectCommand q c = q >>=
604 maybe (liftIO (ioError collectError))
605 (\l->if removeSpaces l == ":}"
606 then return (Just $ removeSpaces c)
607 else collectCommand q (c++map normSpace l))
608 where normSpace '\r' = ' '
610 -- QUESTION: is userError the one to use here?
611 collectError = userError "unterminated multiline command :{ .. :}"
612 doCommand (':' : cmd) = specialCommand cmd
613 doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion
616 enqueueCommands :: [String] -> GHCi ()
617 enqueueCommands cmds = do
619 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
622 runStmt :: String -> SingleStep -> GHCi Bool
624 | null (filter (not.isSpace) stmt) = return False
625 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
627 = do result <- GhciMonad.runStmt stmt step
628 afterRunStmt (const True) result
630 --afterRunStmt :: GHC.RunResult -> GHCi Bool
631 -- False <=> the statement failed to compile
632 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
633 afterRunStmt _ (GHC.RunException e) = throw e
634 afterRunStmt step_here run_result = do
635 resumes <- GHC.getResumeContext
637 GHC.RunOk names -> do
638 show_types <- isOptionSet ShowType
639 when show_types $ printTypeOfNames names
640 GHC.RunBreak _ names mb_info
641 | isNothing mb_info ||
642 step_here (GHC.resumeSpan $ head resumes) -> do
643 mb_id_loc <- toBreakIdAndLocation mb_info
644 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
646 then printStoppedAtBreakInfo (head resumes) names
647 else enqueueCommands [breakCmd]
648 -- run the command set with ":set stop <cmd>"
650 enqueueCommands [stop st]
652 | otherwise -> resume step_here GHC.SingleStep >>=
653 afterRunStmt step_here >> return ()
657 io installSignalHandlers
658 b <- isOptionSet RevertCAFs
661 return (case run_result of GHC.RunOk _ -> True; _ -> False)
663 toBreakIdAndLocation ::
664 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
665 toBreakIdAndLocation Nothing = return Nothing
666 toBreakIdAndLocation (Just info) = do
667 let mod = GHC.breakInfo_module info
668 nm = GHC.breakInfo_number info
670 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
671 breakModule loc == mod,
672 breakTick loc == nm ]
674 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
675 printStoppedAtBreakInfo resume names = do
676 printForUser $ ptext (sLit "Stopped at") <+>
677 ppr (GHC.resumeSpan resume)
678 -- printTypeOfNames session names
679 let namesSorted = sortBy compareNames names
680 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
681 docs <- pprTypeAndContents [id | AnId id <- tythings]
682 printForUserPartWay docs
684 printTypeOfNames :: [Name] -> GHCi ()
685 printTypeOfNames names
686 = mapM_ (printTypeOfName ) $ sortBy compareNames names
688 compareNames :: Name -> Name -> Ordering
689 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
690 where compareWith n = (getOccString n, getSrcSpan n)
692 printTypeOfName :: Name -> GHCi ()
694 = do maybe_tything <- GHC.lookupName n
695 case maybe_tything of
697 Just thing -> printTyThing thing
700 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
702 specialCommand :: String -> InputT GHCi Bool
703 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
704 specialCommand str = do
705 let (cmd,rest) = break isSpace str
706 maybe_cmd <- lift $ lookupCommand cmd
708 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
710 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
714 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
718 lookupCommand :: String -> GHCi (MaybeCommand)
719 lookupCommand "" = do
721 case last_command st of
722 Just c -> return $ GotCommand c
723 Nothing -> return NoLastCommand
724 lookupCommand str = do
725 mc <- io $ lookupCommand' str
727 setGHCiState st{ last_command = mc }
729 Just c -> GotCommand c
730 Nothing -> BadCommand
732 lookupCommand' :: String -> IO (Maybe Command)
733 lookupCommand' str = do
734 macros <- readIORef macros_ref
735 let cmds = builtin_commands ++ macros
736 -- look for exact match first, then the first prefix match
737 return $ case [ c | c <- cmds, str == cmdName c ] of
739 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
743 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
744 getCurrentBreakSpan = do
745 resumes <- GHC.getResumeContext
749 let ix = GHC.resumeHistoryIx r
751 then return (Just (GHC.resumeSpan r))
753 let hist = GHC.resumeHistory r !! (ix-1)
754 span <- GHC.getHistorySpan hist
757 getCurrentBreakModule :: GHCi (Maybe Module)
758 getCurrentBreakModule = do
759 resumes <- GHC.getResumeContext
763 let ix = GHC.resumeHistoryIx r
765 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
767 let hist = GHC.resumeHistory r !! (ix-1)
768 return $ Just $ GHC.getHistoryModule hist
770 -----------------------------------------------------------------------------
773 noArgs :: GHCi () -> String -> GHCi ()
775 noArgs _ _ = io $ putStrLn "This command takes no arguments"
777 help :: String -> GHCi ()
778 help _ = io (putStr helpText)
780 info :: String -> InputT GHCi ()
781 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
782 info s = handleSourceError GHC.printExceptionAndWarnings $ do
783 { let names = words s
784 ; dflags <- getDynFlags
785 ; let pefas = dopt Opt_PrintExplicitForalls dflags
786 ; mapM_ (infoThing pefas) names }
788 infoThing pefas str = do
789 names <- GHC.parseName str
790 mb_stuffs <- mapM GHC.getInfo names
791 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
792 unqual <- GHC.getPrintUnqual
793 outputStrLn $ showSDocForUser unqual $
794 vcat (intersperse (text "") $
795 map (pprInfo pefas) filtered)
797 -- Filter out names whose parent is also there Good
798 -- example is '[]', which is both a type and data
799 -- constructor in the same type
800 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
801 filterOutChildren get_thing xs
802 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
804 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
806 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
807 pprInfo pefas (thing, fixity, insts)
808 = pprTyThingInContextLoc pefas thing
809 $$ show_fixity fixity
810 $$ vcat (map GHC.pprInstance insts)
813 | fix == GHC.defaultFixity = empty
814 | otherwise = ppr fix <+> ppr (GHC.getName thing)
816 runMain :: String -> GHCi ()
817 runMain s = case toArgs s of
818 Left err -> io (hPutStrLn stderr err)
820 do dflags <- getDynFlags
821 case mainFunIs dflags of
822 Nothing -> doWithArgs args "main"
823 Just f -> doWithArgs args f
825 runRun :: String -> GHCi ()
826 runRun s = case toCmdArgs s of
827 Left err -> io (hPutStrLn stderr err)
828 Right (cmd, args) -> doWithArgs args cmd
830 doWithArgs :: [String] -> String -> GHCi ()
831 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
832 show args ++ " (" ++ cmd ++ ")"]
834 addModule :: [FilePath] -> InputT GHCi ()
836 lift revertCAFs -- always revert CAFs on load/add.
837 files <- mapM expandPath files
838 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
839 -- remove old targets with the same id; e.g. for :add *M
840 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
841 mapM_ GHC.addTarget targets
842 prev_context <- GHC.getContext
843 ok <- trySuccess $ GHC.load LoadAllTargets
844 afterLoad ok False prev_context
846 changeDirectory :: String -> InputT GHCi ()
847 changeDirectory "" = do
848 -- :cd on its own changes to the user's home directory
849 either_dir <- liftIO $ IO.try getHomeDirectory
852 Right dir -> changeDirectory dir
853 changeDirectory dir = do
854 graph <- GHC.getModuleGraph
855 when (not (null graph)) $
856 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
857 prev_context <- GHC.getContext
859 GHC.load LoadAllTargets
860 lift $ setContextAfterLoad prev_context False []
861 GHC.workingDirectoryChanged
862 dir <- expandPath dir
863 liftIO $ setCurrentDirectory dir
865 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
867 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
871 editFile :: String -> GHCi ()
873 do file <- if null str then chooseEditFile else return str
877 $ ghcError (CmdLineError "editor not set, use :set editor")
878 io $ system (cmd ++ ' ':file)
881 -- The user didn't specify a file so we pick one for them.
882 -- Our strategy is to pick the first module that failed to load,
883 -- or otherwise the first target.
885 -- XXX: Can we figure out what happened if the depndecy analysis fails
886 -- (e.g., because the porgrammeer mistyped the name of a module)?
887 -- XXX: Can we figure out the location of an error to pass to the editor?
888 -- XXX: if we could figure out the list of errors that occured during the
889 -- last load/reaload, then we could start the editor focused on the first
891 chooseEditFile :: GHCi String
893 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
895 graph <- GHC.getModuleGraph
896 failed_graph <- filterM hasFailed graph
897 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
899 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
902 case pick (order failed_graph) of
903 Just file -> return file
905 do targets <- GHC.getTargets
906 case msum (map fromTarget targets) of
907 Just file -> return file
908 Nothing -> ghcError (CmdLineError "No files to edit.")
910 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
911 fromTarget _ = Nothing -- when would we get a module target?
913 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
914 defineMacro overwrite s = do
915 let (macro_name, definition) = break isSpace s
916 macros <- io (readIORef macros_ref)
917 let defined = map cmdName macros
920 then io $ putStrLn "no macros defined"
921 else io $ putStr ("the following macros are defined:\n" ++
924 if (not overwrite && macro_name `elem` defined)
925 then ghcError (CmdLineError
926 ("macro '" ++ macro_name ++ "' is already defined"))
929 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
931 -- give the expression a type signature, so we can be sure we're getting
932 -- something of the right type.
933 let new_expr = '(' : definition ++ ") :: String -> IO String"
935 -- compile the expression
936 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
937 hv <- GHC.compileExpr new_expr
938 io (writeIORef macros_ref --
939 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
941 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
943 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
944 -- make sure we force any exceptions in the result, while we are still
945 -- inside the exception handler for commands:
946 seqList str (return ())
947 enqueueCommands (lines str)
950 undefineMacro :: String -> GHCi ()
951 undefineMacro str = mapM_ undef (words str)
952 where undef macro_name = do
953 cmds <- io (readIORef macros_ref)
954 if (macro_name `notElem` map cmdName cmds)
955 then ghcError (CmdLineError
956 ("macro '" ++ macro_name ++ "' is not defined"))
958 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
960 cmdCmd :: String -> GHCi ()
962 let expr = '(' : str ++ ") :: IO String"
963 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
964 hv <- GHC.compileExpr expr
965 cmds <- io $ (unsafeCoerce# hv :: IO String)
966 enqueueCommands (lines cmds)
969 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
970 loadModule fs = timeIt (loadModule' fs)
972 loadModule_ :: [FilePath] -> InputT GHCi ()
973 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
975 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
976 loadModule' files = do
977 prev_context <- GHC.getContext
981 lift discardActiveBreakPoints
983 GHC.load LoadAllTargets
985 let (filenames, phases) = unzip files
986 exp_filenames <- mapM expandPath filenames
987 let files' = zip exp_filenames phases
988 targets <- mapM (uncurry GHC.guessTarget) files'
990 -- NOTE: we used to do the dependency anal first, so that if it
991 -- fails we didn't throw away the current set of modules. This would
992 -- require some re-working of the GHC interface, so we'll leave it
993 -- as a ToDo for now.
995 GHC.setTargets targets
996 doLoad False prev_context LoadAllTargets
998 checkModule :: String -> InputT GHCi ()
1000 let modl = GHC.mkModuleName m
1001 prev_context <- GHC.getContext
1002 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1003 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1004 outputStrLn (showSDoc (
1005 case GHC.moduleInfo r of
1006 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1008 (local,global) = ASSERT( all isExternalName scope )
1009 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1011 (text "global names: " <+> ppr global) $$
1012 (text "local names: " <+> ppr local)
1015 afterLoad (successIf ok) False prev_context
1017 reloadModule :: String -> InputT GHCi ()
1019 prev_context <- GHC.getContext
1020 doLoad True prev_context $
1021 if null m then LoadAllTargets
1022 else LoadUpTo (GHC.mkModuleName m)
1025 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1026 doLoad retain_context prev_context howmuch = do
1027 -- turn off breakpoints before we load: we can't turn them off later, because
1028 -- the ModBreaks will have gone away.
1029 lift discardActiveBreakPoints
1030 ok <- trySuccess $ GHC.load howmuch
1031 afterLoad ok retain_context prev_context
1034 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1035 afterLoad ok retain_context prev_context = do
1036 lift revertCAFs -- always revert CAFs on load.
1037 lift discardTickArrays
1038 loaded_mod_summaries <- getLoadedModules
1039 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1040 loaded_mod_names = map GHC.moduleName loaded_mods
1041 modulesLoadedMsg ok loaded_mod_names
1043 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1046 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1047 setContextAfterLoad prev keep_ctxt [] = do
1048 prel_mod <- getPrelude
1049 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1050 setContextAfterLoad prev keep_ctxt ms = do
1051 -- load a target if one is available, otherwise load the topmost module.
1052 targets <- GHC.getTargets
1053 case [ m | Just m <- map (findTarget ms) targets ] of
1055 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1056 load_this (last graph')
1061 = case filter (`matches` t) ms of
1065 summary `matches` Target (TargetModule m) _ _
1066 = GHC.ms_mod_name summary == m
1067 summary `matches` Target (TargetFile f _) _ _
1068 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1072 load_this summary | m <- GHC.ms_mod summary = do
1073 b <- GHC.moduleIsInterpreted m
1074 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1076 prel_mod <- getPrelude
1077 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1079 -- | Keep any package modules (except Prelude) when changing the context.
1080 setContextKeepingPackageModules
1081 :: ([Module],[Module]) -- previous context
1082 -> Bool -- re-execute :module commands
1083 -> ([Module],[Module]) -- new context
1085 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1086 let (_,bs0) = prev_context
1087 prel_mod <- getPrelude
1088 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1089 let bs1 = if null as then nub (prel_mod : bs) else bs
1090 GHC.setContext as (nub (bs1 ++ pkg_modules))
1094 mapM_ (playCtxtCmd False) (remembered_ctx st)
1097 setGHCiState st{ remembered_ctx = [] }
1099 isHomeModule :: Module -> Bool
1100 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1102 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1103 modulesLoadedMsg ok mods = do
1104 dflags <- getDynFlags
1105 when (verbosity dflags > 0) $ do
1107 | null mods = text "none."
1108 | otherwise = hsep (
1109 punctuate comma (map ppr mods)) <> text "."
1112 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1114 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1117 typeOfExpr :: String -> InputT GHCi ()
1119 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1120 ty <- GHC.exprType str
1121 dflags <- getDynFlags
1122 let pefas = dopt Opt_PrintExplicitForalls dflags
1123 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1125 kindOfType :: String -> InputT GHCi ()
1127 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1128 ty <- GHC.typeKind str
1129 printForUser' $ text str <+> dcolon <+> ppr ty
1131 quit :: String -> InputT GHCi Bool
1132 quit _ = return True
1134 shellEscape :: String -> GHCi Bool
1135 shellEscape str = io (system str >> return False)
1137 -----------------------------------------------------------------------------
1138 -- Browsing a module's contents
1140 browseCmd :: Bool -> String -> InputT GHCi ()
1143 ['*':s] | looksLikeModuleName s -> do
1144 m <- lift $ wantInterpretedModule s
1145 browseModule bang m False
1146 [s] | looksLikeModuleName s -> do
1147 m <- lift $ lookupModule s
1148 browseModule bang m True
1150 (as,bs) <- GHC.getContext
1151 -- Guess which module the user wants to browse. Pick
1152 -- modules that are interpreted first. The most
1153 -- recently-added module occurs last, it seems.
1155 (as@(_:_), _) -> browseModule bang (last as) True
1156 ([], bs@(_:_)) -> browseModule bang (last bs) True
1157 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1158 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1160 -- without bang, show items in context of their parents and omit children
1161 -- with bang, show class methods and data constructors separately, and
1162 -- indicate import modules, to aid qualifying unqualified names
1163 -- with sorted, sort items alphabetically
1164 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1165 browseModule bang modl exports_only = do
1166 -- :browse! reports qualifiers wrt current context
1167 current_unqual <- GHC.getPrintUnqual
1168 -- Temporarily set the context to the module we're interested in,
1169 -- just so we can get an appropriate PrintUnqualified
1170 (as,bs) <- GHC.getContext
1171 prel_mod <- lift getPrelude
1172 if exports_only then GHC.setContext [] [prel_mod,modl]
1173 else GHC.setContext [modl] []
1174 target_unqual <- GHC.getPrintUnqual
1175 GHC.setContext as bs
1177 let unqual = if bang then current_unqual else target_unqual
1179 mb_mod_info <- GHC.getModuleInfo modl
1181 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1182 GHC.moduleNameString (GHC.moduleName modl)))
1184 dflags <- getDynFlags
1186 | exports_only = GHC.modInfoExports mod_info
1187 | otherwise = GHC.modInfoTopLevelScope mod_info
1190 -- sort alphabetically name, but putting
1191 -- locally-defined identifiers first.
1192 -- We would like to improve this; see #1799.
1193 sorted_names = loc_sort local ++ occ_sort external
1195 (local,external) = ASSERT( all isExternalName names )
1196 partition ((==modl) . nameModule) names
1197 occ_sort = sortBy (compare `on` nameOccName)
1198 -- try to sort by src location. If the first name in
1199 -- our list has a good source location, then they all should.
1201 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1202 = sortBy (compare `on` nameSrcSpan) names
1206 mb_things <- mapM GHC.lookupName sorted_names
1207 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1209 rdr_env <- GHC.getGRE
1211 let pefas = dopt Opt_PrintExplicitForalls dflags
1212 things | bang = catMaybes mb_things
1213 | otherwise = filtered_things
1214 pretty | bang = pprTyThing
1215 | otherwise = pprTyThingInContext
1217 labels [] = text "-- not currently imported"
1218 labels l = text $ intercalate "\n" $ map qualifier l
1219 qualifier = maybe "-- defined locally"
1220 (("-- imported via "++) . intercalate ", "
1221 . map GHC.moduleNameString)
1222 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1223 modNames = map (importInfo . GHC.getName) things
1225 -- annotate groups of imports with their import modules
1226 -- the default ordering is somewhat arbitrary, so we group
1227 -- by header and sort groups; the names themselves should
1228 -- really come in order of source appearance.. (trac #1799)
1229 annotate mts = concatMap (\(m,ts)->labels m:ts)
1230 $ sortBy cmpQualifiers $ group mts
1231 where cmpQualifiers =
1232 compare `on` (map (fmap (map moduleNameFS)) . fst)
1234 group mts@((m,_):_) = (m,map snd g) : group ng
1235 where (g,ng) = partition ((==m).fst) mts
1237 let prettyThings = map (pretty pefas) things
1238 prettyThings' | bang = annotate $ zip modNames prettyThings
1239 | otherwise = prettyThings
1240 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1241 -- ToDo: modInfoInstances currently throws an exception for
1242 -- package modules. When it works, we can do this:
1243 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1245 -----------------------------------------------------------------------------
1246 -- Setting the module context
1248 setContext :: String -> GHCi ()
1250 | all sensible strs = do
1251 playCtxtCmd True (cmd, as, bs)
1253 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1254 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1256 (cmd, strs, as, bs) =
1258 '+':stuff -> rest AddModules stuff
1259 '-':stuff -> rest RemModules stuff
1260 stuff -> rest SetContext stuff
1262 rest cmd stuff = (cmd, strs, as, bs)
1263 where strs = words stuff
1264 (as,bs) = partitionWith starred strs
1266 sensible ('*':m) = looksLikeModuleName m
1267 sensible m = looksLikeModuleName m
1269 starred ('*':m) = Left m
1272 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1273 playCtxtCmd fail (cmd, as, bs)
1275 (as',bs') <- do_checks fail
1276 (prev_as,prev_bs) <- GHC.getContext
1280 prel_mod <- getPrelude
1281 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1285 let as_to_add = as' \\ (prev_as ++ prev_bs)
1286 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1287 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1289 let new_as = prev_as \\ (as' ++ bs')
1290 new_bs = prev_bs \\ (as' ++ bs')
1291 return (new_as, new_bs)
1292 GHC.setContext new_as new_bs
1295 as' <- mapM wantInterpretedModule as
1296 bs' <- mapM lookupModule bs
1298 do_checks False = do
1299 as' <- mapM (trymaybe . wantInterpretedModule) as
1300 bs' <- mapM (trymaybe . lookupModule) bs
1301 return (catMaybes as', catMaybes bs')
1306 Left _ -> return Nothing
1307 Right a -> return (Just a)
1309 ----------------------------------------------------------------------------
1312 -- set options in the interpreter. Syntax is exactly the same as the
1313 -- ghc command line, except that certain options aren't available (-C,
1316 -- This is pretty fragile: most options won't work as expected. ToDo:
1317 -- figure out which ones & disallow them.
1319 setCmd :: String -> GHCi ()
1321 = do st <- getGHCiState
1322 let opts = options st
1323 io $ putStrLn (showSDoc (
1324 text "options currently set: " <>
1327 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1329 dflags <- getDynFlags
1330 io $ putStrLn (showSDoc (
1331 vcat (text "GHCi-specific dynamic flag settings:"
1332 :map (flagSetting dflags) ghciFlags)
1334 io $ putStrLn (showSDoc (
1335 vcat (text "other dynamic, non-language, flag settings:"
1336 :map (flagSetting dflags) nonLanguageDynFlags)
1338 where flagSetting dflags (str, f, _)
1339 | dopt f dflags = text " " <> text "-f" <> text str
1340 | otherwise = text " " <> text "-fno-" <> text str
1341 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1343 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1345 flags = [Opt_PrintExplicitForalls
1346 ,Opt_PrintBindResult
1347 ,Opt_BreakOnException
1349 ,Opt_PrintEvldWithShow
1352 = case getCmd str of
1353 Right ("args", rest) ->
1355 Left err -> io (hPutStrLn stderr err)
1356 Right args -> setArgs args
1357 Right ("prog", rest) ->
1359 Right [prog] -> setProg prog
1360 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1361 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1362 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1363 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1364 _ -> case toArgs str of
1365 Left err -> io (hPutStrLn stderr err)
1366 Right wds -> setOptions wds
1368 setArgs, setOptions :: [String] -> GHCi ()
1369 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1373 setGHCiState st{ args = args }
1377 setGHCiState st{ progname = prog }
1381 setGHCiState st{ editor = cmd }
1383 setStop str@(c:_) | isDigit c
1384 = do let (nm_str,rest) = break (not.isDigit) str
1387 let old_breaks = breaks st
1388 if all ((/= nm) . fst) old_breaks
1389 then printForUser (text "Breakpoint" <+> ppr nm <+>
1390 text "does not exist")
1392 let new_breaks = map fn old_breaks
1393 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1394 | otherwise = (i,loc)
1395 setGHCiState st{ breaks = new_breaks }
1398 setGHCiState st{ stop = cmd }
1400 setPrompt value = do
1403 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1405 '\"' : _ -> case reads value of
1406 [(value', xs)] | all isSpace xs ->
1407 setGHCiState (st { prompt = value' })
1409 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1410 _ -> setGHCiState (st { prompt = value })
1413 do -- first, deal with the GHCi opts (+s, +t, etc.)
1414 let (plus_opts, minus_opts) = partitionWith isPlus wds
1415 mapM_ setOpt plus_opts
1416 -- then, dynamic flags
1417 newDynFlags minus_opts
1419 newDynFlags :: [String] -> GHCi ()
1420 newDynFlags minus_opts = do
1421 dflags <- getDynFlags
1422 let pkg_flags = packageFlags dflags
1423 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1424 handleFlagWarnings dflags' warns
1426 if (not (null leftovers))
1427 then ghcError $ errorsToGhcException leftovers
1430 new_pkgs <- setDynFlags dflags'
1432 -- if the package flags changed, we should reset the context
1433 -- and link the new packages.
1434 dflags <- getDynFlags
1435 when (packageFlags dflags /= pkg_flags) $ do
1436 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1438 GHC.load LoadAllTargets
1439 io (linkPackages dflags new_pkgs)
1440 -- package flags changed, we can't re-use any of the old context
1441 setContextAfterLoad ([],[]) False []
1445 unsetOptions :: String -> GHCi ()
1447 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1448 let opts = words str
1449 (minus_opts, rest1) = partition isMinus opts
1450 (plus_opts, rest2) = partitionWith isPlus rest1
1452 if (not (null rest2))
1453 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1456 mapM_ unsetOpt plus_opts
1458 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1459 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1461 no_flags <- mapM no_flag minus_opts
1462 newDynFlags no_flags
1464 isMinus :: String -> Bool
1465 isMinus ('-':_) = True
1468 isPlus :: String -> Either String String
1469 isPlus ('+':opt) = Left opt
1470 isPlus other = Right other
1472 setOpt, unsetOpt :: String -> GHCi ()
1475 = case strToGHCiOpt str of
1476 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1477 Just o -> setOption o
1480 = case strToGHCiOpt str of
1481 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1482 Just o -> unsetOption o
1484 strToGHCiOpt :: String -> (Maybe GHCiOption)
1485 strToGHCiOpt "s" = Just ShowTiming
1486 strToGHCiOpt "t" = Just ShowType
1487 strToGHCiOpt "r" = Just RevertCAFs
1488 strToGHCiOpt _ = Nothing
1490 optToStr :: GHCiOption -> String
1491 optToStr ShowTiming = "s"
1492 optToStr ShowType = "t"
1493 optToStr RevertCAFs = "r"
1495 -- ---------------------------------------------------------------------------
1498 showCmd :: String -> GHCi ()
1502 ["args"] -> io $ putStrLn (show (args st))
1503 ["prog"] -> io $ putStrLn (show (progname st))
1504 ["prompt"] -> io $ putStrLn (show (prompt st))
1505 ["editor"] -> io $ putStrLn (show (editor st))
1506 ["stop"] -> io $ putStrLn (show (stop st))
1507 ["modules" ] -> showModules
1508 ["bindings"] -> showBindings
1509 ["linker"] -> io showLinkerState
1510 ["breaks"] -> showBkptTable
1511 ["context"] -> showContext
1512 ["packages"] -> showPackages
1513 ["languages"] -> showLanguages
1514 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1515 " | breaks | context | packages | languages ]"))
1517 showModules :: GHCi ()
1519 loaded_mods <- getLoadedModules
1520 -- we want *loaded* modules only, see #1734
1521 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1522 mapM_ show_one loaded_mods
1524 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1525 getLoadedModules = do
1526 graph <- GHC.getModuleGraph
1527 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1529 showBindings :: GHCi ()
1531 bindings <- GHC.getBindings
1532 docs <- pprTypeAndContents
1533 [ id | AnId id <- sortBy compareTyThings bindings]
1534 printForUserPartWay docs
1536 compareTyThings :: TyThing -> TyThing -> Ordering
1537 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1539 printTyThing :: TyThing -> GHCi ()
1540 printTyThing tyth = do dflags <- getDynFlags
1541 let pefas = dopt Opt_PrintExplicitForalls dflags
1542 printForUser (pprTyThing pefas tyth)
1544 showBkptTable :: GHCi ()
1547 printForUser $ prettyLocations (breaks st)
1549 showContext :: GHCi ()
1551 resumes <- GHC.getResumeContext
1552 printForUser $ vcat (map pp_resume (reverse resumes))
1555 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1556 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1558 showPackages :: GHCi ()
1560 pkg_flags <- fmap packageFlags getDynFlags
1561 io $ putStrLn $ showSDoc $ vcat $
1562 text ("active package flags:"++if null pkg_flags then " none" else "")
1563 : map showFlag pkg_flags
1564 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1565 io $ putStrLn $ showSDoc $ vcat $
1566 text "packages currently loaded:"
1567 : map (nest 2 . text . packageIdString)
1568 (sortBy (compare `on` packageIdFS) pkg_ids)
1569 where showFlag (ExposePackage p) = text $ " -package " ++ p
1570 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1571 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1573 showLanguages :: GHCi ()
1575 dflags <- getDynFlags
1576 io $ putStrLn $ showSDoc $ vcat $
1577 text "active language flags:" :
1578 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1580 -- -----------------------------------------------------------------------------
1583 completeCmd, completeMacro, completeIdentifier, completeModule,
1584 completeHomeModule, completeSetOptions, completeShowOptions,
1585 completeHomeModuleOrFile, completeExpression
1586 :: CompletionFunc GHCi
1588 ghciCompleteWord :: CompletionFunc GHCi
1589 ghciCompleteWord line@(left,_) = case firstWord of
1590 ':':cmd | null rest -> completeCmd line
1592 completion <- lookupCompletion cmd
1594 "import" -> completeModule line
1595 _ -> completeExpression line
1597 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1598 lookupCompletion ('!':_) = return completeFilename
1599 lookupCompletion c = do
1600 maybe_cmd <- liftIO $ lookupCommand' c
1602 Just (_,_,f) -> return f
1603 Nothing -> return completeFilename
1605 completeCmd = wrapCompleter " " $ \w -> do
1606 cmds <- liftIO $ readIORef macros_ref
1607 return (filter (w `isPrefixOf`) (map (':':)
1608 (map cmdName (builtin_commands ++ cmds))))
1610 completeMacro = wrapIdentCompleter $ \w -> do
1611 cmds <- liftIO $ readIORef macros_ref
1612 return (filter (w `isPrefixOf`) (map cmdName cmds))
1614 completeIdentifier = wrapIdentCompleter $ \w -> do
1615 rdrs <- GHC.getRdrNamesInScope
1616 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1618 completeModule = wrapIdentCompleter $ \w -> do
1619 dflags <- GHC.getSessionDynFlags
1620 let pkg_mods = allExposedModules dflags
1621 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1622 return $ filter (w `isPrefixOf`)
1623 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1625 completeHomeModule = wrapIdentCompleter listHomeModules
1627 listHomeModules :: String -> GHCi [String]
1628 listHomeModules w = do
1629 g <- GHC.getModuleGraph
1630 let home_mods = map GHC.ms_mod_name g
1631 return $ sort $ filter (w `isPrefixOf`)
1632 $ map (showSDoc.ppr) home_mods
1634 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1635 return (filter (w `isPrefixOf`) options)
1636 where options = "args":"prog":"prompt":"editor":"stop":flagList
1637 flagList = map head $ group $ sort allFlags
1639 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1640 return (filter (w `isPrefixOf`) options)
1641 where options = ["args", "prog", "prompt", "editor", "stop",
1642 "modules", "bindings", "linker", "breaks",
1643 "context", "packages", "languages"]
1645 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1646 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1649 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1650 unionComplete f1 f2 line = do
1655 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1656 wrapCompleter breakChars fun = completeWord Nothing breakChars
1657 $ fmap (map simpleCompletion) . fmap sort . fun
1659 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1660 wrapIdentCompleter = wrapCompleter word_break_chars
1662 allExposedModules :: DynFlags -> [ModuleName]
1663 allExposedModules dflags
1664 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1666 pkg_db = pkgIdMap (pkgState dflags)
1668 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1671 -- ---------------------------------------------------------------------------
1672 -- User code exception handling
1674 -- This is the exception handler for exceptions generated by the
1675 -- user's code and exceptions coming from children sessions;
1676 -- it normally just prints out the exception. The
1677 -- handler must be recursive, in case showing the exception causes
1678 -- more exceptions to be raised.
1680 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1681 -- raising another exception. We therefore don't put the recursive
1682 -- handler arond the flushing operation, so if stderr is closed
1683 -- GHCi will just die gracefully rather than going into an infinite loop.
1684 handler :: SomeException -> GHCi Bool
1686 handler exception = do
1688 io installSignalHandlers
1689 ghciHandle handler (showException exception >> return False)
1691 showException :: SomeException -> GHCi ()
1693 io $ case fromException se of
1694 Just Interrupted -> putStrLn "Interrupted."
1695 -- omit the location for CmdLineError:
1696 Just (CmdLineError s) -> putStrLn s
1698 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1699 Just other_ghc_ex -> print other_ghc_ex
1700 Nothing -> putStrLn ("*** Exception: " ++ show se)
1702 -----------------------------------------------------------------------------
1703 -- recursive exception handlers
1705 -- Don't forget to unblock async exceptions in the handler, or if we're
1706 -- in an exception loop (eg. let a = error a in a) the ^C exception
1707 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1709 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1710 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1712 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1713 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1715 -- ----------------------------------------------------------------------------
1718 -- TODO: won't work if home dir is encoded.
1719 -- (changeDirectory may not work either in that case.)
1720 expandPath :: MonadIO m => String -> InputT m String
1721 expandPath path = do
1722 exp_path <- liftIO $ expandPathIO path
1723 enc <- fmap BS.unpack $ Encoding.encode exp_path
1726 expandPathIO :: String -> IO String
1728 case dropWhile isSpace path of
1730 tilde <- getHomeDirectory -- will fail if HOME not defined
1731 return (tilde ++ '/':d)
1735 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1736 wantInterpretedModule str = do
1737 modl <- lookupModule str
1738 dflags <- getDynFlags
1739 when (GHC.modulePackageId modl /= thisPackage dflags) $
1740 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1741 is_interpreted <- GHC.moduleIsInterpreted modl
1742 when (not is_interpreted) $
1743 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1746 wantNameFromInterpretedModule :: GHC.GhcMonad m
1747 => (Name -> SDoc -> m ())
1751 wantNameFromInterpretedModule noCanDo str and_then =
1752 handleSourceError (GHC.printExceptionAndWarnings) $ do
1753 names <- GHC.parseName str
1757 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1758 if not (GHC.isExternalName n)
1759 then noCanDo n $ ppr n <>
1760 text " is not defined in an interpreted module"
1762 is_interpreted <- GHC.moduleIsInterpreted modl
1763 if not is_interpreted
1764 then noCanDo n $ text "module " <> ppr modl <>
1765 text " is not interpreted"
1768 -- -----------------------------------------------------------------------------
1769 -- commands for debugger
1771 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1772 sprintCmd = pprintCommand False False
1773 printCmd = pprintCommand True False
1774 forceCmd = pprintCommand False True
1776 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1777 pprintCommand bind force str = do
1778 pprintClosureCommand bind force str
1780 stepCmd :: String -> GHCi ()
1781 stepCmd [] = doContinue (const True) GHC.SingleStep
1782 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1784 stepLocalCmd :: String -> GHCi ()
1785 stepLocalCmd [] = do
1786 mb_span <- getCurrentBreakSpan
1788 Nothing -> stepCmd []
1790 Just mod <- getCurrentBreakModule
1791 current_toplevel_decl <- enclosingTickSpan mod loc
1792 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1794 stepLocalCmd expression = stepCmd expression
1796 stepModuleCmd :: String -> GHCi ()
1797 stepModuleCmd [] = do
1798 mb_span <- getCurrentBreakSpan
1800 Nothing -> stepCmd []
1802 Just span <- getCurrentBreakSpan
1803 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1804 doContinue f GHC.SingleStep
1806 stepModuleCmd expression = stepCmd expression
1808 -- | Returns the span of the largest tick containing the srcspan given
1809 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1810 enclosingTickSpan mod src = do
1811 ticks <- getTickArray mod
1812 let line = srcSpanStartLine src
1813 ASSERT (inRange (bounds ticks) line) do
1814 let enclosing_spans = [ span | (_,span) <- ticks ! line
1815 , srcSpanEnd span >= srcSpanEnd src]
1816 return . head . sortBy leftmost_largest $ enclosing_spans
1818 traceCmd :: String -> GHCi ()
1819 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1820 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1822 continueCmd :: String -> GHCi ()
1823 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1825 -- doContinue :: SingleStep -> GHCi ()
1826 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1827 doContinue pred step = do
1828 runResult <- resume pred step
1829 afterRunStmt pred runResult
1832 abandonCmd :: String -> GHCi ()
1833 abandonCmd = noArgs $ do
1834 b <- GHC.abandon -- the prompt will change to indicate the new context
1835 when (not b) $ io $ putStrLn "There is no computation running."
1838 deleteCmd :: String -> GHCi ()
1839 deleteCmd argLine = do
1840 deleteSwitch $ words argLine
1842 deleteSwitch :: [String] -> GHCi ()
1844 io $ putStrLn "The delete command requires at least one argument."
1845 -- delete all break points
1846 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1847 deleteSwitch idents = do
1848 mapM_ deleteOneBreak idents
1850 deleteOneBreak :: String -> GHCi ()
1852 | all isDigit str = deleteBreak (read str)
1853 | otherwise = return ()
1855 historyCmd :: String -> GHCi ()
1857 | null arg = history 20
1858 | all isDigit arg = history (read arg)
1859 | otherwise = io $ putStrLn "Syntax: :history [num]"
1862 resumes <- GHC.getResumeContext
1864 [] -> io $ putStrLn "Not stopped at a breakpoint"
1866 let hist = GHC.resumeHistory r
1867 (took,rest) = splitAt num hist
1869 [] -> io $ putStrLn $
1870 "Empty history. Perhaps you forgot to use :trace?"
1872 spans <- mapM GHC.getHistorySpan took
1873 let nums = map (printf "-%-3d:") [(1::Int)..]
1874 names = map GHC.historyEnclosingDecl took
1875 printForUser (vcat(zipWith3
1876 (\x y z -> x <+> y <+> z)
1878 (map (bold . ppr) names)
1879 (map (parens . ppr) spans)))
1880 io $ putStrLn $ if null rest then "<end of history>" else "..."
1882 bold :: SDoc -> SDoc
1883 bold c | do_bold = text start_bold <> c <> text end_bold
1886 backCmd :: String -> GHCi ()
1887 backCmd = noArgs $ do
1888 (names, _, span) <- GHC.back
1889 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1890 printTypeOfNames names
1891 -- run the command set with ":set stop <cmd>"
1893 enqueueCommands [stop st]
1895 forwardCmd :: String -> GHCi ()
1896 forwardCmd = noArgs $ do
1897 (names, ix, span) <- GHC.forward
1898 printForUser $ (if (ix == 0)
1899 then ptext (sLit "Stopped at")
1900 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1901 printTypeOfNames names
1902 -- run the command set with ":set stop <cmd>"
1904 enqueueCommands [stop st]
1906 -- handle the "break" command
1907 breakCmd :: String -> GHCi ()
1908 breakCmd argLine = do
1909 breakSwitch $ words argLine
1911 breakSwitch :: [String] -> GHCi ()
1913 io $ putStrLn "The break command requires at least one argument."
1914 breakSwitch (arg1:rest)
1915 | looksLikeModuleName arg1 && not (null rest) = do
1916 mod <- wantInterpretedModule arg1
1917 breakByModule mod rest
1918 | all isDigit arg1 = do
1919 (toplevel, _) <- GHC.getContext
1921 (mod : _) -> breakByModuleLine mod (read arg1) rest
1923 io $ putStrLn "Cannot find default module for breakpoint."
1924 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1925 | otherwise = do -- try parsing it as an identifier
1926 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1927 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1928 if GHC.isGoodSrcLoc loc
1929 then ASSERT( isExternalName name )
1930 findBreakAndSet (GHC.nameModule name) $
1931 findBreakByCoord (Just (GHC.srcLocFile loc))
1932 (GHC.srcLocLine loc,
1934 else noCanDo name $ text "can't find its location: " <> ppr loc
1936 noCanDo n why = printForUser $
1937 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1939 breakByModule :: Module -> [String] -> GHCi ()
1940 breakByModule mod (arg1:rest)
1941 | all isDigit arg1 = do -- looks like a line number
1942 breakByModuleLine mod (read arg1) rest
1946 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1947 breakByModuleLine mod line args
1948 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1949 | [col] <- args, all isDigit col =
1950 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1951 | otherwise = breakSyntax
1954 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1956 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1957 findBreakAndSet mod lookupTickTree = do
1958 tickArray <- getTickArray mod
1959 (breakArray, _) <- getModBreak mod
1960 case lookupTickTree tickArray of
1961 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1962 Just (tick, span) -> do
1963 success <- io $ setBreakFlag True breakArray tick
1967 recordBreak $ BreakLocation
1974 text "Breakpoint " <> ppr nm <>
1976 then text " was already set at " <> ppr span
1977 else text " activated at " <> ppr span
1979 printForUser $ text "Breakpoint could not be activated at"
1982 -- When a line number is specified, the current policy for choosing
1983 -- the best breakpoint is this:
1984 -- - the leftmost complete subexpression on the specified line, or
1985 -- - the leftmost subexpression starting on the specified line, or
1986 -- - the rightmost subexpression enclosing the specified line
1988 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1989 findBreakByLine line arr
1990 | not (inRange (bounds arr) line) = Nothing
1992 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1993 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1994 listToMaybe (sortBy (rightmost `on` snd) ticks)
1998 starts_here = [ tick | tick@(_,span) <- ticks,
1999 GHC.srcSpanStartLine span == line ]
2001 (complete,incomplete) = partition ends_here starts_here
2002 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2004 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2005 -> Maybe (BreakIndex,SrcSpan)
2006 findBreakByCoord mb_file (line, col) arr
2007 | not (inRange (bounds arr) line) = Nothing
2009 listToMaybe (sortBy (rightmost `on` snd) contains ++
2010 sortBy (leftmost_smallest `on` snd) after_here)
2014 -- the ticks that span this coordinate
2015 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2016 is_correct_file span ]
2018 is_correct_file span
2019 | Just f <- mb_file = GHC.srcSpanFile span == f
2022 after_here = [ tick | tick@(_,span) <- ticks,
2023 GHC.srcSpanStartLine span == line,
2024 GHC.srcSpanStartCol span >= col ]
2026 -- For now, use ANSI bold on terminals that we know support it.
2027 -- Otherwise, we add a line of carets under the active expression instead.
2028 -- In particular, on Windows and when running the testsuite (which sets
2029 -- TERM to vt100 for other reasons) we get carets.
2030 -- We really ought to use a proper termcap/terminfo library.
2032 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2033 where mTerm = System.Environment.getEnv "TERM"
2034 `catchIO` \_ -> return "TERM not set"
2036 start_bold :: String
2037 start_bold = "\ESC[1m"
2039 end_bold = "\ESC[0m"
2041 listCmd :: String -> InputT GHCi ()
2043 mb_span <- lift getCurrentBreakSpan
2046 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2048 | GHC.isGoodSrcSpan span -> listAround span True
2050 do resumes <- GHC.getResumeContext
2052 [] -> panic "No resumes"
2054 do let traceIt = case GHC.resumeHistory r of
2055 [] -> text "rerunning with :trace,"
2057 doWhat = traceIt <+> text ":back then :list"
2058 printForUser' (text "Unable to list source for" <+>
2060 $$ text "Try" <+> doWhat)
2061 listCmd str = list2 (words str)
2063 list2 :: [String] -> InputT GHCi ()
2064 list2 [arg] | all isDigit arg = do
2065 (toplevel, _) <- GHC.getContext
2067 [] -> outputStrLn "No module to list"
2068 (mod : _) -> listModuleLine mod (read arg)
2069 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2070 mod <- wantInterpretedModule arg1
2071 listModuleLine mod (read arg2)
2073 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2074 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2075 if GHC.isGoodSrcLoc loc
2077 tickArray <- ASSERT( isExternalName name )
2078 lift $ getTickArray (GHC.nameModule name)
2079 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2080 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2083 Nothing -> listAround (GHC.srcLocSpan loc) False
2084 Just (_,span) -> listAround span False
2086 noCanDo name $ text "can't find its location: " <>
2089 noCanDo n why = printForUser' $
2090 text "cannot list source code for " <> ppr n <> text ": " <> why
2092 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2094 listModuleLine :: Module -> Int -> InputT GHCi ()
2095 listModuleLine modl line = do
2096 graph <- GHC.getModuleGraph
2097 let this = filter ((== modl) . GHC.ms_mod) graph
2099 [] -> panic "listModuleLine"
2101 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2102 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2103 listAround (GHC.srcLocSpan loc) False
2105 -- | list a section of a source file around a particular SrcSpan.
2106 -- If the highlight flag is True, also highlight the span using
2107 -- start_bold\/end_bold.
2109 -- GHC files are UTF-8, so we can implement this by:
2110 -- 1) read the file in as a BS and syntax highlight it as before
2111 -- 2) convert the BS to String using utf-string, and write it out.
2112 -- It would be better if we could convert directly between UTF-8 and the
2113 -- console encoding, of course.
2114 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2115 listAround span do_highlight = do
2116 contents <- liftIO $ BS.readFile (unpackFS file)
2118 lines = BS.split '\n' contents
2119 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2120 drop (line1 - 1 - pad_before) $ lines
2121 fst_line = max 1 (line1 - pad_before)
2122 line_nos = [ fst_line .. ]
2124 highlighted | do_highlight = zipWith highlight line_nos these_lines
2125 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2127 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2128 prefixed = zipWith ($) highlighted bs_line_nos
2130 let output = BS.intercalate (BS.pack "\n") prefixed
2131 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2132 $ \(p,n) -> utf8DecodeString (castPtr p) n
2133 outputStrLn utf8Decoded
2135 file = GHC.srcSpanFile span
2136 line1 = GHC.srcSpanStartLine span
2137 col1 = GHC.srcSpanStartCol span
2138 line2 = GHC.srcSpanEndLine span
2139 col2 = GHC.srcSpanEndCol span
2141 pad_before | line1 == 1 = 0
2145 highlight | do_bold = highlight_bold
2146 | otherwise = highlight_carets
2148 highlight_bold no line prefix
2149 | no == line1 && no == line2
2150 = let (a,r) = BS.splitAt col1 line
2151 (b,c) = BS.splitAt (col2-col1) r
2153 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2155 = let (a,b) = BS.splitAt col1 line in
2156 BS.concat [prefix, a, BS.pack start_bold, b]
2158 = let (a,b) = BS.splitAt col2 line in
2159 BS.concat [prefix, a, BS.pack end_bold, b]
2160 | otherwise = BS.concat [prefix, line]
2162 highlight_carets no line prefix
2163 | no == line1 && no == line2
2164 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2165 BS.replicate (col2-col1) '^']
2167 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2170 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2172 | otherwise = BS.concat [prefix, line]
2174 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2175 nl = BS.singleton '\n'
2177 -- --------------------------------------------------------------------------
2180 getTickArray :: Module -> GHCi TickArray
2181 getTickArray modl = do
2183 let arrmap = tickarrays st
2184 case lookupModuleEnv arrmap modl of
2185 Just arr -> return arr
2187 (_breakArray, ticks) <- getModBreak modl
2188 let arr = mkTickArray (assocs ticks)
2189 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2192 discardTickArrays :: GHCi ()
2193 discardTickArrays = do
2195 setGHCiState st{tickarrays = emptyModuleEnv}
2197 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2199 = accumArray (flip (:)) [] (1, max_line)
2200 [ (line, (nm,span)) | (nm,span) <- ticks,
2201 line <- srcSpanLines span ]
2203 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2204 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2205 GHC.srcSpanEndLine span ]
2207 lookupModule :: GHC.GhcMonad m => String -> m Module
2208 lookupModule modName
2209 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2211 -- don't reset the counter back to zero?
2212 discardActiveBreakPoints :: GHCi ()
2213 discardActiveBreakPoints = do
2215 mapM (turnOffBreak.snd) (breaks st)
2216 setGHCiState $ st { breaks = [] }
2218 deleteBreak :: Int -> GHCi ()
2219 deleteBreak identity = do
2221 let oldLocations = breaks st
2222 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2224 then printForUser (text "Breakpoint" <+> ppr identity <+>
2225 text "does not exist")
2227 mapM (turnOffBreak.snd) this
2228 setGHCiState $ st { breaks = rest }
2230 turnOffBreak :: BreakLocation -> GHCi Bool
2231 turnOffBreak loc = do
2232 (arr, _) <- getModBreak (breakModule loc)
2233 io $ setBreakFlag False arr (breakTick loc)
2235 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2236 getModBreak mod = do
2237 Just mod_info <- GHC.getModuleInfo mod
2238 let modBreaks = GHC.modInfoModBreaks mod_info
2239 let array = GHC.modBreaks_flags modBreaks
2240 let ticks = GHC.modBreaks_locs modBreaks
2241 return (array, ticks)
2243 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2244 setBreakFlag toggle array index
2245 | toggle = GHC.setBreakOn array index
2246 | otherwise = GHC.setBreakOff array index