1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Type, Module, ModuleName, TyThing(..), Phase,
29 import Outputable hiding (printForUser)
30 import Module -- for ModuleEnv
37 -- Other random utilities
39 import BasicTypes hiding (isTopLevel)
40 import Panic hiding (showException)
41 import FastString ( unpackFS )
47 #ifndef mingw32_HOST_OS
49 #if __GLASGOW_HASKELL__ > 504
53 import GHC.ConsoleHandler ( flushConsole )
54 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
55 import qualified System.Win32
59 import Control.Concurrent ( yield ) -- Used in readline loop
60 import System.Console.Readline as Readline
65 import Control.Exception as Exception
66 -- import Control.Concurrent
68 import qualified Data.ByteString.Char8 as BS
72 import System.Environment
73 import System.Exit ( exitWith, ExitCode(..) )
74 import System.Directory
76 import System.IO.Error as IO
80 import Control.Monad as Monad
82 import Foreign.StablePtr ( newStablePtr )
83 import GHC.Exts ( unsafeCoerce# )
84 import GHC.IOBase ( IOErrorType(InvalidArgument) )
86 import Data.IORef ( IORef, readIORef, writeIORef )
88 import System.Posix.Internals ( setNonBlockingFD )
90 -----------------------------------------------------------------------------
94 " / _ \\ /\\ /\\/ __(_)\n"++
95 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
96 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
97 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
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 ("break", keepGoing breakCmd, False, completeIdentifier),
110 ("browse", keepGoing browseCmd, False, completeModule),
111 ("cd", keepGoing changeDirectory, False, completeFilename),
112 ("check", keepGoing checkModule, False, completeHomeModule),
113 ("continue", continueCmd, False, completeNone),
114 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
115 ("def", keepGoing defineMacro, False, completeIdentifier),
116 ("delete", keepGoing deleteCmd, False, completeNone),
117 ("e", keepGoing editFile, False, completeFilename),
118 ("edit", keepGoing editFile, False, completeFilename),
119 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
120 ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
121 ("help", keepGoing help, False, completeNone),
122 ("info", keepGoing info, False, completeIdentifier),
123 ("kind", keepGoing kindOfType, False, completeIdentifier),
124 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
125 ("list", keepGoing listCmd, False, completeNone),
126 ("module", keepGoing setContext, False, completeModule),
127 ("main", keepGoing runMain, False, completeIdentifier),
128 ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
129 ("quit", quit, False, completeNone),
130 ("reload", keepGoing reloadModule, False, completeNone),
131 ("set", keepGoing setCmd, True, completeSetOptions),
132 ("show", keepGoing showCmd, False, completeNone),
133 ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
134 ("step", stepCmd, False, completeIdentifier),
135 ("type", keepGoing typeOfExpr, 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 " <stmt> evaluate/run <stmt>\n" ++
152 " :add <filename> ... add module(s) to the current target set\n" ++
153 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
154 " :break <name> set a breakpoint on the specified function\n" ++
155 " :browse [*]<module> display the names defined by <module>\n" ++
156 " :cd <dir> change directory to <dir>\n" ++
157 " :continue resume after a breakpoint\n" ++
158 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
159 " :def <cmd> <expr> define a command :<cmd>\n" ++
160 " :delete <number> delete the specified breakpoint\n" ++
161 " :delete * delete all breakpoints\n" ++
162 " :edit <file> edit file\n" ++
163 " :edit edit last module\n" ++
164 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
165 -- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
166 " :help, :? display this list of commands\n" ++
167 " :info [<name> ...] display information about the given names\n" ++
168 " :kind <type> show the kind of <type>\n" ++
169 " :load <filename> ... load module(s) and their dependents\n" ++
170 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
171 " :main [<arguments> ...] run the main function with the given arguments\n" ++
172 " :print [<name> ...] prints a value without forcing its computation\n" ++
173 " :quit exit GHCi\n" ++
174 " :reload reload the current module set\n" ++
176 " :set <option> ... set options\n" ++
177 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
178 " :set prog <progname> set the value returned by System.getProgName\n" ++
179 " :set prompt <prompt> set the prompt used in GHCi\n" ++
180 " :set editor <cmd> set the command used for :edit\n" ++
181 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
183 " :show breaks show active breakpoints\n" ++
184 " :show context show the breakpoint context\n" ++
185 " :show modules show the currently loaded modules\n" ++
186 " :show bindings show the current bindings made at the prompt\n" ++
188 " :sprint [<name> ...] simplifed version of :print\n" ++
189 " :step single-step after stopping at a breakpoint\n"++
190 " :step <expr> single-step into <expr>\n"++
191 " :type <expr> show the type of <expr>\n" ++
192 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
193 " :unset <option> ... unset options\n" ++
194 " :!<command> run the shell command <command>\n" ++
196 " Options for ':set' and ':unset':\n" ++
198 " +r revert top-level expressions after each evaluation\n" ++
199 " +s print timing/memory stats after each evaluation\n" ++
200 " +t print type after evaluation\n" ++
201 " -<flags> most GHC command line flags can also be set here\n" ++
202 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
204 -- Todo: add help for breakpoint commands here
210 win <- System.Win32.getWindowsDirectory
211 return (win `joinFileName` "notepad.exe")
216 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
217 interactiveUI session srcs maybe_expr = do
218 -- HACK! If we happen to get into an infinite loop (eg the user
219 -- types 'let x=x in x' at the prompt), then the thread will block
220 -- on a blackhole, and become unreachable during GC. The GC will
221 -- detect that it is unreachable and send it the NonTermination
222 -- exception. However, since the thread is unreachable, everything
223 -- it refers to might be finalized, including the standard Handles.
224 -- This sounds like a bug, but we don't have a good solution right
230 -- Initialise buffering for the *interpreted* I/O system
231 initInterpBuffering session
233 when (isNothing maybe_expr) $ do
234 -- Only for GHCi (not runghc and ghc -e):
235 -- Turn buffering off for the compiled program's stdout/stderr
237 -- Turn buffering off for GHCi's stdout
239 hSetBuffering stdout NoBuffering
240 -- We don't want the cmd line to buffer any input that might be
241 -- intended for the program, so unbuffer stdin.
242 hSetBuffering stdin NoBuffering
244 -- initial context is just the Prelude
245 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
246 GHC.setContext session [] [prel_mod]
250 Readline.setAttemptedCompletionFunction (Just completeWord)
251 --Readline.parseAndBind "set show-all-if-ambiguous 1"
253 let symbols = "!#$%&*+/<=>?@\\^|-~"
254 specials = "(),;[]`{}"
256 word_break_chars = spaces ++ specials ++ symbols
258 Readline.setBasicWordBreakCharacters word_break_chars
259 Readline.setCompleterWordBreakCharacters word_break_chars
262 default_editor <- findEditor
264 startGHCi (runGHCi srcs maybe_expr)
265 GHCiState{ progname = "<interactive>",
269 editor = default_editor,
274 breaks = emptyActiveBreakPoints,
275 tickarrays = emptyModuleEnv
279 Readline.resetTerminal Nothing
284 prel_name = GHC.mkModuleName "Prelude"
286 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
287 runGHCi paths maybe_expr = do
288 let read_dot_files = not opt_IgnoreDotGhci
290 when (read_dot_files) $ do
293 exists <- io (doesFileExist file)
295 dir_ok <- io (checkPerms ".")
296 file_ok <- io (checkPerms file)
297 when (dir_ok && file_ok) $ do
298 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
301 Right hdl -> fileLoop hdl False
303 when (read_dot_files) $ do
304 -- Read in $HOME/.ghci
305 either_dir <- io (IO.try (getEnv "HOME"))
309 cwd <- io (getCurrentDirectory)
310 when (dir /= cwd) $ do
311 let file = dir ++ "/.ghci"
312 ok <- io (checkPerms file)
314 either_hdl <- io (IO.try (openFile file ReadMode))
317 Right hdl -> fileLoop hdl False
319 -- Perform a :load for files given on the GHCi command line
320 -- When in -e mode, if the load fails then we want to stop
321 -- immediately rather than going on to evaluate the expression.
322 when (not (null paths)) $ do
323 ok <- ghciHandle (\e -> do showException e; return Failed) $
325 when (isJust maybe_expr && failed ok) $
326 io (exitWith (ExitFailure 1))
328 -- if verbosity is greater than 0, or we are connected to a
329 -- terminal, display the prompt in the interactive loop.
330 is_tty <- io (hIsTerminalDevice stdin)
331 dflags <- getDynFlags
332 let show_prompt = verbosity dflags > 0 || is_tty
337 #if defined(mingw32_HOST_OS)
338 -- The win32 Console API mutates the first character of
339 -- type-ahead when reading from it in a non-buffered manner. Work
340 -- around this by flushing the input buffer of type-ahead characters,
341 -- but only if stdin is available.
342 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
344 Left err | isDoesNotExistError err -> return ()
345 | otherwise -> io (ioError err)
346 Right () -> return ()
348 -- initialise the console if necessary
351 -- enter the interactive loop
352 interactiveLoop is_tty show_prompt
354 -- just evaluate the expression we were given
359 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
362 interactiveLoop is_tty show_prompt =
363 -- Ignore ^C exceptions caught here
364 ghciHandleDyn (\e -> case e of
366 #if defined(mingw32_HOST_OS)
369 interactiveLoop is_tty show_prompt
370 _other -> return ()) $
372 ghciUnblock $ do -- unblock necessary if we recursed from the
373 -- exception handler above.
375 -- read commands from stdin
379 else fileLoop stdin show_prompt
381 fileLoop stdin show_prompt
385 -- NOTE: We only read .ghci files if they are owned by the current user,
386 -- and aren't world writable. Otherwise, we could be accidentally
387 -- running code planted by a malicious third party.
389 -- Furthermore, We only read ./.ghci if . is owned by the current user
390 -- and isn't writable by anyone else. I think this is sufficient: we
391 -- don't need to check .. and ../.. etc. because "." always refers to
392 -- the same directory while a process is running.
394 checkPerms :: String -> IO Bool
396 #ifdef mingw32_HOST_OS
399 Util.handle (\_ -> return False) $ do
400 st <- getFileStatus name
402 if fileOwner st /= me then do
403 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
406 let mode = fileMode st
407 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
408 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
410 putStrLn $ "*** WARNING: " ++ name ++
411 " is writable by someone else, IGNORING!"
416 fileLoop :: Handle -> Bool -> GHCi ()
417 fileLoop hdl show_prompt = do
418 session <- getSession
419 (mod,imports) <- io (GHC.getContext session)
421 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
422 l <- io (IO.try (hGetLine hdl))
424 Left e | isEOFError e -> return ()
425 | InvalidArgument <- etype -> return ()
426 | otherwise -> io (ioError e)
427 where etype = ioeGetErrorType e
428 -- treat InvalidArgument in the same way as EOF:
429 -- this can happen if the user closed stdin, or
430 -- perhaps did getContents which closes stdin at
433 case removeSpaces l of
434 "" -> fileLoop hdl show_prompt
435 l -> do quit <- runCommand l
436 if quit then return () else fileLoop hdl show_prompt
438 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
439 stringLoop [] = return False
440 stringLoop (s:ss) = do
441 case removeSpaces s of
443 l -> do quit <- runCommand l
444 if quit then return True else stringLoop ss
446 mkPrompt toplevs exports prompt
447 = showSDoc $ f prompt
449 f ('%':'s':xs) = perc_s <> f xs
450 f ('%':'%':xs) = char '%' <> f xs
451 f (x:xs) = char x <> f xs
454 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
455 hsep (map (ppr . GHC.moduleName) exports)
459 readlineLoop :: GHCi ()
461 session <- getSession
462 (mod,imports) <- io (GHC.getContext session)
464 saveSession -- for use by completion
466 l <- io (readline (mkPrompt mod imports (prompt st))
467 `finally` setNonBlockingFD 0)
468 -- readline sometimes puts stdin into blocking mode,
469 -- so we need to put it back for the IO library
474 case removeSpaces l of
479 if quit then return () else readlineLoop
482 runCommand :: String -> GHCi Bool
483 runCommand c = ghciHandle handler (doCommand c)
485 doCommand (':' : command) = specialCommand command
487 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
490 -- This version is for the GHC command-line option -e. The only difference
491 -- from runCommand is that it catches the ExitException exception and
492 -- exits, rather than printing out the exception.
493 runCommandEval c = ghciHandle handleEval (doCommand c)
495 handleEval (ExitException code) = io (exitWith code)
496 handleEval e = do handler e
497 io (exitWith (ExitFailure 1))
499 doCommand (':' : command) = specialCommand command
501 = do nms <- runStmt stmt
503 Nothing -> io (exitWith (ExitFailure 1))
504 -- failure to run the command causes exit(1) for ghc -e.
505 _ -> do finishEvalExpr nms
508 runStmt :: String -> GHCi (Maybe (Bool,[Name]))
510 | null (filter (not.isSpace) stmt) = return (Just (False,[]))
512 = do st <- getGHCiState
513 session <- getSession
514 result <- io $ withProgName (progname st) $ withArgs (args st) $
515 GHC.runStmt session stmt
516 switchOnRunResult result
518 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
519 switchOnRunResult GHC.RunFailed = return Nothing
520 switchOnRunResult (GHC.RunException e) = throw e
521 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
522 switchOnRunResult (GHC.RunBreak threadId names info resume) = do
523 session <- getSession
524 Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
525 let modBreaks = GHC.modInfoModBreaks mod_info
526 let ticks = GHC.modBreaks_locs modBreaks
528 -- display information about the breakpoint
529 let location = ticks ! GHC.breakInfo_number info
530 printForUser $ ptext SLIT("Stopped at") <+> ppr location
532 pushResume location threadId resume
534 -- run the command set with ":set stop <cmd>"
538 return (Just (True,names))
540 -- possibly print the type and revert CAFs after evaluating an expression
541 finishEvalExpr mb_names
542 = do show_types <- isOptionSet ShowType
543 session <- getSession
546 Just (is_break,names) ->
547 when (is_break || show_types) $
548 mapM_ (showTypeOfName session) names
551 io installSignalHandlers
552 b <- isOptionSet RevertCAFs
553 io (when b revertCAFs)
555 showTypeOfName :: Session -> Name -> GHCi ()
556 showTypeOfName session n
557 = do maybe_tything <- io (GHC.lookupName session n)
558 case maybe_tything of
560 Just thing -> showTyThing thing
562 specialCommand :: String -> GHCi Bool
563 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
564 specialCommand str = do
565 let (cmd,rest) = break isSpace str
566 maybe_cmd <- io (lookupCommand cmd)
568 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
569 ++ shortHelpText) >> return False)
570 Just (_,f,_,_) -> f (dropWhile isSpace rest)
572 lookupCommand :: String -> IO (Maybe Command)
573 lookupCommand str = do
574 cmds <- readIORef commands
575 -- look for exact match first, then the first prefix match
576 case [ c | c <- cmds, str == cmdName c ] of
577 c:_ -> return (Just c)
578 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
580 c:_ -> return (Just c)
582 -----------------------------------------------------------------------------
585 help :: String -> GHCi ()
586 help _ = io (putStr helpText)
588 info :: String -> GHCi ()
589 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
590 info s = do { let names = words s
591 ; session <- getSession
592 ; dflags <- getDynFlags
593 ; let exts = dopt Opt_GlasgowExts dflags
594 ; mapM_ (infoThing exts session) names }
596 infoThing exts session str = io $ do
597 names <- GHC.parseName session str
598 let filtered = filterOutChildren names
599 mb_stuffs <- mapM (GHC.getInfo session) filtered
600 unqual <- GHC.getPrintUnqual session
601 putStrLn (showSDocForUser unqual $
602 vcat (intersperse (text "") $
603 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
605 -- Filter out names whose parent is also there Good
606 -- example is '[]', which is both a type and data
607 -- constructor in the same type
608 filterOutChildren :: [Name] -> [Name]
609 filterOutChildren names = filter (not . parent_is_there) names
610 where parent_is_there n
611 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
615 pprInfo exts (thing, fixity, insts)
616 = pprTyThingInContextLoc exts thing
617 $$ show_fixity fixity
618 $$ vcat (map GHC.pprInstance insts)
621 | fix == GHC.defaultFixity = empty
622 | otherwise = ppr fix <+> ppr (GHC.getName thing)
624 -----------------------------------------------------------------------------
627 runMain :: String -> GHCi ()
629 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
630 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
633 addModule :: [FilePath] -> GHCi ()
635 io (revertCAFs) -- always revert CAFs on load/add.
636 files <- mapM expandPath files
637 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
638 session <- getSession
639 io (mapM_ (GHC.addTarget session) targets)
640 ok <- io (GHC.load session LoadAllTargets)
643 changeDirectory :: String -> GHCi ()
644 changeDirectory dir = do
645 session <- getSession
646 graph <- io (GHC.getModuleGraph session)
647 when (not (null graph)) $
648 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
649 io (GHC.setTargets session [])
650 io (GHC.load session LoadAllTargets)
651 setContextAfterLoad session []
652 io (GHC.workingDirectoryChanged session)
653 dir <- expandPath dir
654 io (setCurrentDirectory dir)
656 editFile :: String -> GHCi ()
659 -- find the name of the "topmost" file loaded
660 session <- getSession
661 graph0 <- io (GHC.getModuleGraph session)
662 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
663 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
664 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
665 Just file -> do_edit file
666 Nothing -> throwDyn (CmdLineError "unknown file name")
667 | otherwise = do_edit str
673 throwDyn (CmdLineError "editor not set, use :set editor")
674 io $ system (cmd ++ ' ':file)
677 defineMacro :: String -> GHCi ()
679 let (macro_name, definition) = break isSpace s
680 cmds <- io (readIORef commands)
682 then throwDyn (CmdLineError "invalid macro name")
684 if (macro_name `elem` map cmdName cmds)
685 then throwDyn (CmdLineError
686 ("command '" ++ macro_name ++ "' is already defined"))
689 -- give the expression a type signature, so we can be sure we're getting
690 -- something of the right type.
691 let new_expr = '(' : definition ++ ") :: String -> IO String"
693 -- compile the expression
695 maybe_hv <- io (GHC.compileExpr cms new_expr)
698 Just hv -> io (writeIORef commands --
699 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
701 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
703 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
704 stringLoop (lines str)
706 undefineMacro :: String -> GHCi ()
707 undefineMacro macro_name = do
708 cmds <- io (readIORef commands)
709 if (macro_name `elem` map cmdName builtin_commands)
710 then throwDyn (CmdLineError
711 ("command '" ++ macro_name ++ "' cannot be undefined"))
713 if (macro_name `notElem` map cmdName cmds)
714 then throwDyn (CmdLineError
715 ("command '" ++ macro_name ++ "' not defined"))
717 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
720 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
721 loadModule fs = timeIt (loadModule' fs)
723 loadModule_ :: [FilePath] -> GHCi ()
724 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
726 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
727 loadModule' files = do
728 session <- getSession
731 io (GHC.setTargets session [])
732 io (GHC.load session LoadAllTargets)
735 let (filenames, phases) = unzip files
736 exp_filenames <- mapM expandPath filenames
737 let files' = zip exp_filenames phases
738 targets <- io (mapM (uncurry GHC.guessTarget) files')
740 -- NOTE: we used to do the dependency anal first, so that if it
741 -- fails we didn't throw away the current set of modules. This would
742 -- require some re-working of the GHC interface, so we'll leave it
743 -- as a ToDo for now.
745 io (GHC.setTargets session targets)
746 ok <- io (GHC.load session LoadAllTargets)
750 checkModule :: String -> GHCi ()
752 let modl = GHC.mkModuleName m
753 session <- getSession
754 result <- io (GHC.checkModule session modl)
756 Nothing -> io $ putStrLn "Nothing"
757 Just r -> io $ putStrLn (showSDoc (
758 case GHC.checkedModuleInfo r of
759 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
761 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
763 (text "global names: " <+> ppr global) $$
764 (text "local names: " <+> ppr local)
766 afterLoad (successIf (isJust result)) session
768 reloadModule :: String -> GHCi ()
770 io (revertCAFs) -- always revert CAFs on reload.
771 session <- getSession
772 ok <- io (GHC.load session LoadAllTargets)
775 io (revertCAFs) -- always revert CAFs on reload.
776 session <- getSession
777 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
780 afterLoad ok session = do
781 io (revertCAFs) -- always revert CAFs on load.
784 discardActiveBreakPoints
785 graph <- io (GHC.getModuleGraph session)
786 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
787 setContextAfterLoad session graph'
788 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
790 setContextAfterLoad session [] = do
791 prel_mod <- getPrelude
792 io (GHC.setContext session [] [prel_mod])
793 setContextAfterLoad session ms = do
794 -- load a target if one is available, otherwise load the topmost module.
795 targets <- io (GHC.getTargets session)
796 case [ m | Just m <- map (findTarget ms) targets ] of
798 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
799 load_this (last graph')
804 = case filter (`matches` t) ms of
808 summary `matches` Target (TargetModule m) _
809 = GHC.ms_mod_name summary == m
810 summary `matches` Target (TargetFile f _) _
811 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
812 summary `matches` target
815 load_this summary | m <- GHC.ms_mod summary = do
816 b <- io (GHC.moduleIsInterpreted session m)
817 if b then io (GHC.setContext session [m] [])
819 prel_mod <- getPrelude
820 io (GHC.setContext session [] [prel_mod,m])
823 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
824 modulesLoadedMsg ok mods = do
825 dflags <- getDynFlags
826 when (verbosity dflags > 0) $ do
828 | null mods = text "none."
830 punctuate comma (map ppr mods)) <> text "."
833 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
835 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
838 typeOfExpr :: String -> GHCi ()
840 = do cms <- getSession
841 maybe_ty <- io (GHC.exprType cms str)
844 Just ty -> do ty' <- cleanType ty
845 printForUser $ text str <> text " :: " <> ppr ty'
847 kindOfType :: String -> GHCi ()
849 = do cms <- getSession
850 maybe_ty <- io (GHC.typeKind cms str)
853 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
855 quit :: String -> GHCi Bool
858 shellEscape :: String -> GHCi Bool
859 shellEscape str = io (system str >> return False)
861 -----------------------------------------------------------------------------
862 -- create tags file for currently loaded modules.
864 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
866 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
867 createCTagsFileCmd file = ghciCreateTagsFile CTags file
869 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
870 createETagsFileCmd file = ghciCreateTagsFile ETags file
872 data TagsKind = ETags | CTags
874 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
875 ghciCreateTagsFile kind file = do
876 session <- getSession
877 io $ createTagsFile session kind file
880 -- - remove restriction that all modules must be interpreted
881 -- (problem: we don't know source locations for entities unless
882 -- we compiled the module.
884 -- - extract createTagsFile so it can be used from the command-line
885 -- (probably need to fix first problem before this is useful).
887 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
888 createTagsFile session tagskind tagFile = do
889 graph <- GHC.getModuleGraph session
890 let ms = map GHC.ms_mod graph
892 is_interpreted <- GHC.moduleIsInterpreted session m
893 -- should we just skip these?
894 when (not is_interpreted) $
895 throwDyn (CmdLineError ("module '"
896 ++ GHC.moduleNameString (GHC.moduleName m)
897 ++ "' is not interpreted"))
898 mbModInfo <- GHC.getModuleInfo session m
900 | Just modinfo <- mbModInfo,
901 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
902 | otherwise = GHC.alwaysQualify
905 Just modInfo -> return $! listTags unqual modInfo
908 mtags <- mapM tagModule ms
909 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
911 Left e -> hPutStrLn stderr $ ioeGetErrorString e
914 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
915 listTags unqual modInfo =
916 [ tagInfo unqual name loc
917 | name <- GHC.modInfoExports modInfo
918 , let loc = nameSrcLoc name
922 type TagInfo = (String -- tag name
925 ,Int -- column number
928 -- get tag info, for later translation into Vim or Emacs style
929 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
930 tagInfo unqual name loc
931 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
932 , showSDocForUser unqual $ ftext (srcLocFile loc)
937 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
938 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
939 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
940 IO.try (writeFile file tags)
941 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
942 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
943 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
944 tagGroups <- mapM tagFileGroup groups
945 IO.try (writeFile file $ concat tagGroups)
947 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
948 tagFileGroup group@((_,fileName,_,_):_) = do
949 file <- readFile fileName -- need to get additional info from sources..
950 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
951 sortedGroup = sortLe byLine group
952 tags = unlines $ perFile sortedGroup 1 0 $ lines file
953 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
954 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
955 perFile (tagInfo:tags) (count+1) (pos+length line) lines
956 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
957 showETag tagInfo line pos : perFile tags count pos lines
958 perFile tags count pos lines = []
960 -- simple ctags format, for Vim et al
961 showTag :: TagInfo -> String
962 showTag (tag,file,lineNo,colNo)
963 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
965 -- etags format, for Emacs/XEmacs
966 showETag :: TagInfo -> String -> Int -> String
967 showETag (tag,file,lineNo,colNo) line charPos
968 = take colNo line ++ tag
970 ++ "\x01" ++ show lineNo
971 ++ "," ++ show charPos
973 -----------------------------------------------------------------------------
974 -- Browsing a module's contents
976 browseCmd :: String -> GHCi ()
979 ['*':m] | looksLikeModuleName m -> browseModule m False
980 [m] | looksLikeModuleName m -> browseModule m True
981 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
983 browseModule m exports_only = do
985 modl <- if exports_only then lookupModule s m
986 else wantInterpretedModule s m
988 -- Temporarily set the context to the module we're interested in,
989 -- just so we can get an appropriate PrintUnqualified
990 (as,bs) <- io (GHC.getContext s)
991 prel_mod <- getPrelude
992 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
993 else GHC.setContext s [modl] [])
994 unqual <- io (GHC.getPrintUnqual s)
995 io (GHC.setContext s as bs)
997 mb_mod_info <- io $ GHC.getModuleInfo s modl
999 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1002 | exports_only = GHC.modInfoExports mod_info
1003 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1005 filtered = filterOutChildren names
1007 things <- io $ mapM (GHC.lookupName s) filtered
1009 dflags <- getDynFlags
1010 let exts = dopt Opt_GlasgowExts dflags
1011 io (putStrLn (showSDocForUser unqual (
1012 vcat (map (pprTyThingInContext exts) (catMaybes things))
1014 -- ToDo: modInfoInstances currently throws an exception for
1015 -- package modules. When it works, we can do this:
1016 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1018 -----------------------------------------------------------------------------
1019 -- Setting the module context
1022 | all sensible mods = fn mods
1023 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1025 (fn, mods) = case str of
1026 '+':stuff -> (addToContext, words stuff)
1027 '-':stuff -> (removeFromContext, words stuff)
1028 stuff -> (newContext, words stuff)
1030 sensible ('*':m) = looksLikeModuleName m
1031 sensible m = looksLikeModuleName m
1033 separate :: Session -> [String] -> [Module] -> [Module]
1034 -> GHCi ([Module],[Module])
1035 separate session [] as bs = return (as,bs)
1036 separate session (('*':str):ms) as bs = do
1037 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1038 b <- io $ GHC.moduleIsInterpreted session m
1039 if b then separate session ms (m:as) bs
1040 else throwDyn (CmdLineError ("module '"
1041 ++ GHC.moduleNameString (GHC.moduleName m)
1042 ++ "' is not interpreted"))
1043 separate session (str:ms) as bs = do
1044 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1045 separate session ms as (m:bs)
1047 newContext :: [String] -> GHCi ()
1048 newContext strs = do
1050 (as,bs) <- separate s strs [] []
1051 prel_mod <- getPrelude
1052 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1053 io $ GHC.setContext s as bs'
1056 addToContext :: [String] -> GHCi ()
1057 addToContext strs = do
1059 (as,bs) <- io $ GHC.getContext s
1061 (new_as,new_bs) <- separate s strs [] []
1063 let as_to_add = new_as \\ (as ++ bs)
1064 bs_to_add = new_bs \\ (as ++ bs)
1066 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1069 removeFromContext :: [String] -> GHCi ()
1070 removeFromContext strs = do
1072 (as,bs) <- io $ GHC.getContext s
1074 (as_to_remove,bs_to_remove) <- separate s strs [] []
1076 let as' = as \\ (as_to_remove ++ bs_to_remove)
1077 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1079 io $ GHC.setContext s as' bs'
1081 ----------------------------------------------------------------------------
1084 -- set options in the interpreter. Syntax is exactly the same as the
1085 -- ghc command line, except that certain options aren't available (-C,
1088 -- This is pretty fragile: most options won't work as expected. ToDo:
1089 -- figure out which ones & disallow them.
1091 setCmd :: String -> GHCi ()
1093 = do st <- getGHCiState
1094 let opts = options st
1095 io $ putStrLn (showSDoc (
1096 text "options currently set: " <>
1099 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1102 = case toArgs str of
1103 ("args":args) -> setArgs args
1104 ("prog":prog) -> setProg prog
1105 ("prompt":prompt) -> setPrompt (after 6)
1106 ("editor":cmd) -> setEditor (after 6)
1107 ("stop":cmd) -> setStop (after 4)
1108 wds -> setOptions wds
1109 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1113 setGHCiState st{ args = args }
1117 setGHCiState st{ progname = prog }
1119 io (hPutStrLn stderr "syntax: :set prog <progname>")
1123 setGHCiState st{ editor = cmd }
1127 setGHCiState st{ stop = cmd }
1129 setPrompt value = do
1132 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1133 else setGHCiState st{ prompt = remQuotes value }
1135 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1139 do -- first, deal with the GHCi opts (+s, +t, etc.)
1140 let (plus_opts, minus_opts) = partition isPlus wds
1141 mapM_ setOpt plus_opts
1143 -- then, dynamic flags
1144 dflags <- getDynFlags
1145 let pkg_flags = packageFlags dflags
1146 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1148 if (not (null leftovers))
1149 then throwDyn (CmdLineError ("unrecognised flags: " ++
1153 new_pkgs <- setDynFlags dflags'
1155 -- if the package flags changed, we should reset the context
1156 -- and link the new packages.
1157 dflags <- getDynFlags
1158 when (packageFlags dflags /= pkg_flags) $ do
1159 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1160 session <- getSession
1161 io (GHC.setTargets session [])
1162 io (GHC.load session LoadAllTargets)
1163 io (linkPackages dflags new_pkgs)
1164 setContextAfterLoad session []
1168 unsetOptions :: String -> GHCi ()
1170 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1171 let opts = words str
1172 (minus_opts, rest1) = partition isMinus opts
1173 (plus_opts, rest2) = partition isPlus rest1
1175 if (not (null rest2))
1176 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1179 mapM_ unsetOpt plus_opts
1181 -- can't do GHC flags for now
1182 if (not (null minus_opts))
1183 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1186 isMinus ('-':s) = True
1189 isPlus ('+':s) = True
1193 = case strToGHCiOpt str of
1194 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1195 Just o -> setOption o
1198 = case strToGHCiOpt str of
1199 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1200 Just o -> unsetOption o
1202 strToGHCiOpt :: String -> (Maybe GHCiOption)
1203 strToGHCiOpt "s" = Just ShowTiming
1204 strToGHCiOpt "t" = Just ShowType
1205 strToGHCiOpt "r" = Just RevertCAFs
1206 strToGHCiOpt _ = Nothing
1208 optToStr :: GHCiOption -> String
1209 optToStr ShowTiming = "s"
1210 optToStr ShowType = "t"
1211 optToStr RevertCAFs = "r"
1213 -- ---------------------------------------------------------------------------
1218 ["modules" ] -> showModules
1219 ["bindings"] -> showBindings
1220 ["linker"] -> io showLinkerState
1221 ["breaks"] -> showBkptTable
1222 ["context"] -> showContext
1223 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
1226 session <- getSession
1227 let show_one ms = do m <- io (GHC.showModule session ms)
1229 graph <- io (GHC.getModuleGraph session)
1230 mapM_ show_one graph
1234 unqual <- io (GHC.getPrintUnqual s)
1235 bindings <- io (GHC.getBindings s)
1236 mapM_ showTyThing bindings
1239 showTyThing (AnId id) = do
1240 ty' <- cleanType (GHC.idType id)
1241 printForUser $ ppr id <> text " :: " <> ppr ty'
1242 showTyThing _ = return ()
1244 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1245 cleanType :: Type -> GHCi Type
1247 dflags <- getDynFlags
1248 if dopt Opt_GlasgowExts dflags
1250 else return $! GHC.dropForAlls ty
1252 showBkptTable :: GHCi ()
1254 activeBreaks <- getActiveBreakPoints
1255 printForUser $ ppr activeBreaks
1257 showContext :: GHCi ()
1260 printForUser $ vcat (map pp_resume (resume st))
1262 pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
1264 -- -----------------------------------------------------------------------------
1267 completeNone :: String -> IO [String]
1268 completeNone w = return []
1271 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1272 completeWord w start end = do
1273 line <- Readline.getLineBuffer
1275 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1277 | Just c <- is_cmd line -> do
1278 maybe_cmd <- lookupCommand c
1279 let (n,w') = selectWord (words' 0 line)
1281 Nothing -> return Nothing
1282 Just (_,_,False,complete) -> wrapCompleter complete w
1283 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1284 return (map (drop n) rets)
1285 in wrapCompleter complete' w'
1287 --printf "complete %s, start = %d, end = %d\n" w start end
1288 wrapCompleter completeIdentifier w
1289 where words' _ [] = []
1290 words' n str = let (w,r) = break isSpace str
1291 (s,r') = span isSpace r
1292 in (n,w):words' (n+length w+length s) r'
1293 -- In a Haskell expression we want to parse 'a-b' as three words
1294 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1295 -- only be a single word.
1296 selectWord [] = (0,w)
1297 selectWord ((offset,x):xs)
1298 | offset+length x >= start = (start-offset,take (end-offset) x)
1299 | otherwise = selectWord xs
1302 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1303 | otherwise = Nothing
1306 cmds <- readIORef commands
1307 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1309 completeMacro w = do
1310 cmds <- readIORef commands
1311 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1312 return (filter (w `isPrefixOf`) cmds')
1314 completeIdentifier w = do
1316 rdrs <- GHC.getRdrNamesInScope s
1317 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1319 completeModule w = do
1321 dflags <- GHC.getSessionDynFlags s
1322 let pkg_mods = allExposedModules dflags
1323 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1325 completeHomeModule w = do
1327 g <- GHC.getModuleGraph s
1328 let home_mods = map GHC.ms_mod_name g
1329 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1331 completeSetOptions w = do
1332 return (filter (w `isPrefixOf`) options)
1333 where options = "args":"prog":allFlags
1335 completeFilename = Readline.filenameCompletionFunction
1337 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1339 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1340 unionComplete f1 f2 w = do
1345 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1346 wrapCompleter fun w = do
1349 [] -> return Nothing
1350 [x] -> return (Just (x,[]))
1351 xs -> case getCommonPrefix xs of
1352 "" -> return (Just ("",xs))
1353 pref -> return (Just (pref,xs))
1355 getCommonPrefix :: [String] -> String
1356 getCommonPrefix [] = ""
1357 getCommonPrefix (s:ss) = foldl common s ss
1358 where common s "" = ""
1360 common (c:cs) (d:ds)
1361 | c == d = c : common cs ds
1364 allExposedModules :: DynFlags -> [ModuleName]
1365 allExposedModules dflags
1366 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1368 pkg_db = pkgIdMap (pkgState dflags)
1370 completeCmd = completeNone
1371 completeMacro = completeNone
1372 completeIdentifier = completeNone
1373 completeModule = completeNone
1374 completeHomeModule = completeNone
1375 completeSetOptions = completeNone
1376 completeFilename = completeNone
1377 completeHomeModuleOrFile=completeNone
1378 completeBkpt = completeNone
1381 -- ---------------------------------------------------------------------------
1382 -- User code exception handling
1384 -- This is the exception handler for exceptions generated by the
1385 -- user's code and exceptions coming from children sessions;
1386 -- it normally just prints out the exception. The
1387 -- handler must be recursive, in case showing the exception causes
1388 -- more exceptions to be raised.
1390 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1391 -- raising another exception. We therefore don't put the recursive
1392 -- handler arond the flushing operation, so if stderr is closed
1393 -- GHCi will just die gracefully rather than going into an infinite loop.
1394 handler :: Exception -> GHCi Bool
1396 handler exception = do
1398 io installSignalHandlers
1399 ghciHandle handler (showException exception >> return False)
1401 showException (DynException dyn) =
1402 case fromDynamic dyn of
1403 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1404 Just Interrupted -> io (putStrLn "Interrupted.")
1405 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1406 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1407 Just other_ghc_ex -> io (print other_ghc_ex)
1409 showException other_exception
1410 = io (putStrLn ("*** Exception: " ++ show other_exception))
1412 -----------------------------------------------------------------------------
1413 -- recursive exception handlers
1415 -- Don't forget to unblock async exceptions in the handler, or if we're
1416 -- in an exception loop (eg. let a = error a in a) the ^C exception
1417 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1419 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1420 ghciHandle h (GHCi m) = GHCi $ \s ->
1421 Exception.catch (m s)
1422 (\e -> unGHCi (ghciUnblock (h e)) s)
1424 ghciUnblock :: GHCi a -> GHCi a
1425 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1428 -- ----------------------------------------------------------------------------
1431 expandPath :: String -> GHCi String
1433 case dropWhile isSpace path of
1435 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1436 return (tilde ++ '/':d)
1440 -- ----------------------------------------------------------------------------
1441 -- Windows console setup
1443 setUpConsole :: IO ()
1445 #ifdef mingw32_HOST_OS
1446 -- On Windows we need to set a known code page, otherwise the characters
1447 -- we read from the console will be be in some strange encoding, and
1448 -- similarly for characters we write to the console.
1450 -- At the moment, GHCi pretends all input is Latin-1. In the
1451 -- future we should support UTF-8, but for now we set the code pages
1454 -- It seems you have to set the font in the console window to
1455 -- a Unicode font in order for output to work properly,
1456 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1457 -- (see MSDN for SetConsoleOutputCP()).
1459 setConsoleCP 28591 -- ISO Latin-1
1460 setConsoleOutputCP 28591 -- ISO Latin-1
1464 -- -----------------------------------------------------------------------------
1465 -- commands for debugger
1467 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1469 stepCmd :: String -> GHCi Bool
1470 stepCmd [] = doContinue setStepFlag
1471 stepCmd expression = do
1473 runCommand expression
1475 continueCmd :: String -> GHCi Bool
1476 continueCmd [] = doContinue $ return ()
1477 continueCmd other = do
1478 io $ putStrLn "The continue command accepts no arguments."
1481 doContinue :: IO () -> GHCi Bool
1482 doContinue actionBeforeCont = do
1483 resumeAction <- popResume
1484 case resumeAction of
1486 io $ putStrLn "There is no computation running."
1488 Just (_,_,handle) -> do
1489 io $ actionBeforeCont
1490 session <- getSession
1491 runResult <- io $ GHC.resume session handle
1492 names <- switchOnRunResult runResult
1493 finishEvalExpr names
1496 deleteCmd :: String -> GHCi ()
1497 deleteCmd argLine = do
1498 deleteSwitch $ words argLine
1500 deleteSwitch :: [String] -> GHCi ()
1502 io $ putStrLn "The delete command requires at least one argument."
1503 -- delete all break points
1504 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1505 deleteSwitch idents = do
1506 mapM_ deleteOneBreak idents
1508 deleteOneBreak :: String -> GHCi ()
1510 | all isDigit str = deleteBreak (read str)
1511 | otherwise = return ()
1513 -- handle the "break" command
1514 breakCmd :: String -> GHCi ()
1515 breakCmd argLine = do
1516 session <- getSession
1517 breakSwitch session $ words argLine
1519 breakSwitch :: Session -> [String] -> GHCi ()
1520 breakSwitch _session [] = do
1521 io $ putStrLn "The break command requires at least one argument."
1522 breakSwitch session args@(arg1:rest)
1523 | looksLikeModuleName arg1 = do
1524 mod <- wantInterpretedModule session arg1
1525 breakByModule session mod rest
1526 | all isDigit arg1 = do
1527 (toplevel, _) <- io $ GHC.getContext session
1529 (mod : _) -> breakByModuleLine mod (read arg1) rest
1531 io $ putStrLn "Cannot find default module for breakpoint."
1532 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1533 | otherwise = do -- assume it's a name
1534 names <- io $ GHC.parseName session arg1
1538 let loc = nameSrcLoc n
1540 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1541 if not is_interpreted
1542 then noCanDo $ text "module " <> ppr modl <>
1543 text " is not interpreted"
1546 then findBreakAndSet (nameModule n) $
1547 findBreakByCoord (srcLocLine loc, srcLocCol loc)
1548 else noCanDo $ text "can't find its location: " <>
1551 noCanDo why = printForUser $
1552 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1555 wantInterpretedModule :: Session -> String -> GHCi Module
1556 wantInterpretedModule session str = do
1557 modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1558 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1559 when (not is_interpreted) $
1560 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1563 breakByModule :: Session -> Module -> [String] -> GHCi ()
1564 breakByModule session mod args@(arg1:rest)
1565 | all isDigit arg1 = do -- looks like a line number
1566 breakByModuleLine mod (read arg1) rest
1567 | otherwise = io $ putStrLn "Invalid arguments to :break"
1569 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1570 breakByModuleLine mod line args
1571 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1572 | [col] <- args, all isDigit col =
1573 findBreakAndSet mod $ findBreakByCoord (line, read col)
1574 | otherwise = io $ putStrLn "Invalid arguments to :break"
1576 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1577 findBreakAndSet mod lookupTickTree = do
1578 tickArray <- getTickArray mod
1579 (breakArray, _) <- getModBreak mod
1580 case lookupTickTree tickArray of
1581 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1582 Just (tick, span) -> do
1583 success <- io $ setBreakFlag True breakArray tick
1584 session <- getSession
1588 recordBreak $ BreakLocation
1594 text "Breakpoint " <> ppr nm <>
1596 then text " was already set at " <> ppr span
1597 else text " activated at " <> ppr span
1599 printForUser $ text "Breakpoint could not be activated at"
1602 -- When a line number is specified, the current policy for choosing
1603 -- the best breakpoint is this:
1604 -- - the leftmost complete subexpression on the specified line, or
1605 -- - the leftmost subexpression starting on the specified line, or
1606 -- - the rightmost subexpression enclosing the specified line
1608 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1609 findBreakByLine line arr
1610 | not (inRange (bounds arr) line) = Nothing
1612 listToMaybe (sortBy leftmost_largest complete) `mplus`
1613 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1614 listToMaybe (sortBy rightmost ticks)
1618 starts_here = [ tick | tick@(nm,span) <- ticks,
1619 srcSpanStartLine span == line ]
1621 (complete,incomplete) = partition ends_here starts_here
1622 where ends_here (nm,span) = srcSpanEndLine span == line
1624 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1625 findBreakByCoord (line, col) arr
1626 | not (inRange (bounds arr) line) = Nothing
1628 listToMaybe (sortBy rightmost contains)
1632 -- the ticks that span this coordinate
1633 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1635 leftmost_smallest (_,a) (_,b) = a `compare` b
1636 leftmost_largest (_,a) (_,b) = (srcSpanStart a `compare` srcSpanStart b)
1638 (srcSpanEnd b `compare` srcSpanEnd a)
1639 rightmost (_,a) (_,b) = b `compare` a
1641 spans :: SrcSpan -> (Int,Int) -> Bool
1642 spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
1643 where loc = mkSrcLoc (srcSpanFile span) l c
1645 start_bold = BS.pack "\ESC[1m"
1646 end_bold = BS.pack "\ESC[0m"
1648 listCmd :: String -> GHCi ()
1652 [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1653 (span,_,_):_ -> io $ listAround span True
1655 -- | list a section of a source file around a particular SrcSpan.
1656 -- If the highlight flag is True, also highlight the span using
1657 -- start_bold/end_bold.
1658 listAround span do_highlight = do
1659 contents <- BS.readFile (unpackFS file)
1661 lines = BS.split '\n' contents
1662 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1663 drop (line1 - 1 - pad_before) $ lines
1664 fst_line = max 1 (line1 - pad_before)
1665 line_nos = [ fst_line .. ]
1667 highlighted | do_highlight = zipWith highlight line_nos these_lines
1668 | otherwise = these_lines
1670 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1671 prefixed = zipWith BS.append bs_line_nos highlighted
1673 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1675 file = srcSpanFile span
1676 line1 = srcSpanStartLine span
1677 col1 = srcSpanStartCol span
1678 line2 = srcSpanEndLine span
1679 col2 = srcSpanEndCol span
1681 pad_before | line1 == 1 = 0
1686 | no == line1 && no == line2
1687 = let (a,r) = BS.splitAt col1 line
1688 (b,c) = BS.splitAt (col2-col1) r
1690 BS.concat [a,start_bold,b,end_bold,c]
1692 = let (a,b) = BS.splitAt col1 line in
1693 BS.concat [a, start_bold, b]
1695 = let (a,b) = BS.splitAt col2 line in
1696 BS.concat [a, end_bold, b]
1699 -- --------------------------------------------------------------------------
1702 getTickArray :: Module -> GHCi TickArray
1703 getTickArray modl = do
1705 let arrmap = tickarrays st
1706 case lookupModuleEnv arrmap modl of
1707 Just arr -> return arr
1709 (breakArray, ticks) <- getModBreak modl
1710 let arr = mkTickArray (assocs ticks)
1711 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1714 discardTickArrays :: GHCi ()
1715 discardTickArrays = do
1717 setGHCiState st{tickarrays = emptyModuleEnv}
1719 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1721 = accumArray (flip (:)) [] (1, max_line)
1722 [ (line, (nm,span)) | (nm,span) <- ticks,
1723 line <- srcSpanLines span ]
1725 max_line = maximum (map srcSpanEndLine (map snd ticks))
1726 srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
1728 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1729 getModBreak mod = do
1730 session <- getSession
1731 Just mod_info <- io $ GHC.getModuleInfo session mod
1732 let modBreaks = GHC.modInfoModBreaks mod_info
1733 let array = GHC.modBreaks_flags modBreaks
1734 let ticks = GHC.modBreaks_locs modBreaks
1735 return (array, ticks)
1737 lookupModule :: Session -> String -> GHCi Module
1738 lookupModule session modName
1739 = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1741 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1742 setBreakFlag toggle array index
1743 | toggle = GHC.setBreakOn array index
1744 | otherwise = GHC.setBreakOff array index
1747 {- these should probably go to the GHC API at some point -}
1748 enableBreakPoint :: Session -> Module -> Int -> IO ()
1749 enableBreakPoint session mod index = return ()
1751 disableBreakPoint :: Session -> Module -> Int -> IO ()
1752 disableBreakPoint session mod index = return ()
1754 activeBreakPoints :: Session -> IO [(Module,Int)]
1755 activeBreakPoints session = return []
1757 enableSingleStep :: Session -> IO ()
1758 enableSingleStep session = return ()
1760 disableSingleStep :: Session -> IO ()
1761 disableSingleStep session = return ()