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