1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12 #include "HsVersions.h"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Module, ModuleName, TyThing(..), Phase,
22 BreakIndex, SrcSpan, Resume, SingleStep )
28 import HscTypes ( implicitTyThings )
29 import Outputable hiding (printForUser)
30 import Module -- for ModuleEnv
34 -- Other random utilities
36 import BasicTypes hiding (isTopLevel)
37 import Panic hiding (showException)
43 import Maybes ( orElse )
46 #ifndef mingw32_HOST_OS
47 import System.Posix hiding (getEnv)
49 import GHC.ConsoleHandler ( flushConsole )
50 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
51 import qualified System.Win32
55 import Control.Concurrent ( yield ) -- Used in readline loop
56 import System.Console.Readline as Readline
61 import Control.Exception as Exception
62 -- import Control.Concurrent
64 import qualified Data.ByteString.Char8 as BS
68 import System.Environment
69 import System.Exit ( exitWith, ExitCode(..) )
70 import System.Directory
72 import System.IO.Error as IO
73 import System.IO.Unsafe
77 import Control.Monad as Monad
80 import Foreign.StablePtr ( newStablePtr )
81 import GHC.Exts ( unsafeCoerce# )
82 import GHC.IOBase ( IOErrorType(InvalidArgument) )
84 import Data.IORef ( IORef, readIORef, writeIORef )
86 import System.Posix.Internals ( setNonBlockingFD )
88 -----------------------------------------------------------------------------
90 ghciWelcomeMsg :: String
91 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
92 ": http://www.haskell.org/ghc/ :? for help"
94 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
96 cmdName :: Command -> String
99 commands :: IORef [Command]
100 GLOBAL_VAR(commands, builtin_commands, [Command])
102 builtin_commands :: [Command]
104 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
105 ("?", keepGoing help, False, completeNone),
106 ("add", keepGoingPaths addModule, False, completeFilename),
107 ("abandon", keepGoing abandonCmd, False, completeNone),
108 ("break", keepGoing breakCmd, False, completeIdentifier),
109 ("back", keepGoing backCmd, False, completeNone),
110 ("browse", keepGoing browseCmd, False, completeModule),
111 ("cd", keepGoing changeDirectory, False, completeFilename),
112 ("check", keepGoing checkModule, False, completeHomeModule),
113 ("continue", keepGoing continueCmd, False, completeNone),
114 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
115 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
116 ("def", keepGoing defineMacro, False, completeIdentifier),
117 ("delete", keepGoing deleteCmd, False, completeNone),
118 ("e", keepGoing editFile, False, completeFilename),
119 ("edit", keepGoing editFile, False, completeFilename),
120 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
121 ("force", keepGoing forceCmd, False, completeIdentifier),
122 ("forward", keepGoing forwardCmd, False, completeNone),
123 ("help", keepGoing help, False, completeNone),
124 ("history", keepGoing historyCmd, False, completeNone),
125 ("info", keepGoing info, False, completeIdentifier),
126 ("kind", keepGoing kindOfType, False, completeIdentifier),
127 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
128 ("list", keepGoing listCmd, False, completeNone),
129 ("module", keepGoing setContext, False, completeModule),
130 ("main", keepGoing runMain, False, completeIdentifier),
131 ("print", keepGoing printCmd, False, completeIdentifier),
132 ("quit", quit, False, completeNone),
133 ("reload", keepGoing reloadModule, False, completeNone),
134 ("set", keepGoing setCmd, True, completeSetOptions),
135 ("show", keepGoing showCmd, False, completeNone),
136 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
137 ("step", keepGoing stepCmd, False, completeIdentifier),
138 ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
139 ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
140 ("type", keepGoing typeOfExpr, False, completeIdentifier),
141 ("trace", keepGoing traceCmd, False, completeIdentifier),
142 ("undef", keepGoing undefineMacro, False, completeMacro),
143 ("unset", keepGoing unsetOptions, True, completeSetOptions)
146 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
147 keepGoing a str = a str >> return False
149 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
150 keepGoingPaths a str = a (toArgs str) >> return False
152 shortHelpText :: String
153 shortHelpText = "use :? for help.\n"
157 " Commands available from the prompt:\n" ++
159 " <statement> evaluate/run <statement>\n" ++
160 " :add <filename> ... add module(s) to the current target set\n" ++
161 " :browse [*]<module> display the names defined by <module>\n" ++
162 " :cd <dir> change directory to <dir>\n" ++
163 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
164 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
165 " :def <cmd> <expr> define a command :<cmd>\n" ++
166 " :edit <file> edit file\n" ++
167 " :edit edit last module\n" ++
168 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
169 " :help, :? display this list of commands\n" ++
170 " :info [<name> ...] display information about the given names\n" ++
171 " :kind <type> show the kind of <type>\n" ++
172 " :load <filename> ... load module(s) and their dependents\n" ++
173 " :main [<arguments> ...] run the main function with the given arguments\n" ++
174 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
175 " :quit exit GHCi\n" ++
176 " :reload reload the current module set\n" ++
177 " :type <expr> show the type of <expr>\n" ++
178 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
179 " :!<command> run the shell command <command>\n" ++
181 " -- Commands for debugging:\n" ++
183 " :abandon at a breakpoint, abandon current computation\n" ++
184 " :back go back in the history (after :trace)\n" ++
185 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
186 " :break <name> set a breakpoint on the specified function\n" ++
187 " :continue resume after a breakpoint\n" ++
188 " :delete <number> delete the specified breakpoint\n" ++
189 " :delete * delete all breakpoints\n" ++
190 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
191 " :forward go forward in the history (after :back)\n" ++
192 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
193 " :print [<name> ...] prints a value without forcing its computation\n" ++
194 " :sprint [<name> ...] simplifed version of :print\n" ++
195 " :step single-step after stopping at a breakpoint\n"++
196 " :step <expr> single-step into <expr>\n"++
197 " :steplocal single-step restricted to the current top level decl.\n"++
198 " :stepmodule single-step restricted to the current module\n"++
199 " :trace trace after stopping at a breakpoint\n"++
200 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
203 " -- Commands for changing settings:\n" ++
205 " :set <option> ... set options\n" ++
206 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
207 " :set prog <progname> set the value returned by System.getProgName\n" ++
208 " :set prompt <prompt> set the prompt used in GHCi\n" ++
209 " :set editor <cmd> set the command used for :edit\n" ++
210 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
211 " :unset <option> ... unset options\n" ++
213 " Options for ':set' and ':unset':\n" ++
215 " +r revert top-level expressions after each evaluation\n" ++
216 " +s print timing/memory stats after each evaluation\n" ++
217 " +t print type after evaluation\n" ++
218 " -<flags> most GHC command line flags can also be set here\n" ++
219 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
221 " -- Commands for displaying information:\n" ++
223 " :show bindings show the current bindings made at the prompt\n" ++
224 " :show breaks show the active breakpoints\n" ++
225 " :show context show the breakpoint context\n" ++
226 " :show modules show the currently loaded modules\n" ++
227 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
230 findEditor :: IO String
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 (GHC.mkModuleName "Prelude")
273 GHC.setContext session [] [prel_mod]
277 Readline.setAttemptedCompletionFunction (Just completeWord)
278 --Readline.parseAndBind "set show-all-if-ambiguous 1"
280 let symbols = "!#$%&*+/<=>?@\\^|-~"
281 specials = "(),;[]`{}"
283 word_break_chars = spaces ++ specials ++ symbols
285 Readline.setBasicWordBreakCharacters word_break_chars
286 Readline.setCompleterWordBreakCharacters word_break_chars
289 default_editor <- findEditor
291 startGHCi (runGHCi srcs maybe_expr)
292 GHCiState{ progname = "<interactive>",
296 editor = default_editor,
302 tickarrays = emptyModuleEnv,
307 Readline.resetTerminal Nothing
312 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
313 runGHCi paths maybe_expr = do
314 let read_dot_files = not opt_IgnoreDotGhci
316 when (read_dot_files) $ do
319 exists <- io (doesFileExist file)
321 dir_ok <- io (checkPerms ".")
322 file_ok <- io (checkPerms file)
323 when (dir_ok && file_ok) $ do
324 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
327 Right hdl -> fileLoop hdl False
329 when (read_dot_files) $ do
330 -- Read in $HOME/.ghci
331 either_dir <- io (IO.try (getEnv "HOME"))
335 cwd <- io (getCurrentDirectory)
336 when (dir /= cwd) $ do
337 let file = dir ++ "/.ghci"
338 ok <- io (checkPerms file)
340 either_hdl <- io (IO.try (openFile file ReadMode))
343 Right hdl -> fileLoop hdl False
345 -- Perform a :load for files given on the GHCi command line
346 -- When in -e mode, if the load fails then we want to stop
347 -- immediately rather than going on to evaluate the expression.
348 when (not (null paths)) $ do
349 ok <- ghciHandle (\e -> do showException e; return Failed) $
351 when (isJust maybe_expr && failed ok) $
352 io (exitWith (ExitFailure 1))
354 -- if verbosity is greater than 0, or we are connected to a
355 -- terminal, display the prompt in the interactive loop.
356 is_tty <- io (hIsTerminalDevice stdin)
357 dflags <- getDynFlags
358 let show_prompt = verbosity dflags > 0 || is_tty
363 #if defined(mingw32_HOST_OS)
364 -- The win32 Console API mutates the first character of
365 -- type-ahead when reading from it in a non-buffered manner. Work
366 -- around this by flushing the input buffer of type-ahead characters,
367 -- but only if stdin is available.
368 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
370 Left err | isDoesNotExistError err -> return ()
371 | otherwise -> io (ioError err)
372 Right () -> return ()
374 -- initialise the console if necessary
377 -- enter the interactive loop
378 interactiveLoop is_tty show_prompt
380 -- just evaluate the expression we were given
385 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
388 interactiveLoop :: Bool -> Bool -> 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
464 mkPrompt :: GHCi String
466 session <- getSession
467 (toplevs,exports) <- io (GHC.getContext session)
468 resumes <- io $ GHC.getResumeContext session
474 let ix = GHC.resumeHistoryIx r
476 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
478 let hist = GHC.resumeHistory r !! (ix-1)
479 span <- io$ GHC.getHistorySpan session hist
480 return (brackets (ppr (negate ix) <> char ':'
481 <+> ppr span) <> space)
483 dots | _:rs <- resumes, not (null rs) = text "... "
487 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
488 hsep (map (ppr . GHC.moduleName) exports)
490 deflt_prompt = dots <> context_bit <> modules_bit
492 f ('%':'s':xs) = deflt_prompt <> f xs
493 f ('%':'%':xs) = char '%' <> f xs
494 f (x:xs) = char x <> f xs
498 return (showSDoc (f (prompt st)))
502 readlineLoop :: GHCi ()
505 saveSession -- for use by completion
507 l <- io (readline prompt `finally` setNonBlockingFD 0)
508 -- readline sometimes puts stdin into blocking mode,
509 -- so we need to put it back for the IO library
514 case removeSpaces l of
518 quit <- runCommands l
519 if quit then return () else readlineLoop
522 runCommands :: String -> GHCi Bool
524 q <- ghciHandle handler (doCommand cmd)
525 if q then return True else runNext
531 c:cs -> do setGHCiState st{ cmdqueue = cs }
534 doCommand (':' : cmd) = specialCommand cmd
535 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
538 enqueueCommands :: [String] -> GHCi ()
539 enqueueCommands cmds = do
541 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
544 -- This version is for the GHC command-line option -e. The only difference
545 -- from runCommand is that it catches the ExitException exception and
546 -- exits, rather than printing out the exception.
547 runCommandEval :: String -> GHCi Bool
548 runCommandEval c = ghciHandle handleEval (doCommand c)
550 handleEval (ExitException code) = io (exitWith code)
551 handleEval e = do handler e
552 io (exitWith (ExitFailure 1))
554 doCommand (':' : command) = specialCommand command
556 = do r <- runStmt stmt GHC.RunToCompletion
558 False -> io (exitWith (ExitFailure 1))
559 -- failure to run the command causes exit(1) for ghc -e.
562 runStmt :: String -> SingleStep -> GHCi Bool
564 | null (filter (not.isSpace) stmt) = return False
565 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
567 = do st <- getGHCiState
568 session <- getSession
569 result <- io $ withProgName (progname st) $ withArgs (args st) $
570 GHC.runStmt session stmt step
571 afterRunStmt (const True) result
574 --afterRunStmt :: GHC.RunResult -> GHCi Bool
575 -- False <=> the statement failed to compile
576 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
577 afterRunStmt _ (GHC.RunException e) = throw e
578 afterRunStmt step_here run_result = do
579 session <- getSession
580 resumes <- io $ GHC.getResumeContext session
582 GHC.RunOk names -> do
583 show_types <- isOptionSet ShowType
584 when show_types $ printTypeOfNames session names
585 GHC.RunBreak _ names mb_info
586 | isNothing mb_info ||
587 step_here (GHC.resumeSpan $ head resumes) -> do
588 printForUser $ ptext SLIT("Stopped at") <+>
589 ppr (GHC.resumeSpan $ head resumes)
590 -- printTypeOfNames session names
591 printTypeAndContentOfNames session names
592 maybe (return ()) runBreakCmd mb_info
593 -- run the command set with ":set stop <cmd>"
595 enqueueCommands [stop st]
597 | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
598 afterRunStmt step_here >> return ()
602 io installSignalHandlers
603 b <- isOptionSet RevertCAFs
604 io (when b revertCAFs)
606 return (case run_result of GHC.RunOk _ -> True; _ -> False)
608 where printTypeAndContentOfNames session names = do
609 let namesSorted = sortBy compareNames names
610 tythings <- catMaybes `liftM`
611 io (mapM (GHC.lookupName session) namesSorted)
612 let ids = [id | AnId id <- tythings]
613 terms <- mapM (io . GHC.obtainTermB session 10 False) ids
614 docs_terms <- mapM (io . showTerm session) terms
615 dflags <- getDynFlags
616 let pefas = dopt Opt_PrintExplicitForalls dflags
617 printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
618 (map (pprTyThing pefas . AnId) ids)
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 | (_,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 _ _ = 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 -> LoadHowMuch -> GHCi SuccessFlag
925 doLoad session howmuch = do
926 -- turn off breakpoints before we load: we can't turn them off later, because
927 -- the ModBreaks will have gone away.
928 discardActiveBreakPoints
929 ok <- io (GHC.load session howmuch)
933 afterLoad :: SuccessFlag -> Session -> GHCi ()
934 afterLoad ok session = do
935 io (revertCAFs) -- always revert CAFs on load.
937 loaded_mods <- getLoadedModules session
938 setContextAfterLoad session loaded_mods
939 modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
941 setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()
942 setContextAfterLoad session [] = do
943 prel_mod <- getPrelude
944 io (GHC.setContext session [] [prel_mod])
945 setContextAfterLoad session ms = do
946 -- load a target if one is available, otherwise load the topmost module.
947 targets <- io (GHC.getTargets session)
948 case [ m | Just m <- map (findTarget ms) targets ] of
950 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
951 load_this (last graph')
956 = case filter (`matches` t) ms of
960 summary `matches` Target (TargetModule m) _
961 = GHC.ms_mod_name summary == m
962 summary `matches` Target (TargetFile f _) _
963 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
967 load_this summary | m <- GHC.ms_mod summary = do
968 b <- io (GHC.moduleIsInterpreted session m)
969 if b then io (GHC.setContext session [m] [])
971 prel_mod <- getPrelude
972 io (GHC.setContext session [] [prel_mod,m])
975 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
976 modulesLoadedMsg ok mods = do
977 dflags <- getDynFlags
978 when (verbosity dflags > 0) $ do
980 | null mods = text "none."
982 punctuate comma (map ppr mods)) <> text "."
985 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
987 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
990 typeOfExpr :: String -> GHCi ()
992 = do cms <- getSession
993 maybe_ty <- io (GHC.exprType cms str)
996 Just ty -> do dflags <- getDynFlags
997 let pefas = dopt Opt_PrintExplicitForalls dflags
998 printForUser $ text str <+> dcolon
999 <+> pprTypeForUser pefas ty
1001 kindOfType :: String -> GHCi ()
1003 = do cms <- getSession
1004 maybe_ty <- io (GHC.typeKind cms str)
1006 Nothing -> return ()
1007 Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
1009 quit :: String -> GHCi Bool
1010 quit _ = return True
1012 shellEscape :: String -> GHCi Bool
1013 shellEscape str = io (system str >> return False)
1015 -----------------------------------------------------------------------------
1016 -- Browsing a module's contents
1018 browseCmd :: String -> GHCi ()
1021 ['*':m] | looksLikeModuleName m -> browseModule m False
1022 [m] | looksLikeModuleName m -> browseModule m True
1023 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1025 browseModule :: String -> Bool -> GHCi ()
1026 browseModule m exports_only = do
1028 modl <- if exports_only then lookupModule m
1029 else wantInterpretedModule m
1031 -- Temporarily set the context to the module we're interested in,
1032 -- just so we can get an appropriate PrintUnqualified
1033 (as,bs) <- io (GHC.getContext s)
1034 prel_mod <- getPrelude
1035 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1036 else GHC.setContext s [modl] [])
1037 unqual <- io (GHC.getPrintUnqual s)
1038 io (GHC.setContext s as bs)
1040 mb_mod_info <- io $ GHC.getModuleInfo s modl
1042 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1045 | exports_only = GHC.modInfoExports mod_info
1046 | otherwise = GHC.modInfoTopLevelScope mod_info
1049 mb_things <- io $ mapM (GHC.lookupName s) names
1050 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1052 dflags <- getDynFlags
1053 let pefas = dopt Opt_PrintExplicitForalls dflags
1054 io (putStrLn (showSDocForUser unqual (
1055 vcat (map (pprTyThingInContext pefas) filtered_things)
1057 -- ToDo: modInfoInstances currently throws an exception for
1058 -- package modules. When it works, we can do this:
1059 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1061 -----------------------------------------------------------------------------
1062 -- Setting the module context
1064 setContext :: String -> GHCi ()
1066 | all sensible mods = fn mods
1067 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1069 (fn, mods) = case str of
1070 '+':stuff -> (addToContext, words stuff)
1071 '-':stuff -> (removeFromContext, words stuff)
1072 stuff -> (newContext, words stuff)
1074 sensible ('*':m) = looksLikeModuleName m
1075 sensible m = looksLikeModuleName m
1077 separate :: Session -> [String] -> [Module] -> [Module]
1078 -> GHCi ([Module],[Module])
1079 separate _ [] as bs = return (as,bs)
1080 separate session (('*':str):ms) as bs = do
1081 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1082 b <- io $ GHC.moduleIsInterpreted session m
1083 if b then separate session ms (m:as) bs
1084 else throwDyn (CmdLineError ("module '"
1085 ++ GHC.moduleNameString (GHC.moduleName m)
1086 ++ "' is not interpreted"))
1087 separate session (str:ms) as bs = do
1088 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1089 separate session ms as (m:bs)
1091 newContext :: [String] -> GHCi ()
1092 newContext strs = do
1094 (as,bs) <- separate s strs [] []
1095 prel_mod <- getPrelude
1096 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1097 io $ GHC.setContext s as bs'
1100 addToContext :: [String] -> GHCi ()
1101 addToContext strs = do
1103 (as,bs) <- io $ GHC.getContext s
1105 (new_as,new_bs) <- separate s strs [] []
1107 let as_to_add = new_as \\ (as ++ bs)
1108 bs_to_add = new_bs \\ (as ++ bs)
1110 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1113 removeFromContext :: [String] -> GHCi ()
1114 removeFromContext strs = do
1116 (as,bs) <- io $ GHC.getContext s
1118 (as_to_remove,bs_to_remove) <- separate s strs [] []
1120 let as' = as \\ (as_to_remove ++ bs_to_remove)
1121 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1123 io $ GHC.setContext s as' bs'
1125 ----------------------------------------------------------------------------
1128 -- set options in the interpreter. Syntax is exactly the same as the
1129 -- ghc command line, except that certain options aren't available (-C,
1132 -- This is pretty fragile: most options won't work as expected. ToDo:
1133 -- figure out which ones & disallow them.
1135 setCmd :: String -> GHCi ()
1137 = do st <- getGHCiState
1138 let opts = options st
1139 io $ putStrLn (showSDoc (
1140 text "options currently set: " <>
1143 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1146 = case toArgs str of
1147 ("args":args) -> setArgs args
1148 ("prog":prog) -> setProg prog
1149 ("prompt":_) -> setPrompt (after 6)
1150 ("editor":_) -> setEditor (after 6)
1151 ("stop":_) -> setStop (after 4)
1152 wds -> setOptions wds
1153 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1155 setArgs, setProg, setOptions :: [String] -> GHCi ()
1156 setEditor, setStop, setPrompt :: String -> GHCi ()
1160 setGHCiState st{ args = args }
1164 setGHCiState st{ progname = prog }
1166 io (hPutStrLn stderr "syntax: :set prog <progname>")
1170 setGHCiState st{ editor = cmd }
1172 setStop str@(c:_) | isDigit c
1173 = do let (nm_str,rest) = break (not.isDigit) str
1176 let old_breaks = breaks st
1177 if all ((/= nm) . fst) old_breaks
1178 then printForUser (text "Breakpoint" <+> ppr nm <+>
1179 text "does not exist")
1181 let new_breaks = map fn old_breaks
1182 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1183 | otherwise = (i,loc)
1184 setGHCiState st{ breaks = new_breaks }
1187 setGHCiState st{ stop = cmd }
1189 setPrompt value = do
1192 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1193 else setGHCiState st{ prompt = remQuotes value }
1195 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1199 do -- first, deal with the GHCi opts (+s, +t, etc.)
1200 let (plus_opts, minus_opts) = partitionWith isPlus wds
1201 mapM_ setOpt plus_opts
1202 -- then, dynamic flags
1203 newDynFlags minus_opts
1205 newDynFlags :: [String] -> GHCi ()
1206 newDynFlags minus_opts = do
1207 dflags <- getDynFlags
1208 let pkg_flags = packageFlags dflags
1209 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1211 if (not (null leftovers))
1212 then throwDyn (CmdLineError ("unrecognised flags: " ++
1216 new_pkgs <- setDynFlags dflags'
1218 -- if the package flags changed, we should reset the context
1219 -- and link the new packages.
1220 dflags <- getDynFlags
1221 when (packageFlags dflags /= pkg_flags) $ do
1222 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1223 session <- getSession
1224 io (GHC.setTargets session [])
1225 io (GHC.load session LoadAllTargets)
1226 io (linkPackages dflags new_pkgs)
1227 setContextAfterLoad session []
1231 unsetOptions :: String -> GHCi ()
1233 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1234 let opts = words str
1235 (minus_opts, rest1) = partition isMinus opts
1236 (plus_opts, rest2) = partitionWith isPlus rest1
1238 if (not (null rest2))
1239 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1242 mapM_ unsetOpt plus_opts
1244 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1245 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1247 no_flags <- mapM no_flag minus_opts
1248 newDynFlags no_flags
1250 isMinus :: String -> Bool
1251 isMinus ('-':_) = True
1254 isPlus :: String -> Either String String
1255 isPlus ('+':opt) = Left opt
1256 isPlus other = Right other
1258 setOpt, unsetOpt :: String -> GHCi ()
1261 = case strToGHCiOpt str of
1262 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1263 Just o -> setOption o
1266 = case strToGHCiOpt str of
1267 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1268 Just o -> unsetOption o
1270 strToGHCiOpt :: String -> (Maybe GHCiOption)
1271 strToGHCiOpt "s" = Just ShowTiming
1272 strToGHCiOpt "t" = Just ShowType
1273 strToGHCiOpt "r" = Just RevertCAFs
1274 strToGHCiOpt _ = Nothing
1276 optToStr :: GHCiOption -> String
1277 optToStr ShowTiming = "s"
1278 optToStr ShowType = "t"
1279 optToStr RevertCAFs = "r"
1281 -- ---------------------------------------------------------------------------
1284 showCmd :: String -> GHCi ()
1288 ["args"] -> io $ putStrLn (show (args st))
1289 ["prog"] -> io $ putStrLn (show (progname st))
1290 ["prompt"] -> io $ putStrLn (show (prompt st))
1291 ["editor"] -> io $ putStrLn (show (editor st))
1292 ["stop"] -> io $ putStrLn (show (stop st))
1293 ["modules" ] -> showModules
1294 ["bindings"] -> showBindings
1295 ["linker"] -> io showLinkerState
1296 ["breaks"] -> showBkptTable
1297 ["context"] -> showContext
1298 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1300 showModules :: GHCi ()
1302 session <- getSession
1303 loaded_mods <- getLoadedModules session
1304 -- we want *loaded* modules only, see #1734
1305 let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1306 mapM_ show_one loaded_mods
1308 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1309 getLoadedModules session = do
1310 graph <- io (GHC.getModuleGraph session)
1311 filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1313 showBindings :: GHCi ()
1316 bindings <- io (GHC.getBindings s)
1317 mapM_ printTyThing $ sortBy compareTyThings bindings
1320 compareTyThings :: TyThing -> TyThing -> Ordering
1321 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1323 printTyThing :: TyThing -> GHCi ()
1324 printTyThing tyth = do dflags <- getDynFlags
1325 let pefas = dopt Opt_PrintExplicitForalls dflags
1326 printForUser (pprTyThing pefas tyth)
1328 showBkptTable :: GHCi ()
1331 printForUser $ prettyLocations (breaks st)
1333 showContext :: GHCi ()
1335 session <- getSession
1336 resumes <- io $ GHC.getResumeContext session
1337 printForUser $ vcat (map pp_resume (reverse resumes))
1340 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1341 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1344 -- -----------------------------------------------------------------------------
1347 completeNone :: String -> IO [String]
1348 completeNone _w = return []
1351 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1352 completeWord w start end = do
1353 line <- Readline.getLineBuffer
1354 let line_words = words (dropWhile isSpace line)
1356 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1358 | ((':':c) : _) <- line_words -> do
1359 maybe_cmd <- lookupCommand c
1360 let (n,w') = selectWord (words' 0 line)
1362 Nothing -> return Nothing
1363 Just (_,_,False,complete) -> wrapCompleter complete w
1364 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1365 return (map (drop n) rets)
1366 in wrapCompleter complete' w'
1367 | ("import" : _) <- line_words ->
1368 wrapCompleter completeModule w
1370 --printf "complete %s, start = %d, end = %d\n" w start end
1371 wrapCompleter completeIdentifier w
1372 where words' _ [] = []
1373 words' n str = let (w,r) = break isSpace str
1374 (s,r') = span isSpace r
1375 in (n,w):words' (n+length w+length s) r'
1376 -- In a Haskell expression we want to parse 'a-b' as three words
1377 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1378 -- only be a single word.
1379 selectWord [] = (0,w)
1380 selectWord ((offset,x):xs)
1381 | offset+length x >= start = (start-offset,take (end-offset) x)
1382 | otherwise = selectWord xs
1385 completeCmd, completeMacro, completeIdentifier, completeModule,
1386 completeHomeModule, completeSetOptions, completeFilename,
1387 completeHomeModuleOrFile
1388 :: String -> IO [String]
1391 cmds <- readIORef commands
1392 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1394 completeMacro w = do
1395 cmds <- readIORef commands
1396 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1397 return (filter (w `isPrefixOf`) cmds')
1399 completeIdentifier w = do
1401 rdrs <- GHC.getRdrNamesInScope s
1402 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1404 completeModule w = do
1406 dflags <- GHC.getSessionDynFlags s
1407 let pkg_mods = allExposedModules dflags
1408 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1410 completeHomeModule w = do
1412 g <- GHC.getModuleGraph s
1413 let home_mods = map GHC.ms_mod_name g
1414 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1416 completeSetOptions w = do
1417 return (filter (w `isPrefixOf`) options)
1418 where options = "args":"prog":allFlags
1420 completeFilename = Readline.filenameCompletionFunction
1422 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1424 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1425 unionComplete f1 f2 w = do
1430 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1431 wrapCompleter fun w = do
1434 [] -> return Nothing
1435 [x] -> return (Just (x,[]))
1436 xs -> case getCommonPrefix xs of
1437 "" -> return (Just ("",xs))
1438 pref -> return (Just (pref,xs))
1440 getCommonPrefix :: [String] -> String
1441 getCommonPrefix [] = ""
1442 getCommonPrefix (s:ss) = foldl common s ss
1443 where common _s "" = ""
1445 common (c:cs) (d:ds)
1446 | c == d = c : common cs ds
1449 allExposedModules :: DynFlags -> [ModuleName]
1450 allExposedModules dflags
1451 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1453 pkg_db = pkgIdMap (pkgState dflags)
1455 completeCmd = completeNone
1456 completeMacro = completeNone
1457 completeIdentifier = completeNone
1458 completeModule = completeNone
1459 completeHomeModule = completeNone
1460 completeSetOptions = completeNone
1461 completeFilename = completeNone
1462 completeHomeModuleOrFile=completeNone
1463 completeBkpt = completeNone
1466 -- ---------------------------------------------------------------------------
1467 -- User code exception handling
1469 -- This is the exception handler for exceptions generated by the
1470 -- user's code and exceptions coming from children sessions;
1471 -- it normally just prints out the exception. The
1472 -- handler must be recursive, in case showing the exception causes
1473 -- more exceptions to be raised.
1475 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1476 -- raising another exception. We therefore don't put the recursive
1477 -- handler arond the flushing operation, so if stderr is closed
1478 -- GHCi will just die gracefully rather than going into an infinite loop.
1479 handler :: Exception -> GHCi Bool
1481 handler exception = do
1483 io installSignalHandlers
1484 ghciHandle handler (showException exception >> return False)
1486 showException :: Exception -> GHCi ()
1487 showException (DynException dyn) =
1488 case fromDynamic dyn of
1489 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1490 Just Interrupted -> io (putStrLn "Interrupted.")
1491 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1492 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1493 Just other_ghc_ex -> io (print other_ghc_ex)
1495 showException other_exception
1496 = io (putStrLn ("*** Exception: " ++ show other_exception))
1498 -----------------------------------------------------------------------------
1499 -- recursive exception handlers
1501 -- Don't forget to unblock async exceptions in the handler, or if we're
1502 -- in an exception loop (eg. let a = error a in a) the ^C exception
1503 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1505 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1506 ghciHandle h (GHCi m) = GHCi $ \s ->
1507 Exception.catch (m s)
1508 (\e -> unGHCi (ghciUnblock (h e)) s)
1510 ghciUnblock :: GHCi a -> GHCi a
1511 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1514 -- ----------------------------------------------------------------------------
1517 expandPath :: String -> GHCi String
1519 case dropWhile isSpace path of
1521 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1522 return (tilde ++ '/':d)
1526 wantInterpretedModule :: String -> GHCi Module
1527 wantInterpretedModule str = do
1528 session <- getSession
1529 modl <- lookupModule str
1530 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1531 when (not is_interpreted) $
1532 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1535 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1536 -> (Name -> GHCi ())
1538 wantNameFromInterpretedModule noCanDo str and_then = do
1539 session <- getSession
1540 names <- io $ GHC.parseName session str
1544 let modl = GHC.nameModule n
1545 if not (GHC.isExternalName n)
1546 then noCanDo n $ ppr n <>
1547 text " is not defined in an interpreted module"
1549 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1550 if not is_interpreted
1551 then noCanDo n $ text "module " <> ppr modl <>
1552 text " is not interpreted"
1555 -- ----------------------------------------------------------------------------
1556 -- Windows console setup
1558 setUpConsole :: IO ()
1560 #ifdef mingw32_HOST_OS
1561 -- On Windows we need to set a known code page, otherwise the characters
1562 -- we read from the console will be be in some strange encoding, and
1563 -- similarly for characters we write to the console.
1565 -- At the moment, GHCi pretends all input is Latin-1. In the
1566 -- future we should support UTF-8, but for now we set the code
1567 -- pages to Latin-1. Doing it this way does lead to problems,
1568 -- however: see bug #1649.
1570 -- It seems you have to set the font in the console window to
1571 -- a Unicode font in order for output to work properly,
1572 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1573 -- (see MSDN for SetConsoleOutputCP()).
1575 -- This call has been known to hang on some machines, see bug #1483
1577 setConsoleCP 28591 -- ISO Latin-1
1578 setConsoleOutputCP 28591 -- ISO Latin-1
1582 -- -----------------------------------------------------------------------------
1583 -- commands for debugger
1585 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1586 sprintCmd = pprintCommand False False
1587 printCmd = pprintCommand True False
1588 forceCmd = pprintCommand False True
1590 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1591 pprintCommand bind force str = do
1592 session <- getSession
1593 io $ pprintClosureCommand session bind force str
1595 stepCmd :: String -> GHCi ()
1596 stepCmd [] = doContinue (const True) GHC.SingleStep
1597 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1599 stepLocalCmd :: String -> GHCi ()
1600 stepLocalCmd [] = do
1601 mb_span <- getCurrentBreakSpan
1603 Nothing -> stepCmd []
1605 Just mod <- getCurrentBreakModule
1606 current_toplevel_decl <- enclosingTickSpan mod loc
1607 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1609 stepLocalCmd expression = stepCmd expression
1611 stepModuleCmd :: String -> GHCi ()
1612 stepModuleCmd [] = do
1613 mb_span <- getCurrentBreakSpan
1615 Nothing -> stepCmd []
1617 Just span <- getCurrentBreakSpan
1618 let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1619 doContinue f GHC.SingleStep
1621 stepModuleCmd expression = stepCmd expression
1623 -- | Returns the span of the largest tick containing the srcspan given
1624 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1625 enclosingTickSpan mod src = do
1626 ticks <- getTickArray mod
1627 let line = srcSpanStartLine src
1628 ASSERT (inRange (bounds ticks) line) do
1629 let enclosing_spans = [ span | (_,span) <- ticks ! line
1630 , srcSpanEnd span >= srcSpanEnd src]
1631 return . head . sortBy leftmost_largest $ enclosing_spans
1633 traceCmd :: String -> GHCi ()
1634 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1635 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1637 continueCmd :: String -> GHCi ()
1638 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1640 -- doContinue :: SingleStep -> GHCi ()
1641 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1642 doContinue pred step = do
1643 session <- getSession
1644 runResult <- io $ GHC.resume session step
1645 afterRunStmt pred runResult
1648 abandonCmd :: String -> GHCi ()
1649 abandonCmd = noArgs $ do
1651 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1652 when (not b) $ io $ putStrLn "There is no computation running."
1655 deleteCmd :: String -> GHCi ()
1656 deleteCmd argLine = do
1657 deleteSwitch $ words argLine
1659 deleteSwitch :: [String] -> GHCi ()
1661 io $ putStrLn "The delete command requires at least one argument."
1662 -- delete all break points
1663 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1664 deleteSwitch idents = do
1665 mapM_ deleteOneBreak idents
1667 deleteOneBreak :: String -> GHCi ()
1669 | all isDigit str = deleteBreak (read str)
1670 | otherwise = return ()
1672 historyCmd :: String -> GHCi ()
1674 | null arg = history 20
1675 | all isDigit arg = history (read arg)
1676 | otherwise = io $ putStrLn "Syntax: :history [num]"
1680 resumes <- io $ GHC.getResumeContext s
1682 [] -> io $ putStrLn "Not stopped at a breakpoint"
1684 let hist = GHC.resumeHistory r
1685 (took,rest) = splitAt num hist
1686 spans <- mapM (io . GHC.getHistorySpan s) took
1687 let nums = map (printf "-%-3d:") [(1::Int)..]
1688 let names = map GHC.historyEnclosingDecl took
1689 printForUser (vcat(zipWith3
1690 (\x y z -> x <+> y <+> z)
1692 (map (bold . ppr) names)
1693 (map (parens . ppr) spans)))
1694 io $ putStrLn $ if null rest then "<end of history>" else "..."
1696 bold :: SDoc -> SDoc
1697 bold c | do_bold = text start_bold <> c <> text end_bold
1700 backCmd :: String -> GHCi ()
1701 backCmd = noArgs $ do
1703 (names, _, span) <- io $ GHC.back s
1704 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1705 printTypeOfNames s names
1706 -- run the command set with ":set stop <cmd>"
1708 enqueueCommands [stop st]
1710 forwardCmd :: String -> GHCi ()
1711 forwardCmd = noArgs $ do
1713 (names, ix, span) <- io $ GHC.forward s
1714 printForUser $ (if (ix == 0)
1715 then ptext SLIT("Stopped at")
1716 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1717 printTypeOfNames s names
1718 -- run the command set with ":set stop <cmd>"
1720 enqueueCommands [stop st]
1722 -- handle the "break" command
1723 breakCmd :: String -> GHCi ()
1724 breakCmd argLine = do
1725 session <- getSession
1726 breakSwitch session $ words argLine
1728 breakSwitch :: Session -> [String] -> GHCi ()
1729 breakSwitch _session [] = do
1730 io $ putStrLn "The break command requires at least one argument."
1731 breakSwitch session (arg1:rest)
1732 | looksLikeModuleName arg1 = do
1733 mod <- wantInterpretedModule arg1
1734 breakByModule mod rest
1735 | all isDigit arg1 = do
1736 (toplevel, _) <- io $ GHC.getContext session
1738 (mod : _) -> breakByModuleLine mod (read arg1) rest
1740 io $ putStrLn "Cannot find default module for breakpoint."
1741 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1742 | otherwise = do -- try parsing it as an identifier
1743 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1744 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1745 if GHC.isGoodSrcLoc loc
1746 then findBreakAndSet (GHC.nameModule name) $
1747 findBreakByCoord (Just (GHC.srcLocFile loc))
1748 (GHC.srcLocLine loc,
1750 else noCanDo name $ text "can't find its location: " <> ppr loc
1752 noCanDo n why = printForUser $
1753 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1755 breakByModule :: Module -> [String] -> GHCi ()
1756 breakByModule mod (arg1:rest)
1757 | all isDigit arg1 = do -- looks like a line number
1758 breakByModuleLine mod (read arg1) rest
1762 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1763 breakByModuleLine mod line args
1764 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1765 | [col] <- args, all isDigit col =
1766 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1767 | otherwise = breakSyntax
1770 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1772 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1773 findBreakAndSet mod lookupTickTree = do
1774 tickArray <- getTickArray mod
1775 (breakArray, _) <- getModBreak mod
1776 case lookupTickTree tickArray of
1777 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1778 Just (tick, span) -> do
1779 success <- io $ setBreakFlag True breakArray tick
1783 recordBreak $ BreakLocation
1790 text "Breakpoint " <> ppr nm <>
1792 then text " was already set at " <> ppr span
1793 else text " activated at " <> ppr span
1795 printForUser $ text "Breakpoint could not be activated at"
1798 -- When a line number is specified, the current policy for choosing
1799 -- the best breakpoint is this:
1800 -- - the leftmost complete subexpression on the specified line, or
1801 -- - the leftmost subexpression starting on the specified line, or
1802 -- - the rightmost subexpression enclosing the specified line
1804 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1805 findBreakByLine line arr
1806 | not (inRange (bounds arr) line) = Nothing
1808 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
1809 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1810 listToMaybe (sortBy (rightmost `on` snd) ticks)
1814 starts_here = [ tick | tick@(_,span) <- ticks,
1815 GHC.srcSpanStartLine span == line ]
1817 (complete,incomplete) = partition ends_here starts_here
1818 where ends_here (_,span) = GHC.srcSpanEndLine span == line
1820 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1821 -> Maybe (BreakIndex,SrcSpan)
1822 findBreakByCoord mb_file (line, col) arr
1823 | not (inRange (bounds arr) line) = Nothing
1825 listToMaybe (sortBy (rightmost `on` snd) contains ++
1826 sortBy (leftmost_smallest `on` snd) after_here)
1830 -- the ticks that span this coordinate
1831 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
1832 is_correct_file span ]
1834 is_correct_file span
1835 | Just f <- mb_file = GHC.srcSpanFile span == f
1838 after_here = [ tick | tick@(_,span) <- ticks,
1839 GHC.srcSpanStartLine span == line,
1840 GHC.srcSpanStartCol span >= col ]
1842 -- For now, use ANSI bold on terminals that we know support it.
1843 -- Otherwise, we add a line of carets under the active expression instead.
1844 -- In particular, on Windows and when running the testsuite (which sets
1845 -- TERM to vt100 for other reasons) we get carets.
1846 -- We really ought to use a proper termcap/terminfo library.
1848 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
1849 where mTerm = System.Environment.getEnv "TERM"
1850 `Exception.catch` \_ -> return "TERM not set"
1852 start_bold :: String
1853 start_bold = "\ESC[1m"
1855 end_bold = "\ESC[0m"
1857 listCmd :: String -> GHCi ()
1859 mb_span <- getCurrentBreakSpan
1861 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1862 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1863 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1864 listCmd str = list2 (words str)
1866 list2 :: [String] -> GHCi ()
1867 list2 [arg] | all isDigit arg = do
1868 session <- getSession
1869 (toplevel, _) <- io $ GHC.getContext session
1871 [] -> io $ putStrLn "No module to list"
1872 (mod : _) -> listModuleLine mod (read arg)
1873 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1874 mod <- wantInterpretedModule arg1
1875 listModuleLine mod (read arg2)
1877 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1878 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1879 if GHC.isGoodSrcLoc loc
1881 tickArray <- getTickArray (GHC.nameModule name)
1882 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1883 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1886 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1887 Just (_,span) -> io $ listAround span False
1889 noCanDo name $ text "can't find its location: " <>
1892 noCanDo n why = printForUser $
1893 text "cannot list source code for " <> ppr n <> text ": " <> why
1895 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1897 listModuleLine :: Module -> Int -> GHCi ()
1898 listModuleLine modl line = do
1899 session <- getSession
1900 graph <- io (GHC.getModuleGraph session)
1901 let this = filter ((== modl) . GHC.ms_mod) graph
1903 [] -> panic "listModuleLine"
1905 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1906 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1907 io $ listAround (GHC.srcLocSpan loc) False
1909 -- | list a section of a source file around a particular SrcSpan.
1910 -- If the highlight flag is True, also highlight the span using
1911 -- start_bold/end_bold.
1912 listAround :: SrcSpan -> Bool -> IO ()
1913 listAround span do_highlight = do
1914 contents <- BS.readFile (unpackFS file)
1916 lines = BS.split '\n' contents
1917 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1918 drop (line1 - 1 - pad_before) $ lines
1919 fst_line = max 1 (line1 - pad_before)
1920 line_nos = [ fst_line .. ]
1922 highlighted | do_highlight = zipWith highlight line_nos these_lines
1923 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
1925 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1926 prefixed = zipWith ($) highlighted bs_line_nos
1928 BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
1930 file = GHC.srcSpanFile span
1931 line1 = GHC.srcSpanStartLine span
1932 col1 = GHC.srcSpanStartCol span
1933 line2 = GHC.srcSpanEndLine span
1934 col2 = GHC.srcSpanEndCol span
1936 pad_before | line1 == 1 = 0
1940 highlight | do_bold = highlight_bold
1941 | otherwise = highlight_carets
1943 highlight_bold no line prefix
1944 | no == line1 && no == line2
1945 = let (a,r) = BS.splitAt col1 line
1946 (b,c) = BS.splitAt (col2-col1) r
1948 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
1950 = let (a,b) = BS.splitAt col1 line in
1951 BS.concat [prefix, a, BS.pack start_bold, b]
1953 = let (a,b) = BS.splitAt col2 line in
1954 BS.concat [prefix, a, BS.pack end_bold, b]
1955 | otherwise = BS.concat [prefix, line]
1957 highlight_carets no line prefix
1958 | no == line1 && no == line2
1959 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
1960 BS.replicate (col2-col1) '^']
1962 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
1965 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
1967 | otherwise = BS.concat [prefix, line]
1969 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
1970 nl = BS.singleton '\n'
1972 -- --------------------------------------------------------------------------
1975 getTickArray :: Module -> GHCi TickArray
1976 getTickArray modl = do
1978 let arrmap = tickarrays st
1979 case lookupModuleEnv arrmap modl of
1980 Just arr -> return arr
1982 (_breakArray, ticks) <- getModBreak modl
1983 let arr = mkTickArray (assocs ticks)
1984 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1987 discardTickArrays :: GHCi ()
1988 discardTickArrays = do
1990 setGHCiState st{tickarrays = emptyModuleEnv}
1992 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1994 = accumArray (flip (:)) [] (1, max_line)
1995 [ (line, (nm,span)) | (nm,span) <- ticks,
1996 line <- srcSpanLines span ]
1998 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1999 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2000 GHC.srcSpanEndLine span ]
2002 lookupModule :: String -> GHCi Module
2003 lookupModule modName
2004 = do session <- getSession
2005 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2007 -- don't reset the counter back to zero?
2008 discardActiveBreakPoints :: GHCi ()
2009 discardActiveBreakPoints = do
2011 mapM (turnOffBreak.snd) (breaks st)
2012 setGHCiState $ st { breaks = [] }
2014 deleteBreak :: Int -> GHCi ()
2015 deleteBreak identity = do
2017 let oldLocations = breaks st
2018 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2020 then printForUser (text "Breakpoint" <+> ppr identity <+>
2021 text "does not exist")
2023 mapM (turnOffBreak.snd) this
2024 setGHCiState $ st { breaks = rest }
2026 turnOffBreak :: BreakLocation -> GHCi Bool
2027 turnOffBreak loc = do
2028 (arr, _) <- getModBreak (breakModule loc)
2029 io $ setBreakFlag False arr (breakTick loc)
2031 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2032 getModBreak mod = do
2033 session <- getSession
2034 Just mod_info <- io $ GHC.getModuleInfo session mod
2035 let modBreaks = GHC.modInfoModBreaks mod_info
2036 let array = GHC.modBreaks_flags modBreaks
2037 let ticks = GHC.modBreaks_locs modBreaks
2038 return (array, ticks)
2040 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2041 setBreakFlag toggle array index
2042 | toggle = GHC.setBreakOn array index
2043 | otherwise = GHC.setBreakOff array index