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