1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
9 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
11 #include "HsVersions.h"
19 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
20 Type, Module, ModuleName, TyThing(..), Phase,
21 BreakIndex, SrcSpan, Resume, SingleStep )
26 import HscTypes ( implicitTyThings )
28 import Outputable hiding (printForUser)
29 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
42 import Maybes ( orElse )
45 #ifndef mingw32_HOST_OS
46 import System.Posix hiding (getEnv)
48 import GHC.ConsoleHandler ( flushConsole )
49 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
50 import qualified System.Win32
54 import Control.Concurrent ( yield ) -- Used in readline loop
55 import System.Console.Readline as Readline
60 import Control.Exception as Exception
61 -- import Control.Concurrent
63 import qualified Data.ByteString.Char8 as BS
67 import System.Environment
68 import System.Exit ( exitWith, ExitCode(..) )
69 import System.Directory
71 import System.IO.Error as IO
75 import Control.Monad as Monad
78 import Foreign.StablePtr ( newStablePtr )
79 import GHC.Exts ( unsafeCoerce# )
80 import GHC.IOBase ( IOErrorType(InvalidArgument) )
82 import Data.IORef ( IORef, readIORef, writeIORef )
84 import System.Posix.Internals ( setNonBlockingFD )
86 -----------------------------------------------------------------------------
88 ghciWelcomeMsg :: String
89 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
90 ": http://www.haskell.org/ghc/ :? for help"
92 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
95 GLOBAL_VAR(commands, builtin_commands, [Command])
97 builtin_commands :: [Command]
99 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
100 ("?", keepGoing help, False, completeNone),
101 ("add", keepGoingPaths addModule, False, completeFilename),
102 ("abandon", keepGoing abandonCmd, False, completeNone),
103 ("break", keepGoing breakCmd, False, completeIdentifier),
104 ("back", keepGoing backCmd, False, completeNone),
105 ("browse", keepGoing browseCmd, False, completeModule),
106 ("cd", keepGoing changeDirectory, False, completeFilename),
107 ("check", keepGoing checkModule, False, completeHomeModule),
108 ("continue", keepGoing continueCmd, False, completeNone),
109 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
110 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
111 ("def", keepGoing defineMacro, False, completeIdentifier),
112 ("delete", keepGoing deleteCmd, False, completeNone),
113 ("e", keepGoing editFile, False, completeFilename),
114 ("edit", keepGoing editFile, False, completeFilename),
115 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
116 ("force", keepGoing forceCmd, False, completeIdentifier),
117 ("forward", keepGoing forwardCmd, False, completeNone),
118 ("help", keepGoing help, False, completeNone),
119 ("history", keepGoing historyCmd, False, completeNone),
120 ("info", keepGoing info, False, completeIdentifier),
121 ("kind", keepGoing kindOfType, False, completeIdentifier),
122 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
123 ("list", keepGoing listCmd, False, completeNone),
124 ("module", keepGoing setContext, False, completeModule),
125 ("main", keepGoing runMain, False, completeIdentifier),
126 ("print", keepGoing printCmd, False, completeIdentifier),
127 ("quit", quit, False, completeNone),
128 ("reload", keepGoing reloadModule, False, completeNone),
129 ("set", keepGoing setCmd, True, completeSetOptions),
130 ("show", keepGoing showCmd, False, completeNone),
131 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
132 ("step", keepGoing stepCmd, False, completeIdentifier),
133 ("stepover", keepGoing stepOverCmd, False, completeIdentifier),
134 ("type", keepGoing typeOfExpr, False, completeIdentifier),
135 ("trace", keepGoing traceCmd, False, completeIdentifier),
136 ("undef", keepGoing undefineMacro, False, completeMacro),
137 ("unset", keepGoing unsetOptions, True, completeSetOptions)
140 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
141 keepGoing a str = a str >> return False
143 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
144 keepGoingPaths a str = a (toArgs str) >> return False
146 shortHelpText = "use :? for help.\n"
149 " Commands available from the prompt:\n" ++
151 " <statement> evaluate/run <statement>\n" ++
152 " :add <filename> ... add module(s) to the current target set\n" ++
153 " :browse [*]<module> display the names defined by <module>\n" ++
154 " :cd <dir> change directory to <dir>\n" ++
155 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
156 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
157 " :def <cmd> <expr> define a command :<cmd>\n" ++
158 " :edit <file> edit file\n" ++
159 " :edit edit last module\n" ++
160 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
161 " :help, :? display this list of commands\n" ++
162 " :info [<name> ...] display information about the given names\n" ++
163 " :kind <type> show the kind of <type>\n" ++
164 " :load <filename> ... load module(s) and their dependents\n" ++
165 " :main [<arguments> ...] run the main function with the given arguments\n" ++
166 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
167 " :quit exit GHCi\n" ++
168 " :reload reload the current module set\n" ++
169 " :type <expr> show the type of <expr>\n" ++
170 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
171 " :!<command> run the shell command <command>\n" ++
173 " -- Commands for debugging:\n" ++
175 " :abandon at a breakpoint, abandon current computation\n" ++
176 " :back go back in the history (after :trace)\n" ++
177 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
178 " :break <name> set a breakpoint on the specified function\n" ++
179 " :continue resume after a breakpoint\n" ++
180 " :delete <number> delete the specified breakpoint\n" ++
181 " :delete * delete all breakpoints\n" ++
182 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
183 " :forward go forward in the history (after :back)\n" ++
184 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
185 " :print [<name> ...] prints a value without forcing its computation\n" ++
186 " :sprint [<name> ...] simplifed version of :print\n" ++
187 " :step single-step after stopping at a breakpoint\n"++
188 " :step <expr> single-step into <expr>\n"++
189 " :trace trace after stopping at a breakpoint\n"++
190 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
193 " -- Commands for changing settings:\n" ++
195 " :set <option> ... set options\n" ++
196 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
197 " :set prog <progname> set the value returned by System.getProgName\n" ++
198 " :set prompt <prompt> set the prompt used in GHCi\n" ++
199 " :set editor <cmd> set the command used for :edit\n" ++
200 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
201 " :unset <option> ... unset options\n" ++
203 " Options for ':set' and ':unset':\n" ++
205 " +r revert top-level expressions after each evaluation\n" ++
206 " +s print timing/memory stats after each evaluation\n" ++
207 " +t print type after evaluation\n" ++
208 " -<flags> most GHC command line flags can also be set here\n" ++
209 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
211 " -- Commands for displaying information:\n" ++
213 " :show bindings show the current bindings made at the prompt\n" ++
214 " :show breaks show the active breakpoints\n" ++
215 " :show context show the breakpoint context\n" ++
216 " :show modules show the currently loaded modules\n" ++
217 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
224 win <- System.Win32.getWindowsDirectory
225 return (win `joinFileName` "notepad.exe")
230 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
231 interactiveUI session srcs maybe_expr = do
232 -- HACK! If we happen to get into an infinite loop (eg the user
233 -- types 'let x=x in x' at the prompt), then the thread will block
234 -- on a blackhole, and become unreachable during GC. The GC will
235 -- detect that it is unreachable and send it the NonTermination
236 -- exception. However, since the thread is unreachable, everything
237 -- it refers to might be finalized, including the standard Handles.
238 -- This sounds like a bug, but we don't have a good solution right
244 -- Initialise buffering for the *interpreted* I/O system
245 initInterpBuffering session
247 when (isNothing maybe_expr) $ do
248 -- Only for GHCi (not runghc and ghc -e):
250 -- Turn buffering off for the compiled program's stdout/stderr
252 -- Turn buffering off for GHCi's stdout
254 hSetBuffering stdout NoBuffering
255 -- We don't want the cmd line to buffer any input that might be
256 -- intended for the program, so unbuffer stdin.
257 hSetBuffering stdin NoBuffering
259 -- initial context is just the Prelude
260 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
261 GHC.setContext session [] [prel_mod]
265 Readline.setAttemptedCompletionFunction (Just completeWord)
266 --Readline.parseAndBind "set show-all-if-ambiguous 1"
268 let symbols = "!#$%&*+/<=>?@\\^|-~"
269 specials = "(),;[]`{}"
271 word_break_chars = spaces ++ specials ++ symbols
273 Readline.setBasicWordBreakCharacters word_break_chars
274 Readline.setCompleterWordBreakCharacters word_break_chars
277 default_editor <- findEditor
279 startGHCi (runGHCi srcs maybe_expr)
280 GHCiState{ progname = "<interactive>",
284 editor = default_editor,
290 tickarrays = emptyModuleEnv,
295 Readline.resetTerminal Nothing
300 prel_name = GHC.mkModuleName "Prelude"
302 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
303 runGHCi paths maybe_expr = do
304 let read_dot_files = not opt_IgnoreDotGhci
306 when (read_dot_files) $ do
309 exists <- io (doesFileExist file)
311 dir_ok <- io (checkPerms ".")
312 file_ok <- io (checkPerms file)
313 when (dir_ok && file_ok) $ do
314 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
317 Right hdl -> fileLoop hdl False
319 when (read_dot_files) $ do
320 -- Read in $HOME/.ghci
321 either_dir <- io (IO.try (getEnv "HOME"))
325 cwd <- io (getCurrentDirectory)
326 when (dir /= cwd) $ do
327 let file = dir ++ "/.ghci"
328 ok <- io (checkPerms file)
330 either_hdl <- io (IO.try (openFile file ReadMode))
333 Right hdl -> fileLoop hdl False
335 -- Perform a :load for files given on the GHCi command line
336 -- When in -e mode, if the load fails then we want to stop
337 -- immediately rather than going on to evaluate the expression.
338 when (not (null paths)) $ do
339 ok <- ghciHandle (\e -> do showException e; return Failed) $
341 when (isJust maybe_expr && failed ok) $
342 io (exitWith (ExitFailure 1))
344 -- if verbosity is greater than 0, or we are connected to a
345 -- terminal, display the prompt in the interactive loop.
346 is_tty <- io (hIsTerminalDevice stdin)
347 dflags <- getDynFlags
348 let show_prompt = verbosity dflags > 0 || is_tty
353 #if defined(mingw32_HOST_OS)
354 -- The win32 Console API mutates the first character of
355 -- type-ahead when reading from it in a non-buffered manner. Work
356 -- around this by flushing the input buffer of type-ahead characters,
357 -- but only if stdin is available.
358 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
360 Left err | isDoesNotExistError err -> return ()
361 | otherwise -> io (ioError err)
362 Right () -> return ()
364 -- initialise the console if necessary
367 -- enter the interactive loop
368 interactiveLoop is_tty show_prompt
370 -- just evaluate the expression we were given
375 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
378 interactiveLoop is_tty show_prompt =
379 -- Ignore ^C exceptions caught here
380 ghciHandleDyn (\e -> case e of
382 #if defined(mingw32_HOST_OS)
385 interactiveLoop is_tty show_prompt
386 _other -> return ()) $
388 ghciUnblock $ do -- unblock necessary if we recursed from the
389 -- exception handler above.
391 -- read commands from stdin
395 else fileLoop stdin show_prompt
397 fileLoop stdin show_prompt
401 -- NOTE: We only read .ghci files if they are owned by the current user,
402 -- and aren't world writable. Otherwise, we could be accidentally
403 -- running code planted by a malicious third party.
405 -- Furthermore, We only read ./.ghci if . is owned by the current user
406 -- and isn't writable by anyone else. I think this is sufficient: we
407 -- don't need to check .. and ../.. etc. because "." always refers to
408 -- the same directory while a process is running.
410 checkPerms :: String -> IO Bool
412 #ifdef mingw32_HOST_OS
415 Util.handle (\_ -> return False) $ do
416 st <- getFileStatus name
418 if fileOwner st /= me then do
419 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
422 let mode = fileMode st
423 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
424 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
426 putStrLn $ "*** WARNING: " ++ name ++
427 " is writable by someone else, IGNORING!"
432 fileLoop :: Handle -> Bool -> GHCi ()
433 fileLoop hdl show_prompt = do
434 when show_prompt $ do
437 l <- io (IO.try (hGetLine hdl))
439 Left e | isEOFError e -> return ()
440 | InvalidArgument <- etype -> return ()
441 | otherwise -> io (ioError e)
442 where etype = ioeGetErrorType e
443 -- treat InvalidArgument in the same way as EOF:
444 -- this can happen if the user closed stdin, or
445 -- perhaps did getContents which closes stdin at
448 case removeSpaces l of
449 "" -> fileLoop hdl show_prompt
450 l -> do quit <- runCommands l
451 if quit then return () else fileLoop hdl show_prompt
454 session <- getSession
455 (toplevs,exports) <- io (GHC.getContext session)
456 resumes <- io $ GHC.getResumeContext session
462 let ix = GHC.resumeHistoryIx r
464 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
466 let hist = GHC.resumeHistory r !! (ix-1)
467 span <- io$ GHC.getHistorySpan session hist
468 return (brackets (ppr (negate ix) <> char ':'
469 <+> ppr span) <> space)
471 dots | r:rs <- resumes, not (null rs) = text "... "
475 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
476 hsep (map (ppr . GHC.moduleName) exports)
478 deflt_prompt = dots <> context_bit <> modules_bit
480 f ('%':'s':xs) = deflt_prompt <> f xs
481 f ('%':'%':xs) = char '%' <> f xs
482 f (x:xs) = char x <> f xs
486 return (showSDoc (f (prompt st)))
490 readlineLoop :: GHCi ()
492 session <- getSession
493 (mod,imports) <- io (GHC.getContext session)
495 saveSession -- for use by completion
497 mb_span <- getCurrentBreakSpan
499 l <- io (readline prompt `finally` setNonBlockingFD 0)
500 -- readline sometimes puts stdin into blocking mode,
501 -- so we need to put it back for the IO library
506 case removeSpaces l of
510 quit <- runCommands l
511 if quit then return () else readlineLoop
514 runCommands :: String -> GHCi Bool
516 q <- ghciHandle handler (doCommand cmd)
517 if q then return True else runNext
523 c:cs -> do setGHCiState st{ cmdqueue = cs }
526 doCommand (':' : cmd) = specialCommand cmd
527 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
530 enqueueCommands :: [String] -> GHCi ()
531 enqueueCommands cmds = do
533 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
536 -- This version is for the GHC command-line option -e. The only difference
537 -- from runCommand is that it catches the ExitException exception and
538 -- exits, rather than printing out the exception.
539 runCommandEval c = ghciHandle handleEval (doCommand c)
541 handleEval (ExitException code) = io (exitWith code)
542 handleEval e = do handler e
543 io (exitWith (ExitFailure 1))
545 doCommand (':' : command) = specialCommand command
547 = do r <- runStmt stmt GHC.RunToCompletion
549 False -> io (exitWith (ExitFailure 1))
550 -- failure to run the command causes exit(1) for ghc -e.
553 runStmt :: String -> SingleStep -> GHCi Bool
555 | null (filter (not.isSpace) stmt) = return False
556 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
558 = do st <- getGHCiState
559 session <- getSession
560 result <- io $ withProgName (progname st) $ withArgs (args st) $
561 GHC.runStmt session stmt step
562 afterRunStmt (const True) result
565 --afterRunStmt :: GHC.RunResult -> GHCi Bool
566 -- False <=> the statement failed to compile
567 afterRunStmt _ (GHC.RunException e) = throw e
568 afterRunStmt pred run_result = do
569 session <- getSession
570 resumes <- io $ GHC.getResumeContext session
572 GHC.RunOk names -> do
573 show_types <- isOptionSet ShowType
574 when show_types $ printTypeOfNames session names
575 GHC.RunBreak _ names mb_info
576 | isNothing mb_info ||
577 pred (GHC.resumeSpan $ head resumes) -> do
578 printForUser $ ptext SLIT("Stopped at") <+>
579 ppr (GHC.resumeSpan $ head resumes)
580 printTypeOfNames session names
581 maybe (return ()) runBreakCmd mb_info
582 -- run the command set with ":set stop <cmd>"
584 enqueueCommands [stop st]
586 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
587 afterRunStmt pred >> return ()
591 io installSignalHandlers
592 b <- isOptionSet RevertCAFs
593 io (when b revertCAFs)
595 return (case run_result of GHC.RunOk _ -> True; _ -> False)
597 runBreakCmd :: GHC.BreakInfo -> GHCi ()
598 runBreakCmd info = do
599 let mod = GHC.breakInfo_module info
600 nm = GHC.breakInfo_number info
602 case [ loc | (i,loc) <- breaks st,
603 breakModule loc == mod, breakTick loc == nm ] of
605 loc:_ | null cmd -> return ()
606 | otherwise -> do enqueueCommands [cmd]; return ()
607 where cmd = onBreakCmd loc
609 printTypeOfNames :: Session -> [Name] -> GHCi ()
610 printTypeOfNames session names
611 = mapM_ (printTypeOfName session) $ sortBy compareNames names
613 compareNames :: Name -> Name -> Ordering
614 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
615 where compareWith n = (getOccString n, getSrcSpan n)
617 printTypeOfName :: Session -> Name -> GHCi ()
618 printTypeOfName session n
619 = do maybe_tything <- io (GHC.lookupName session n)
620 case maybe_tything of
622 Just thing -> printTyThing thing
624 specialCommand :: String -> GHCi Bool
625 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
626 specialCommand str = do
627 let (cmd,rest) = break isSpace str
628 maybe_cmd <- io (lookupCommand cmd)
630 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
631 ++ shortHelpText) >> return False)
632 Just (_,f,_,_) -> f (dropWhile isSpace rest)
634 lookupCommand :: String -> IO (Maybe Command)
635 lookupCommand str = do
636 cmds <- readIORef commands
637 -- look for exact match first, then the first prefix match
638 case [ c | c <- cmds, str == cmdName c ] of
639 c:_ -> return (Just c)
640 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
642 c:_ -> return (Just c)
645 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
646 getCurrentBreakSpan = do
647 session <- getSession
648 resumes <- io $ GHC.getResumeContext session
652 let ix = GHC.resumeHistoryIx r
654 then return (Just (GHC.resumeSpan r))
656 let hist = GHC.resumeHistory r !! (ix-1)
657 span <- io $ GHC.getHistorySpan session hist
660 getCurrentBreakModule :: GHCi (Maybe Module)
661 getCurrentBreakModule = do
662 session <- getSession
663 resumes <- io $ GHC.getResumeContext session
667 let ix = GHC.resumeHistoryIx r
669 then return (GHC.breakInfo_module `fmap` GHC.resumeBreakInfo r)
671 let hist = GHC.resumeHistory r !! (ix-1)
672 return $ Just $ GHC.getHistoryModule hist
674 -----------------------------------------------------------------------------
677 noArgs :: GHCi () -> String -> GHCi ()
679 noArgs m _ = io $ putStrLn "This command takes no arguments"
681 help :: String -> GHCi ()
682 help _ = io (putStr helpText)
684 info :: String -> GHCi ()
685 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
686 info s = do { let names = words s
687 ; session <- getSession
688 ; dflags <- getDynFlags
689 ; let pefas = dopt Opt_PrintExplicitForalls dflags
690 ; mapM_ (infoThing pefas session) names }
692 infoThing pefas session str = io $ do
693 names <- GHC.parseName session str
694 mb_stuffs <- mapM (GHC.getInfo session) names
695 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
696 unqual <- GHC.getPrintUnqual session
697 putStrLn (showSDocForUser unqual $
698 vcat (intersperse (text "") $
699 map (pprInfo pefas) filtered))
701 -- Filter out names whose parent is also there Good
702 -- example is '[]', which is both a type and data
703 -- constructor in the same type
704 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
705 filterOutChildren get_thing xs
706 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
708 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
710 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
711 pprInfo pefas (thing, fixity, insts)
712 = pprTyThingInContextLoc pefas thing
713 $$ show_fixity fixity
714 $$ vcat (map GHC.pprInstance insts)
717 | fix == GHC.defaultFixity = empty
718 | otherwise = ppr fix <+> ppr (GHC.getName thing)
720 runMain :: String -> GHCi ()
722 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
723 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
725 addModule :: [FilePath] -> GHCi ()
727 io (revertCAFs) -- always revert CAFs on load/add.
728 files <- mapM expandPath files
729 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
730 session <- getSession
731 io (mapM_ (GHC.addTarget session) targets)
732 ok <- io (GHC.load session LoadAllTargets)
735 changeDirectory :: String -> GHCi ()
736 changeDirectory dir = do
737 session <- getSession
738 graph <- io (GHC.getModuleGraph session)
739 when (not (null graph)) $
740 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
741 io (GHC.setTargets session [])
742 io (GHC.load session LoadAllTargets)
743 setContextAfterLoad session []
744 io (GHC.workingDirectoryChanged session)
745 dir <- expandPath dir
746 io (setCurrentDirectory dir)
748 editFile :: String -> GHCi ()
750 do file <- if null str then chooseEditFile else return str
754 $ throwDyn (CmdLineError "editor not set, use :set editor")
755 io $ system (cmd ++ ' ':file)
758 -- The user didn't specify a file so we pick one for them.
759 -- Our strategy is to pick the first module that failed to load,
760 -- or otherwise the first target.
762 -- XXX: Can we figure out what happened if the depndecy analysis fails
763 -- (e.g., because the porgrammeer mistyped the name of a module)?
764 -- XXX: Can we figure out the location of an error to pass to the editor?
765 -- XXX: if we could figure out the list of errors that occured during the
766 -- last load/reaload, then we could start the editor focused on the first
768 chooseEditFile :: GHCi String
770 do session <- getSession
771 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
773 graph <- io (GHC.getModuleGraph session)
774 failed_graph <- filterM hasFailed graph
775 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
777 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
780 case pick (order failed_graph) of
781 Just file -> return file
783 do targets <- io (GHC.getTargets session)
784 case msum (map fromTarget targets) of
785 Just file -> return file
786 Nothing -> throwDyn (CmdLineError "No files to edit.")
788 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
789 fromTarget _ = Nothing -- when would we get a module target?
791 defineMacro :: String -> GHCi ()
793 let (macro_name, definition) = break isSpace s
794 cmds <- io (readIORef commands)
796 then throwDyn (CmdLineError "invalid macro name")
798 if (macro_name `elem` map cmdName cmds)
799 then throwDyn (CmdLineError
800 ("command '" ++ macro_name ++ "' is already defined"))
803 -- give the expression a type signature, so we can be sure we're getting
804 -- something of the right type.
805 let new_expr = '(' : definition ++ ") :: String -> IO String"
807 -- compile the expression
809 maybe_hv <- io (GHC.compileExpr cms new_expr)
812 Just hv -> io (writeIORef commands --
813 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
815 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
817 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
818 enqueueCommands (lines str)
821 undefineMacro :: String -> GHCi ()
822 undefineMacro macro_name = do
823 cmds <- io (readIORef commands)
824 if (macro_name `elem` map cmdName builtin_commands)
825 then throwDyn (CmdLineError
826 ("command '" ++ macro_name ++ "' cannot be undefined"))
828 if (macro_name `notElem` map cmdName cmds)
829 then throwDyn (CmdLineError
830 ("command '" ++ macro_name ++ "' not defined"))
832 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
834 cmdCmd :: String -> GHCi ()
836 let expr = '(' : str ++ ") :: IO String"
837 session <- getSession
838 maybe_hv <- io (GHC.compileExpr session expr)
842 cmds <- io $ (unsafeCoerce# hv :: IO String)
843 enqueueCommands (lines cmds)
846 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
847 loadModule fs = timeIt (loadModule' fs)
849 loadModule_ :: [FilePath] -> GHCi ()
850 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
852 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
853 loadModule' files = do
854 session <- getSession
857 discardActiveBreakPoints
858 io (GHC.setTargets session [])
859 io (GHC.load session LoadAllTargets)
862 let (filenames, phases) = unzip files
863 exp_filenames <- mapM expandPath filenames
864 let files' = zip exp_filenames phases
865 targets <- io (mapM (uncurry GHC.guessTarget) files')
867 -- NOTE: we used to do the dependency anal first, so that if it
868 -- fails we didn't throw away the current set of modules. This would
869 -- require some re-working of the GHC interface, so we'll leave it
870 -- as a ToDo for now.
872 io (GHC.setTargets session targets)
873 doLoad session LoadAllTargets
875 checkModule :: String -> GHCi ()
877 let modl = GHC.mkModuleName m
878 session <- getSession
879 result <- io (GHC.checkModule session modl False)
881 Nothing -> io $ putStrLn "Nothing"
882 Just r -> io $ putStrLn (showSDoc (
883 case GHC.checkedModuleInfo r of
884 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
886 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
888 (text "global names: " <+> ppr global) $$
889 (text "local names: " <+> ppr local)
891 afterLoad (successIf (isJust result)) session
893 reloadModule :: String -> GHCi ()
895 io (revertCAFs) -- always revert CAFs on reload.
896 discardActiveBreakPoints
897 session <- getSession
898 doLoad session $ if null m then LoadAllTargets
899 else LoadUpTo (GHC.mkModuleName m)
902 doLoad session howmuch = do
903 -- turn off breakpoints before we load: we can't turn them off later, because
904 -- the ModBreaks will have gone away.
905 discardActiveBreakPoints
906 ok <- io (GHC.load session howmuch)
910 afterLoad ok session = do
911 io (revertCAFs) -- always revert CAFs on load.
913 graph <- io (GHC.getModuleGraph session)
914 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
915 setContextAfterLoad session graph'
916 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
918 setContextAfterLoad session [] = do
919 prel_mod <- getPrelude
920 io (GHC.setContext session [] [prel_mod])
921 setContextAfterLoad session ms = do
922 -- load a target if one is available, otherwise load the topmost module.
923 targets <- io (GHC.getTargets session)
924 case [ m | Just m <- map (findTarget ms) targets ] of
926 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
927 load_this (last graph')
932 = case filter (`matches` t) ms of
936 summary `matches` Target (TargetModule m) _
937 = GHC.ms_mod_name summary == m
938 summary `matches` Target (TargetFile f _) _
939 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
940 summary `matches` target
943 load_this summary | m <- GHC.ms_mod summary = do
944 b <- io (GHC.moduleIsInterpreted session m)
945 if b then io (GHC.setContext session [m] [])
947 prel_mod <- getPrelude
948 io (GHC.setContext session [] [prel_mod,m])
951 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
952 modulesLoadedMsg ok mods = do
953 dflags <- getDynFlags
954 when (verbosity dflags > 0) $ do
956 | null mods = text "none."
958 punctuate comma (map ppr mods)) <> text "."
961 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
963 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
966 typeOfExpr :: String -> GHCi ()
968 = do cms <- getSession
969 maybe_ty <- io (GHC.exprType cms str)
972 Just ty -> do ty' <- cleanType ty
973 printForUser $ text str <> text " :: " <> ppr ty'
975 kindOfType :: String -> GHCi ()
977 = do cms <- getSession
978 maybe_ty <- io (GHC.typeKind cms str)
981 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
983 quit :: String -> GHCi Bool
986 shellEscape :: String -> GHCi Bool
987 shellEscape str = io (system str >> return False)
989 -----------------------------------------------------------------------------
990 -- Browsing a module's contents
992 browseCmd :: String -> GHCi ()
995 ['*':m] | looksLikeModuleName m -> browseModule m False
996 [m] | looksLikeModuleName m -> browseModule m True
997 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
999 browseModule m exports_only = do
1001 modl <- if exports_only then lookupModule m
1002 else wantInterpretedModule m
1004 -- Temporarily set the context to the module we're interested in,
1005 -- just so we can get an appropriate PrintUnqualified
1006 (as,bs) <- io (GHC.getContext s)
1007 prel_mod <- getPrelude
1008 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1009 else GHC.setContext s [modl] [])
1010 unqual <- io (GHC.getPrintUnqual s)
1011 io (GHC.setContext s as bs)
1013 mb_mod_info <- io $ GHC.getModuleInfo s modl
1015 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1018 | exports_only = GHC.modInfoExports mod_info
1019 | otherwise = GHC.modInfoTopLevelScope mod_info
1022 mb_things <- io $ mapM (GHC.lookupName s) names
1023 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1025 dflags <- getDynFlags
1026 let pefas = dopt Opt_PrintExplicitForalls dflags
1027 io (putStrLn (showSDocForUser unqual (
1028 vcat (map (pprTyThingInContext pefas) filtered_things)
1030 -- ToDo: modInfoInstances currently throws an exception for
1031 -- package modules. When it works, we can do this:
1032 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1034 -----------------------------------------------------------------------------
1035 -- Setting the module context
1038 | all sensible mods = fn mods
1039 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1041 (fn, mods) = case str of
1042 '+':stuff -> (addToContext, words stuff)
1043 '-':stuff -> (removeFromContext, words stuff)
1044 stuff -> (newContext, words stuff)
1046 sensible ('*':m) = looksLikeModuleName m
1047 sensible m = looksLikeModuleName m
1049 separate :: Session -> [String] -> [Module] -> [Module]
1050 -> GHCi ([Module],[Module])
1051 separate session [] as bs = return (as,bs)
1052 separate session (('*':str):ms) as bs = do
1053 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1054 b <- io $ GHC.moduleIsInterpreted session m
1055 if b then separate session ms (m:as) bs
1056 else throwDyn (CmdLineError ("module '"
1057 ++ GHC.moduleNameString (GHC.moduleName m)
1058 ++ "' is not interpreted"))
1059 separate session (str:ms) as bs = do
1060 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1061 separate session ms as (m:bs)
1063 newContext :: [String] -> GHCi ()
1064 newContext strs = do
1066 (as,bs) <- separate s strs [] []
1067 prel_mod <- getPrelude
1068 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1069 io $ GHC.setContext s as bs'
1072 addToContext :: [String] -> GHCi ()
1073 addToContext strs = do
1075 (as,bs) <- io $ GHC.getContext s
1077 (new_as,new_bs) <- separate s strs [] []
1079 let as_to_add = new_as \\ (as ++ bs)
1080 bs_to_add = new_bs \\ (as ++ bs)
1082 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1085 removeFromContext :: [String] -> GHCi ()
1086 removeFromContext strs = do
1088 (as,bs) <- io $ GHC.getContext s
1090 (as_to_remove,bs_to_remove) <- separate s strs [] []
1092 let as' = as \\ (as_to_remove ++ bs_to_remove)
1093 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1095 io $ GHC.setContext s as' bs'
1097 ----------------------------------------------------------------------------
1100 -- set options in the interpreter. Syntax is exactly the same as the
1101 -- ghc command line, except that certain options aren't available (-C,
1104 -- This is pretty fragile: most options won't work as expected. ToDo:
1105 -- figure out which ones & disallow them.
1107 setCmd :: String -> GHCi ()
1109 = do st <- getGHCiState
1110 let opts = options st
1111 io $ putStrLn (showSDoc (
1112 text "options currently set: " <>
1115 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1118 = case toArgs str of
1119 ("args":args) -> setArgs args
1120 ("prog":prog) -> setProg prog
1121 ("prompt":prompt) -> setPrompt (after 6)
1122 ("editor":cmd) -> setEditor (after 6)
1123 ("stop":cmd) -> setStop (after 4)
1124 wds -> setOptions wds
1125 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1129 setGHCiState st{ args = args }
1133 setGHCiState st{ progname = prog }
1135 io (hPutStrLn stderr "syntax: :set prog <progname>")
1139 setGHCiState st{ editor = cmd }
1141 setStop str@(c:_) | isDigit c
1142 = do let (nm_str,rest) = break (not.isDigit) str
1145 let old_breaks = breaks st
1146 if all ((/= nm) . fst) old_breaks
1147 then printForUser (text "Breakpoint" <+> ppr nm <+>
1148 text "does not exist")
1150 let new_breaks = map fn old_breaks
1151 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1152 | otherwise = (i,loc)
1153 setGHCiState st{ breaks = new_breaks }
1156 setGHCiState st{ stop = cmd }
1158 setPrompt value = do
1161 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1162 else setGHCiState st{ prompt = remQuotes value }
1164 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1168 do -- first, deal with the GHCi opts (+s, +t, etc.)
1169 let (plus_opts, minus_opts) = partition isPlus wds
1170 mapM_ setOpt plus_opts
1171 -- then, dynamic flags
1172 newDynFlags minus_opts
1174 newDynFlags minus_opts = do
1175 dflags <- getDynFlags
1176 let pkg_flags = packageFlags dflags
1177 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1179 if (not (null leftovers))
1180 then throwDyn (CmdLineError ("unrecognised flags: " ++
1184 new_pkgs <- setDynFlags dflags'
1186 -- if the package flags changed, we should reset the context
1187 -- and link the new packages.
1188 dflags <- getDynFlags
1189 when (packageFlags dflags /= pkg_flags) $ do
1190 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1191 session <- getSession
1192 io (GHC.setTargets session [])
1193 io (GHC.load session LoadAllTargets)
1194 io (linkPackages dflags new_pkgs)
1195 setContextAfterLoad session []
1199 unsetOptions :: String -> GHCi ()
1201 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1202 let opts = words str
1203 (minus_opts, rest1) = partition isMinus opts
1204 (plus_opts, rest2) = partition isPlus rest1
1206 if (not (null rest2))
1207 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1210 mapM_ unsetOpt plus_opts
1212 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1213 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1215 no_flags <- mapM no_flag minus_opts
1216 newDynFlags no_flags
1218 isMinus ('-':s) = True
1221 isPlus ('+':s) = True
1225 = case strToGHCiOpt str of
1226 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1227 Just o -> setOption o
1230 = case strToGHCiOpt str of
1231 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1232 Just o -> unsetOption o
1234 strToGHCiOpt :: String -> (Maybe GHCiOption)
1235 strToGHCiOpt "s" = Just ShowTiming
1236 strToGHCiOpt "t" = Just ShowType
1237 strToGHCiOpt "r" = Just RevertCAFs
1238 strToGHCiOpt _ = Nothing
1240 optToStr :: GHCiOption -> String
1241 optToStr ShowTiming = "s"
1242 optToStr ShowType = "t"
1243 optToStr RevertCAFs = "r"
1245 -- ---------------------------------------------------------------------------
1251 ["args"] -> io $ putStrLn (show (args st))
1252 ["prog"] -> io $ putStrLn (show (progname st))
1253 ["prompt"] -> io $ putStrLn (show (prompt st))
1254 ["editor"] -> io $ putStrLn (show (editor st))
1255 ["stop"] -> io $ putStrLn (show (stop st))
1256 ["modules" ] -> showModules
1257 ["bindings"] -> showBindings
1258 ["linker"] -> io showLinkerState
1259 ["breaks"] -> showBkptTable
1260 ["context"] -> showContext
1261 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1264 session <- getSession
1265 let show_one ms = do m <- io (GHC.showModule session ms)
1267 graph <- io (GHC.getModuleGraph session)
1268 mapM_ show_one graph
1272 unqual <- io (GHC.getPrintUnqual s)
1273 bindings <- io (GHC.getBindings s)
1274 mapM_ printTyThing $ sortBy compareTyThings bindings
1277 compareTyThings :: TyThing -> TyThing -> Ordering
1278 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1280 printTyThing :: TyThing -> GHCi ()
1281 printTyThing (AnId id) = do
1282 ty' <- cleanType (GHC.idType id)
1283 printForUser $ ppr id <> text " :: " <> ppr ty'
1284 printTyThing _ = return ()
1286 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1287 cleanType :: Type -> GHCi Type
1289 dflags <- getDynFlags
1290 if dopt Opt_PrintExplicitForalls dflags
1292 else return $! GHC.dropForAlls ty
1294 showBkptTable :: GHCi ()
1297 printForUser $ prettyLocations (breaks st)
1299 showContext :: GHCi ()
1301 session <- getSession
1302 resumes <- io $ GHC.getResumeContext session
1303 printForUser $ vcat (map pp_resume (reverse resumes))
1306 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1307 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1310 -- -----------------------------------------------------------------------------
1313 completeNone :: String -> IO [String]
1314 completeNone w = return []
1317 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1318 completeWord w start end = do
1319 line <- Readline.getLineBuffer
1321 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1323 | Just c <- is_cmd line -> do
1324 maybe_cmd <- lookupCommand c
1325 let (n,w') = selectWord (words' 0 line)
1327 Nothing -> return Nothing
1328 Just (_,_,False,complete) -> wrapCompleter complete w
1329 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1330 return (map (drop n) rets)
1331 in wrapCompleter complete' w'
1333 --printf "complete %s, start = %d, end = %d\n" w start end
1334 wrapCompleter completeIdentifier w
1335 where words' _ [] = []
1336 words' n str = let (w,r) = break isSpace str
1337 (s,r') = span isSpace r
1338 in (n,w):words' (n+length w+length s) r'
1339 -- In a Haskell expression we want to parse 'a-b' as three words
1340 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1341 -- only be a single word.
1342 selectWord [] = (0,w)
1343 selectWord ((offset,x):xs)
1344 | offset+length x >= start = (start-offset,take (end-offset) x)
1345 | otherwise = selectWord xs
1348 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1349 | otherwise = Nothing
1352 cmds <- readIORef commands
1353 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1355 completeMacro w = do
1356 cmds <- readIORef commands
1357 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1358 return (filter (w `isPrefixOf`) cmds')
1360 completeIdentifier w = do
1362 rdrs <- GHC.getRdrNamesInScope s
1363 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1365 completeModule w = do
1367 dflags <- GHC.getSessionDynFlags s
1368 let pkg_mods = allExposedModules dflags
1369 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1371 completeHomeModule w = do
1373 g <- GHC.getModuleGraph s
1374 let home_mods = map GHC.ms_mod_name g
1375 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1377 completeSetOptions w = do
1378 return (filter (w `isPrefixOf`) options)
1379 where options = "args":"prog":allFlags
1381 completeFilename = Readline.filenameCompletionFunction
1383 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1385 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1386 unionComplete f1 f2 w = do
1391 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1392 wrapCompleter fun w = do
1395 [] -> return Nothing
1396 [x] -> return (Just (x,[]))
1397 xs -> case getCommonPrefix xs of
1398 "" -> return (Just ("",xs))
1399 pref -> return (Just (pref,xs))
1401 getCommonPrefix :: [String] -> String
1402 getCommonPrefix [] = ""
1403 getCommonPrefix (s:ss) = foldl common s ss
1404 where common s "" = ""
1406 common (c:cs) (d:ds)
1407 | c == d = c : common cs ds
1410 allExposedModules :: DynFlags -> [ModuleName]
1411 allExposedModules dflags
1412 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1414 pkg_db = pkgIdMap (pkgState dflags)
1416 completeCmd = completeNone
1417 completeMacro = completeNone
1418 completeIdentifier = completeNone
1419 completeModule = completeNone
1420 completeHomeModule = completeNone
1421 completeSetOptions = completeNone
1422 completeFilename = completeNone
1423 completeHomeModuleOrFile=completeNone
1424 completeBkpt = completeNone
1427 -- ---------------------------------------------------------------------------
1428 -- User code exception handling
1430 -- This is the exception handler for exceptions generated by the
1431 -- user's code and exceptions coming from children sessions;
1432 -- it normally just prints out the exception. The
1433 -- handler must be recursive, in case showing the exception causes
1434 -- more exceptions to be raised.
1436 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1437 -- raising another exception. We therefore don't put the recursive
1438 -- handler arond the flushing operation, so if stderr is closed
1439 -- GHCi will just die gracefully rather than going into an infinite loop.
1440 handler :: Exception -> GHCi Bool
1442 handler exception = do
1444 io installSignalHandlers
1445 ghciHandle handler (showException exception >> return False)
1447 showException (DynException dyn) =
1448 case fromDynamic dyn of
1449 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1450 Just Interrupted -> io (putStrLn "Interrupted.")
1451 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1452 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1453 Just other_ghc_ex -> io (print other_ghc_ex)
1455 showException other_exception
1456 = io (putStrLn ("*** Exception: " ++ show other_exception))
1458 -----------------------------------------------------------------------------
1459 -- recursive exception handlers
1461 -- Don't forget to unblock async exceptions in the handler, or if we're
1462 -- in an exception loop (eg. let a = error a in a) the ^C exception
1463 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1465 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1466 ghciHandle h (GHCi m) = GHCi $ \s ->
1467 Exception.catch (m s)
1468 (\e -> unGHCi (ghciUnblock (h e)) s)
1470 ghciUnblock :: GHCi a -> GHCi a
1471 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1474 -- ----------------------------------------------------------------------------
1477 expandPath :: String -> GHCi String
1479 case dropWhile isSpace path of
1481 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1482 return (tilde ++ '/':d)
1486 wantInterpretedModule :: String -> GHCi Module
1487 wantInterpretedModule str = do
1488 session <- getSession
1489 modl <- lookupModule str
1490 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1491 when (not is_interpreted) $
1492 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1495 wantNameFromInterpretedModule noCanDo str and_then = do
1496 session <- getSession
1497 names <- io $ GHC.parseName session str
1501 let modl = GHC.nameModule n
1502 if not (GHC.isExternalName n)
1503 then noCanDo n $ ppr n <>
1504 text " is not defined in an interpreted module"
1506 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1507 if not is_interpreted
1508 then noCanDo n $ text "module " <> ppr modl <>
1509 text " is not interpreted"
1512 -- ----------------------------------------------------------------------------
1513 -- Windows console setup
1515 setUpConsole :: IO ()
1517 #ifdef mingw32_HOST_OS
1518 -- On Windows we need to set a known code page, otherwise the characters
1519 -- we read from the console will be be in some strange encoding, and
1520 -- similarly for characters we write to the console.
1522 -- At the moment, GHCi pretends all input is Latin-1. In the
1523 -- future we should support UTF-8, but for now we set the code pages
1526 -- It seems you have to set the font in the console window to
1527 -- a Unicode font in order for output to work properly,
1528 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1529 -- (see MSDN for SetConsoleOutputCP()).
1531 setConsoleCP 28591 -- ISO Latin-1
1532 setConsoleOutputCP 28591 -- ISO Latin-1
1536 -- -----------------------------------------------------------------------------
1537 -- commands for debugger
1539 sprintCmd = pprintCommand False False
1540 printCmd = pprintCommand True False
1541 forceCmd = pprintCommand False True
1543 pprintCommand bind force str = do
1544 session <- getSession
1545 io $ pprintClosureCommand session bind force str
1547 stepCmd :: String -> GHCi ()
1548 stepCmd [] = doContinue (const True) GHC.SingleStep
1549 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1552 mb_span <- getCurrentBreakSpan
1554 Nothing -> stepCmd []
1556 Just mod <- getCurrentBreakModule
1557 parent <- enclosingTickSpan mod loc
1558 allTicksRightmost <- (sortBy rightmost . map snd) `fmap`
1560 let lastTick = null allTicksRightmost ||
1561 head allTicksRightmost == loc
1563 then doContinue (`isSubspanOf` parent) GHC.SingleStep
1564 else doContinue (const True) GHC.SingleStep
1569 So, the only tricky part in stepOver is detecting that we have
1570 arrived to the last tick in an expression, in which case we must
1571 step normally to the next tick.
1573 1. Retrieve the enclosing expression block (with a tick)
1574 2. Retrieve all the ticks there and sort them out by 'rightness'
1575 3. See if the current tick turned out the first one in the list
1578 --ticksIn :: Module -> SrcSpan -> GHCi [Tick]
1579 ticksIn mod src = do
1580 ticks <- getTickArray mod
1581 let lines = [srcSpanStartLine src .. srcSpanEndLine src]
1582 return [ t | line <- lines
1583 , t@(_,span) <- ticks ! line
1584 , srcSpanStart src <= srcSpanStart span
1585 , srcSpanEnd src >= srcSpanEnd span
1588 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1589 enclosingTickSpan mod src = do
1590 ticks <- getTickArray mod
1591 let line = srcSpanStartLine src
1592 ASSERT (inRange (bounds ticks) line) do
1593 let enclosing_spans = [ span | (_,span) <- ticks ! line
1594 , srcSpanEnd span >= srcSpanEnd src]
1595 return . head . sortBy leftmost_largest $ enclosing_spans
1597 traceCmd :: String -> GHCi ()
1598 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1599 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1601 continueCmd :: String -> GHCi ()
1602 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1604 -- doContinue :: SingleStep -> GHCi ()
1605 doContinue pred step = do
1606 session <- getSession
1607 runResult <- io $ GHC.resume session step
1608 afterRunStmt pred runResult
1611 abandonCmd :: String -> GHCi ()
1612 abandonCmd = noArgs $ do
1614 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1615 when (not b) $ io $ putStrLn "There is no computation running."
1618 deleteCmd :: String -> GHCi ()
1619 deleteCmd argLine = do
1620 deleteSwitch $ words argLine
1622 deleteSwitch :: [String] -> GHCi ()
1624 io $ putStrLn "The delete command requires at least one argument."
1625 -- delete all break points
1626 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1627 deleteSwitch idents = do
1628 mapM_ deleteOneBreak idents
1630 deleteOneBreak :: String -> GHCi ()
1632 | all isDigit str = deleteBreak (read str)
1633 | otherwise = return ()
1635 historyCmd :: String -> GHCi ()
1637 | null arg = history 20
1638 | all isDigit arg = history (read arg)
1639 | otherwise = io $ putStrLn "Syntax: :history [num]"
1643 resumes <- io $ GHC.getResumeContext s
1645 [] -> io $ putStrLn "Not stopped at a breakpoint"
1647 let hist = GHC.resumeHistory r
1648 (took,rest) = splitAt num hist
1649 spans <- mapM (io . GHC.getHistorySpan s) took
1650 let nums = map (printf "-%-3d:") [(1::Int)..]
1651 let names = map GHC.historyEnclosingDecl took
1652 printForUser (vcat(zipWith3
1653 (\x y z -> x <+> y <+> z)
1655 (map (bold . ppr) names)
1656 (map (parens . ppr) spans)))
1657 io $ putStrLn $ if null rest then "<end of history>" else "..."
1659 bold c | do_bold = text start_bold <> c <> text end_bold
1662 backCmd :: String -> GHCi ()
1663 backCmd = noArgs $ do
1665 (names, ix, span) <- io $ GHC.back s
1666 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1667 printTypeOfNames s names
1668 -- run the command set with ":set stop <cmd>"
1670 enqueueCommands [stop st]
1672 forwardCmd :: String -> GHCi ()
1673 forwardCmd = noArgs $ do
1675 (names, ix, span) <- io $ GHC.forward s
1676 printForUser $ (if (ix == 0)
1677 then ptext SLIT("Stopped at")
1678 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1679 printTypeOfNames s names
1680 -- run the command set with ":set stop <cmd>"
1682 enqueueCommands [stop st]
1684 -- handle the "break" command
1685 breakCmd :: String -> GHCi ()
1686 breakCmd argLine = do
1687 session <- getSession
1688 breakSwitch session $ words argLine
1690 breakSwitch :: Session -> [String] -> GHCi ()
1691 breakSwitch _session [] = do
1692 io $ putStrLn "The break command requires at least one argument."
1693 breakSwitch session args@(arg1:rest)
1694 | looksLikeModuleName arg1 = do
1695 mod <- wantInterpretedModule arg1
1696 breakByModule session mod rest
1697 | all isDigit arg1 = do
1698 (toplevel, _) <- io $ GHC.getContext session
1700 (mod : _) -> breakByModuleLine mod (read arg1) rest
1702 io $ putStrLn "Cannot find default module for breakpoint."
1703 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1704 | otherwise = do -- try parsing it as an identifier
1705 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1706 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1707 if GHC.isGoodSrcLoc loc
1708 then findBreakAndSet (GHC.nameModule name) $
1709 findBreakByCoord (Just (GHC.srcLocFile loc))
1710 (GHC.srcLocLine loc,
1712 else noCanDo name $ text "can't find its location: " <> ppr loc
1714 noCanDo n why = printForUser $
1715 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1717 breakByModule :: Session -> Module -> [String] -> GHCi ()
1718 breakByModule session mod args@(arg1:rest)
1719 | all isDigit arg1 = do -- looks like a line number
1720 breakByModuleLine mod (read arg1) rest
1721 breakByModule session mod _
1724 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1725 breakByModuleLine mod line args
1726 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1727 | [col] <- args, all isDigit col =
1728 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1729 | otherwise = breakSyntax
1731 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1733 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1734 findBreakAndSet mod lookupTickTree = do
1735 tickArray <- getTickArray mod
1736 (breakArray, _) <- getModBreak mod
1737 case lookupTickTree tickArray of
1738 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1739 Just (tick, span) -> do
1740 success <- io $ setBreakFlag True breakArray tick
1741 session <- getSession
1745 recordBreak $ BreakLocation
1752 text "Breakpoint " <> ppr nm <>
1754 then text " was already set at " <> ppr span
1755 else text " activated at " <> ppr span
1757 printForUser $ text "Breakpoint could not be activated at"
1760 -- When a line number is specified, the current policy for choosing
1761 -- the best breakpoint is this:
1762 -- - the leftmost complete subexpression on the specified line, or
1763 -- - the leftmost subexpression starting on the specified line, or
1764 -- - the rightmost subexpression enclosing the specified line
1766 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1767 findBreakByLine line arr
1768 | not (inRange (bounds arr) line) = Nothing
1770 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1771 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1772 listToMaybe (sortBy (rightmost `on` snd) ticks)
1776 starts_here = [ tick | tick@(nm,span) <- ticks,
1777 GHC.srcSpanStartLine span == line ]
1779 (complete,incomplete) = partition ends_here starts_here
1780 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1782 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1783 -> Maybe (BreakIndex,SrcSpan)
1784 findBreakByCoord mb_file (line, col) arr
1785 | not (inRange (bounds arr) line) = Nothing
1787 listToMaybe (sortBy (rightmost `on` snd) contains ++
1788 sortBy (leftmost_smallest `on` snd) after_here)
1792 -- the ticks that span this coordinate
1793 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1794 is_correct_file span ]
1796 is_correct_file span
1797 | Just f <- mb_file = GHC.srcSpanFile span == f
1800 after_here = [ tick | tick@(nm,span) <- ticks,
1801 GHC.srcSpanStartLine span == line,
1802 GHC.srcSpanStartCol span >= col ]
1804 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1805 -- of carets under the active expression instead. The Windows console
1806 -- doesn't support ANSI escape sequences, and most Unix terminals
1807 -- (including xterm) do, so this is a reasonable guess until we have a
1808 -- proper termcap/terminfo library.
1809 #if !defined(mingw32_TARGET_OS)
1815 start_bold = "\ESC[1m"
1816 end_bold = "\ESC[0m"
1818 listCmd :: String -> GHCi ()
1820 mb_span <- getCurrentBreakSpan
1822 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1823 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1824 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1825 listCmd str = list2 (words str)
1827 list2 [arg] | all isDigit arg = do
1828 session <- getSession
1829 (toplevel, _) <- io $ GHC.getContext session
1831 [] -> io $ putStrLn "No module to list"
1832 (mod : _) -> listModuleLine mod (read arg)
1833 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1834 mod <- wantInterpretedModule arg1
1835 listModuleLine mod (read arg2)
1837 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1838 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1839 if GHC.isGoodSrcLoc loc
1841 tickArray <- getTickArray (GHC.nameModule name)
1842 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1843 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1846 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1847 Just (_,span) -> io $ listAround span False
1849 noCanDo name $ text "can't find its location: " <>
1852 noCanDo n why = printForUser $
1853 text "cannot list source code for " <> ppr n <> text ": " <> why
1855 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1857 listModuleLine :: Module -> Int -> GHCi ()
1858 listModuleLine modl line = do
1859 session <- getSession
1860 graph <- io (GHC.getModuleGraph session)
1861 let this = filter ((== modl) . GHC.ms_mod) graph
1863 [] -> panic "listModuleLine"
1865 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1866 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1867 io $ listAround (GHC.srcLocSpan loc) False
1869 -- | list a section of a source file around a particular SrcSpan.
1870 -- If the highlight flag is True, also highlight the span using
1871 -- start_bold/end_bold.
1872 listAround span do_highlight = do
1873 contents <- BS.readFile (unpackFS file)
1875 lines = BS.split '\n' contents
1876 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1877 drop (line1 - 1 - pad_before) $ lines
1878 fst_line = max 1 (line1 - pad_before)
1879 line_nos = [ fst_line .. ]
1881 highlighted | do_highlight = zipWith highlight line_nos these_lines
1882 | otherwise = these_lines
1884 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1885 prefixed = zipWith BS.append bs_line_nos highlighted
1887 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1889 file = GHC.srcSpanFile span
1890 line1 = GHC.srcSpanStartLine span
1891 col1 = GHC.srcSpanStartCol span
1892 line2 = GHC.srcSpanEndLine span
1893 col2 = GHC.srcSpanEndCol span
1895 pad_before | line1 == 1 = 0
1899 highlight | do_bold = highlight_bold
1900 | otherwise = highlight_carets
1902 highlight_bold no line
1903 | no == line1 && no == line2
1904 = let (a,r) = BS.splitAt col1 line
1905 (b,c) = BS.splitAt (col2-col1) r
1907 BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
1909 = let (a,b) = BS.splitAt col1 line in
1910 BS.concat [a, BS.pack start_bold, b]
1912 = let (a,b) = BS.splitAt col2 line in
1913 BS.concat [a, BS.pack end_bold, b]
1916 highlight_carets no line
1917 | no == line1 && no == line2
1918 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1919 BS.replicate (col2-col1) '^']
1921 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1922 BS.replicate (BS.length line-col1) '^']
1924 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1927 indent = BS.pack " "
1928 nl = BS.singleton '\n'
1930 -- --------------------------------------------------------------------------
1933 getTickArray :: Module -> GHCi TickArray
1934 getTickArray modl = do
1936 let arrmap = tickarrays st
1937 case lookupModuleEnv arrmap modl of
1938 Just arr -> return arr
1940 (breakArray, ticks) <- getModBreak modl
1941 let arr = mkTickArray (assocs ticks)
1942 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1945 discardTickArrays :: GHCi ()
1946 discardTickArrays = do
1948 setGHCiState st{tickarrays = emptyModuleEnv}
1950 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1952 = accumArray (flip (:)) [] (1, max_line)
1953 [ (line, (nm,span)) | (nm,span) <- ticks,
1954 line <- srcSpanLines span ]
1956 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1957 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1958 GHC.srcSpanEndLine span ]
1960 lookupModule :: String -> GHCi Module
1961 lookupModule modName
1962 = do session <- getSession
1963 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1965 -- don't reset the counter back to zero?
1966 discardActiveBreakPoints :: GHCi ()
1967 discardActiveBreakPoints = do
1969 mapM (turnOffBreak.snd) (breaks st)
1970 setGHCiState $ st { breaks = [] }
1972 deleteBreak :: Int -> GHCi ()
1973 deleteBreak identity = do
1975 let oldLocations = breaks st
1976 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1978 then printForUser (text "Breakpoint" <+> ppr identity <+>
1979 text "does not exist")
1981 mapM (turnOffBreak.snd) this
1982 setGHCiState $ st { breaks = rest }
1984 turnOffBreak loc = do
1985 (arr, _) <- getModBreak (breakModule loc)
1986 io $ setBreakFlag False arr (breakTick loc)
1988 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1989 getModBreak mod = do
1990 session <- getSession
1991 Just mod_info <- io $ GHC.getModuleInfo session mod
1992 let modBreaks = GHC.modInfoModBreaks mod_info
1993 let array = GHC.modBreaks_flags modBreaks
1994 let ticks = GHC.modBreaks_locs modBreaks
1995 return (array, ticks)
1997 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1998 setBreakFlag toggle array index
1999 | toggle = GHC.setBreakOn array index
2000 | otherwise = GHC.setBreakOff array index