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
79 import System.IO.Unsafe
83 import Control.Monad as Monad
86 import Foreign.StablePtr ( newStablePtr )
87 import GHC.Exts ( unsafeCoerce# )
88 import GHC.IOBase ( IOErrorType(InvalidArgument) )
90 import Data.IORef ( IORef, readIORef, writeIORef )
92 import System.Posix.Internals ( setNonBlockingFD )
94 -----------------------------------------------------------------------------
96 ghciWelcomeMsg :: String
97 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
98 ": http://www.haskell.org/ghc/ :? for help"
100 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
101 cmdName (n,_,_,_) = n
103 GLOBAL_VAR(commands, builtin_commands, [Command])
105 builtin_commands :: [Command]
107 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
108 ("?", keepGoing help, False, completeNone),
109 ("add", keepGoingPaths addModule, False, completeFilename),
110 ("abandon", keepGoing abandonCmd, False, completeNone),
111 ("break", keepGoing breakCmd, False, completeIdentifier),
112 ("back", keepGoing backCmd, False, completeNone),
113 ("browse", keepGoing browseCmd, False, completeModule),
114 ("cd", keepGoing changeDirectory, False, completeFilename),
115 ("check", keepGoing checkModule, False, completeHomeModule),
116 ("continue", keepGoing continueCmd, False, completeNone),
117 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
118 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
119 ("def", keepGoing defineMacro, False, completeIdentifier),
120 ("delete", keepGoing deleteCmd, False, completeNone),
121 ("e", keepGoing editFile, False, completeFilename),
122 ("edit", keepGoing editFile, False, completeFilename),
123 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
124 ("force", keepGoing forceCmd, False, completeIdentifier),
125 ("forward", keepGoing forwardCmd, False, completeNone),
126 ("help", keepGoing help, False, completeNone),
127 ("history", keepGoing historyCmd, False, completeNone),
128 ("info", keepGoing info, False, completeIdentifier),
129 ("kind", keepGoing kindOfType, False, completeIdentifier),
130 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
131 ("list", keepGoing listCmd, False, completeNone),
132 ("module", keepGoing setContext, False, completeModule),
133 ("main", keepGoing runMain, False, completeIdentifier),
134 ("print", keepGoing printCmd, False, completeIdentifier),
135 ("quit", quit, False, completeNone),
136 ("reload", keepGoing reloadModule, False, completeNone),
137 ("set", keepGoing setCmd, True, completeSetOptions),
138 ("show", keepGoing showCmd, False, completeNone),
139 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
140 ("step", keepGoing stepCmd, False, completeIdentifier),
141 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
142 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
143 ("type", keepGoing typeOfExpr, False, completeIdentifier),
144 ("trace", keepGoing traceCmd, False, completeIdentifier),
145 ("undef", keepGoing undefineMacro, False, completeMacro),
146 ("unset", keepGoing unsetOptions, True, completeSetOptions)
149 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
150 keepGoing a str = a str >> return False
152 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
153 keepGoingPaths a str = a (toArgs str) >> return False
155 shortHelpText = "use :? for help.\n"
158 " Commands available from the prompt:\n" ++
160 " <statement> evaluate/run <statement>\n" ++
161 " :add <filename> ... add module(s) to the current target set\n" ++
162 " :browse [*]<module> display the names defined by <module>\n" ++
163 " :cd <dir> change directory to <dir>\n" ++
164 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
165 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
166 " :def <cmd> <expr> define a command :<cmd>\n" ++
167 " :edit <file> edit file\n" ++
168 " :edit edit last module\n" ++
169 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
170 " :help, :? display this list of commands\n" ++
171 " :info [<name> ...] display information about the given names\n" ++
172 " :kind <type> show the kind of <type>\n" ++
173 " :load <filename> ... load module(s) and their dependents\n" ++
174 " :main [<arguments> ...] run the main function with the given arguments\n" ++
175 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
176 " :quit exit GHCi\n" ++
177 " :reload reload the current module set\n" ++
178 " :type <expr> show the type of <expr>\n" ++
179 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
180 " :!<command> run the shell command <command>\n" ++
182 " -- Commands for debugging:\n" ++
184 " :abandon at a breakpoint, abandon current computation\n" ++
185 " :back go back in the history (after :trace)\n" ++
186 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
187 " :break <name> set a breakpoint on the specified function\n" ++
188 " :continue resume after a breakpoint\n" ++
189 " :delete <number> delete the specified breakpoint\n" ++
190 " :delete * delete all breakpoints\n" ++
191 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
192 " :forward go forward in the history (after :back)\n" ++
193 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
194 " :print [<name> ...] prints a value without forcing its computation\n" ++
195 " :sprint [<name> ...] simplifed version of :print\n" ++
196 " :step single-step after stopping at a breakpoint\n"++
197 " :step <expr> single-step into <expr>\n"++
198 " :steplocal single-step restricted to the current top level decl.\n"++
199 " :stepmodule single-step restricted to the current module\n"++
200 " :trace trace after stopping at a breakpoint\n"++
201 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
204 " -- Commands for changing settings:\n" ++
206 " :set <option> ... set options\n" ++
207 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
208 " :set prog <progname> set the value returned by System.getProgName\n" ++
209 " :set prompt <prompt> set the prompt used in GHCi\n" ++
210 " :set editor <cmd> set the command used for :edit\n" ++
211 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
212 " :unset <option> ... unset options\n" ++
214 " Options for ':set' and ':unset':\n" ++
216 " +r revert top-level expressions after each evaluation\n" ++
217 " +s print timing/memory stats after each evaluation\n" ++
218 " +t print type after evaluation\n" ++
219 " -<flags> most GHC command line flags can also be set here\n" ++
220 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
222 " -- Commands for displaying information:\n" ++
224 " :show bindings show the current bindings made at the prompt\n" ++
225 " :show breaks show the active breakpoints\n" ++
226 " :show context show the breakpoint context\n" ++
227 " :show modules show the currently loaded modules\n" ++
228 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
235 win <- System.Win32.getWindowsDirectory
236 return (win `joinFileName` "notepad.exe")
241 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
242 interactiveUI session srcs maybe_expr = do
243 -- HACK! If we happen to get into an infinite loop (eg the user
244 -- types 'let x=x in x' at the prompt), then the thread will block
245 -- on a blackhole, and become unreachable during GC. The GC will
246 -- detect that it is unreachable and send it the NonTermination
247 -- exception. However, since the thread is unreachable, everything
248 -- it refers to might be finalized, including the standard Handles.
249 -- This sounds like a bug, but we don't have a good solution right
255 -- Initialise buffering for the *interpreted* I/O system
256 initInterpBuffering session
258 when (isNothing maybe_expr) $ do
259 -- Only for GHCi (not runghc and ghc -e):
261 -- Turn buffering off for the compiled program's stdout/stderr
263 -- Turn buffering off for GHCi's stdout
265 hSetBuffering stdout NoBuffering
266 -- We don't want the cmd line to buffer any input that might be
267 -- intended for the program, so unbuffer stdin.
268 hSetBuffering stdin NoBuffering
270 -- initial context is just the Prelude
271 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
272 GHC.setContext session [] [prel_mod]
276 Readline.setAttemptedCompletionFunction (Just completeWord)
277 --Readline.parseAndBind "set show-all-if-ambiguous 1"
279 let symbols = "!#$%&*+/<=>?@\\^|-~"
280 specials = "(),;[]`{}"
282 word_break_chars = spaces ++ specials ++ symbols
284 Readline.setBasicWordBreakCharacters word_break_chars
285 Readline.setCompleterWordBreakCharacters word_break_chars
288 default_editor <- findEditor
290 startGHCi (runGHCi srcs maybe_expr)
291 GHCiState{ progname = "<interactive>",
295 editor = default_editor,
301 tickarrays = emptyModuleEnv,
306 Readline.resetTerminal Nothing
311 prel_name = GHC.mkModuleName "Prelude"
313 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
314 runGHCi paths maybe_expr = do
315 let read_dot_files = not opt_IgnoreDotGhci
317 when (read_dot_files) $ do
320 exists <- io (doesFileExist file)
322 dir_ok <- io (checkPerms ".")
323 file_ok <- io (checkPerms file)
324 when (dir_ok && file_ok) $ do
325 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
328 Right hdl -> fileLoop hdl False
330 when (read_dot_files) $ do
331 -- Read in $HOME/.ghci
332 either_dir <- io (IO.try (getEnv "HOME"))
336 cwd <- io (getCurrentDirectory)
337 when (dir /= cwd) $ do
338 let file = dir ++ "/.ghci"
339 ok <- io (checkPerms file)
341 either_hdl <- io (IO.try (openFile file ReadMode))
344 Right hdl -> fileLoop hdl False
346 -- Perform a :load for files given on the GHCi command line
347 -- When in -e mode, if the load fails then we want to stop
348 -- immediately rather than going on to evaluate the expression.
349 when (not (null paths)) $ do
350 ok <- ghciHandle (\e -> do showException e; return Failed) $
352 when (isJust maybe_expr && failed ok) $
353 io (exitWith (ExitFailure 1))
355 -- if verbosity is greater than 0, or we are connected to a
356 -- terminal, display the prompt in the interactive loop.
357 is_tty <- io (hIsTerminalDevice stdin)
358 dflags <- getDynFlags
359 let show_prompt = verbosity dflags > 0 || is_tty
364 #if defined(mingw32_HOST_OS)
365 -- The win32 Console API mutates the first character of
366 -- type-ahead when reading from it in a non-buffered manner. Work
367 -- around this by flushing the input buffer of type-ahead characters,
368 -- but only if stdin is available.
369 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
371 Left err | isDoesNotExistError err -> return ()
372 | otherwise -> io (ioError err)
373 Right () -> return ()
375 -- initialise the console if necessary
378 -- enter the interactive loop
379 interactiveLoop is_tty show_prompt
381 -- just evaluate the expression we were given
386 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
389 interactiveLoop is_tty show_prompt =
390 -- Ignore ^C exceptions caught here
391 ghciHandleDyn (\e -> case e of
393 #if defined(mingw32_HOST_OS)
396 interactiveLoop is_tty show_prompt
397 _other -> return ()) $
399 ghciUnblock $ do -- unblock necessary if we recursed from the
400 -- exception handler above.
402 -- read commands from stdin
406 else fileLoop stdin show_prompt
408 fileLoop stdin show_prompt
412 -- NOTE: We only read .ghci files if they are owned by the current user,
413 -- and aren't world writable. Otherwise, we could be accidentally
414 -- running code planted by a malicious third party.
416 -- Furthermore, We only read ./.ghci if . is owned by the current user
417 -- and isn't writable by anyone else. I think this is sufficient: we
418 -- don't need to check .. and ../.. etc. because "." always refers to
419 -- the same directory while a process is running.
421 checkPerms :: String -> IO Bool
423 #ifdef mingw32_HOST_OS
426 Util.handle (\_ -> return False) $ do
427 st <- getFileStatus name
429 if fileOwner st /= me then do
430 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
433 let mode = fileMode st
434 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
435 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
437 putStrLn $ "*** WARNING: " ++ name ++
438 " is writable by someone else, IGNORING!"
443 fileLoop :: Handle -> Bool -> GHCi ()
444 fileLoop hdl show_prompt = do
445 when show_prompt $ do
448 l <- io (IO.try (hGetLine hdl))
450 Left e | isEOFError e -> return ()
451 | InvalidArgument <- etype -> return ()
452 | otherwise -> io (ioError e)
453 where etype = ioeGetErrorType e
454 -- treat InvalidArgument in the same way as EOF:
455 -- this can happen if the user closed stdin, or
456 -- perhaps did getContents which closes stdin at
459 case removeSpaces l of
460 "" -> fileLoop hdl show_prompt
461 l -> do quit <- runCommands l
462 if quit then return () else fileLoop hdl show_prompt
465 session <- getSession
466 (toplevs,exports) <- io (GHC.getContext session)
467 resumes <- io $ GHC.getResumeContext session
473 let ix = GHC.resumeHistoryIx r
475 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
477 let hist = GHC.resumeHistory r !! (ix-1)
478 span <- io$ GHC.getHistorySpan session hist
479 return (brackets (ppr (negate ix) <> char ':'
480 <+> ppr span) <> space)
482 dots | r:rs <- resumes, not (null rs) = text "... "
486 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
487 hsep (map (ppr . GHC.moduleName) exports)
489 deflt_prompt = dots <> context_bit <> modules_bit
491 f ('%':'s':xs) = deflt_prompt <> f xs
492 f ('%':'%':xs) = char '%' <> f xs
493 f (x:xs) = char x <> f xs
497 return (showSDoc (f (prompt st)))
501 readlineLoop :: GHCi ()
503 session <- getSession
504 (mod,imports) <- io (GHC.getContext session)
506 saveSession -- for use by completion
508 mb_span <- getCurrentBreakSpan
510 l <- io (readline prompt `finally` setNonBlockingFD 0)
511 -- readline sometimes puts stdin into blocking mode,
512 -- so we need to put it back for the IO library
517 case removeSpaces l of
521 quit <- runCommands l
522 if quit then return () else readlineLoop
525 runCommands :: String -> GHCi Bool
527 q <- ghciHandle handler (doCommand cmd)
528 if q then return True else runNext
534 c:cs -> do setGHCiState st{ cmdqueue = cs }
537 doCommand (':' : cmd) = specialCommand cmd
538 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
541 enqueueCommands :: [String] -> GHCi ()
542 enqueueCommands cmds = do
544 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
547 -- This version is for the GHC command-line option -e. The only difference
548 -- from runCommand is that it catches the ExitException exception and
549 -- exits, rather than printing out the exception.
550 runCommandEval c = ghciHandle handleEval (doCommand c)
552 handleEval (ExitException code) = io (exitWith code)
553 handleEval e = do handler e
554 io (exitWith (ExitFailure 1))
556 doCommand (':' : command) = specialCommand command
558 = do r <- runStmt stmt GHC.RunToCompletion
560 False -> io (exitWith (ExitFailure 1))
561 -- failure to run the command causes exit(1) for ghc -e.
564 runStmt :: String -> SingleStep -> GHCi Bool
566 | null (filter (not.isSpace) stmt) = return False
567 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
569 = do st <- getGHCiState
570 session <- getSession
571 result <- io $ withProgName (progname st) $ withArgs (args st) $
572 GHC.runStmt session stmt step
573 afterRunStmt (const True) result
576 --afterRunStmt :: GHC.RunResult -> GHCi Bool
577 -- False <=> the statement failed to compile
578 afterRunStmt _ (GHC.RunException e) = throw e
579 afterRunStmt step_here run_result = do
580 session <- getSession
581 resumes <- io $ GHC.getResumeContext session
583 GHC.RunOk names -> do
584 show_types <- isOptionSet ShowType
585 when show_types $ printTypeOfNames session names
586 GHC.RunBreak _ names mb_info
587 | isNothing mb_info ||
588 step_here (GHC.resumeSpan $ head resumes) -> do
589 printForUser $ ptext SLIT("Stopped at") <+>
590 ppr (GHC.resumeSpan $ head resumes)
591 -- printTypeOfNames session names
592 printTypeAndContentOfNames session names
593 maybe (return ()) runBreakCmd mb_info
594 -- run the command set with ":set stop <cmd>"
596 enqueueCommands [stop st]
598 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
599 afterRunStmt step_here >> return ()
603 io installSignalHandlers
604 b <- isOptionSet RevertCAFs
605 io (when b revertCAFs)
607 return (case run_result of GHC.RunOk _ -> True; _ -> False)
609 where printTypeAndContentOfNames session names = do
610 let namesSorted = sortBy compareNames names
611 tythings <- catMaybes `liftM`
612 io (mapM (GHC.lookupName session) namesSorted)
613 docs_ty <- mapM showTyThing tythings
614 terms <- mapM (io . GHC.obtainTermB session 10 False)
615 [ id | (AnId id, Just _) <- zip tythings docs_ty]
616 docs_terms <- mapM (io . showTerm session) terms
617 printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts)
621 runBreakCmd :: GHC.BreakInfo -> GHCi ()
622 runBreakCmd info = do
623 let mod = GHC.breakInfo_module info
624 nm = GHC.breakInfo_number info
626 case [ loc | (i,loc) <- breaks st,
627 breakModule loc == mod, breakTick loc == nm ] of
629 loc:_ | null cmd -> return ()
630 | otherwise -> do enqueueCommands [cmd]; return ()
631 where cmd = onBreakCmd loc
633 printTypeOfNames :: Session -> [Name] -> GHCi ()
634 printTypeOfNames session names
635 = mapM_ (printTypeOfName session) $ sortBy compareNames names
637 compareNames :: Name -> Name -> Ordering
638 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
639 where compareWith n = (getOccString n, getSrcSpan n)
641 printTypeOfName :: Session -> Name -> GHCi ()
642 printTypeOfName session n
643 = do maybe_tything <- io (GHC.lookupName session n)
644 case maybe_tything of
646 Just thing -> printTyThing thing
648 specialCommand :: String -> GHCi Bool
649 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
650 specialCommand str = do
651 let (cmd,rest) = break isSpace str
652 maybe_cmd <- io (lookupCommand cmd)
654 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
655 ++ shortHelpText) >> return False)
656 Just (_,f,_,_) -> f (dropWhile isSpace rest)
658 lookupCommand :: String -> IO (Maybe Command)
659 lookupCommand str = do
660 cmds <- readIORef commands
661 -- look for exact match first, then the first prefix match
662 case [ c | c <- cmds, str == cmdName c ] of
663 c:_ -> return (Just c)
664 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
666 c:_ -> return (Just c)
669 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
670 getCurrentBreakSpan = do
671 session <- getSession
672 resumes <- io $ GHC.getResumeContext session
676 let ix = GHC.resumeHistoryIx r
678 then return (Just (GHC.resumeSpan r))
680 let hist = GHC.resumeHistory r !! (ix-1)
681 span <- io $ GHC.getHistorySpan session hist
684 getCurrentBreakModule :: GHCi (Maybe Module)
685 getCurrentBreakModule = do
686 session <- getSession
687 resumes <- io $ GHC.getResumeContext session
691 let ix = GHC.resumeHistoryIx r
693 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
695 let hist = GHC.resumeHistory r !! (ix-1)
696 return $ Just $ GHC.getHistoryModule hist
698 -----------------------------------------------------------------------------
701 noArgs :: GHCi () -> String -> GHCi ()
703 noArgs m _ = io $ putStrLn "This command takes no arguments"
705 help :: String -> GHCi ()
706 help _ = io (putStr helpText)
708 info :: String -> GHCi ()
709 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
710 info s = do { let names = words s
711 ; session <- getSession
712 ; dflags <- getDynFlags
713 ; let pefas = dopt Opt_PrintExplicitForalls dflags
714 ; mapM_ (infoThing pefas session) names }
716 infoThing pefas session str = io $ do
717 names <- GHC.parseName session str
718 mb_stuffs <- mapM (GHC.getInfo session) names
719 let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
720 unqual <- GHC.getPrintUnqual session
721 putStrLn (showSDocForUser unqual $
722 vcat (intersperse (text "") $
723 map (pprInfo pefas) filtered))
725 -- Filter out names whose parent is also there Good
726 -- example is '[]', which is both a type and data
727 -- constructor in the same type
728 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
729 filterOutChildren get_thing xs
730 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
732 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
734 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
735 pprInfo pefas (thing, fixity, insts)
736 = pprTyThingInContextLoc pefas thing
737 $$ show_fixity fixity
738 $$ vcat (map GHC.pprInstance insts)
741 | fix == GHC.defaultFixity = empty
742 | otherwise = ppr fix <+> ppr (GHC.getName thing)
744 runMain :: String -> GHCi ()
746 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
747 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
749 addModule :: [FilePath] -> GHCi ()
751 io (revertCAFs) -- always revert CAFs on load/add.
752 files <- mapM expandPath files
753 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
754 session <- getSession
755 io (mapM_ (GHC.addTarget session) targets)
756 ok <- io (GHC.load session LoadAllTargets)
759 changeDirectory :: String -> GHCi ()
760 changeDirectory dir = do
761 session <- getSession
762 graph <- io (GHC.getModuleGraph session)
763 when (not (null graph)) $
764 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
765 io (GHC.setTargets session [])
766 io (GHC.load session LoadAllTargets)
767 setContextAfterLoad session []
768 io (GHC.workingDirectoryChanged session)
769 dir <- expandPath dir
770 io (setCurrentDirectory dir)
772 editFile :: String -> GHCi ()
774 do file <- if null str then chooseEditFile else return str
778 $ throwDyn (CmdLineError "editor not set, use :set editor")
779 io $ system (cmd ++ ' ':file)
782 -- The user didn't specify a file so we pick one for them.
783 -- Our strategy is to pick the first module that failed to load,
784 -- or otherwise the first target.
786 -- XXX: Can we figure out what happened if the depndecy analysis fails
787 -- (e.g., because the porgrammeer mistyped the name of a module)?
788 -- XXX: Can we figure out the location of an error to pass to the editor?
789 -- XXX: if we could figure out the list of errors that occured during the
790 -- last load/reaload, then we could start the editor focused on the first
792 chooseEditFile :: GHCi String
794 do session <- getSession
795 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
797 graph <- io (GHC.getModuleGraph session)
798 failed_graph <- filterM hasFailed graph
799 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
801 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
804 case pick (order failed_graph) of
805 Just file -> return file
807 do targets <- io (GHC.getTargets session)
808 case msum (map fromTarget targets) of
809 Just file -> return file
810 Nothing -> throwDyn (CmdLineError "No files to edit.")
812 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
813 fromTarget _ = Nothing -- when would we get a module target?
815 defineMacro :: String -> GHCi ()
817 let (macro_name, definition) = break isSpace s
818 cmds <- io (readIORef commands)
820 then throwDyn (CmdLineError "invalid macro name")
822 if (macro_name `elem` map cmdName cmds)
823 then throwDyn (CmdLineError
824 ("command '" ++ macro_name ++ "' is already defined"))
827 -- give the expression a type signature, so we can be sure we're getting
828 -- something of the right type.
829 let new_expr = '(' : definition ++ ") :: String -> IO String"
831 -- compile the expression
833 maybe_hv <- io (GHC.compileExpr cms new_expr)
836 Just hv -> io (writeIORef commands --
837 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
839 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
841 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
842 enqueueCommands (lines str)
845 undefineMacro :: String -> GHCi ()
846 undefineMacro macro_name = do
847 cmds <- io (readIORef commands)
848 if (macro_name `elem` map cmdName builtin_commands)
849 then throwDyn (CmdLineError
850 ("command '" ++ macro_name ++ "' cannot be undefined"))
852 if (macro_name `notElem` map cmdName cmds)
853 then throwDyn (CmdLineError
854 ("command '" ++ macro_name ++ "' not defined"))
856 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
858 cmdCmd :: String -> GHCi ()
860 let expr = '(' : str ++ ") :: IO String"
861 session <- getSession
862 maybe_hv <- io (GHC.compileExpr session expr)
866 cmds <- io $ (unsafeCoerce# hv :: IO String)
867 enqueueCommands (lines cmds)
870 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
871 loadModule fs = timeIt (loadModule' fs)
873 loadModule_ :: [FilePath] -> GHCi ()
874 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
876 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
877 loadModule' files = do
878 session <- getSession
881 discardActiveBreakPoints
882 io (GHC.setTargets session [])
883 io (GHC.load session LoadAllTargets)
886 let (filenames, phases) = unzip files
887 exp_filenames <- mapM expandPath filenames
888 let files' = zip exp_filenames phases
889 targets <- io (mapM (uncurry GHC.guessTarget) files')
891 -- NOTE: we used to do the dependency anal first, so that if it
892 -- fails we didn't throw away the current set of modules. This would
893 -- require some re-working of the GHC interface, so we'll leave it
894 -- as a ToDo for now.
896 io (GHC.setTargets session targets)
897 doLoad session LoadAllTargets
899 checkModule :: String -> GHCi ()
901 let modl = GHC.mkModuleName m
902 session <- getSession
903 result <- io (GHC.checkModule session modl False)
905 Nothing -> io $ putStrLn "Nothing"
906 Just r -> io $ putStrLn (showSDoc (
907 case GHC.checkedModuleInfo r of
908 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
910 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
912 (text "global names: " <+> ppr global) $$
913 (text "local names: " <+> ppr local)
915 afterLoad (successIf (isJust result)) session
917 reloadModule :: String -> GHCi ()
919 session <- getSession
920 doLoad session $ if null m then LoadAllTargets
921 else LoadUpTo (GHC.mkModuleName m)
924 doLoad session howmuch = do
925 -- turn off breakpoints before we load: we can't turn them off later, because
926 -- the ModBreaks will have gone away.
927 discardActiveBreakPoints
928 ok <- io (GHC.load session howmuch)
932 afterLoad ok session = do
933 io (revertCAFs) -- always revert CAFs on load.
935 graph <- io (GHC.getModuleGraph session)
936 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
937 setContextAfterLoad session graph'
938 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
940 setContextAfterLoad session [] = do
941 prel_mod <- getPrelude
942 io (GHC.setContext session [] [prel_mod])
943 setContextAfterLoad session ms = do
944 -- load a target if one is available, otherwise load the topmost module.
945 targets <- io (GHC.getTargets session)
946 case [ m | Just m <- map (findTarget ms) targets ] of
948 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
949 load_this (last graph')
954 = case filter (`matches` t) ms of
958 summary `matches` Target (TargetModule m) _
959 = GHC.ms_mod_name summary == m
960 summary `matches` Target (TargetFile f _) _
961 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
962 summary `matches` target
965 load_this summary | m <- GHC.ms_mod summary = do
966 b <- io (GHC.moduleIsInterpreted session m)
967 if b then io (GHC.setContext session [m] [])
969 prel_mod <- getPrelude
970 io (GHC.setContext session [] [prel_mod,m])
973 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
974 modulesLoadedMsg ok mods = do
975 dflags <- getDynFlags
976 when (verbosity dflags > 0) $ do
978 | null mods = text "none."
980 punctuate comma (map ppr mods)) <> text "."
983 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
985 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
988 typeOfExpr :: String -> GHCi ()
990 = do cms <- getSession
991 maybe_ty <- io (GHC.exprType cms str)
994 Just ty -> do ty' <- cleanType ty
995 printForUser $ text str <> text " :: " <> ppr ty'
997 kindOfType :: String -> GHCi ()
999 = do cms <- getSession
1000 maybe_ty <- io (GHC.typeKind cms str)
1002 Nothing -> return ()
1003 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
1005 quit :: String -> GHCi Bool
1006 quit _ = return True
1008 shellEscape :: String -> GHCi Bool
1009 shellEscape str = io (system str >> return False)
1011 -----------------------------------------------------------------------------
1012 -- Browsing a module's contents
1014 browseCmd :: String -> GHCi ()
1017 ['*':m] | looksLikeModuleName m -> browseModule m False
1018 [m] | looksLikeModuleName m -> browseModule m True
1019 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1021 browseModule m exports_only = do
1023 modl <- if exports_only then lookupModule m
1024 else wantInterpretedModule m
1026 -- Temporarily set the context to the module we're interested in,
1027 -- just so we can get an appropriate PrintUnqualified
1028 (as,bs) <- io (GHC.getContext s)
1029 prel_mod <- getPrelude
1030 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1031 else GHC.setContext s [modl] [])
1032 unqual <- io (GHC.getPrintUnqual s)
1033 io (GHC.setContext s as bs)
1035 mb_mod_info <- io $ GHC.getModuleInfo s modl
1037 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1040 | exports_only = GHC.modInfoExports mod_info
1041 | otherwise = GHC.modInfoTopLevelScope mod_info
1044 mb_things <- io $ mapM (GHC.lookupName s) names
1045 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1047 dflags <- getDynFlags
1048 let pefas = dopt Opt_PrintExplicitForalls dflags
1049 io (putStrLn (showSDocForUser unqual (
1050 vcat (map (pprTyThingInContext pefas) filtered_things)
1052 -- ToDo: modInfoInstances currently throws an exception for
1053 -- package modules. When it works, we can do this:
1054 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1056 -----------------------------------------------------------------------------
1057 -- Setting the module context
1060 | all sensible mods = fn mods
1061 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1063 (fn, mods) = case str of
1064 '+':stuff -> (addToContext, words stuff)
1065 '-':stuff -> (removeFromContext, words stuff)
1066 stuff -> (newContext, words stuff)
1068 sensible ('*':m) = looksLikeModuleName m
1069 sensible m = looksLikeModuleName m
1071 separate :: Session -> [String] -> [Module] -> [Module]
1072 -> GHCi ([Module],[Module])
1073 separate session [] as bs = return (as,bs)
1074 separate session (('*':str):ms) as bs = do
1075 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1076 b <- io $ GHC.moduleIsInterpreted session m
1077 if b then separate session ms (m:as) bs
1078 else throwDyn (CmdLineError ("module '"
1079 ++ GHC.moduleNameString (GHC.moduleName m)
1080 ++ "' is not interpreted"))
1081 separate session (str:ms) as bs = do
1082 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1083 separate session ms as (m:bs)
1085 newContext :: [String] -> GHCi ()
1086 newContext strs = do
1088 (as,bs) <- separate s strs [] []
1089 prel_mod <- getPrelude
1090 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1091 io $ GHC.setContext s as bs'
1094 addToContext :: [String] -> GHCi ()
1095 addToContext strs = do
1097 (as,bs) <- io $ GHC.getContext s
1099 (new_as,new_bs) <- separate s strs [] []
1101 let as_to_add = new_as \\ (as ++ bs)
1102 bs_to_add = new_bs \\ (as ++ bs)
1104 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1107 removeFromContext :: [String] -> GHCi ()
1108 removeFromContext strs = do
1110 (as,bs) <- io $ GHC.getContext s
1112 (as_to_remove,bs_to_remove) <- separate s strs [] []
1114 let as' = as \\ (as_to_remove ++ bs_to_remove)
1115 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1117 io $ GHC.setContext s as' bs'
1119 ----------------------------------------------------------------------------
1122 -- set options in the interpreter. Syntax is exactly the same as the
1123 -- ghc command line, except that certain options aren't available (-C,
1126 -- This is pretty fragile: most options won't work as expected. ToDo:
1127 -- figure out which ones & disallow them.
1129 setCmd :: String -> GHCi ()
1131 = do st <- getGHCiState
1132 let opts = options st
1133 io $ putStrLn (showSDoc (
1134 text "options currently set: " <>
1137 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1140 = case toArgs str of
1141 ("args":args) -> setArgs args
1142 ("prog":prog) -> setProg prog
1143 ("prompt":prompt) -> setPrompt (after 6)
1144 ("editor":cmd) -> setEditor (after 6)
1145 ("stop":cmd) -> setStop (after 4)
1146 wds -> setOptions wds
1147 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1151 setGHCiState st{ args = args }
1155 setGHCiState st{ progname = prog }
1157 io (hPutStrLn stderr "syntax: :set prog <progname>")
1161 setGHCiState st{ editor = cmd }
1163 setStop str@(c:_) | isDigit c
1164 = do let (nm_str,rest) = break (not.isDigit) str
1167 let old_breaks = breaks st
1168 if all ((/= nm) . fst) old_breaks
1169 then printForUser (text "Breakpoint" <+> ppr nm <+>
1170 text "does not exist")
1172 let new_breaks = map fn old_breaks
1173 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1174 | otherwise = (i,loc)
1175 setGHCiState st{ breaks = new_breaks }
1178 setGHCiState st{ stop = cmd }
1180 setPrompt value = do
1183 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1184 else setGHCiState st{ prompt = remQuotes value }
1186 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1190 do -- first, deal with the GHCi opts (+s, +t, etc.)
1191 let (plus_opts, minus_opts) = partition isPlus wds
1192 mapM_ setOpt plus_opts
1193 -- then, dynamic flags
1194 newDynFlags minus_opts
1196 newDynFlags minus_opts = do
1197 dflags <- getDynFlags
1198 let pkg_flags = packageFlags dflags
1199 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1201 if (not (null leftovers))
1202 then throwDyn (CmdLineError ("unrecognised flags: " ++
1206 new_pkgs <- setDynFlags dflags'
1208 -- if the package flags changed, we should reset the context
1209 -- and link the new packages.
1210 dflags <- getDynFlags
1211 when (packageFlags dflags /= pkg_flags) $ do
1212 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1213 session <- getSession
1214 io (GHC.setTargets session [])
1215 io (GHC.load session LoadAllTargets)
1216 io (linkPackages dflags new_pkgs)
1217 setContextAfterLoad session []
1221 unsetOptions :: String -> GHCi ()
1223 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1224 let opts = words str
1225 (minus_opts, rest1) = partition isMinus opts
1226 (plus_opts, rest2) = partition isPlus rest1
1228 if (not (null rest2))
1229 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1232 mapM_ unsetOpt plus_opts
1234 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1235 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1237 no_flags <- mapM no_flag minus_opts
1238 newDynFlags no_flags
1240 isMinus ('-':s) = True
1243 isPlus ('+':s) = True
1247 = case strToGHCiOpt str of
1248 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1249 Just o -> setOption o
1252 = case strToGHCiOpt str of
1253 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1254 Just o -> unsetOption o
1256 strToGHCiOpt :: String -> (Maybe GHCiOption)
1257 strToGHCiOpt "s" = Just ShowTiming
1258 strToGHCiOpt "t" = Just ShowType
1259 strToGHCiOpt "r" = Just RevertCAFs
1260 strToGHCiOpt _ = Nothing
1262 optToStr :: GHCiOption -> String
1263 optToStr ShowTiming = "s"
1264 optToStr ShowType = "t"
1265 optToStr RevertCAFs = "r"
1267 -- ---------------------------------------------------------------------------
1273 ["args"] -> io $ putStrLn (show (args st))
1274 ["prog"] -> io $ putStrLn (show (progname st))
1275 ["prompt"] -> io $ putStrLn (show (prompt st))
1276 ["editor"] -> io $ putStrLn (show (editor st))
1277 ["stop"] -> io $ putStrLn (show (stop st))
1278 ["modules" ] -> showModules
1279 ["bindings"] -> showBindings
1280 ["linker"] -> io showLinkerState
1281 ["breaks"] -> showBkptTable
1282 ["context"] -> showContext
1283 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1286 session <- getSession
1287 let show_one ms = do m <- io (GHC.showModule session ms)
1289 graph <- io (GHC.getModuleGraph session)
1290 mapM_ show_one graph
1294 unqual <- io (GHC.getPrintUnqual s)
1295 bindings <- io (GHC.getBindings s)
1296 mapM_ printTyThing $ sortBy compareTyThings bindings
1299 compareTyThings :: TyThing -> TyThing -> Ordering
1300 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1302 showTyThing :: TyThing -> GHCi (Maybe SDoc)
1303 showTyThing (AnId id) = do
1304 ty' <- cleanType (GHC.idType id)
1305 return $ Just $ ppr id <> text " :: " <> ppr ty'
1306 showTyThing _ = return Nothing
1308 printTyThing :: TyThing -> GHCi ()
1309 printTyThing tyth = do
1310 mb_x <- showTyThing tyth
1312 Just x -> printForUser x
1313 Nothing -> return ()
1315 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1316 cleanType :: Type -> GHCi Type
1318 dflags <- getDynFlags
1319 if dopt Opt_PrintExplicitForalls dflags
1321 else return $! GHC.dropForAlls ty
1323 showBkptTable :: GHCi ()
1326 printForUser $ prettyLocations (breaks st)
1328 showContext :: GHCi ()
1330 session <- getSession
1331 resumes <- io $ GHC.getResumeContext session
1332 printForUser $ vcat (map pp_resume (reverse resumes))
1335 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1336 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1339 -- -----------------------------------------------------------------------------
1342 completeNone :: String -> IO [String]
1343 completeNone w = return []
1346 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1347 completeWord w start end = do
1348 line <- Readline.getLineBuffer
1349 let line_words = words (dropWhile isSpace line)
1351 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1353 | ((':':c) : _) <- line_words -> do
1354 maybe_cmd <- lookupCommand c
1355 let (n,w') = selectWord (words' 0 line)
1357 Nothing -> return Nothing
1358 Just (_,_,False,complete) -> wrapCompleter complete w
1359 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1360 return (map (drop n) rets)
1361 in wrapCompleter complete' w'
1362 | ("import" : _) <- line_words ->
1363 wrapCompleter completeModule w
1365 --printf "complete %s, start = %d, end = %d\n" w start end
1366 wrapCompleter completeIdentifier w
1367 where words' _ [] = []
1368 words' n str = let (w,r) = break isSpace str
1369 (s,r') = span isSpace r
1370 in (n,w):words' (n+length w+length s) r'
1371 -- In a Haskell expression we want to parse 'a-b' as three words
1372 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1373 -- only be a single word.
1374 selectWord [] = (0,w)
1375 selectWord ((offset,x):xs)
1376 | offset+length x >= start = (start-offset,take (end-offset) x)
1377 | otherwise = selectWord xs
1381 cmds <- readIORef commands
1382 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1384 completeMacro w = do
1385 cmds <- readIORef commands
1386 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1387 return (filter (w `isPrefixOf`) cmds')
1389 completeIdentifier w = do
1391 rdrs <- GHC.getRdrNamesInScope s
1392 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1394 completeModule w = do
1396 dflags <- GHC.getSessionDynFlags s
1397 let pkg_mods = allExposedModules dflags
1398 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1400 completeHomeModule w = do
1402 g <- GHC.getModuleGraph s
1403 let home_mods = map GHC.ms_mod_name g
1404 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1406 completeSetOptions w = do
1407 return (filter (w `isPrefixOf`) options)
1408 where options = "args":"prog":allFlags
1410 completeFilename = Readline.filenameCompletionFunction
1412 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1414 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1415 unionComplete f1 f2 w = do
1420 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1421 wrapCompleter fun w = do
1424 [] -> return Nothing
1425 [x] -> return (Just (x,[]))
1426 xs -> case getCommonPrefix xs of
1427 "" -> return (Just ("",xs))
1428 pref -> return (Just (pref,xs))
1430 getCommonPrefix :: [String] -> String
1431 getCommonPrefix [] = ""
1432 getCommonPrefix (s:ss) = foldl common s ss
1433 where common s "" = ""
1435 common (c:cs) (d:ds)
1436 | c == d = c : common cs ds
1439 allExposedModules :: DynFlags -> [ModuleName]
1440 allExposedModules dflags
1441 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1443 pkg_db = pkgIdMap (pkgState dflags)
1445 completeCmd = completeNone
1446 completeMacro = completeNone
1447 completeIdentifier = completeNone
1448 completeModule = completeNone
1449 completeHomeModule = completeNone
1450 completeSetOptions = completeNone
1451 completeFilename = completeNone
1452 completeHomeModuleOrFile=completeNone
1453 completeBkpt = completeNone
1456 -- ---------------------------------------------------------------------------
1457 -- User code exception handling
1459 -- This is the exception handler for exceptions generated by the
1460 -- user's code and exceptions coming from children sessions;
1461 -- it normally just prints out the exception. The
1462 -- handler must be recursive, in case showing the exception causes
1463 -- more exceptions to be raised.
1465 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1466 -- raising another exception. We therefore don't put the recursive
1467 -- handler arond the flushing operation, so if stderr is closed
1468 -- GHCi will just die gracefully rather than going into an infinite loop.
1469 handler :: Exception -> GHCi Bool
1471 handler exception = do
1473 io installSignalHandlers
1474 ghciHandle handler (showException exception >> return False)
1476 showException (DynException dyn) =
1477 case fromDynamic dyn of
1478 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1479 Just Interrupted -> io (putStrLn "Interrupted.")
1480 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1481 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1482 Just other_ghc_ex -> io (print other_ghc_ex)
1484 showException other_exception
1485 = io (putStrLn ("*** Exception: " ++ show other_exception))
1487 -----------------------------------------------------------------------------
1488 -- recursive exception handlers
1490 -- Don't forget to unblock async exceptions in the handler, or if we're
1491 -- in an exception loop (eg. let a = error a in a) the ^C exception
1492 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1494 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1495 ghciHandle h (GHCi m) = GHCi $ \s ->
1496 Exception.catch (m s)
1497 (\e -> unGHCi (ghciUnblock (h e)) s)
1499 ghciUnblock :: GHCi a -> GHCi a
1500 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1503 -- ----------------------------------------------------------------------------
1506 expandPath :: String -> GHCi String
1508 case dropWhile isSpace path of
1510 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1511 return (tilde ++ '/':d)
1515 wantInterpretedModule :: String -> GHCi Module
1516 wantInterpretedModule str = do
1517 session <- getSession
1518 modl <- lookupModule str
1519 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1520 when (not is_interpreted) $
1521 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1524 wantNameFromInterpretedModule noCanDo str and_then = do
1525 session <- getSession
1526 names <- io $ GHC.parseName session str
1530 let modl = GHC.nameModule n
1531 if not (GHC.isExternalName n)
1532 then noCanDo n $ ppr n <>
1533 text " is not defined in an interpreted module"
1535 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1536 if not is_interpreted
1537 then noCanDo n $ text "module " <> ppr modl <>
1538 text " is not interpreted"
1541 -- ----------------------------------------------------------------------------
1542 -- Windows console setup
1544 setUpConsole :: IO ()
1546 #ifdef mingw32_HOST_OS
1547 -- On Windows we need to set a known code page, otherwise the characters
1548 -- we read from the console will be be in some strange encoding, and
1549 -- similarly for characters we write to the console.
1551 -- At the moment, GHCi pretends all input is Latin-1. In the
1552 -- future we should support UTF-8, but for now we set the code pages
1555 -- It seems you have to set the font in the console window to
1556 -- a Unicode font in order for output to work properly,
1557 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1558 -- (see MSDN for SetConsoleOutputCP()).
1560 setConsoleCP 28591 -- ISO Latin-1
1561 setConsoleOutputCP 28591 -- ISO Latin-1
1565 -- -----------------------------------------------------------------------------
1566 -- commands for debugger
1568 sprintCmd = pprintCommand False False
1569 printCmd = pprintCommand True False
1570 forceCmd = pprintCommand False True
1572 pprintCommand bind force str = do
1573 session <- getSession
1574 io $ pprintClosureCommand session bind force str
1576 stepCmd :: String -> GHCi ()
1577 stepCmd [] = doContinue (const True) GHC.SingleStep
1578 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1580 stepLocalCmd :: String -> GHCi ()
1581 stepLocalCmd [] = do
1582 mb_span <- getCurrentBreakSpan
1584 Nothing -> stepCmd []
1586 Just mod <- getCurrentBreakModule
1587 current_toplevel_decl <- enclosingTickSpan mod loc
1588 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1590 stepLocalCmd expression = stepCmd expression
1592 stepModuleCmd :: String -> GHCi ()
1593 stepModuleCmd [] = do
1594 mb_span <- getCurrentBreakSpan
1596 Nothing -> stepCmd []
1598 Just span <- getCurrentBreakSpan
1599 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1600 doContinue f GHC.SingleStep
1602 stepModuleCmd expression = stepCmd expression
1604 -- | Returns the span of the largest tick containing the srcspan given
1605 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1606 enclosingTickSpan mod src = do
1607 ticks <- getTickArray mod
1608 let line = srcSpanStartLine src
1609 ASSERT (inRange (bounds ticks) line) do
1610 let enclosing_spans = [ span | (_,span) <- ticks ! line
1611 , srcSpanEnd span >= srcSpanEnd src]
1612 return . head . sortBy leftmost_largest $ enclosing_spans
1614 traceCmd :: String -> GHCi ()
1615 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1616 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1618 continueCmd :: String -> GHCi ()
1619 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1621 -- doContinue :: SingleStep -> GHCi ()
1622 doContinue pred step = do
1623 session <- getSession
1624 runResult <- io $ GHC.resume session step
1625 afterRunStmt pred runResult
1628 abandonCmd :: String -> GHCi ()
1629 abandonCmd = noArgs $ do
1631 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1632 when (not b) $ io $ putStrLn "There is no computation running."
1635 deleteCmd :: String -> GHCi ()
1636 deleteCmd argLine = do
1637 deleteSwitch $ words argLine
1639 deleteSwitch :: [String] -> GHCi ()
1641 io $ putStrLn "The delete command requires at least one argument."
1642 -- delete all break points
1643 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1644 deleteSwitch idents = do
1645 mapM_ deleteOneBreak idents
1647 deleteOneBreak :: String -> GHCi ()
1649 | all isDigit str = deleteBreak (read str)
1650 | otherwise = return ()
1652 historyCmd :: String -> GHCi ()
1654 | null arg = history 20
1655 | all isDigit arg = history (read arg)
1656 | otherwise = io $ putStrLn "Syntax: :history [num]"
1660 resumes <- io $ GHC.getResumeContext s
1662 [] -> io $ putStrLn "Not stopped at a breakpoint"
1664 let hist = GHC.resumeHistory r
1665 (took,rest) = splitAt num hist
1666 spans <- mapM (io . GHC.getHistorySpan s) took
1667 let nums = map (printf "-%-3d:") [(1::Int)..]
1668 let names = map GHC.historyEnclosingDecl took
1669 printForUser (vcat(zipWith3
1670 (\x y z -> x <+> y <+> z)
1672 (map (bold . ppr) names)
1673 (map (parens . ppr) spans)))
1674 io $ putStrLn $ if null rest then "<end of history>" else "..."
1676 bold c | do_bold = text start_bold <> c <> text end_bold
1679 backCmd :: String -> GHCi ()
1680 backCmd = noArgs $ do
1682 (names, ix, span) <- io $ GHC.back s
1683 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1684 printTypeOfNames s names
1685 -- run the command set with ":set stop <cmd>"
1687 enqueueCommands [stop st]
1689 forwardCmd :: String -> GHCi ()
1690 forwardCmd = noArgs $ do
1692 (names, ix, span) <- io $ GHC.forward s
1693 printForUser $ (if (ix == 0)
1694 then ptext SLIT("Stopped at")
1695 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1696 printTypeOfNames s names
1697 -- run the command set with ":set stop <cmd>"
1699 enqueueCommands [stop st]
1701 -- handle the "break" command
1702 breakCmd :: String -> GHCi ()
1703 breakCmd argLine = do
1704 session <- getSession
1705 breakSwitch session $ words argLine
1707 breakSwitch :: Session -> [String] -> GHCi ()
1708 breakSwitch _session [] = do
1709 io $ putStrLn "The break command requires at least one argument."
1710 breakSwitch session args@(arg1:rest)
1711 | looksLikeModuleName arg1 = do
1712 mod <- wantInterpretedModule arg1
1713 breakByModule session mod rest
1714 | all isDigit arg1 = do
1715 (toplevel, _) <- io $ GHC.getContext session
1717 (mod : _) -> breakByModuleLine mod (read arg1) rest
1719 io $ putStrLn "Cannot find default module for breakpoint."
1720 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1721 | otherwise = do -- try parsing it as an identifier
1722 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1723 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1724 if GHC.isGoodSrcLoc loc
1725 then findBreakAndSet (GHC.nameModule name) $
1726 findBreakByCoord (Just (GHC.srcLocFile loc))
1727 (GHC.srcLocLine loc,
1729 else noCanDo name $ text "can't find its location: " <> ppr loc
1731 noCanDo n why = printForUser $
1732 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1734 breakByModule :: Session -> Module -> [String] -> GHCi ()
1735 breakByModule session mod args@(arg1:rest)
1736 | all isDigit arg1 = do -- looks like a line number
1737 breakByModuleLine mod (read arg1) rest
1738 breakByModule session mod _
1741 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1742 breakByModuleLine mod line args
1743 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1744 | [col] <- args, all isDigit col =
1745 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1746 | otherwise = breakSyntax
1748 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1750 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1751 findBreakAndSet mod lookupTickTree = do
1752 tickArray <- getTickArray mod
1753 (breakArray, _) <- getModBreak mod
1754 case lookupTickTree tickArray of
1755 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1756 Just (tick, span) -> do
1757 success <- io $ setBreakFlag True breakArray tick
1758 session <- getSession
1762 recordBreak $ BreakLocation
1769 text "Breakpoint " <> ppr nm <>
1771 then text " was already set at " <> ppr span
1772 else text " activated at " <> ppr span
1774 printForUser $ text "Breakpoint could not be activated at"
1777 -- When a line number is specified, the current policy for choosing
1778 -- the best breakpoint is this:
1779 -- - the leftmost complete subexpression on the specified line, or
1780 -- - the leftmost subexpression starting on the specified line, or
1781 -- - the rightmost subexpression enclosing the specified line
1783 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1784 findBreakByLine line arr
1785 | not (inRange (bounds arr) line) = Nothing
1787 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1788 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1789 listToMaybe (sortBy (rightmost `on` snd) ticks)
1793 starts_here = [ tick | tick@(nm,span) <- ticks,
1794 GHC.srcSpanStartLine span == line ]
1796 (complete,incomplete) = partition ends_here starts_here
1797 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1799 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1800 -> Maybe (BreakIndex,SrcSpan)
1801 findBreakByCoord mb_file (line, col) arr
1802 | not (inRange (bounds arr) line) = Nothing
1804 listToMaybe (sortBy (rightmost `on` snd) contains ++
1805 sortBy (leftmost_smallest `on` snd) after_here)
1809 -- the ticks that span this coordinate
1810 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1811 is_correct_file span ]
1813 is_correct_file span
1814 | Just f <- mb_file = GHC.srcSpanFile span == f
1817 after_here = [ tick | tick@(nm,span) <- ticks,
1818 GHC.srcSpanStartLine span == line,
1819 GHC.srcSpanStartCol span >= col ]
1821 -- For now, use ANSI bold on terminals that we know support it.
1822 -- Otherwise, we add a line of carets under the active expression instead.
1823 -- In particular, on Windows and when running the testsuite (which sets
1824 -- TERM to vt100 for other reasons) we get carets.
1825 -- We really ought to use a proper termcap/terminfo library.
1827 do_bold = unsafePerformIO (System.Environment.getEnv "TERM") `elem`
1830 start_bold :: String
1831 start_bold = "\ESC[1m"
1833 end_bold = "\ESC[0m"
1835 listCmd :: String -> GHCi ()
1837 mb_span <- getCurrentBreakSpan
1839 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1840 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1841 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1842 listCmd str = list2 (words str)
1844 list2 [arg] | all isDigit arg = do
1845 session <- getSession
1846 (toplevel, _) <- io $ GHC.getContext session
1848 [] -> io $ putStrLn "No module to list"
1849 (mod : _) -> listModuleLine mod (read arg)
1850 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1851 mod <- wantInterpretedModule arg1
1852 listModuleLine mod (read arg2)
1854 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1855 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1856 if GHC.isGoodSrcLoc loc
1858 tickArray <- getTickArray (GHC.nameModule name)
1859 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1860 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1863 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1864 Just (_,span) -> io $ listAround span False
1866 noCanDo name $ text "can't find its location: " <>
1869 noCanDo n why = printForUser $
1870 text "cannot list source code for " <> ppr n <> text ": " <> why
1872 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1874 listModuleLine :: Module -> Int -> GHCi ()
1875 listModuleLine modl line = do
1876 session <- getSession
1877 graph <- io (GHC.getModuleGraph session)
1878 let this = filter ((== modl) . GHC.ms_mod) graph
1880 [] -> panic "listModuleLine"
1882 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1883 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1884 io $ listAround (GHC.srcLocSpan loc) False
1886 -- | list a section of a source file around a particular SrcSpan.
1887 -- If the highlight flag is True, also highlight the span using
1888 -- start_bold/end_bold.
1889 listAround span do_highlight = do
1890 contents <- BS.readFile (unpackFS file)
1892 lines = BS.split '\n' contents
1893 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1894 drop (line1 - 1 - pad_before) $ lines
1895 fst_line = max 1 (line1 - pad_before)
1896 line_nos = [ fst_line .. ]
1898 highlighted | do_highlight = zipWith highlight line_nos these_lines
1899 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
1901 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1902 prefixed = zipWith ($) highlighted bs_line_nos
1904 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1906 file = GHC.srcSpanFile span
1907 line1 = GHC.srcSpanStartLine span
1908 col1 = GHC.srcSpanStartCol span
1909 line2 = GHC.srcSpanEndLine span
1910 col2 = GHC.srcSpanEndCol span
1912 pad_before | line1 == 1 = 0
1916 highlight | do_bold = highlight_bold
1917 | otherwise = highlight_carets
1919 highlight_bold no line prefix
1920 | no == line1 && no == line2
1921 = let (a,r) = BS.splitAt col1 line
1922 (b,c) = BS.splitAt (col2-col1) r
1924 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
1926 = let (a,b) = BS.splitAt col1 line in
1927 BS.concat [prefix, a, BS.pack start_bold, b]
1929 = let (a,b) = BS.splitAt col2 line in
1930 BS.concat [prefix, a, BS.pack end_bold, b]
1931 | otherwise = BS.concat [prefix, line]
1933 highlight_carets no line prefix
1934 | no == line1 && no == line2
1935 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
1936 BS.replicate (col2-col1) '^']
1938 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
1941 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
1943 | otherwise = BS.concat [prefix, line]
1945 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
1946 nl = BS.singleton '\n'
1948 -- --------------------------------------------------------------------------
1951 getTickArray :: Module -> GHCi TickArray
1952 getTickArray modl = do
1954 let arrmap = tickarrays st
1955 case lookupModuleEnv arrmap modl of
1956 Just arr -> return arr
1958 (breakArray, ticks) <- getModBreak modl
1959 let arr = mkTickArray (assocs ticks)
1960 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1963 discardTickArrays :: GHCi ()
1964 discardTickArrays = do
1966 setGHCiState st{tickarrays = emptyModuleEnv}
1968 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1970 = accumArray (flip (:)) [] (1, max_line)
1971 [ (line, (nm,span)) | (nm,span) <- ticks,
1972 line <- srcSpanLines span ]
1974 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1975 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1976 GHC.srcSpanEndLine span ]
1978 lookupModule :: String -> GHCi Module
1979 lookupModule modName
1980 = do session <- getSession
1981 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1983 -- don't reset the counter back to zero?
1984 discardActiveBreakPoints :: GHCi ()
1985 discardActiveBreakPoints = do
1987 mapM (turnOffBreak.snd) (breaks st)
1988 setGHCiState $ st { breaks = [] }
1990 deleteBreak :: Int -> GHCi ()
1991 deleteBreak identity = do
1993 let oldLocations = breaks st
1994 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1996 then printForUser (text "Breakpoint" <+> ppr identity <+>
1997 text "does not exist")
1999 mapM (turnOffBreak.snd) this
2000 setGHCiState $ st { breaks = rest }
2002 turnOffBreak loc = do
2003 (arr, _) <- getModBreak (breakModule loc)
2004 io $ setBreakFlag False arr (breakTick loc)
2006 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2007 getModBreak mod = do
2008 session <- getSession
2009 Just mod_info <- io $ GHC.getModuleInfo session mod
2010 let modBreaks = GHC.modInfoModBreaks mod_info
2011 let array = GHC.modBreaks_flags modBreaks
2012 let ticks = GHC.modBreaks_locs modBreaks
2013 return (array, ticks)
2015 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2016 setBreakFlag toggle array index
2017 | toggle = GHC.setBreakOn array index
2018 | otherwise = GHC.setBreakOff array index