distclean: <lib>/.depend[.bak]
[ghc-hetmet.git] / compiler / ghci / InteractiveUI.hs
1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 --
4 -- GHC Interactive User Interface
5 --
6 -- (c) The GHC Team 2005-2006
7 --
8 -----------------------------------------------------------------------------
9 {-# OPTIONS -w #-}
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
14 -- for details
15
16 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
17
18 #include "HsVersions.h"
19
20 import GhciMonad
21 import GhciTags
22 import Debugger
23
24 -- The GHC interface
25 import qualified GHC
26 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
27                           Type, Module, ModuleName, TyThing(..), Phase,
28                           BreakIndex, SrcSpan, Resume, SingleStep )
29 import PprTyThing
30 import DynFlags
31 import Packages
32 import PackageConfig
33 import UniqFM
34 import HscTypes         ( implicitTyThings )
35 import Outputable       hiding (printForUser)
36 import Module           -- for ModuleEnv
37 import Name
38 import SrcLoc
39
40 -- Other random utilities
41 import Digraph
42 import BasicTypes hiding (isTopLevel)
43 import Panic      hiding (showException)
44 import Config
45 import StaticFlags
46 import Linker
47 import Util
48 import NameSet
49 import Maybes           ( orElse )
50 import FastString
51
52 #ifndef mingw32_HOST_OS
53 import System.Posix hiding (getEnv)
54 #else
55 import GHC.ConsoleHandler ( flushConsole )
56 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
57 import qualified System.Win32
58 #endif
59
60 #ifdef USE_READLINE
61 import Control.Concurrent       ( yield )       -- Used in readline loop
62 import System.Console.Readline as Readline
63 #endif
64
65 --import SystemExts
66
67 import Control.Exception as Exception
68 -- import Control.Concurrent
69
70 import qualified Data.ByteString.Char8 as BS
71 import Data.List
72 import Data.Maybe
73 import System.Cmd
74 import System.Environment
75 import System.Exit      ( exitWith, ExitCode(..) )
76 import System.Directory
77 import System.IO
78 import System.IO.Error as IO
79 import System.IO.Unsafe
80 import Data.Char
81 import Data.Dynamic
82 import Data.Array
83 import Control.Monad as Monad
84 import Text.Printf
85
86 import Foreign.StablePtr        ( newStablePtr )
87 import GHC.Exts         ( unsafeCoerce# )
88 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
89
90 import Data.IORef       ( IORef, readIORef, writeIORef )
91
92 import System.Posix.Internals ( setNonBlockingFD )
93
94 -----------------------------------------------------------------------------
95
96 ghciWelcomeMsg :: String
97 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
98                  ": http://www.haskell.org/ghc/  :? for help"
99
100 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
101 cmdName (n,_,_,_) = n
102
103 GLOBAL_VAR(commands, builtin_commands, [Command])
104
105 builtin_commands :: [Command]
106 builtin_commands = [
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)
147   ]
148
149 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
150 keepGoing a str = a str >> return False
151
152 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
153 keepGoingPaths a str = a (toArgs str) >> return False
154
155 shortHelpText = "use :? for help.\n"
156
157 helpText =
158  " Commands available from the prompt:\n" ++
159  "\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" ++
181  "\n" ++
182  " -- Commands for debugging:\n" ++
183  "\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"++
202
203  "\n" ++
204  " -- Commands for changing settings:\n" ++
205  "\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" ++
213  "\n" ++
214  "  Options for ':set' and ':unset':\n" ++
215  "\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" ++
221  "\n" ++
222  " -- Commands for displaying information:\n" ++
223  "\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" ++
229  "\n" 
230
231 findEditor = do
232   getEnv "EDITOR" 
233     `IO.catch` \_ -> do
234 #if mingw32_HOST_OS
235         win <- System.Win32.getWindowsDirectory
236         return (win `joinFileName` "notepad.exe")
237 #else
238         return ""
239 #endif
240
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
250    -- now.
251    newStablePtr stdin
252    newStablePtr stdout
253    newStablePtr stderr
254
255     -- Initialise buffering for the *interpreted* I/O system
256    initInterpBuffering session
257
258    when (isNothing maybe_expr) $ do
259         -- Only for GHCi (not runghc and ghc -e):
260
261         -- Turn buffering off for the compiled program's stdout/stderr
262         turnOffBuffering
263         -- Turn buffering off for GHCi's stdout
264         hFlush 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
269
270         -- initial context is just the Prelude
271    prel_mod <- GHC.findModule session prel_name (Just basePackageId)
272    GHC.setContext session [] [prel_mod]
273
274 #ifdef USE_READLINE
275    Readline.initialize
276    Readline.setAttemptedCompletionFunction (Just completeWord)
277    --Readline.parseAndBind "set show-all-if-ambiguous 1"
278
279    let symbols = "!#$%&*+/<=>?@\\^|-~"
280        specials = "(),;[]`{}"
281        spaces = " \t\n"
282        word_break_chars = spaces ++ specials ++ symbols
283
284    Readline.setBasicWordBreakCharacters word_break_chars
285    Readline.setCompleterWordBreakCharacters word_break_chars
286 #endif
287
288    default_editor <- findEditor
289
290    startGHCi (runGHCi srcs maybe_expr)
291         GHCiState{ progname = "<interactive>",
292                    args = [],
293                    prompt = "%s> ",
294                    stop = "",
295                    editor = default_editor,
296                    session = session,
297                    options = [],
298                    prelude = prel_mod,
299                    break_ctr = 0,
300                    breaks = [],
301                    tickarrays = emptyModuleEnv,
302                    cmdqueue = []
303                  }
304
305 #ifdef USE_READLINE
306    Readline.resetTerminal Nothing
307 #endif
308
309    return ()
310
311 prel_name = GHC.mkModuleName "Prelude"
312
313 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
314 runGHCi paths maybe_expr = do
315   let read_dot_files = not opt_IgnoreDotGhci
316
317   when (read_dot_files) $ do
318     -- Read in ./.ghci.
319     let file = "./.ghci"
320     exists <- io (doesFileExist file)
321     when exists $ do
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))
326           case either_hdl of
327              Left e    -> return ()
328              Right hdl -> fileLoop hdl False
329     
330   when (read_dot_files) $ do
331     -- Read in $HOME/.ghci
332     either_dir <- io (IO.try (getEnv "HOME"))
333     case either_dir of
334        Left e -> return ()
335        Right dir -> do
336           cwd <- io (getCurrentDirectory)
337           when (dir /= cwd) $ do
338              let file = dir ++ "/.ghci"
339              ok <- io (checkPerms file)
340              when ok $ do
341                either_hdl <- io (IO.try (openFile file ReadMode))
342                case either_hdl of
343                   Left e    -> return ()
344                   Right hdl -> fileLoop hdl False
345
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) $ 
351                 loadModule paths
352      when (isJust maybe_expr && failed ok) $
353         io (exitWith (ExitFailure 1))
354
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
360
361   case maybe_expr of
362         Nothing ->
363           do
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))
370             case flushed of
371              Left err | isDoesNotExistError err -> return ()
372                       | otherwise -> io (ioError err)
373              Right () -> return ()
374 #endif
375             -- initialise the console if necessary
376             io setUpConsole
377
378             -- enter the interactive loop
379             interactiveLoop is_tty show_prompt
380         Just expr -> do
381             -- just evaluate the expression we were given
382             runCommandEval expr
383             return ()
384
385   -- and finally, exit
386   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
387
388
389 interactiveLoop is_tty show_prompt =
390   -- Ignore ^C exceptions caught here
391   ghciHandleDyn (\e -> case e of 
392                         Interrupted -> do
393 #if defined(mingw32_HOST_OS)
394                                 io (putStrLn "")
395 #endif
396                                 interactiveLoop is_tty show_prompt
397                         _other      -> return ()) $ 
398
399   ghciUnblock $ do -- unblock necessary if we recursed from the 
400                    -- exception handler above.
401
402   -- read commands from stdin
403 #ifdef USE_READLINE
404   if (is_tty) 
405         then readlineLoop
406         else fileLoop stdin show_prompt
407 #else
408   fileLoop stdin show_prompt
409 #endif
410
411
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.
415
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.
420
421 checkPerms :: String -> IO Bool
422 checkPerms name =
423 #ifdef mingw32_HOST_OS
424   return True
425 #else
426   Util.handle (\_ -> return False) $ do
427      st <- getFileStatus name
428      me <- getRealUserID
429      if fileOwner st /= me then do
430         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
431         return False
432       else do
433         let mode =  fileMode st
434         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
435            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) 
436            then do
437                putStrLn $ "*** WARNING: " ++ name ++ 
438                           " is writable by someone else, IGNORING!"
439                return False
440           else return True
441 #endif
442
443 fileLoop :: Handle -> Bool -> GHCi ()
444 fileLoop hdl show_prompt = do
445    when show_prompt $ do
446         prompt <- mkPrompt
447         (io (putStr prompt))
448    l <- io (IO.try (hGetLine hdl))
449    case l of
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
457                 -- EOF.
458         Right l -> 
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
463
464 mkPrompt = do
465   session <- getSession
466   (toplevs,exports) <- io (GHC.getContext session)
467   resumes <- io $ GHC.getResumeContext session
468
469   context_bit <-
470         case resumes of
471             [] -> return empty
472             r:rs -> do
473                 let ix = GHC.resumeHistoryIx r
474                 if ix == 0
475                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
476                    else do
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)
481   let
482         dots | r:rs <- resumes, not (null rs) = text "... "
483              | otherwise = empty
484
485         modules_bit = 
486              hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
487              hsep (map (ppr . GHC.moduleName) exports)
488
489         deflt_prompt = dots <> context_bit <> modules_bit
490
491         f ('%':'s':xs) = deflt_prompt <> f xs
492         f ('%':'%':xs) = char '%' <> f xs
493         f (x:xs) = char x <> f xs
494         f [] = empty
495    --
496   st <- getGHCiState
497   return (showSDoc (f (prompt st)))
498
499
500 #ifdef USE_READLINE
501 readlineLoop :: GHCi ()
502 readlineLoop = do
503    session <- getSession
504    (mod,imports) <- io (GHC.getContext session)
505    io yield
506    saveSession -- for use by completion
507    st <- getGHCiState
508    mb_span <- getCurrentBreakSpan
509    prompt <- mkPrompt
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
513    splatSavedSession
514    case l of
515         Nothing -> return ()
516         Just l  ->
517           case removeSpaces l of
518             "" -> readlineLoop
519             l  -> do
520                   io (addHistory l)
521                   quit <- runCommands l
522                   if quit then return () else readlineLoop
523 #endif
524
525 runCommands :: String -> GHCi Bool
526 runCommands cmd = do
527         q <- ghciHandle handler (doCommand cmd)
528         if q then return True else runNext
529   where
530        runNext = do
531           st <- getGHCiState
532           case cmdqueue st of
533             []   -> return False
534             c:cs -> do setGHCiState st{ cmdqueue = cs }
535                        runCommands c
536
537        doCommand (':' : cmd) = specialCommand cmd
538        doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
539                                   return False
540
541 enqueueCommands :: [String] -> GHCi ()
542 enqueueCommands cmds = do
543   st <- getGHCiState
544   setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
545
546
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)
551   where 
552     handleEval (ExitException code) = io (exitWith code)
553     handleEval e                    = do handler e
554                                          io (exitWith (ExitFailure 1))
555
556     doCommand (':' : command) = specialCommand command
557     doCommand stmt
558        = do r <- runStmt stmt GHC.RunToCompletion
559             case r of 
560                 False -> io (exitWith (ExitFailure 1))
561                   -- failure to run the command causes exit(1) for ghc -e.
562                 _       -> return True
563
564 runStmt :: String -> SingleStep -> GHCi Bool
565 runStmt stmt step
566  | null (filter (not.isSpace) stmt) = return False
567  | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
568  | otherwise
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
574
575
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
582   case run_result of
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>"
595                st <- getGHCiState
596                enqueueCommands [stop st]
597                return ()
598          | otherwise -> io(GHC.resume session GHC.SingleStep) >>= 
599                         afterRunStmt step_here >> return ()
600      _ -> return ()
601
602   flushInterpBuffers
603   io installSignalHandlers
604   b <- isOptionSet RevertCAFs
605   io (when b revertCAFs)
606
607   return (case run_result of GHC.RunOk _ -> True; _ -> False)
608
609       where printTypeAndContentOfNames session names = do
610               let namesSorted = sortBy compareNames names
611               tythings <- catMaybes `liftM` 
612                               io (mapM (GHC.lookupName session) namesSorted)
613               let ids = [id | AnId id <- tythings]
614               terms <- mapM (io . GHC.obtainTermB session 10 False) ids
615               docs_terms <- mapM (io . showTerm session) terms                                   
616               dflags <- getDynFlags
617               let pefas = dopt Opt_PrintExplicitForalls dflags
618               printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
619                                             (map (pprTyThing pefas . AnId) ids)
620                                             docs_terms
621
622 runBreakCmd :: GHC.BreakInfo -> GHCi ()
623 runBreakCmd info = do
624   let mod = GHC.breakInfo_module info
625       nm  = GHC.breakInfo_number info
626   st <- getGHCiState
627   case  [ loc | (i,loc) <- breaks st,
628                 breakModule loc == mod, breakTick loc == nm ] of
629         []  -> return ()
630         loc:_ | null cmd  -> return ()
631               | otherwise -> do enqueueCommands [cmd]; return ()
632               where cmd = onBreakCmd loc
633
634 printTypeOfNames :: Session -> [Name] -> GHCi ()
635 printTypeOfNames session names
636  = mapM_ (printTypeOfName session) $ sortBy compareNames names
637
638 compareNames :: Name -> Name -> Ordering
639 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
640     where compareWith n = (getOccString n, getSrcSpan n)
641
642 printTypeOfName :: Session -> Name -> GHCi ()
643 printTypeOfName session n
644    = do maybe_tything <- io (GHC.lookupName session n)
645         case maybe_tything of
646             Nothing    -> return ()
647             Just thing -> printTyThing thing
648
649 specialCommand :: String -> GHCi Bool
650 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
651 specialCommand str = do
652   let (cmd,rest) = break isSpace str
653   maybe_cmd <- io (lookupCommand cmd)
654   case maybe_cmd of
655     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" 
656                                     ++ shortHelpText) >> return False)
657     Just (_,f,_,_) -> f (dropWhile isSpace rest)
658
659 lookupCommand :: String -> IO (Maybe Command)
660 lookupCommand str = do
661   cmds <- readIORef commands
662   -- look for exact match first, then the first prefix match
663   case [ c | c <- cmds, str == cmdName c ] of
664      c:_ -> return (Just c)
665      [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
666                 [] -> return Nothing
667                 c:_ -> return (Just c)
668
669
670 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
671 getCurrentBreakSpan = do
672   session <- getSession
673   resumes <- io $ GHC.getResumeContext session
674   case resumes of
675     [] -> return Nothing
676     (r:rs) -> do
677         let ix = GHC.resumeHistoryIx r
678         if ix == 0
679            then return (Just (GHC.resumeSpan r))
680            else do
681                 let hist = GHC.resumeHistory r !! (ix-1)
682                 span <- io $ GHC.getHistorySpan session hist
683                 return (Just span)
684
685 getCurrentBreakModule :: GHCi (Maybe Module)
686 getCurrentBreakModule = do
687   session <- getSession
688   resumes <- io $ GHC.getResumeContext session
689   case resumes of
690     [] -> return Nothing
691     (r:rs) -> do
692         let ix = GHC.resumeHistoryIx r
693         if ix == 0
694            then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
695            else do
696                 let hist = GHC.resumeHistory r !! (ix-1)
697                 return $ Just $ GHC.getHistoryModule  hist
698
699 -----------------------------------------------------------------------------
700 -- Commands
701
702 noArgs :: GHCi () -> String -> GHCi ()
703 noArgs m "" = m
704 noArgs m _ = io $ putStrLn "This command takes no arguments"
705
706 help :: String -> GHCi ()
707 help _ = io (putStr helpText)
708
709 info :: String -> GHCi ()
710 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
711 info s  = do { let names = words s
712              ; session <- getSession
713              ; dflags <- getDynFlags
714              ; let pefas = dopt Opt_PrintExplicitForalls dflags
715              ; mapM_ (infoThing pefas session) names }
716   where
717     infoThing pefas session str = io $ do
718         names     <- GHC.parseName session str
719         mb_stuffs <- mapM (GHC.getInfo session) names
720         let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
721         unqual <- GHC.getPrintUnqual session
722         putStrLn (showSDocForUser unqual $
723                    vcat (intersperse (text "") $
724                          map (pprInfo pefas) filtered))
725
726   -- Filter out names whose parent is also there Good
727   -- example is '[]', which is both a type and data
728   -- constructor in the same type
729 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
730 filterOutChildren get_thing xs 
731   = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
732   where
733     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
734
735 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
736 pprInfo pefas (thing, fixity, insts)
737   =  pprTyThingInContextLoc pefas thing
738   $$ show_fixity fixity
739   $$ vcat (map GHC.pprInstance insts)
740   where
741     show_fixity fix 
742         | fix == GHC.defaultFixity = empty
743         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
744
745 runMain :: String -> GHCi ()
746 runMain args = do
747   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
748   enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
749
750 addModule :: [FilePath] -> GHCi ()
751 addModule files = do
752   io (revertCAFs)                       -- always revert CAFs on load/add.
753   files <- mapM expandPath files
754   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
755   session <- getSession
756   io (mapM_ (GHC.addTarget session) targets)
757   ok <- io (GHC.load session LoadAllTargets)
758   afterLoad ok session
759
760 changeDirectory :: String -> GHCi ()
761 changeDirectory dir = do
762   session <- getSession
763   graph <- io (GHC.getModuleGraph session)
764   when (not (null graph)) $
765         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
766   io (GHC.setTargets session [])
767   io (GHC.load session LoadAllTargets)
768   setContextAfterLoad session []
769   io (GHC.workingDirectoryChanged session)
770   dir <- expandPath dir
771   io (setCurrentDirectory dir)
772
773 editFile :: String -> GHCi ()
774 editFile str =
775   do file <- if null str then chooseEditFile else return str
776      st <- getGHCiState
777      let cmd = editor st
778      when (null cmd) 
779        $ throwDyn (CmdLineError "editor not set, use :set editor")
780      io $ system (cmd ++ ' ':file)
781      return ()
782
783 -- The user didn't specify a file so we pick one for them.
784 -- Our strategy is to pick the first module that failed to load,
785 -- or otherwise the first target.
786 --
787 -- XXX: Can we figure out what happened if the depndecy analysis fails
788 --      (e.g., because the porgrammeer mistyped the name of a module)?
789 -- XXX: Can we figure out the location of an error to pass to the editor?
790 -- XXX: if we could figure out the list of errors that occured during the
791 -- last load/reaload, then we could start the editor focused on the first
792 -- of those.
793 chooseEditFile :: GHCi String
794 chooseEditFile =
795   do session <- getSession
796      let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
797
798      graph <- io (GHC.getModuleGraph session)
799      failed_graph <- filterM hasFailed graph
800      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
801          pick xs  = case xs of
802                       x : _ -> GHC.ml_hs_file (GHC.ms_location x)
803                       _     -> Nothing
804
805      case pick (order failed_graph) of
806        Just file -> return file
807        Nothing   -> 
808          do targets <- io (GHC.getTargets session)
809             case msum (map fromTarget targets) of
810               Just file -> return file
811               Nothing   -> throwDyn (CmdLineError "No files to edit.")
812           
813   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
814         fromTarget _ = Nothing -- when would we get a module target?
815
816 defineMacro :: String -> GHCi ()
817 defineMacro s = do
818   let (macro_name, definition) = break isSpace s
819   cmds <- io (readIORef commands)
820   if (null macro_name) 
821         then throwDyn (CmdLineError "invalid macro name") 
822         else do
823   if (macro_name `elem` map cmdName cmds)
824         then throwDyn (CmdLineError 
825                 ("command '" ++ macro_name ++ "' is already defined"))
826         else do
827
828   -- give the expression a type signature, so we can be sure we're getting
829   -- something of the right type.
830   let new_expr = '(' : definition ++ ") :: String -> IO String"
831
832   -- compile the expression
833   cms <- getSession
834   maybe_hv <- io (GHC.compileExpr cms new_expr)
835   case maybe_hv of
836      Nothing -> return ()
837      Just hv -> io (writeIORef commands --
838                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
839
840 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
841 runMacro fun s = do
842   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
843   enqueueCommands (lines str)
844   return False
845
846 undefineMacro :: String -> GHCi ()
847 undefineMacro macro_name = do
848   cmds <- io (readIORef commands)
849   if (macro_name `elem` map cmdName builtin_commands) 
850         then throwDyn (CmdLineError
851                 ("command '" ++ macro_name ++ "' cannot be undefined"))
852         else do
853   if (macro_name `notElem` map cmdName cmds) 
854         then throwDyn (CmdLineError 
855                 ("command '" ++ macro_name ++ "' not defined"))
856         else do
857   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
858
859 cmdCmd :: String -> GHCi ()
860 cmdCmd str = do
861   let expr = '(' : str ++ ") :: IO String"
862   session <- getSession
863   maybe_hv <- io (GHC.compileExpr session expr)
864   case maybe_hv of
865     Nothing -> return ()
866     Just hv -> do 
867         cmds <- io $ (unsafeCoerce# hv :: IO String)
868         enqueueCommands (lines cmds)
869         return ()
870
871 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
872 loadModule fs = timeIt (loadModule' fs)
873
874 loadModule_ :: [FilePath] -> GHCi ()
875 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
876
877 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
878 loadModule' files = do
879   session <- getSession
880
881   -- unload first
882   discardActiveBreakPoints
883   io (GHC.setTargets session [])
884   io (GHC.load session LoadAllTargets)
885
886   -- expand tildes
887   let (filenames, phases) = unzip files
888   exp_filenames <- mapM expandPath filenames
889   let files' = zip exp_filenames phases
890   targets <- io (mapM (uncurry GHC.guessTarget) files')
891
892   -- NOTE: we used to do the dependency anal first, so that if it
893   -- fails we didn't throw away the current set of modules.  This would
894   -- require some re-working of the GHC interface, so we'll leave it
895   -- as a ToDo for now.
896
897   io (GHC.setTargets session targets)
898   doLoad session LoadAllTargets
899
900 checkModule :: String -> GHCi ()
901 checkModule m = do
902   let modl = GHC.mkModuleName m
903   session <- getSession
904   result <- io (GHC.checkModule session modl False)
905   case result of
906     Nothing -> io $ putStrLn "Nothing"
907     Just r  -> io $ putStrLn (showSDoc (
908         case GHC.checkedModuleInfo r of
909            Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> 
910                 let
911                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
912                 in
913                         (text "global names: " <+> ppr global) $$
914                         (text "local  names: " <+> ppr local)
915            _ -> empty))
916   afterLoad (successIf (isJust result)) session
917
918 reloadModule :: String -> GHCi ()
919 reloadModule m = do
920   session <- getSession
921   doLoad session $ if null m then LoadAllTargets 
922                              else LoadUpTo (GHC.mkModuleName m)
923   return ()
924
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)
930   afterLoad ok session
931   return ok
932
933 afterLoad ok session = do
934   io (revertCAFs)  -- always revert CAFs on load.
935   discardTickArrays
936   graph <- io (GHC.getModuleGraph session)
937   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
938   setContextAfterLoad session graph'
939   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
940
941 setContextAfterLoad session [] = do
942   prel_mod <- getPrelude
943   io (GHC.setContext session [] [prel_mod])
944 setContextAfterLoad session ms = do
945   -- load a target if one is available, otherwise load the topmost module.
946   targets <- io (GHC.getTargets session)
947   case [ m | Just m <- map (findTarget ms) targets ] of
948         []    -> 
949           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
950           load_this (last graph')         
951         (m:_) -> 
952           load_this m
953  where
954    findTarget ms t
955     = case filter (`matches` t) ms of
956         []    -> Nothing
957         (m:_) -> Just m
958
959    summary `matches` Target (TargetModule m) _
960         = GHC.ms_mod_name summary == m
961    summary `matches` Target (TargetFile f _) _ 
962         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
963    summary `matches` target
964         = False
965
966    load_this summary | m <- GHC.ms_mod summary = do
967         b <- io (GHC.moduleIsInterpreted session m)
968         if b then io (GHC.setContext session [m] []) 
969              else do
970                    prel_mod <- getPrelude
971                    io (GHC.setContext session []  [prel_mod,m])
972
973
974 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
975 modulesLoadedMsg ok mods = do
976   dflags <- getDynFlags
977   when (verbosity dflags > 0) $ do
978    let mod_commas 
979         | null mods = text "none."
980         | otherwise = hsep (
981             punctuate comma (map ppr mods)) <> text "."
982    case ok of
983     Failed ->
984        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
985     Succeeded  ->
986        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
987
988
989 typeOfExpr :: String -> GHCi ()
990 typeOfExpr str 
991   = do cms <- getSession
992        maybe_ty <- io (GHC.exprType cms str)
993        case maybe_ty of
994           Nothing -> return ()
995           Just ty -> do dflags <- getDynFlags
996                         let pefas = dopt Opt_PrintExplicitForalls dflags
997                         printForUser $ text str <+> dcolon
998                                         <+> pprTypeForUser pefas ty
999
1000 kindOfType :: String -> GHCi ()
1001 kindOfType str 
1002   = do cms <- getSession
1003        maybe_ty <- io (GHC.typeKind cms str)
1004        case maybe_ty of
1005           Nothing    -> return ()
1006           Just ty    -> printForUser $ text str <+> dcolon <+> ppr ty
1007           
1008 quit :: String -> GHCi Bool
1009 quit _ = return True
1010
1011 shellEscape :: String -> GHCi Bool
1012 shellEscape str = io (system str >> return False)
1013
1014 -----------------------------------------------------------------------------
1015 -- Browsing a module's contents
1016
1017 browseCmd :: String -> GHCi ()
1018 browseCmd m = 
1019   case words m of
1020     ['*':m] | looksLikeModuleName m -> browseModule m False
1021     [m]     | looksLikeModuleName m -> browseModule m True
1022     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
1023
1024 browseModule m exports_only = do
1025   s <- getSession
1026   modl <- if exports_only then lookupModule m
1027                           else wantInterpretedModule m
1028
1029   -- Temporarily set the context to the module we're interested in,
1030   -- just so we can get an appropriate PrintUnqualified
1031   (as,bs) <- io (GHC.getContext s)
1032   prel_mod <- getPrelude
1033   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1034                       else GHC.setContext s [modl] [])
1035   unqual <- io (GHC.getPrintUnqual s)
1036   io (GHC.setContext s as bs)
1037
1038   mb_mod_info <- io $ GHC.getModuleInfo s modl
1039   case mb_mod_info of
1040     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1041     Just mod_info -> do
1042         let names
1043                | exports_only = GHC.modInfoExports mod_info
1044                | otherwise    = GHC.modInfoTopLevelScope mod_info
1045                                 `orElse` []
1046
1047         mb_things <- io $ mapM (GHC.lookupName s) names
1048         let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1049
1050         dflags <- getDynFlags
1051         let pefas = dopt Opt_PrintExplicitForalls dflags
1052         io (putStrLn (showSDocForUser unqual (
1053                 vcat (map (pprTyThingInContext pefas) filtered_things)
1054            )))
1055         -- ToDo: modInfoInstances currently throws an exception for
1056         -- package modules.  When it works, we can do this:
1057         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1058
1059 -----------------------------------------------------------------------------
1060 -- Setting the module context
1061
1062 setContext str
1063   | all sensible mods = fn mods
1064   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1065   where
1066     (fn, mods) = case str of 
1067                         '+':stuff -> (addToContext,      words stuff)
1068                         '-':stuff -> (removeFromContext, words stuff)
1069                         stuff     -> (newContext,        words stuff) 
1070
1071     sensible ('*':m) = looksLikeModuleName m
1072     sensible m       = looksLikeModuleName m
1073
1074 separate :: Session -> [String] -> [Module] -> [Module] 
1075         -> GHCi ([Module],[Module])
1076 separate session []           as bs = return (as,bs)
1077 separate session (('*':str):ms) as bs = do
1078    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1079    b <- io $ GHC.moduleIsInterpreted session m
1080    if b then separate session ms (m:as) bs
1081         else throwDyn (CmdLineError ("module '"
1082                         ++ GHC.moduleNameString (GHC.moduleName m)
1083                         ++ "' is not interpreted"))
1084 separate session (str:ms) as bs = do
1085   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1086   separate session ms as (m:bs)
1087
1088 newContext :: [String] -> GHCi ()
1089 newContext strs = do
1090   s <- getSession
1091   (as,bs) <- separate s strs [] []
1092   prel_mod <- getPrelude
1093   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1094   io $ GHC.setContext s as bs'
1095
1096
1097 addToContext :: [String] -> GHCi ()
1098 addToContext strs = do
1099   s <- getSession
1100   (as,bs) <- io $ GHC.getContext s
1101
1102   (new_as,new_bs) <- separate s strs [] []
1103
1104   let as_to_add = new_as \\ (as ++ bs)
1105       bs_to_add = new_bs \\ (as ++ bs)
1106
1107   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1108
1109
1110 removeFromContext :: [String] -> GHCi ()
1111 removeFromContext strs = do
1112   s <- getSession
1113   (as,bs) <- io $ GHC.getContext s
1114
1115   (as_to_remove,bs_to_remove) <- separate s strs [] []
1116
1117   let as' = as \\ (as_to_remove ++ bs_to_remove)
1118       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1119
1120   io $ GHC.setContext s as' bs'
1121
1122 ----------------------------------------------------------------------------
1123 -- Code for `:set'
1124
1125 -- set options in the interpreter.  Syntax is exactly the same as the
1126 -- ghc command line, except that certain options aren't available (-C,
1127 -- -E etc.)
1128 --
1129 -- This is pretty fragile: most options won't work as expected.  ToDo:
1130 -- figure out which ones & disallow them.
1131
1132 setCmd :: String -> GHCi ()
1133 setCmd ""
1134   = do st <- getGHCiState
1135        let opts = options st
1136        io $ putStrLn (showSDoc (
1137               text "options currently set: " <> 
1138               if null opts
1139                    then text "none."
1140                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1141            ))
1142 setCmd str
1143   = case toArgs str of
1144         ("args":args) -> setArgs args
1145         ("prog":prog) -> setProg prog
1146         ("prompt":prompt) -> setPrompt (after 6)
1147         ("editor":cmd) -> setEditor (after 6)
1148         ("stop":cmd) -> setStop (after 4)
1149         wds -> setOptions wds
1150    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1151
1152 setArgs args = do
1153   st <- getGHCiState
1154   setGHCiState st{ args = args }
1155
1156 setProg [prog] = do
1157   st <- getGHCiState
1158   setGHCiState st{ progname = prog }
1159 setProg _ = do
1160   io (hPutStrLn stderr "syntax: :set prog <progname>")
1161
1162 setEditor cmd = do
1163   st <- getGHCiState
1164   setGHCiState st{ editor = cmd }
1165
1166 setStop str@(c:_) | isDigit c
1167   = do let (nm_str,rest) = break (not.isDigit) str
1168            nm = read nm_str
1169        st <- getGHCiState
1170        let old_breaks = breaks st
1171        if all ((/= nm) . fst) old_breaks
1172               then printForUser (text "Breakpoint" <+> ppr nm <+>
1173                                  text "does not exist")
1174               else do
1175        let new_breaks = map fn old_breaks
1176            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1177                       | otherwise = (i,loc)
1178        setGHCiState st{ breaks = new_breaks }
1179 setStop cmd = do
1180   st <- getGHCiState
1181   setGHCiState st{ stop = cmd }
1182
1183 setPrompt value = do
1184   st <- getGHCiState
1185   if null value
1186       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1187       else setGHCiState st{ prompt = remQuotes value }
1188   where
1189      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1190      remQuotes x = x
1191
1192 setOptions wds =
1193    do -- first, deal with the GHCi opts (+s, +t, etc.)
1194       let (plus_opts, minus_opts)  = partition isPlus wds
1195       mapM_ setOpt plus_opts
1196       -- then, dynamic flags
1197       newDynFlags minus_opts
1198
1199 newDynFlags minus_opts = do
1200       dflags <- getDynFlags
1201       let pkg_flags = packageFlags dflags
1202       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1203
1204       if (not (null leftovers))
1205                 then throwDyn (CmdLineError ("unrecognised flags: " ++ 
1206                                                 unwords leftovers))
1207                 else return ()
1208
1209       new_pkgs <- setDynFlags dflags'
1210
1211       -- if the package flags changed, we should reset the context
1212       -- and link the new packages.
1213       dflags <- getDynFlags
1214       when (packageFlags dflags /= pkg_flags) $ do
1215         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1216         session <- getSession
1217         io (GHC.setTargets session [])
1218         io (GHC.load session LoadAllTargets)
1219         io (linkPackages dflags new_pkgs)
1220         setContextAfterLoad session []
1221       return ()
1222
1223
1224 unsetOptions :: String -> GHCi ()
1225 unsetOptions str
1226   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1227        let opts = words str
1228            (minus_opts, rest1) = partition isMinus opts
1229            (plus_opts, rest2)  = partition isPlus rest1
1230
1231        if (not (null rest2)) 
1232           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1233           else do
1234
1235        mapM_ unsetOpt plus_opts
1236  
1237        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1238            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1239
1240        no_flags <- mapM no_flag minus_opts
1241        newDynFlags no_flags
1242
1243 isMinus ('-':s) = True
1244 isMinus _ = False
1245
1246 isPlus ('+':s) = True
1247 isPlus _ = False
1248
1249 setOpt ('+':str)
1250   = case strToGHCiOpt str of
1251         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1252         Just o  -> setOption o
1253
1254 unsetOpt ('+':str)
1255   = case strToGHCiOpt str of
1256         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1257         Just o  -> unsetOption o
1258
1259 strToGHCiOpt :: String -> (Maybe GHCiOption)
1260 strToGHCiOpt "s" = Just ShowTiming
1261 strToGHCiOpt "t" = Just ShowType
1262 strToGHCiOpt "r" = Just RevertCAFs
1263 strToGHCiOpt _   = Nothing
1264
1265 optToStr :: GHCiOption -> String
1266 optToStr ShowTiming = "s"
1267 optToStr ShowType   = "t"
1268 optToStr RevertCAFs = "r"
1269
1270 -- ---------------------------------------------------------------------------
1271 -- code for `:show'
1272
1273 showCmd str = do
1274   st <- getGHCiState
1275   case words str of
1276         ["args"]     -> io $ putStrLn (show (args st))
1277         ["prog"]     -> io $ putStrLn (show (progname st))
1278         ["prompt"]   -> io $ putStrLn (show (prompt st))
1279         ["editor"]   -> io $ putStrLn (show (editor st))
1280         ["stop"]     -> io $ putStrLn (show (stop st))
1281         ["modules" ] -> showModules
1282         ["bindings"] -> showBindings
1283         ["linker"]   -> io showLinkerState
1284         ["breaks"]   -> showBkptTable
1285         ["context"]  -> showContext
1286         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1287
1288 showModules = do
1289   session <- getSession
1290   let show_one ms = do m <- io (GHC.showModule session ms)
1291                        io (putStrLn m)
1292   graph <- io (GHC.getModuleGraph session)
1293   mapM_ show_one graph
1294
1295 showBindings = do
1296   s <- getSession
1297   unqual <- io (GHC.getPrintUnqual s)
1298   bindings <- io (GHC.getBindings s)
1299   mapM_ printTyThing $ sortBy compareTyThings bindings
1300   return ()
1301
1302 compareTyThings :: TyThing -> TyThing -> Ordering
1303 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1304
1305 printTyThing :: TyThing -> GHCi ()
1306 printTyThing tyth = do dflags <- getDynFlags
1307                        let pefas = dopt Opt_PrintExplicitForalls dflags
1308                        printForUser (pprTyThing pefas tyth)
1309
1310 showBkptTable :: GHCi ()
1311 showBkptTable = do
1312   st <- getGHCiState
1313   printForUser $ prettyLocations (breaks st)
1314
1315 showContext :: GHCi ()
1316 showContext = do
1317    session <- getSession
1318    resumes <- io $ GHC.getResumeContext session
1319    printForUser $ vcat (map pp_resume (reverse resumes))
1320   where
1321    pp_resume resume =
1322         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1323         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1324
1325
1326 -- -----------------------------------------------------------------------------
1327 -- Completion
1328
1329 completeNone :: String -> IO [String]
1330 completeNone w = return []
1331
1332 #ifdef USE_READLINE
1333 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1334 completeWord w start end = do
1335   line <- Readline.getLineBuffer
1336   let line_words = words (dropWhile isSpace line)
1337   case w of
1338      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1339      _other
1340         | ((':':c) : _) <- line_words -> do
1341            maybe_cmd <- lookupCommand c
1342            let (n,w') = selectWord (words' 0 line)
1343            case maybe_cmd of
1344              Nothing -> return Nothing
1345              Just (_,_,False,complete) -> wrapCompleter complete w
1346              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1347                                                               return (map (drop n) rets)
1348                                          in wrapCompleter complete' w'
1349         | ("import" : _) <- line_words ->
1350                 wrapCompleter completeModule w
1351         | otherwise     -> do
1352                 --printf "complete %s, start = %d, end = %d\n" w start end
1353                 wrapCompleter completeIdentifier w
1354     where words' _ [] = []
1355           words' n str = let (w,r) = break isSpace str
1356                              (s,r') = span isSpace r
1357                          in (n,w):words' (n+length w+length s) r'
1358           -- In a Haskell expression we want to parse 'a-b' as three words
1359           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1360           -- only be a single word.
1361           selectWord [] = (0,w)
1362           selectWord ((offset,x):xs)
1363               | offset+length x >= start = (start-offset,take (end-offset) x)
1364               | otherwise = selectWord xs
1365
1366
1367 completeCmd w = do
1368   cmds <- readIORef commands
1369   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1370
1371 completeMacro w = do
1372   cmds <- readIORef commands
1373   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1374   return (filter (w `isPrefixOf`) cmds')
1375
1376 completeIdentifier w = do
1377   s <- restoreSession
1378   rdrs <- GHC.getRdrNamesInScope s
1379   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1380
1381 completeModule w = do
1382   s <- restoreSession
1383   dflags <- GHC.getSessionDynFlags s
1384   let pkg_mods = allExposedModules dflags
1385   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1386
1387 completeHomeModule w = do
1388   s <- restoreSession
1389   g <- GHC.getModuleGraph s
1390   let home_mods = map GHC.ms_mod_name g
1391   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1392
1393 completeSetOptions w = do
1394   return (filter (w `isPrefixOf`) options)
1395     where options = "args":"prog":allFlags
1396
1397 completeFilename = Readline.filenameCompletionFunction
1398
1399 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1400
1401 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1402 unionComplete f1 f2 w = do
1403   s1 <- f1 w
1404   s2 <- f2 w
1405   return (s1 ++ s2)
1406
1407 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1408 wrapCompleter fun w =  do
1409   strs <- fun w
1410   case strs of
1411     []  -> return Nothing
1412     [x] -> return (Just (x,[]))
1413     xs  -> case getCommonPrefix xs of
1414                 ""   -> return (Just ("",xs))
1415                 pref -> return (Just (pref,xs))
1416
1417 getCommonPrefix :: [String] -> String
1418 getCommonPrefix [] = ""
1419 getCommonPrefix (s:ss) = foldl common s ss
1420   where common s "" = ""
1421         common "" s = ""
1422         common (c:cs) (d:ds)
1423            | c == d = c : common cs ds
1424            | otherwise = ""
1425
1426 allExposedModules :: DynFlags -> [ModuleName]
1427 allExposedModules dflags 
1428  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1429  where
1430   pkg_db = pkgIdMap (pkgState dflags)
1431 #else
1432 completeCmd        = completeNone
1433 completeMacro      = completeNone
1434 completeIdentifier = completeNone
1435 completeModule     = completeNone
1436 completeHomeModule = completeNone
1437 completeSetOptions = completeNone
1438 completeFilename   = completeNone
1439 completeHomeModuleOrFile=completeNone
1440 completeBkpt       = completeNone
1441 #endif
1442
1443 -- ---------------------------------------------------------------------------
1444 -- User code exception handling
1445
1446 -- This is the exception handler for exceptions generated by the
1447 -- user's code and exceptions coming from children sessions; 
1448 -- it normally just prints out the exception.  The
1449 -- handler must be recursive, in case showing the exception causes
1450 -- more exceptions to be raised.
1451 --
1452 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1453 -- raising another exception.  We therefore don't put the recursive
1454 -- handler arond the flushing operation, so if stderr is closed
1455 -- GHCi will just die gracefully rather than going into an infinite loop.
1456 handler :: Exception -> GHCi Bool
1457
1458 handler exception = do
1459   flushInterpBuffers
1460   io installSignalHandlers
1461   ghciHandle handler (showException exception >> return False)
1462
1463 showException (DynException dyn) =
1464   case fromDynamic dyn of
1465     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1466     Just Interrupted      -> io (putStrLn "Interrupted.")
1467     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1468     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1469     Just other_ghc_ex     -> io (print other_ghc_ex)
1470
1471 showException other_exception
1472   = io (putStrLn ("*** Exception: " ++ show other_exception))
1473
1474 -----------------------------------------------------------------------------
1475 -- recursive exception handlers
1476
1477 -- Don't forget to unblock async exceptions in the handler, or if we're
1478 -- in an exception loop (eg. let a = error a in a) the ^C exception
1479 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1480
1481 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1482 ghciHandle h (GHCi m) = GHCi $ \s -> 
1483    Exception.catch (m s) 
1484         (\e -> unGHCi (ghciUnblock (h e)) s)
1485
1486 ghciUnblock :: GHCi a -> GHCi a
1487 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1488
1489
1490 -- ----------------------------------------------------------------------------
1491 -- Utils
1492
1493 expandPath :: String -> GHCi String
1494 expandPath path = 
1495   case dropWhile isSpace path of
1496    ('~':d) -> do
1497         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1498         return (tilde ++ '/':d)
1499    other -> 
1500         return other
1501
1502 wantInterpretedModule :: String -> GHCi Module
1503 wantInterpretedModule str = do
1504    session <- getSession
1505    modl <- lookupModule str
1506    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1507    when (not is_interpreted) $
1508        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1509    return modl
1510
1511 wantNameFromInterpretedModule noCanDo str and_then = do
1512    session <- getSession
1513    names <- io $ GHC.parseName session str
1514    case names of
1515       []    -> return ()
1516       (n:_) -> do
1517             let modl = GHC.nameModule n
1518             if not (GHC.isExternalName n)
1519                then noCanDo n $ ppr n <>
1520                                 text " is not defined in an interpreted module"
1521                else do
1522             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1523             if not is_interpreted
1524                then noCanDo n $ text "module " <> ppr modl <>
1525                                 text " is not interpreted"
1526                else and_then n
1527
1528 -- ----------------------------------------------------------------------------
1529 -- Windows console setup
1530
1531 setUpConsole :: IO ()
1532 setUpConsole = do
1533 #ifdef mingw32_HOST_OS
1534         -- On Windows we need to set a known code page, otherwise the characters
1535         -- we read from the console will be be in some strange encoding, and
1536         -- similarly for characters we write to the console.
1537         --
1538         -- At the moment, GHCi pretends all input is Latin-1.  In the
1539         -- future we should support UTF-8, but for now we set the code pages
1540         -- to Latin-1.
1541         --
1542         -- It seems you have to set the font in the console window to
1543         -- a Unicode font in order for output to work properly,
1544         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1545         -- (see MSDN for SetConsoleOutputCP()).
1546         --
1547         setConsoleCP 28591       -- ISO Latin-1
1548         setConsoleOutputCP 28591 -- ISO Latin-1
1549 #endif
1550         return ()
1551
1552 -- -----------------------------------------------------------------------------
1553 -- commands for debugger
1554
1555 sprintCmd = pprintCommand False False
1556 printCmd  = pprintCommand True False
1557 forceCmd  = pprintCommand False True
1558
1559 pprintCommand bind force str = do
1560   session <- getSession
1561   io $ pprintClosureCommand session bind force str
1562
1563 stepCmd :: String -> GHCi ()
1564 stepCmd []         = doContinue (const True) GHC.SingleStep
1565 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1566
1567 stepLocalCmd :: String -> GHCi ()
1568 stepLocalCmd  [] = do 
1569   mb_span <- getCurrentBreakSpan
1570   case mb_span of
1571     Nothing  -> stepCmd []
1572     Just loc -> do
1573        Just mod <- getCurrentBreakModule
1574        current_toplevel_decl <- enclosingTickSpan mod loc
1575        doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1576
1577 stepLocalCmd expression = stepCmd expression
1578
1579 stepModuleCmd :: String -> GHCi ()
1580 stepModuleCmd  [] = do 
1581   mb_span <- getCurrentBreakSpan
1582   case mb_span of
1583     Nothing  -> stepCmd []
1584     Just loc -> do
1585        Just span <- getCurrentBreakSpan
1586        let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1587        doContinue f GHC.SingleStep
1588
1589 stepModuleCmd expression = stepCmd expression
1590
1591 -- | Returns the span of the largest tick containing the srcspan given
1592 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1593 enclosingTickSpan mod src = do
1594   ticks <- getTickArray mod
1595   let line = srcSpanStartLine src
1596   ASSERT (inRange (bounds ticks) line) do
1597   let enclosing_spans = [ span | (_,span) <- ticks ! line
1598                                , srcSpanEnd span >= srcSpanEnd src]
1599   return . head . sortBy leftmost_largest $ enclosing_spans
1600
1601 traceCmd :: String -> GHCi ()
1602 traceCmd []         = doContinue (const True) GHC.RunAndLogSteps
1603 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1604
1605 continueCmd :: String -> GHCi ()
1606 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1607
1608 -- doContinue :: SingleStep -> GHCi ()
1609 doContinue pred step = do 
1610   session <- getSession
1611   runResult <- io $ GHC.resume session step
1612   afterRunStmt pred runResult
1613   return ()
1614
1615 abandonCmd :: String -> GHCi ()
1616 abandonCmd = noArgs $ do
1617   s <- getSession
1618   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1619   when (not b) $ io $ putStrLn "There is no computation running."
1620   return ()
1621
1622 deleteCmd :: String -> GHCi ()
1623 deleteCmd argLine = do
1624    deleteSwitch $ words argLine
1625    where
1626    deleteSwitch :: [String] -> GHCi ()
1627    deleteSwitch [] = 
1628       io $ putStrLn "The delete command requires at least one argument."
1629    -- delete all break points
1630    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1631    deleteSwitch idents = do
1632       mapM_ deleteOneBreak idents 
1633       where
1634       deleteOneBreak :: String -> GHCi ()
1635       deleteOneBreak str
1636          | all isDigit str = deleteBreak (read str)
1637          | otherwise = return ()
1638
1639 historyCmd :: String -> GHCi ()
1640 historyCmd arg
1641   | null arg        = history 20
1642   | all isDigit arg = history (read arg)
1643   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1644   where
1645   history num = do
1646     s <- getSession
1647     resumes <- io $ GHC.getResumeContext s
1648     case resumes of
1649       [] -> io $ putStrLn "Not stopped at a breakpoint"
1650       (r:rs) -> do
1651         let hist = GHC.resumeHistory r
1652             (took,rest) = splitAt num hist
1653         spans <- mapM (io . GHC.getHistorySpan s) took
1654         let nums  = map (printf "-%-3d:") [(1::Int)..]
1655         let names = map GHC.historyEnclosingDecl took
1656         printForUser (vcat(zipWith3 
1657                              (\x y z -> x <+> y <+> z) 
1658                              (map text nums) 
1659                              (map (bold . ppr) names)
1660                              (map (parens . ppr) spans)))
1661         io $ putStrLn $ if null rest then "<end of history>" else "..."
1662
1663 bold c | do_bold   = text start_bold <> c <> text end_bold
1664        | otherwise = c
1665
1666 backCmd :: String -> GHCi ()
1667 backCmd = noArgs $ do
1668   s <- getSession
1669   (names, ix, span) <- io $ GHC.back s
1670   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1671   printTypeOfNames s names
1672    -- run the command set with ":set stop <cmd>"
1673   st <- getGHCiState
1674   enqueueCommands [stop st]
1675
1676 forwardCmd :: String -> GHCi ()
1677 forwardCmd = noArgs $ do
1678   s <- getSession
1679   (names, ix, span) <- io $ GHC.forward s
1680   printForUser $ (if (ix == 0)
1681                     then ptext SLIT("Stopped at")
1682                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1683   printTypeOfNames s names
1684    -- run the command set with ":set stop <cmd>"
1685   st <- getGHCiState
1686   enqueueCommands [stop st]
1687
1688 -- handle the "break" command
1689 breakCmd :: String -> GHCi ()
1690 breakCmd argLine = do
1691    session <- getSession
1692    breakSwitch session $ words argLine
1693
1694 breakSwitch :: Session -> [String] -> GHCi ()
1695 breakSwitch _session [] = do
1696    io $ putStrLn "The break command requires at least one argument."
1697 breakSwitch session args@(arg1:rest) 
1698    | looksLikeModuleName arg1 = do
1699         mod <- wantInterpretedModule arg1
1700         breakByModule session mod rest
1701    | all isDigit arg1 = do
1702         (toplevel, _) <- io $ GHC.getContext session 
1703         case toplevel of
1704            (mod : _) -> breakByModuleLine mod (read arg1) rest
1705            [] -> do 
1706               io $ putStrLn "Cannot find default module for breakpoint." 
1707               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1708    | otherwise = do -- try parsing it as an identifier
1709         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1710         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1711         if GHC.isGoodSrcLoc loc
1712                then findBreakAndSet (GHC.nameModule name) $ 
1713                          findBreakByCoord (Just (GHC.srcLocFile loc))
1714                                           (GHC.srcLocLine loc, 
1715                                            GHC.srcLocCol loc)
1716                else noCanDo name $ text "can't find its location: " <> ppr loc
1717        where
1718           noCanDo n why = printForUser $
1719                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1720
1721 breakByModule :: Session -> Module -> [String] -> GHCi () 
1722 breakByModule session mod args@(arg1:rest)
1723    | all isDigit arg1 = do  -- looks like a line number
1724         breakByModuleLine mod (read arg1) rest
1725 breakByModule session mod _
1726    = breakSyntax
1727
1728 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1729 breakByModuleLine mod line args
1730    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1731    | [col] <- args, all isDigit col =
1732         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1733    | otherwise = breakSyntax
1734
1735 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1736
1737 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1738 findBreakAndSet mod lookupTickTree = do 
1739    tickArray <- getTickArray mod
1740    (breakArray, _) <- getModBreak mod
1741    case lookupTickTree tickArray of 
1742       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1743       Just (tick, span) -> do
1744          success <- io $ setBreakFlag True breakArray tick 
1745          session <- getSession
1746          if success 
1747             then do
1748                (alreadySet, nm) <- 
1749                      recordBreak $ BreakLocation
1750                              { breakModule = mod
1751                              , breakLoc = span
1752                              , breakTick = tick
1753                              , onBreakCmd = ""
1754                              }
1755                printForUser $
1756                   text "Breakpoint " <> ppr nm <>
1757                   if alreadySet 
1758                      then text " was already set at " <> ppr span
1759                      else text " activated at " <> ppr span
1760             else do
1761             printForUser $ text "Breakpoint could not be activated at" 
1762                                  <+> ppr span
1763
1764 -- When a line number is specified, the current policy for choosing
1765 -- the best breakpoint is this:
1766 --    - the leftmost complete subexpression on the specified line, or
1767 --    - the leftmost subexpression starting on the specified line, or
1768 --    - the rightmost subexpression enclosing the specified line
1769 --
1770 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1771 findBreakByLine line arr
1772   | not (inRange (bounds arr) line) = Nothing
1773   | otherwise =
1774     listToMaybe (sortBy (leftmost_largest `on` snd)  complete)   `mplus`
1775     listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1776     listToMaybe (sortBy (rightmost `on` snd) ticks)
1777   where 
1778         ticks = arr ! line
1779
1780         starts_here = [ tick | tick@(nm,span) <- ticks,
1781                                GHC.srcSpanStartLine span == line ]
1782
1783         (complete,incomplete) = partition ends_here starts_here
1784             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1785
1786 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1787                  -> Maybe (BreakIndex,SrcSpan)
1788 findBreakByCoord mb_file (line, col) arr
1789   | not (inRange (bounds arr) line) = Nothing
1790   | otherwise =
1791     listToMaybe (sortBy (rightmost `on` snd) contains ++
1792                  sortBy (leftmost_smallest `on` snd) after_here)
1793   where 
1794         ticks = arr ! line
1795
1796         -- the ticks that span this coordinate
1797         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1798                             is_correct_file span ]
1799
1800         is_correct_file span
1801                  | Just f <- mb_file = GHC.srcSpanFile span == f
1802                  | otherwise         = True
1803
1804         after_here = [ tick | tick@(nm,span) <- ticks,
1805                               GHC.srcSpanStartLine span == line,
1806                               GHC.srcSpanStartCol span >= col ]
1807
1808 -- For now, use ANSI bold on terminals that we know support it.
1809 -- Otherwise, we add a line of carets under the active expression instead.
1810 -- In particular, on Windows and when running the testsuite (which sets
1811 -- TERM to vt100 for other reasons) we get carets.
1812 -- We really ought to use a proper termcap/terminfo library.
1813 do_bold :: Bool
1814 do_bold = unsafePerformIO (System.Environment.getEnv "TERM") `elem`
1815           ["xterm", "linux"]
1816
1817 start_bold :: String
1818 start_bold = "\ESC[1m"
1819 end_bold :: String
1820 end_bold   = "\ESC[0m"
1821
1822 listCmd :: String -> GHCi ()
1823 listCmd "" = do
1824    mb_span <- getCurrentBreakSpan
1825    case mb_span of
1826       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1827       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1828                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
1829 listCmd str = list2 (words str)
1830
1831 list2 [arg] | all isDigit arg = do
1832     session <- getSession
1833     (toplevel, _) <- io $ GHC.getContext session 
1834     case toplevel of
1835         [] -> io $ putStrLn "No module to list"
1836         (mod : _) -> listModuleLine mod (read arg)
1837 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1838         mod <- wantInterpretedModule arg1
1839         listModuleLine mod (read arg2)
1840 list2 [arg] = do
1841         wantNameFromInterpretedModule noCanDo arg $ \name -> do
1842         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1843         if GHC.isGoodSrcLoc loc
1844                then do
1845                   tickArray <- getTickArray (GHC.nameModule name)
1846                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1847                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
1848                                         tickArray
1849                   case mb_span of
1850                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
1851                     Just (_,span) -> io $ listAround span False
1852                else
1853                   noCanDo name $ text "can't find its location: " <>
1854                                  ppr loc
1855     where
1856         noCanDo n why = printForUser $
1857             text "cannot list source code for " <> ppr n <> text ": " <> why
1858 list2  _other = 
1859         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
1860
1861 listModuleLine :: Module -> Int -> GHCi ()
1862 listModuleLine modl line = do
1863    session <- getSession
1864    graph <- io (GHC.getModuleGraph session)
1865    let this = filter ((== modl) . GHC.ms_mod) graph
1866    case this of
1867      [] -> panic "listModuleLine"
1868      summ:_ -> do
1869            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1870                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1871            io $ listAround (GHC.srcLocSpan loc) False
1872
1873 -- | list a section of a source file around a particular SrcSpan.
1874 -- If the highlight flag is True, also highlight the span using
1875 -- start_bold/end_bold.
1876 listAround span do_highlight = do
1877       contents <- BS.readFile (unpackFS file)
1878       let 
1879           lines = BS.split '\n' contents
1880           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ 
1881                         drop (line1 - 1 - pad_before) $ lines
1882           fst_line = max 1 (line1 - pad_before)
1883           line_nos = [ fst_line .. ]
1884
1885           highlighted | do_highlight = zipWith highlight line_nos these_lines
1886                       | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]
1887
1888           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1889           prefixed = zipWith ($) highlighted bs_line_nos
1890       --
1891       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1892   where
1893         file  = GHC.srcSpanFile span
1894         line1 = GHC.srcSpanStartLine span
1895         col1  = GHC.srcSpanStartCol span
1896         line2 = GHC.srcSpanEndLine span
1897         col2  = GHC.srcSpanEndCol span
1898
1899         pad_before | line1 == 1 = 0
1900                    | otherwise  = 1
1901         pad_after = 1
1902
1903         highlight | do_bold   = highlight_bold
1904                   | otherwise = highlight_carets
1905
1906         highlight_bold no line prefix
1907           | no == line1 && no == line2
1908           = let (a,r) = BS.splitAt col1 line
1909                 (b,c) = BS.splitAt (col2-col1) r
1910             in
1911             BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
1912           | no == line1
1913           = let (a,b) = BS.splitAt col1 line in
1914             BS.concat [prefix, a, BS.pack start_bold, b]
1915           | no == line2
1916           = let (a,b) = BS.splitAt col2 line in
1917             BS.concat [prefix, a, BS.pack end_bold, b]
1918           | otherwise   = BS.concat [prefix, line]
1919
1920         highlight_carets no line prefix
1921           | no == line1 && no == line2
1922           = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
1923                                          BS.replicate (col2-col1) '^']
1924           | no == line1
1925           = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, 
1926                                          prefix, line]
1927           | no == line2
1928           = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
1929                                          BS.pack "^^"]
1930           | otherwise   = BS.concat [prefix, line]
1931          where
1932            indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
1933            nl = BS.singleton '\n'
1934
1935 -- --------------------------------------------------------------------------
1936 -- Tick arrays
1937
1938 getTickArray :: Module -> GHCi TickArray
1939 getTickArray modl = do
1940    st <- getGHCiState
1941    let arrmap = tickarrays st
1942    case lookupModuleEnv arrmap modl of
1943       Just arr -> return arr
1944       Nothing  -> do
1945         (breakArray, ticks) <- getModBreak modl 
1946         let arr = mkTickArray (assocs ticks)
1947         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1948         return arr
1949
1950 discardTickArrays :: GHCi ()
1951 discardTickArrays = do
1952    st <- getGHCiState
1953    setGHCiState st{tickarrays = emptyModuleEnv}
1954
1955 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1956 mkTickArray ticks
1957   = accumArray (flip (:)) [] (1, max_line) 
1958         [ (line, (nm,span)) | (nm,span) <- ticks,
1959                               line <- srcSpanLines span ]
1960     where
1961         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1962         srcSpanLines span = [ GHC.srcSpanStartLine span .. 
1963                               GHC.srcSpanEndLine span ]
1964
1965 lookupModule :: String -> GHCi Module
1966 lookupModule modName
1967    = do session <- getSession 
1968         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1969
1970 -- don't reset the counter back to zero?
1971 discardActiveBreakPoints :: GHCi ()
1972 discardActiveBreakPoints = do
1973    st <- getGHCiState
1974    mapM (turnOffBreak.snd) (breaks st)
1975    setGHCiState $ st { breaks = [] }
1976
1977 deleteBreak :: Int -> GHCi ()
1978 deleteBreak identity = do
1979    st <- getGHCiState
1980    let oldLocations    = breaks st
1981        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
1982    if null this 
1983       then printForUser (text "Breakpoint" <+> ppr identity <+>
1984                          text "does not exist")
1985       else do
1986            mapM (turnOffBreak.snd) this
1987            setGHCiState $ st { breaks = rest }
1988
1989 turnOffBreak loc = do
1990   (arr, _) <- getModBreak (breakModule loc)
1991   io $ setBreakFlag False arr (breakTick loc)
1992
1993 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1994 getModBreak mod = do
1995    session <- getSession
1996    Just mod_info <- io $ GHC.getModuleInfo session mod
1997    let modBreaks  = GHC.modInfoModBreaks mod_info
1998    let array      = GHC.modBreaks_flags modBreaks
1999    let ticks      = GHC.modBreaks_locs  modBreaks
2000    return (array, ticks)
2001
2002 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool 
2003 setBreakFlag toggle array index
2004    | toggle    = GHC.setBreakOn array index 
2005    | otherwise = GHC.setBreakOff array index
2006