1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
18 #include "HsVersions.h"
26 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
27 Type, Module, ModuleName, TyThing(..), Phase,
28 BreakIndex, SrcSpan, Resume, SingleStep )
33 import HscTypes ( implicitTyThings )
35 import Outputable hiding (printForUser)
36 import Module -- for ModuleEnv
40 -- Other random utilities
42 import BasicTypes hiding (isTopLevel)
43 import Panic hiding (showException)
49 import Maybes ( orElse )
52 #ifndef mingw32_HOST_OS
53 import System.Posix hiding (getEnv)
55 import GHC.ConsoleHandler ( flushConsole )
56 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
57 import qualified System.Win32
61 import Control.Concurrent ( yield ) -- Used in readline loop
62 import System.Console.Readline as Readline
67 import Control.Exception as Exception
68 -- import Control.Concurrent
70 import qualified Data.ByteString.Char8 as BS
74 import System.Environment
75 import System.Exit ( exitWith, ExitCode(..) )
76 import System.Directory
78 import System.IO.Error as IO
82 import Control.Monad as Monad
85 import Foreign.StablePtr ( newStablePtr )
86 import GHC.Exts ( unsafeCoerce# )
87 import GHC.IOBase ( IOErrorType(InvalidArgument) )
89 import Data.IORef ( IORef, readIORef, writeIORef )
91 import System.Posix.Internals ( setNonBlockingFD )
93 -----------------------------------------------------------------------------
95 ghciWelcomeMsg :: String
96 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
97 ": http://www.haskell.org/ghc/ :? for help"
99 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
100 cmdName (n,_,_,_) = n
102 GLOBAL_VAR(commands, builtin_commands, [Command])
104 builtin_commands :: [Command]
106 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
107 ("?", keepGoing help, False, completeNone),
108 ("add", keepGoingPaths addModule, False, completeFilename),
109 ("abandon", keepGoing abandonCmd, False, completeNone),
110 ("break", keepGoing breakCmd, False, completeIdentifier),
111 ("back", keepGoing backCmd, False, completeNone),
112 ("browse", keepGoing browseCmd, False, completeModule),
113 ("cd", keepGoing changeDirectory, False, completeFilename),
114 ("check", keepGoing checkModule, False, completeHomeModule),
115 ("continue", keepGoing continueCmd, False, completeNone),
116 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
117 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
118 ("def", keepGoing defineMacro, False, completeIdentifier),
119 ("delete", keepGoing deleteCmd, False, completeNone),
120 ("e", keepGoing editFile, False, completeFilename),
121 ("edit", keepGoing editFile, False, completeFilename),
122 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
123 ("force", keepGoing forceCmd, False, completeIdentifier),
124 ("forward", keepGoing forwardCmd, False, completeNone),
125 ("help", keepGoing help, False, completeNone),
126 ("history", keepGoing historyCmd, False, completeNone),
127 ("info", keepGoing info, False, completeIdentifier),
128 ("kind", keepGoing kindOfType, False, completeIdentifier),
129 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
130 ("list", keepGoing listCmd, False, completeNone),
131 ("module", keepGoing setContext, False, completeModule),
132 ("main", keepGoing runMain, False, completeIdentifier),
133 ("print", keepGoing printCmd, False, completeIdentifier),
134 ("quit", quit, False, completeNone),
135 ("reload", keepGoing reloadModule, False, completeNone),
136 ("set", keepGoing setCmd, True, completeSetOptions),
137 ("show", keepGoing showCmd, False, completeNone),
138 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
139 ("step", keepGoing stepCmd, False, completeIdentifier),
140 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
141 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
142 ("type", keepGoing typeOfExpr, False, completeIdentifier),
143 ("trace", keepGoing traceCmd, False, completeIdentifier),
144 ("undef", keepGoing undefineMacro, False, completeMacro),
145 ("unset", keepGoing unsetOptions, True, completeSetOptions)
148 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
149 keepGoing a str = a str >> return False
151 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
152 keepGoingPaths a str = a (toArgs str) >> return False
154 shortHelpText = "use :? for help.\n"
157 " Commands available from the prompt:\n" ++
159 " <statement> evaluate/run <statement>\n" ++
160 " :add <filename> ... add module(s) to the current target set\n" ++
161 " :browse [*]<module> display the names defined by <module>\n" ++
162 " :cd <dir> change directory to <dir>\n" ++
163 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
164 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
165 " :def <cmd> <expr> define a command :<cmd>\n" ++
166 " :edit <file> edit file\n" ++
167 " :edit edit last module\n" ++
168 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
169 " :help, :? display this list of commands\n" ++
170 " :info [<name> ...] display information about the given names\n" ++
171 " :kind <type> show the kind of <type>\n" ++
172 " :load <filename> ... load module(s) and their dependents\n" ++
173 " :main [<arguments> ...] run the main function with the given arguments\n" ++
174 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
175 " :quit exit GHCi\n" ++
176 " :reload reload the current module set\n" ++
177 " :type <expr> show the type of <expr>\n" ++
178 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
179 " :!<command> run the shell command <command>\n" ++
181 " -- Commands for debugging:\n" ++
183 " :abandon at a breakpoint, abandon current computation\n" ++
184 " :back go back in the history (after :trace)\n" ++
185 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
186 " :break <name> set a breakpoint on the specified function\n" ++
187 " :continue resume after a breakpoint\n" ++
188 " :delete <number> delete the specified breakpoint\n" ++
189 " :delete * delete all breakpoints\n" ++
190 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
191 " :forward go forward in the history (after :back)\n" ++
192 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
193 " :print [<name> ...] prints a value without forcing its computation\n" ++
194 " :sprint [<name> ...] simplifed version of :print\n" ++
195 " :step single-step after stopping at a breakpoint\n"++
196 " :step <expr> single-step into <expr>\n"++
197 " :steplocal single-step restricted to the current top level decl.\n"++
198 " :stepmodule single-step restricted to the current module\n"++
199 " :trace trace after stopping at a breakpoint\n"++
200 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
203 " -- Commands for changing settings:\n" ++
205 " :set <option> ... set options\n" ++
206 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
207 " :set prog <progname> set the value returned by System.getProgName\n" ++
208 " :set prompt <prompt> set the prompt used in GHCi\n" ++
209 " :set editor <cmd> set the command used for :edit\n" ++
210 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
211 " :unset <option> ... unset options\n" ++
213 " Options for ':set' and ':unset':\n" ++
215 " +r revert top-level expressions after each evaluation\n" ++
216 " +s print timing/memory stats after each evaluation\n" ++
217 " +t print type after evaluation\n" ++
218 " -<flags> most GHC command line flags can also be set here\n" ++
219 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
221 " -- Commands for displaying information:\n" ++
223 " :show bindings show the current bindings made at the prompt\n" ++
224 " :show breaks show the active breakpoints\n" ++
225 " :show context show the breakpoint context\n" ++
226 " :show modules show the currently loaded modules\n" ++
227 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
234 win <- System.Win32.getWindowsDirectory
235 return (win `joinFileName` "notepad.exe")
240 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
241 interactiveUI session srcs maybe_expr = do
242 -- HACK! If we happen to get into an infinite loop (eg the user
243 -- types 'let x=x in x' at the prompt), then the thread will block
244 -- on a blackhole, and become unreachable during GC. The GC will
245 -- detect that it is unreachable and send it the NonTermination
246 -- exception. However, since the thread is unreachable, everything
247 -- it refers to might be finalized, including the standard Handles.
248 -- This sounds like a bug, but we don't have a good solution right
254 -- Initialise buffering for the *interpreted* I/O system
255 initInterpBuffering session
257 when (isNothing maybe_expr) $ do
258 -- Only for GHCi (not runghc and ghc -e):
260 -- Turn buffering off for the compiled program's stdout/stderr
262 -- Turn buffering off for GHCi's stdout
264 hSetBuffering stdout NoBuffering
265 -- We don't want the cmd line to buffer any input that might be
266 -- intended for the program, so unbuffer stdin.
267 hSetBuffering stdin NoBuffering
269 -- initial context is just the Prelude
270 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
271 GHC.setContext session [] [prel_mod]
275 Readline.setAttemptedCompletionFunction (Just completeWord)
276 --Readline.parseAndBind "set show-all-if-ambiguous 1"
278 let symbols = "!#$%&*+/<=>?@\\^|-~"
279 specials = "(),;[]`{}"
281 word_break_chars = spaces ++ specials ++ symbols
283 Readline.setBasicWordBreakCharacters word_break_chars
284 Readline.setCompleterWordBreakCharacters word_break_chars
287 default_editor <- findEditor
289 startGHCi (runGHCi srcs maybe_expr)
290 GHCiState{ progname = "<interactive>",
294 editor = default_editor,
300 tickarrays = emptyModuleEnv,
305 Readline.resetTerminal Nothing
310 prel_name = GHC.mkModuleName "Prelude"
312 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
313 runGHCi paths maybe_expr = do
314 let read_dot_files = not opt_IgnoreDotGhci
316 when (read_dot_files) $ do
319 exists <- io (doesFileExist file)
321 dir_ok <- io (checkPerms ".")
322 file_ok <- io (checkPerms file)
323 when (dir_ok && file_ok) $ do
324 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
327 Right hdl -> fileLoop hdl False
329 when (read_dot_files) $ do
330 -- Read in $HOME/.ghci
331 either_dir <- io (IO.try (getEnv "HOME"))
335 cwd <- io (getCurrentDirectory)
336 when (dir /= cwd) $ do
337 let file = dir ++ "/.ghci"
338 ok <- io (checkPerms file)
340 either_hdl <- io (IO.try (openFile file ReadMode))
343 Right hdl -> fileLoop hdl False
345 -- Perform a :load for files given on the GHCi command line
346 -- When in -e mode, if the load fails then we want to stop
347 -- immediately rather than going on to evaluate the expression.
348 when (not (null paths)) $ do
349 ok <- ghciHandle (\e -> do showException e; return Failed) $
351 when (isJust maybe_expr && failed ok) $
352 io (exitWith (ExitFailure 1))
354 -- if verbosity is greater than 0, or we are connected to a
355 -- terminal, display the prompt in the interactive loop.
356 is_tty <- io (hIsTerminalDevice stdin)
357 dflags <- getDynFlags
358 let show_prompt = verbosity dflags > 0 || is_tty
363 #if defined(mingw32_HOST_OS)
364 -- The win32 Console API mutates the first character of
365 -- type-ahead when reading from it in a non-buffered manner. Work
366 -- around this by flushing the input buffer of type-ahead characters,
367 -- but only if stdin is available.
368 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
370 Left err | isDoesNotExistError err -> return ()
371 | otherwise -> io (ioError err)
372 Right () -> return ()
374 -- initialise the console if necessary
377 -- enter the interactive loop
378 interactiveLoop is_tty show_prompt
380 -- just evaluate the expression we were given
385 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
388 interactiveLoop is_tty show_prompt =
389 -- Ignore ^C exceptions caught here
390 ghciHandleDyn (\e -> case e of
392 #if defined(mingw32_HOST_OS)
395 interactiveLoop is_tty show_prompt
396 _other -> return ()) $
398 ghciUnblock $ do -- unblock necessary if we recursed from the
399 -- exception handler above.
401 -- read commands from stdin
405 else fileLoop stdin show_prompt
407 fileLoop stdin show_prompt
411 -- NOTE: We only read .ghci files if they are owned by the current user,
412 -- and aren't world writable. Otherwise, we could be accidentally
413 -- running code planted by a malicious third party.
415 -- Furthermore, We only read ./.ghci if . is owned by the current user
416 -- and isn't writable by anyone else. I think this is sufficient: we
417 -- don't need to check .. and ../.. etc. because "." always refers to
418 -- the same directory while a process is running.
420 checkPerms :: String -> IO Bool
422 #ifdef mingw32_HOST_OS
425 Util.handle (\_ -> return False) $ do
426 st <- getFileStatus name
428 if fileOwner st /= me then do
429 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
432 let mode = fileMode st
433 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
434 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
436 putStrLn $ "*** WARNING: " ++ name ++
437 " is writable by someone else, IGNORING!"
442 fileLoop :: Handle -> Bool -> GHCi ()
443 fileLoop hdl show_prompt = do
444 when show_prompt $ do
447 l <- io (IO.try (hGetLine hdl))
449 Left e | isEOFError e -> return ()
450 | InvalidArgument <- etype -> return ()
451 | otherwise -> io (ioError e)
452 where etype = ioeGetErrorType e
453 -- treat InvalidArgument in the same way as EOF:
454 -- this can happen if the user closed stdin, or
455 -- perhaps did getContents which closes stdin at
458 case removeSpaces l of
459 "" -> fileLoop hdl show_prompt
460 l -> do quit <- runCommands l
461 if quit then return () else fileLoop hdl show_prompt
464 session <- getSession
465 (toplevs,exports) <- io (GHC.getContext session)
466 resumes <- io $ GHC.getResumeContext session
472 let ix = GHC.resumeHistoryIx r
474 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
476 let hist = GHC.resumeHistory r !! (ix-1)
477 span <- io$ GHC.getHistorySpan session hist
478 return (brackets (ppr (negate ix) <> char ':'
479 <+> ppr span) <> space)
481 dots | r:rs <- resumes, not (null rs) = text "... "
485 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
486 hsep (map (ppr . GHC.moduleName) exports)
488 deflt_prompt = dots <> context_bit <> modules_bit
490 f ('%':'s':xs) = deflt_prompt <> f xs
491 f ('%':'%':xs) = char '%' <> f xs
492 f (x:xs) = char x <> f xs
496 return (showSDoc (f (prompt st)))
500 readlineLoop :: GHCi ()
502 session <- getSession
503 (mod,imports) <- io (GHC.getContext session)
505 saveSession -- for use by completion
507 mb_span <- getCurrentBreakSpan
509 l <- io (readline prompt `finally` setNonBlockingFD 0)
510 -- readline sometimes puts stdin into blocking mode,
511 -- so we need to put it back for the IO library
516 case removeSpaces l of
520 quit <- runCommands l
521 if quit then return () else readlineLoop
524 runCommands :: String -> GHCi Bool
526 q <- ghciHandle handler (doCommand cmd)
527 if q then return True else runNext
533 c:cs -> do setGHCiState st{ cmdqueue = cs }
536 doCommand (':' : cmd) = specialCommand cmd
537 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
540 enqueueCommands :: [String] -> GHCi ()
541 enqueueCommands cmds = do
543 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
546 -- This version is for the GHC command-line option -e. The only difference
547 -- from runCommand is that it catches the ExitException exception and
548 -- exits, rather than printing out the exception.
549 runCommandEval c = ghciHandle handleEval (doCommand c)
551 handleEval (ExitException code) = io (exitWith code)
552 handleEval e = do handler e
553 io (exitWith (ExitFailure 1))
555 doCommand (':' : command) = specialCommand command
557 = do r <- runStmt stmt GHC.RunToCompletion
559 False -> io (exitWith (ExitFailure 1))
560 -- failure to run the command causes exit(1) for ghc -e.
563 runStmt :: String -> SingleStep -> GHCi Bool
565 | null (filter (not.isSpace) stmt) = return False
566 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
568 = do st <- getGHCiState
569 session <- getSession
570 result <- io $ withProgName (progname st) $ withArgs (args st) $
571 GHC.runStmt session stmt step
572 afterRunStmt (const True) result
575 --afterRunStmt :: GHC.RunResult -> GHCi Bool
576 -- False <=> the statement failed to compile
577 afterRunStmt _ (GHC.RunException e) = throw e
578 afterRunStmt step_here run_result = do
579 session <- getSession
580 resumes <- io $ GHC.getResumeContext session
582 GHC.RunOk names -> do
583 show_types <- isOptionSet ShowType
584 when show_types $ printTypeOfNames session names
585 GHC.RunBreak _ names mb_info
586 | isNothing mb_info ||
587 step_here (GHC.resumeSpan $ head resumes) -> do
588 printForUser $ ptext SLIT("Stopped at") <+>
589 ppr (GHC.resumeSpan $ head resumes)
590 -- printTypeOfNames session names
591 printTypeAndContentOfNames session names
592 maybe (return ()) runBreakCmd mb_info
593 -- run the command set with ":set stop <cmd>"
595 enqueueCommands [stop st]
597 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
598 afterRunStmt step_here >> return ()
602 io installSignalHandlers
603 b <- isOptionSet RevertCAFs
604 io (when b revertCAFs)
606 return (case run_result of GHC.RunOk _ -> True; _ -> False)
608 where printTypeAndContentOfNames session names = do
609 let namesSorted = sortBy compareNames names
610 tythings <- catMaybes `liftM`
611 io (mapM (GHC.lookupName session) namesSorted)
612 docs_ty <- mapM showTyThing tythings
613 terms <- mapM (io . GHC.obtainTermB session 10 False)
614 [ id | (AnId id, Just _) <- zip tythings docs_ty]
615 docs_terms <- mapM (io . showTerm session) terms
616 printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts)
620 runBreakCmd :: GHC.BreakInfo -> GHCi ()
621 runBreakCmd info = do
622 let mod = GHC.breakInfo_module info
623 nm = GHC.breakInfo_number info
625 case [ loc | (i,loc) <- breaks st,
626 breakModule loc == mod, breakTick loc == nm ] of
628 loc:_ | null cmd -> return ()
629 | otherwise -> do enqueueCommands [cmd]; return ()
630 where cmd = onBreakCmd loc
632 printTypeOfNames :: Session -> [Name] -> GHCi ()
633 printTypeOfNames session names
634 = mapM_ (printTypeOfName session) $ sortBy compareNames names
636 compareNames :: Name -> Name -> Ordering
637 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
638 where compareWith n = (getOccString n, getSrcSpan n)
640 printTypeOfName :: Session -> Name -> GHCi ()
641 printTypeOfName session n
642 = do maybe_tything <- io (GHC.lookupName session n)
643 case maybe_tything of
645 Just thing -> printTyThing thing
647 specialCommand :: String -> GHCi Bool
648 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
649 specialCommand str = do
650 let (cmd,rest) = break isSpace str
651 maybe_cmd <- io (lookupCommand cmd)
653 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
654 ++ shortHelpText) >> return False)
655 Just (_,f,_,_) -> f (dropWhile isSpace rest)
657 lookupCommand :: String -> IO (Maybe Command)
658 lookupCommand str = do
659 cmds <- readIORef commands
660 -- look for exact match first, then the first prefix match
661 case [ c | c <- cmds, str == cmdName c ] of
662 c:_ -> return (Just c)
663 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
665 c:_ -> return (Just c)
668 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
669 getCurrentBreakSpan = do
670 session <- getSession
671 resumes <- io $ GHC.getResumeContext session
675 let ix = GHC.resumeHistoryIx r
677 then return (Just (GHC.resumeSpan r))
679 let hist = GHC.resumeHistory r !! (ix-1)
680 span <- io $ GHC.getHistorySpan session hist
683 getCurrentBreakModule :: GHCi (Maybe Module)
684 getCurrentBreakModule = do
685 session <- getSession
686 resumes <- io $ GHC.getResumeContext session
690 let ix = GHC.resumeHistoryIx r
692 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
694 let hist = GHC.resumeHistory r !! (ix-1)
695 return $ Just $ GHC.getHistoryModule hist
697 -----------------------------------------------------------------------------
700 noArgs :: GHCi () -> String -> GHCi ()
702 noArgs m _ = io $ putStrLn "This command takes no arguments"
704 help :: String -> GHCi ()
705 help _ = io (putStr helpText)
707 info :: String -> GHCi ()
708 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
709 info s = do { let names = words s
710 ; session <- getSession
711 ; dflags <- getDynFlags
712 ; let pefas = dopt Opt_PrintExplicitForalls dflags
713 ; mapM_ (infoThing pefas session) names }
715 infoThing pefas session str = io $ do
716 names <- GHC.parseName session str
717 mb_stuffs <- mapM (GHC.getInfo session) names
718 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
719 unqual <- GHC.getPrintUnqual session
720 putStrLn (showSDocForUser unqual $
721 vcat (intersperse (text "") $
722 map (pprInfo pefas) filtered))
724 -- Filter out names whose parent is also there Good
725 -- example is '[]', which is both a type and data
726 -- constructor in the same type
727 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
728 filterOutChildren get_thing xs
729 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
731 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
733 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
734 pprInfo pefas (thing, fixity, insts)
735 = pprTyThingInContextLoc pefas thing
736 $$ show_fixity fixity
737 $$ vcat (map GHC.pprInstance insts)
740 | fix == GHC.defaultFixity = empty
741 | otherwise = ppr fix <+> ppr (GHC.getName thing)
743 runMain :: String -> GHCi ()
745 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
746 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
748 addModule :: [FilePath] -> GHCi ()
750 io (revertCAFs) -- always revert CAFs on load/add.
751 files <- mapM expandPath files
752 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
753 session <- getSession
754 io (mapM_ (GHC.addTarget session) targets)
755 ok <- io (GHC.load session LoadAllTargets)
758 changeDirectory :: String -> GHCi ()
759 changeDirectory dir = do
760 session <- getSession
761 graph <- io (GHC.getModuleGraph session)
762 when (not (null graph)) $
763 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
764 io (GHC.setTargets session [])
765 io (GHC.load session LoadAllTargets)
766 setContextAfterLoad session []
767 io (GHC.workingDirectoryChanged session)
768 dir <- expandPath dir
769 io (setCurrentDirectory dir)
771 editFile :: String -> GHCi ()
773 do file <- if null str then chooseEditFile else return str
777 $ throwDyn (CmdLineError "editor not set, use :set editor")
778 io $ system (cmd ++ ' ':file)
781 -- The user didn't specify a file so we pick one for them.
782 -- Our strategy is to pick the first module that failed to load,
783 -- or otherwise the first target.
785 -- XXX: Can we figure out what happened if the depndecy analysis fails
786 -- (e.g., because the porgrammeer mistyped the name of a module)?
787 -- XXX: Can we figure out the location of an error to pass to the editor?
788 -- XXX: if we could figure out the list of errors that occured during the
789 -- last load/reaload, then we could start the editor focused on the first
791 chooseEditFile :: GHCi String
793 do session <- getSession
794 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
796 graph <- io (GHC.getModuleGraph session)
797 failed_graph <- filterM hasFailed graph
798 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
800 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
803 case pick (order failed_graph) of
804 Just file -> return file
806 do targets <- io (GHC.getTargets session)
807 case msum (map fromTarget targets) of
808 Just file -> return file
809 Nothing -> throwDyn (CmdLineError "No files to edit.")
811 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
812 fromTarget _ = Nothing -- when would we get a module target?
814 defineMacro :: String -> GHCi ()
816 let (macro_name, definition) = break isSpace s
817 cmds <- io (readIORef commands)
819 then throwDyn (CmdLineError "invalid macro name")
821 if (macro_name `elem` map cmdName cmds)
822 then throwDyn (CmdLineError
823 ("command '" ++ macro_name ++ "' is already defined"))
826 -- give the expression a type signature, so we can be sure we're getting
827 -- something of the right type.
828 let new_expr = '(' : definition ++ ") :: String -> IO String"
830 -- compile the expression
832 maybe_hv <- io (GHC.compileExpr cms new_expr)
835 Just hv -> io (writeIORef commands --
836 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
838 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
840 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
841 enqueueCommands (lines str)
844 undefineMacro :: String -> GHCi ()
845 undefineMacro macro_name = do
846 cmds <- io (readIORef commands)
847 if (macro_name `elem` map cmdName builtin_commands)
848 then throwDyn (CmdLineError
849 ("command '" ++ macro_name ++ "' cannot be undefined"))
851 if (macro_name `notElem` map cmdName cmds)
852 then throwDyn (CmdLineError
853 ("command '" ++ macro_name ++ "' not defined"))
855 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
857 cmdCmd :: String -> GHCi ()
859 let expr = '(' : str ++ ") :: IO String"
860 session <- getSession
861 maybe_hv <- io (GHC.compileExpr session expr)
865 cmds <- io $ (unsafeCoerce# hv :: IO String)
866 enqueueCommands (lines cmds)
869 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
870 loadModule fs = timeIt (loadModule' fs)
872 loadModule_ :: [FilePath] -> GHCi ()
873 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
875 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
876 loadModule' files = do
877 session <- getSession
880 discardActiveBreakPoints
881 io (GHC.setTargets session [])
882 io (GHC.load session LoadAllTargets)
885 let (filenames, phases) = unzip files
886 exp_filenames <- mapM expandPath filenames
887 let files' = zip exp_filenames phases
888 targets <- io (mapM (uncurry GHC.guessTarget) files')
890 -- NOTE: we used to do the dependency anal first, so that if it
891 -- fails we didn't throw away the current set of modules. This would
892 -- require some re-working of the GHC interface, so we'll leave it
893 -- as a ToDo for now.
895 io (GHC.setTargets session targets)
896 doLoad session LoadAllTargets
898 checkModule :: String -> GHCi ()
900 let modl = GHC.mkModuleName m
901 session <- getSession
902 result <- io (GHC.checkModule session modl False)
904 Nothing -> io $ putStrLn "Nothing"
905 Just r -> io $ putStrLn (showSDoc (
906 case GHC.checkedModuleInfo r of
907 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
909 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
911 (text "global names: " <+> ppr global) $$
912 (text "local names: " <+> ppr local)
914 afterLoad (successIf (isJust result)) session
916 reloadModule :: String -> GHCi ()
918 session <- getSession
919 doLoad session $ if null m then LoadAllTargets
920 else LoadUpTo (GHC.mkModuleName m)
923 doLoad session howmuch = do
924 -- turn off breakpoints before we load: we can't turn them off later, because
925 -- the ModBreaks will have gone away.
926 discardActiveBreakPoints
927 ok <- io (GHC.load session howmuch)
931 afterLoad ok session = do
932 io (revertCAFs) -- always revert CAFs on load.
934 graph <- io (GHC.getModuleGraph session)
935 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
936 setContextAfterLoad session graph'
937 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
939 setContextAfterLoad session [] = do
940 prel_mod <- getPrelude
941 io (GHC.setContext session [] [prel_mod])
942 setContextAfterLoad session ms = do
943 -- load a target if one is available, otherwise load the topmost module.
944 targets <- io (GHC.getTargets session)
945 case [ m | Just m <- map (findTarget ms) targets ] of
947 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
948 load_this (last graph')
953 = case filter (`matches` t) ms of
957 summary `matches` Target (TargetModule m) _
958 = GHC.ms_mod_name summary == m
959 summary `matches` Target (TargetFile f _) _
960 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
961 summary `matches` target
964 load_this summary | m <- GHC.ms_mod summary = do
965 b <- io (GHC.moduleIsInterpreted session m)
966 if b then io (GHC.setContext session [m] [])
968 prel_mod <- getPrelude
969 io (GHC.setContext session [] [prel_mod,m])
972 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
973 modulesLoadedMsg ok mods = do
974 dflags <- getDynFlags
975 when (verbosity dflags > 0) $ do
977 | null mods = text "none."
979 punctuate comma (map ppr mods)) <> text "."
982 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
984 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
987 typeOfExpr :: String -> GHCi ()
989 = do cms <- getSession
990 maybe_ty <- io (GHC.exprType cms str)
993 Just ty -> do ty' <- cleanType ty
994 printForUser $ text str <> text " :: " <> ppr ty'
996 kindOfType :: String -> GHCi ()
998 = do cms <- getSession
999 maybe_ty <- io (GHC.typeKind cms str)
1001 Nothing -> return ()
1002 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
1004 quit :: String -> GHCi Bool
1005 quit _ = return True
1007 shellEscape :: String -> GHCi Bool
1008 shellEscape str = io (system str >> return False)
1010 -----------------------------------------------------------------------------
1011 -- Browsing a module's contents
1013 browseCmd :: String -> GHCi ()
1016 ['*':m] | looksLikeModuleName m -> browseModule m False
1017 [m] | looksLikeModuleName m -> browseModule m True
1018 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1020 browseModule m exports_only = do
1022 modl <- if exports_only then lookupModule m
1023 else wantInterpretedModule m
1025 -- Temporarily set the context to the module we're interested in,
1026 -- just so we can get an appropriate PrintUnqualified
1027 (as,bs) <- io (GHC.getContext s)
1028 prel_mod <- getPrelude
1029 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1030 else GHC.setContext s [modl] [])
1031 unqual <- io (GHC.getPrintUnqual s)
1032 io (GHC.setContext s as bs)
1034 mb_mod_info <- io $ GHC.getModuleInfo s modl
1036 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1039 | exports_only = GHC.modInfoExports mod_info
1040 | otherwise = GHC.modInfoTopLevelScope mod_info
1043 mb_things <- io $ mapM (GHC.lookupName s) names
1044 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1046 dflags <- getDynFlags
1047 let pefas = dopt Opt_PrintExplicitForalls dflags
1048 io (putStrLn (showSDocForUser unqual (
1049 vcat (map (pprTyThingInContext pefas) filtered_things)
1051 -- ToDo: modInfoInstances currently throws an exception for
1052 -- package modules. When it works, we can do this:
1053 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1055 -----------------------------------------------------------------------------
1056 -- Setting the module context
1059 | all sensible mods = fn mods
1060 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1062 (fn, mods) = case str of
1063 '+':stuff -> (addToContext, words stuff)
1064 '-':stuff -> (removeFromContext, words stuff)
1065 stuff -> (newContext, words stuff)
1067 sensible ('*':m) = looksLikeModuleName m
1068 sensible m = looksLikeModuleName m
1070 separate :: Session -> [String] -> [Module] -> [Module]
1071 -> GHCi ([Module],[Module])
1072 separate session [] as bs = return (as,bs)
1073 separate session (('*':str):ms) as bs = do
1074 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1075 b <- io $ GHC.moduleIsInterpreted session m
1076 if b then separate session ms (m:as) bs
1077 else throwDyn (CmdLineError ("module '"
1078 ++ GHC.moduleNameString (GHC.moduleName m)
1079 ++ "' is not interpreted"))
1080 separate session (str:ms) as bs = do
1081 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1082 separate session ms as (m:bs)
1084 newContext :: [String] -> GHCi ()
1085 newContext strs = do
1087 (as,bs) <- separate s strs [] []
1088 prel_mod <- getPrelude
1089 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1090 io $ GHC.setContext s as bs'
1093 addToContext :: [String] -> GHCi ()
1094 addToContext strs = do
1096 (as,bs) <- io $ GHC.getContext s
1098 (new_as,new_bs) <- separate s strs [] []
1100 let as_to_add = new_as \\ (as ++ bs)
1101 bs_to_add = new_bs \\ (as ++ bs)
1103 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1106 removeFromContext :: [String] -> GHCi ()
1107 removeFromContext strs = do
1109 (as,bs) <- io $ GHC.getContext s
1111 (as_to_remove,bs_to_remove) <- separate s strs [] []
1113 let as' = as \\ (as_to_remove ++ bs_to_remove)
1114 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1116 io $ GHC.setContext s as' bs'
1118 ----------------------------------------------------------------------------
1121 -- set options in the interpreter. Syntax is exactly the same as the
1122 -- ghc command line, except that certain options aren't available (-C,
1125 -- This is pretty fragile: most options won't work as expected. ToDo:
1126 -- figure out which ones & disallow them.
1128 setCmd :: String -> GHCi ()
1130 = do st <- getGHCiState
1131 let opts = options st
1132 io $ putStrLn (showSDoc (
1133 text "options currently set: " <>
1136 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1139 = case toArgs str of
1140 ("args":args) -> setArgs args
1141 ("prog":prog) -> setProg prog
1142 ("prompt":prompt) -> setPrompt (after 6)
1143 ("editor":cmd) -> setEditor (after 6)
1144 ("stop":cmd) -> setStop (after 4)
1145 wds -> setOptions wds
1146 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1150 setGHCiState st{ args = args }
1154 setGHCiState st{ progname = prog }
1156 io (hPutStrLn stderr "syntax: :set prog <progname>")
1160 setGHCiState st{ editor = cmd }
1162 setStop str@(c:_) | isDigit c
1163 = do let (nm_str,rest) = break (not.isDigit) str
1166 let old_breaks = breaks st
1167 if all ((/= nm) . fst) old_breaks
1168 then printForUser (text "Breakpoint" <+> ppr nm <+>
1169 text "does not exist")
1171 let new_breaks = map fn old_breaks
1172 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1173 | otherwise = (i,loc)
1174 setGHCiState st{ breaks = new_breaks }
1177 setGHCiState st{ stop = cmd }
1179 setPrompt value = do
1182 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1183 else setGHCiState st{ prompt = remQuotes value }
1185 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1189 do -- first, deal with the GHCi opts (+s, +t, etc.)
1190 let (plus_opts, minus_opts) = partition isPlus wds
1191 mapM_ setOpt plus_opts
1192 -- then, dynamic flags
1193 newDynFlags minus_opts
1195 newDynFlags minus_opts = do
1196 dflags <- getDynFlags
1197 let pkg_flags = packageFlags dflags
1198 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1200 if (not (null leftovers))
1201 then throwDyn (CmdLineError ("unrecognised flags: " ++
1205 new_pkgs <- setDynFlags dflags'
1207 -- if the package flags changed, we should reset the context
1208 -- and link the new packages.
1209 dflags <- getDynFlags
1210 when (packageFlags dflags /= pkg_flags) $ do
1211 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1212 session <- getSession
1213 io (GHC.setTargets session [])
1214 io (GHC.load session LoadAllTargets)
1215 io (linkPackages dflags new_pkgs)
1216 setContextAfterLoad session []
1220 unsetOptions :: String -> GHCi ()
1222 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1223 let opts = words str
1224 (minus_opts, rest1) = partition isMinus opts
1225 (plus_opts, rest2) = partition isPlus rest1
1227 if (not (null rest2))
1228 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1231 mapM_ unsetOpt plus_opts
1233 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1234 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1236 no_flags <- mapM no_flag minus_opts
1237 newDynFlags no_flags
1239 isMinus ('-':s) = True
1242 isPlus ('+':s) = True
1246 = case strToGHCiOpt str of
1247 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1248 Just o -> setOption o
1251 = case strToGHCiOpt str of
1252 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1253 Just o -> unsetOption o
1255 strToGHCiOpt :: String -> (Maybe GHCiOption)
1256 strToGHCiOpt "s" = Just ShowTiming
1257 strToGHCiOpt "t" = Just ShowType
1258 strToGHCiOpt "r" = Just RevertCAFs
1259 strToGHCiOpt _ = Nothing
1261 optToStr :: GHCiOption -> String
1262 optToStr ShowTiming = "s"
1263 optToStr ShowType = "t"
1264 optToStr RevertCAFs = "r"
1266 -- ---------------------------------------------------------------------------
1272 ["args"] -> io $ putStrLn (show (args st))
1273 ["prog"] -> io $ putStrLn (show (progname st))
1274 ["prompt"] -> io $ putStrLn (show (prompt st))
1275 ["editor"] -> io $ putStrLn (show (editor st))
1276 ["stop"] -> io $ putStrLn (show (stop st))
1277 ["modules" ] -> showModules
1278 ["bindings"] -> showBindings
1279 ["linker"] -> io showLinkerState
1280 ["breaks"] -> showBkptTable
1281 ["context"] -> showContext
1282 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1285 session <- getSession
1286 let show_one ms = do m <- io (GHC.showModule session ms)
1288 graph <- io (GHC.getModuleGraph session)
1289 mapM_ show_one graph
1293 unqual <- io (GHC.getPrintUnqual s)
1294 bindings <- io (GHC.getBindings s)
1295 mapM_ printTyThing $ sortBy compareTyThings bindings
1298 compareTyThings :: TyThing -> TyThing -> Ordering
1299 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1301 showTyThing :: TyThing -> GHCi (Maybe SDoc)
1302 showTyThing (AnId id) = do
1303 ty' <- cleanType (GHC.idType id)
1304 return $ Just $ ppr id <> text " :: " <> ppr ty'
1305 showTyThing _ = return Nothing
1307 printTyThing :: TyThing -> GHCi ()
1308 printTyThing tyth = do
1309 mb_x <- showTyThing tyth
1311 Just x -> printForUser x
1312 Nothing -> return ()
1314 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1315 cleanType :: Type -> GHCi Type
1317 dflags <- getDynFlags
1318 if dopt Opt_PrintExplicitForalls dflags
1320 else return $! GHC.dropForAlls ty
1322 showBkptTable :: GHCi ()
1325 printForUser $ prettyLocations (breaks st)
1327 showContext :: GHCi ()
1329 session <- getSession
1330 resumes <- io $ GHC.getResumeContext session
1331 printForUser $ vcat (map pp_resume (reverse resumes))
1334 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1335 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1338 -- -----------------------------------------------------------------------------
1341 completeNone :: String -> IO [String]
1342 completeNone w = return []
1345 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1346 completeWord w start end = do
1347 line <- Readline.getLineBuffer
1348 let line_words = words (dropWhile isSpace line)
1350 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1352 | ((':':c) : _) <- line_words -> do
1353 maybe_cmd <- lookupCommand c
1354 let (n,w') = selectWord (words' 0 line)
1356 Nothing -> return Nothing
1357 Just (_,_,False,complete) -> wrapCompleter complete w
1358 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1359 return (map (drop n) rets)
1360 in wrapCompleter complete' w'
1361 | ("import" : _) <- line_words ->
1362 wrapCompleter completeModule w
1364 --printf "complete %s, start = %d, end = %d\n" w start end
1365 wrapCompleter completeIdentifier w
1366 where words' _ [] = []
1367 words' n str = let (w,r) = break isSpace str
1368 (s,r') = span isSpace r
1369 in (n,w):words' (n+length w+length s) r'
1370 -- In a Haskell expression we want to parse 'a-b' as three words
1371 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1372 -- only be a single word.
1373 selectWord [] = (0,w)
1374 selectWord ((offset,x):xs)
1375 | offset+length x >= start = (start-offset,take (end-offset) x)
1376 | otherwise = selectWord xs
1380 cmds <- readIORef commands
1381 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1383 completeMacro w = do
1384 cmds <- readIORef commands
1385 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1386 return (filter (w `isPrefixOf`) cmds')
1388 completeIdentifier w = do
1390 rdrs <- GHC.getRdrNamesInScope s
1391 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1393 completeModule w = do
1395 dflags <- GHC.getSessionDynFlags s
1396 let pkg_mods = allExposedModules dflags
1397 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1399 completeHomeModule w = do
1401 g <- GHC.getModuleGraph s
1402 let home_mods = map GHC.ms_mod_name g
1403 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1405 completeSetOptions w = do
1406 return (filter (w `isPrefixOf`) options)
1407 where options = "args":"prog":allFlags
1409 completeFilename = Readline.filenameCompletionFunction
1411 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1413 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1414 unionComplete f1 f2 w = do
1419 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1420 wrapCompleter fun w = do
1423 [] -> return Nothing
1424 [x] -> return (Just (x,[]))
1425 xs -> case getCommonPrefix xs of
1426 "" -> return (Just ("",xs))
1427 pref -> return (Just (pref,xs))
1429 getCommonPrefix :: [String] -> String
1430 getCommonPrefix [] = ""
1431 getCommonPrefix (s:ss) = foldl common s ss
1432 where common s "" = ""
1434 common (c:cs) (d:ds)
1435 | c == d = c : common cs ds
1438 allExposedModules :: DynFlags -> [ModuleName]
1439 allExposedModules dflags
1440 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1442 pkg_db = pkgIdMap (pkgState dflags)
1444 completeCmd = completeNone
1445 completeMacro = completeNone
1446 completeIdentifier = completeNone
1447 completeModule = completeNone
1448 completeHomeModule = completeNone
1449 completeSetOptions = completeNone
1450 completeFilename = completeNone
1451 completeHomeModuleOrFile=completeNone
1452 completeBkpt = completeNone
1455 -- ---------------------------------------------------------------------------
1456 -- User code exception handling
1458 -- This is the exception handler for exceptions generated by the
1459 -- user's code and exceptions coming from children sessions;
1460 -- it normally just prints out the exception. The
1461 -- handler must be recursive, in case showing the exception causes
1462 -- more exceptions to be raised.
1464 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1465 -- raising another exception. We therefore don't put the recursive
1466 -- handler arond the flushing operation, so if stderr is closed
1467 -- GHCi will just die gracefully rather than going into an infinite loop.
1468 handler :: Exception -> GHCi Bool
1470 handler exception = do
1472 io installSignalHandlers
1473 ghciHandle handler (showException exception >> return False)
1475 showException (DynException dyn) =
1476 case fromDynamic dyn of
1477 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1478 Just Interrupted -> io (putStrLn "Interrupted.")
1479 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1480 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1481 Just other_ghc_ex -> io (print other_ghc_ex)
1483 showException other_exception
1484 = io (putStrLn ("*** Exception: " ++ show other_exception))
1486 -----------------------------------------------------------------------------
1487 -- recursive exception handlers
1489 -- Don't forget to unblock async exceptions in the handler, or if we're
1490 -- in an exception loop (eg. let a = error a in a) the ^C exception
1491 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1493 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1494 ghciHandle h (GHCi m) = GHCi $ \s ->
1495 Exception.catch (m s)
1496 (\e -> unGHCi (ghciUnblock (h e)) s)
1498 ghciUnblock :: GHCi a -> GHCi a
1499 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1502 -- ----------------------------------------------------------------------------
1505 expandPath :: String -> GHCi String
1507 case dropWhile isSpace path of
1509 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1510 return (tilde ++ '/':d)
1514 wantInterpretedModule :: String -> GHCi Module
1515 wantInterpretedModule str = do
1516 session <- getSession
1517 modl <- lookupModule str
1518 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1519 when (not is_interpreted) $
1520 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1523 wantNameFromInterpretedModule noCanDo str and_then = do
1524 session <- getSession
1525 names <- io $ GHC.parseName session str
1529 let modl = GHC.nameModule n
1530 if not (GHC.isExternalName n)
1531 then noCanDo n $ ppr n <>
1532 text " is not defined in an interpreted module"
1534 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1535 if not is_interpreted
1536 then noCanDo n $ text "module " <> ppr modl <>
1537 text " is not interpreted"
1540 -- ----------------------------------------------------------------------------
1541 -- Windows console setup
1543 setUpConsole :: IO ()
1545 #ifdef mingw32_HOST_OS
1546 -- On Windows we need to set a known code page, otherwise the characters
1547 -- we read from the console will be be in some strange encoding, and
1548 -- similarly for characters we write to the console.
1550 -- At the moment, GHCi pretends all input is Latin-1. In the
1551 -- future we should support UTF-8, but for now we set the code pages
1554 -- It seems you have to set the font in the console window to
1555 -- a Unicode font in order for output to work properly,
1556 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1557 -- (see MSDN for SetConsoleOutputCP()).
1559 setConsoleCP 28591 -- ISO Latin-1
1560 setConsoleOutputCP 28591 -- ISO Latin-1
1564 -- -----------------------------------------------------------------------------
1565 -- commands for debugger
1567 sprintCmd = pprintCommand False False
1568 printCmd = pprintCommand True False
1569 forceCmd = pprintCommand False True
1571 pprintCommand bind force str = do
1572 session <- getSession
1573 io $ pprintClosureCommand session bind force str
1575 stepCmd :: String -> GHCi ()
1576 stepCmd [] = doContinue (const True) GHC.SingleStep
1577 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1579 stepLocalCmd :: String -> GHCi ()
1580 stepLocalCmd [] = do
1581 mb_span <- getCurrentBreakSpan
1583 Nothing -> stepCmd []
1585 Just mod <- getCurrentBreakModule
1586 current_toplevel_decl <- enclosingTickSpan mod loc
1587 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1589 stepLocalCmd expression = stepCmd expression
1591 stepModuleCmd :: String -> GHCi ()
1592 stepModuleCmd [] = do
1593 mb_span <- getCurrentBreakSpan
1595 Nothing -> stepCmd []
1597 Just span <- getCurrentBreakSpan
1598 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1599 doContinue f GHC.SingleStep
1601 stepModuleCmd expression = stepCmd expression
1603 -- | Returns the span of the largest tick containing the srcspan given
1604 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1605 enclosingTickSpan mod src = do
1606 ticks <- getTickArray mod
1607 let line = srcSpanStartLine src
1608 ASSERT (inRange (bounds ticks) line) do
1609 let enclosing_spans = [ span | (_,span) <- ticks ! line
1610 , srcSpanEnd span >= srcSpanEnd src]
1611 return . head . sortBy leftmost_largest $ enclosing_spans
1613 traceCmd :: String -> GHCi ()
1614 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1615 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1617 continueCmd :: String -> GHCi ()
1618 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1620 -- doContinue :: SingleStep -> GHCi ()
1621 doContinue pred step = do
1622 session <- getSession
1623 runResult <- io $ GHC.resume session step
1624 afterRunStmt pred runResult
1627 abandonCmd :: String -> GHCi ()
1628 abandonCmd = noArgs $ do
1630 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1631 when (not b) $ io $ putStrLn "There is no computation running."
1634 deleteCmd :: String -> GHCi ()
1635 deleteCmd argLine = do
1636 deleteSwitch $ words argLine
1638 deleteSwitch :: [String] -> GHCi ()
1640 io $ putStrLn "The delete command requires at least one argument."
1641 -- delete all break points
1642 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1643 deleteSwitch idents = do
1644 mapM_ deleteOneBreak idents
1646 deleteOneBreak :: String -> GHCi ()
1648 | all isDigit str = deleteBreak (read str)
1649 | otherwise = return ()
1651 historyCmd :: String -> GHCi ()
1653 | null arg = history 20
1654 | all isDigit arg = history (read arg)
1655 | otherwise = io $ putStrLn "Syntax: :history [num]"
1659 resumes <- io $ GHC.getResumeContext s
1661 [] -> io $ putStrLn "Not stopped at a breakpoint"
1663 let hist = GHC.resumeHistory r
1664 (took,rest) = splitAt num hist
1665 spans <- mapM (io . GHC.getHistorySpan s) took
1666 let nums = map (printf "-%-3d:") [(1::Int)..]
1667 let names = map GHC.historyEnclosingDecl took
1668 printForUser (vcat(zipWith3
1669 (\x y z -> x <+> y <+> z)
1671 (map (bold . ppr) names)
1672 (map (parens . ppr) spans)))
1673 io $ putStrLn $ if null rest then "<end of history>" else "..."
1675 bold c | do_bold = text start_bold <> c <> text end_bold
1678 backCmd :: String -> GHCi ()
1679 backCmd = noArgs $ do
1681 (names, ix, span) <- io $ GHC.back s
1682 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1683 printTypeOfNames s names
1684 -- run the command set with ":set stop <cmd>"
1686 enqueueCommands [stop st]
1688 forwardCmd :: String -> GHCi ()
1689 forwardCmd = noArgs $ do
1691 (names, ix, span) <- io $ GHC.forward s
1692 printForUser $ (if (ix == 0)
1693 then ptext SLIT("Stopped at")
1694 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1695 printTypeOfNames s names
1696 -- run the command set with ":set stop <cmd>"
1698 enqueueCommands [stop st]
1700 -- handle the "break" command
1701 breakCmd :: String -> GHCi ()
1702 breakCmd argLine = do
1703 session <- getSession
1704 breakSwitch session $ words argLine
1706 breakSwitch :: Session -> [String] -> GHCi ()
1707 breakSwitch _session [] = do
1708 io $ putStrLn "The break command requires at least one argument."
1709 breakSwitch session args@(arg1:rest)
1710 | looksLikeModuleName arg1 = do
1711 mod <- wantInterpretedModule arg1
1712 breakByModule session mod rest
1713 | all isDigit arg1 = do
1714 (toplevel, _) <- io $ GHC.getContext session
1716 (mod : _) -> breakByModuleLine mod (read arg1) rest
1718 io $ putStrLn "Cannot find default module for breakpoint."
1719 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1720 | otherwise = do -- try parsing it as an identifier
1721 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1722 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1723 if GHC.isGoodSrcLoc loc
1724 then findBreakAndSet (GHC.nameModule name) $
1725 findBreakByCoord (Just (GHC.srcLocFile loc))
1726 (GHC.srcLocLine loc,
1728 else noCanDo name $ text "can't find its location: " <> ppr loc
1730 noCanDo n why = printForUser $
1731 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1733 breakByModule :: Session -> Module -> [String] -> GHCi ()
1734 breakByModule session mod args@(arg1:rest)
1735 | all isDigit arg1 = do -- looks like a line number
1736 breakByModuleLine mod (read arg1) rest
1737 breakByModule session mod _
1740 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1741 breakByModuleLine mod line args
1742 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1743 | [col] <- args, all isDigit col =
1744 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1745 | otherwise = breakSyntax
1747 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1749 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1750 findBreakAndSet mod lookupTickTree = do
1751 tickArray <- getTickArray mod
1752 (breakArray, _) <- getModBreak mod
1753 case lookupTickTree tickArray of
1754 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1755 Just (tick, span) -> do
1756 success <- io $ setBreakFlag True breakArray tick
1757 session <- getSession
1761 recordBreak $ BreakLocation
1768 text "Breakpoint " <> ppr nm <>
1770 then text " was already set at " <> ppr span
1771 else text " activated at " <> ppr span
1773 printForUser $ text "Breakpoint could not be activated at"
1776 -- When a line number is specified, the current policy for choosing
1777 -- the best breakpoint is this:
1778 -- - the leftmost complete subexpression on the specified line, or
1779 -- - the leftmost subexpression starting on the specified line, or
1780 -- - the rightmost subexpression enclosing the specified line
1782 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1783 findBreakByLine line arr
1784 | not (inRange (bounds arr) line) = Nothing
1786 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1787 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1788 listToMaybe (sortBy (rightmost `on` snd) ticks)
1792 starts_here = [ tick | tick@(nm,span) <- ticks,
1793 GHC.srcSpanStartLine span == line ]
1795 (complete,incomplete) = partition ends_here starts_here
1796 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1798 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1799 -> Maybe (BreakIndex,SrcSpan)
1800 findBreakByCoord mb_file (line, col) arr
1801 | not (inRange (bounds arr) line) = Nothing
1803 listToMaybe (sortBy (rightmost `on` snd) contains ++
1804 sortBy (leftmost_smallest `on` snd) after_here)
1808 -- the ticks that span this coordinate
1809 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1810 is_correct_file span ]
1812 is_correct_file span
1813 | Just f <- mb_file = GHC.srcSpanFile span == f
1816 after_here = [ tick | tick@(nm,span) <- ticks,
1817 GHC.srcSpanStartLine span == line,
1818 GHC.srcSpanStartCol span >= col ]
1820 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1821 -- of carets under the active expression instead. The Windows console
1822 -- doesn't support ANSI escape sequences, and most Unix terminals
1823 -- (including xterm) do, so this is a reasonable guess until we have a
1824 -- proper termcap/terminfo library.
1825 #if !defined(mingw32_TARGET_OS)
1831 start_bold = "\ESC[1m"
1832 end_bold = "\ESC[0m"
1834 listCmd :: String -> GHCi ()
1836 mb_span <- getCurrentBreakSpan
1838 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1839 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1840 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1841 listCmd str = list2 (words str)
1843 list2 [arg] | all isDigit arg = do
1844 session <- getSession
1845 (toplevel, _) <- io $ GHC.getContext session
1847 [] -> io $ putStrLn "No module to list"
1848 (mod : _) -> listModuleLine mod (read arg)
1849 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1850 mod <- wantInterpretedModule arg1
1851 listModuleLine mod (read arg2)
1853 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1854 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1855 if GHC.isGoodSrcLoc loc
1857 tickArray <- getTickArray (GHC.nameModule name)
1858 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1859 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1862 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1863 Just (_,span) -> io $ listAround span False
1865 noCanDo name $ text "can't find its location: " <>
1868 noCanDo n why = printForUser $
1869 text "cannot list source code for " <> ppr n <> text ": " <> why
1871 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1873 listModuleLine :: Module -> Int -> GHCi ()
1874 listModuleLine modl line = do
1875 session <- getSession
1876 graph <- io (GHC.getModuleGraph session)
1877 let this = filter ((== modl) . GHC.ms_mod) graph
1879 [] -> panic "listModuleLine"
1881 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1882 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1883 io $ listAround (GHC.srcLocSpan loc) False
1885 -- | list a section of a source file around a particular SrcSpan.
1886 -- If the highlight flag is True, also highlight the span using
1887 -- start_bold/end_bold.
1888 listAround span do_highlight = do
1889 contents <- BS.readFile (unpackFS file)
1891 lines = BS.split '\n' contents
1892 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1893 drop (line1 - 1 - pad_before) $ lines
1894 fst_line = max 1 (line1 - pad_before)
1895 line_nos = [ fst_line .. ]
1897 highlighted | do_highlight = zipWith highlight line_nos these_lines
1898 | otherwise = these_lines
1900 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1901 prefixed = zipWith BS.append bs_line_nos highlighted
1903 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1905 file = GHC.srcSpanFile span
1906 line1 = GHC.srcSpanStartLine span
1907 col1 = GHC.srcSpanStartCol span
1908 line2 = GHC.srcSpanEndLine span
1909 col2 = GHC.srcSpanEndCol span
1911 pad_before | line1 == 1 = 0
1915 highlight | do_bold = highlight_bold
1916 | otherwise = highlight_carets
1918 highlight_bold no line
1919 | no == line1 && no == line2
1920 = let (a,r) = BS.splitAt col1 line
1921 (b,c) = BS.splitAt (col2-col1) r
1923 BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
1925 = let (a,b) = BS.splitAt col1 line in
1926 BS.concat [a, BS.pack start_bold, b]
1928 = let (a,b) = BS.splitAt col2 line in
1929 BS.concat [a, BS.pack end_bold, b]
1932 highlight_carets no line
1933 | no == line1 && no == line2
1934 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1935 BS.replicate (col2-col1) '^']
1937 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1938 BS.replicate (BS.length line-col1) '^']
1940 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1943 indent = BS.pack " "
1944 nl = BS.singleton '\n'
1946 -- --------------------------------------------------------------------------
1949 getTickArray :: Module -> GHCi TickArray
1950 getTickArray modl = do
1952 let arrmap = tickarrays st
1953 case lookupModuleEnv arrmap modl of
1954 Just arr -> return arr
1956 (breakArray, ticks) <- getModBreak modl
1957 let arr = mkTickArray (assocs ticks)
1958 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1961 discardTickArrays :: GHCi ()
1962 discardTickArrays = do
1964 setGHCiState st{tickarrays = emptyModuleEnv}
1966 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1968 = accumArray (flip (:)) [] (1, max_line)
1969 [ (line, (nm,span)) | (nm,span) <- ticks,
1970 line <- srcSpanLines span ]
1972 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1973 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1974 GHC.srcSpanEndLine span ]
1976 lookupModule :: String -> GHCi Module
1977 lookupModule modName
1978 = do session <- getSession
1979 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1981 -- don't reset the counter back to zero?
1982 discardActiveBreakPoints :: GHCi ()
1983 discardActiveBreakPoints = do
1985 mapM (turnOffBreak.snd) (breaks st)
1986 setGHCiState $ st { breaks = [] }
1988 deleteBreak :: Int -> GHCi ()
1989 deleteBreak identity = do
1991 let oldLocations = breaks st
1992 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1994 then printForUser (text "Breakpoint" <+> ppr identity <+>
1995 text "does not exist")
1997 mapM (turnOffBreak.snd) this
1998 setGHCiState $ st { breaks = rest }
2000 turnOffBreak loc = do
2001 (arr, _) <- getModBreak (breakModule loc)
2002 io $ setBreakFlag False arr (breakTick loc)
2004 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2005 getModBreak mod = do
2006 session <- getSession
2007 Just mod_info <- io $ GHC.getModuleInfo session mod
2008 let modBreaks = GHC.modInfoModBreaks mod_info
2009 let array = GHC.modBreaks_flags modBreaks
2010 let ticks = GHC.modBreaks_locs modBreaks
2011 return (array, ticks)
2013 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2014 setBreakFlag toggle array index
2015 | toggle = GHC.setBreakOn array index
2016 | otherwise = GHC.setBreakOff array index