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