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 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_ showTyThing bindings
1252   return ()
1253
1254 showTyThing (AnId id) = do
1255   ty' <- cleanType (GHC.idType id)
1256   printForUser $ ppr id <> text " :: " <> ppr ty'
1257 showTyThing _  = return ()
1258
1259 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1260 cleanType :: Type -> GHCi Type
1261 cleanType ty = do
1262   dflags <- getDynFlags
1263   if dopt Opt_GlasgowExts dflags
1264         then return ty
1265         else return $! GHC.dropForAlls ty
1266
1267 showBkptTable :: GHCi ()
1268 showBkptTable = do
1269   st <- getGHCiState
1270   printForUser $ prettyLocations (breaks st)
1271
1272 showContext :: GHCi ()
1273 showContext = do
1274    session <- getSession
1275    resumes <- io $ GHC.getResumeContext session
1276    printForUser $ vcat (map pp_resume (reverse resumes))
1277   where
1278    pp_resume resume =
1279         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1280         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1281
1282
1283 -- -----------------------------------------------------------------------------
1284 -- Completion
1285
1286 completeNone :: String -> IO [String]
1287 completeNone w = return []
1288
1289 #ifdef USE_READLINE
1290 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1291 completeWord w start end = do
1292   line <- Readline.getLineBuffer
1293   case w of
1294      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1295      _other
1296         | Just c <- is_cmd line -> do
1297            maybe_cmd <- lookupCommand c
1298            let (n,w') = selectWord (words' 0 line)
1299            case maybe_cmd of
1300              Nothing -> return Nothing
1301              Just (_,_,False,complete) -> wrapCompleter complete w
1302              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1303                                                               return (map (drop n) rets)
1304                                          in wrapCompleter complete' w'
1305         | otherwise     -> do
1306                 --printf "complete %s, start = %d, end = %d\n" w start end
1307                 wrapCompleter completeIdentifier w
1308     where words' _ [] = []
1309           words' n str = let (w,r) = break isSpace str
1310                              (s,r') = span isSpace r
1311                          in (n,w):words' (n+length w+length s) r'
1312           -- In a Haskell expression we want to parse 'a-b' as three words
1313           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1314           -- only be a single word.
1315           selectWord [] = (0,w)
1316           selectWord ((offset,x):xs)
1317               | offset+length x >= start = (start-offset,take (end-offset) x)
1318               | otherwise = selectWord xs
1319
1320 is_cmd line
1321  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1322  | otherwise = Nothing
1323
1324 completeCmd w = do
1325   cmds <- readIORef commands
1326   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1327
1328 completeMacro w = do
1329   cmds <- readIORef commands
1330   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1331   return (filter (w `isPrefixOf`) cmds')
1332
1333 completeIdentifier w = do
1334   s <- restoreSession
1335   rdrs <- GHC.getRdrNamesInScope s
1336   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1337
1338 completeModule w = do
1339   s <- restoreSession
1340   dflags <- GHC.getSessionDynFlags s
1341   let pkg_mods = allExposedModules dflags
1342   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1343
1344 completeHomeModule w = do
1345   s <- restoreSession
1346   g <- GHC.getModuleGraph s
1347   let home_mods = map GHC.ms_mod_name g
1348   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1349
1350 completeSetOptions w = do
1351   return (filter (w `isPrefixOf`) options)
1352     where options = "args":"prog":allFlags
1353
1354 completeFilename = Readline.filenameCompletionFunction
1355
1356 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1357
1358 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1359 unionComplete f1 f2 w = do
1360   s1 <- f1 w
1361   s2 <- f2 w
1362   return (s1 ++ s2)
1363
1364 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1365 wrapCompleter fun w =  do
1366   strs <- fun w
1367   case strs of
1368     []  -> return Nothing
1369     [x] -> return (Just (x,[]))
1370     xs  -> case getCommonPrefix xs of
1371                 ""   -> return (Just ("",xs))
1372                 pref -> return (Just (pref,xs))
1373
1374 getCommonPrefix :: [String] -> String
1375 getCommonPrefix [] = ""
1376 getCommonPrefix (s:ss) = foldl common s ss
1377   where common s "" = ""
1378         common "" s = ""
1379         common (c:cs) (d:ds)
1380            | c == d = c : common cs ds
1381            | otherwise = ""
1382
1383 allExposedModules :: DynFlags -> [ModuleName]
1384 allExposedModules dflags
1385  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1386  where
1387   pkg_db = pkgIdMap (pkgState dflags)
1388 #else
1389 completeCmd        = completeNone
1390 completeMacro      = completeNone
1391 completeIdentifier = completeNone
1392 completeModule     = completeNone
1393 completeHomeModule = completeNone
1394 completeSetOptions = completeNone
1395 completeFilename   = completeNone
1396 completeHomeModuleOrFile=completeNone
1397 completeBkpt       = completeNone
1398 #endif
1399
1400 -- ---------------------------------------------------------------------------
1401 -- User code exception handling
1402
1403 -- This is the exception handler for exceptions generated by the
1404 -- user's code and exceptions coming from children sessions;
1405 -- it normally just prints out the exception.  The
1406 -- handler must be recursive, in case showing the exception causes
1407 -- more exceptions to be raised.
1408 --
1409 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1410 -- raising another exception.  We therefore don't put the recursive
1411 -- handler arond the flushing operation, so if stderr is closed
1412 -- GHCi will just die gracefully rather than going into an infinite loop.
1413 handler :: Exception -> GHCi Bool
1414
1415 handler exception = do
1416   flushInterpBuffers
1417   io installSignalHandlers
1418   ghciHandle handler (showException exception >> return False)
1419
1420 showException (DynException dyn) =
1421   case fromDynamic dyn of
1422     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1423     Just Interrupted      -> io (putStrLn "Interrupted.")
1424     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1425     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1426     Just other_ghc_ex     -> io (print other_ghc_ex)
1427
1428 showException other_exception
1429   = io (putStrLn ("*** Exception: " ++ show other_exception))
1430
1431 -----------------------------------------------------------------------------
1432 -- recursive exception handlers
1433
1434 -- Don't forget to unblock async exceptions in the handler, or if we're
1435 -- in an exception loop (eg. let a = error a in a) the ^C exception
1436 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1437
1438 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1439 ghciHandle h (GHCi m) = GHCi $ \s ->
1440    Exception.catch (m s)
1441         (\e -> unGHCi (ghciUnblock (h e)) s)
1442
1443 ghciUnblock :: GHCi a -> GHCi a
1444 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1445
1446
1447 -- ----------------------------------------------------------------------------
1448 -- Utils
1449
1450 expandPath :: String -> GHCi String
1451 expandPath path =
1452   case dropWhile isSpace path of
1453    ('~':d) -> do
1454         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1455         return (tilde ++ '/':d)
1456    other ->
1457         return other
1458
1459 wantInterpretedModule :: String -> GHCi Module
1460 wantInterpretedModule str = do
1461    session <- getSession
1462    modl <- lookupModule str
1463    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1464    when (not is_interpreted) $
1465        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1466    return modl
1467
1468 wantNameFromInterpretedModule noCanDo str and_then = do
1469    session <- getSession
1470    names <- io $ GHC.parseName session str
1471    case names of
1472       []    -> return ()
1473       (n:_) -> do
1474             let modl = GHC.nameModule n
1475             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1476             if not is_interpreted
1477                then noCanDo n $ text "module " <> ppr modl <>
1478                                 text " is not interpreted"
1479                else and_then n
1480
1481 -- ----------------------------------------------------------------------------
1482 -- Windows console setup
1483
1484 setUpConsole :: IO ()
1485 setUpConsole = do
1486 #ifdef mingw32_HOST_OS
1487         -- On Windows we need to set a known code page, otherwise the characters
1488         -- we read from the console will be be in some strange encoding, and
1489         -- similarly for characters we write to the console.
1490         --
1491         -- At the moment, GHCi pretends all input is Latin-1.  In the
1492         -- future we should support UTF-8, but for now we set the code pages
1493         -- to Latin-1.
1494         --
1495         -- It seems you have to set the font in the console window to
1496         -- a Unicode font in order for output to work properly,
1497         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1498         -- (see MSDN for SetConsoleOutputCP()).
1499         --
1500         setConsoleCP 28591       -- ISO Latin-1
1501         setConsoleOutputCP 28591 -- ISO Latin-1
1502 #endif
1503         return ()
1504
1505 -- -----------------------------------------------------------------------------
1506 -- commands for debugger
1507
1508 sprintCmd = pprintCommand False False
1509 printCmd  = pprintCommand True False
1510 forceCmd  = pprintCommand False True
1511
1512 pprintCommand bind force str = do
1513   session <- getSession
1514   io $ pprintClosureCommand session bind force str
1515
1516 stepCmd :: String -> GHCi ()
1517 stepCmd []         = doContinue GHC.SingleStep
1518 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1519
1520 traceCmd :: String -> GHCi ()
1521 traceCmd []         = doContinue GHC.RunAndLogSteps
1522 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1523
1524 continueCmd :: String -> GHCi ()
1525 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1526
1527 doContinue :: SingleStep -> GHCi ()
1528 doContinue step = do
1529   session <- getSession
1530   runResult <- io $ GHC.resume session step
1531   afterRunStmt runResult
1532   return ()
1533
1534 abandonCmd :: String -> GHCi ()
1535 abandonCmd = noArgs $ do
1536   s <- getSession
1537   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1538   when (not b) $ io $ putStrLn "There is no computation running."
1539   return ()
1540
1541 deleteCmd :: String -> GHCi ()
1542 deleteCmd argLine = do
1543    deleteSwitch $ words argLine
1544    where
1545    deleteSwitch :: [String] -> GHCi ()
1546    deleteSwitch [] =
1547       io $ putStrLn "The delete command requires at least one argument."
1548    -- delete all break points
1549    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1550    deleteSwitch idents = do
1551       mapM_ deleteOneBreak idents
1552       where
1553       deleteOneBreak :: String -> GHCi ()
1554       deleteOneBreak str
1555          | all isDigit str = deleteBreak (read str)
1556          | otherwise = return ()
1557
1558 historyCmd :: String -> GHCi ()
1559 historyCmd arg
1560   | null arg        = history 20
1561   | all isDigit arg = history (read arg)
1562   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1563   where
1564   history num = do
1565     s <- getSession
1566     resumes <- io $ GHC.getResumeContext s
1567     case resumes of
1568       [] -> io $ putStrLn "Not stopped at a breakpoint"
1569       (r:rs) -> do
1570         let hist = GHC.resumeHistory r
1571             (took,rest) = splitAt num hist
1572         spans <- mapM (io . GHC.getHistorySpan s) took
1573         let nums = map (printf "-%-3d:") [(1::Int)..]
1574         printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1575         io $ putStrLn $ if null rest then "<end of history>" else "..."
1576
1577 backCmd :: String -> GHCi ()
1578 backCmd = noArgs $ do
1579   s <- getSession
1580   (names, ix, span) <- io $ GHC.back s
1581   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1582   mapM_ (showTypeOfName s) names
1583    -- run the command set with ":set stop <cmd>"
1584   st <- getGHCiState
1585   enqueueCommands [stop st]
1586
1587 forwardCmd :: String -> GHCi ()
1588 forwardCmd = noArgs $ do
1589   s <- getSession
1590   (names, ix, span) <- io $ GHC.forward s
1591   printForUser $ (if (ix == 0)
1592                     then ptext SLIT("Stopped at")
1593                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1594   mapM_ (showTypeOfName s) names
1595    -- run the command set with ":set stop <cmd>"
1596   st <- getGHCiState
1597   enqueueCommands [stop st]
1598
1599 -- handle the "break" command
1600 breakCmd :: String -> GHCi ()
1601 breakCmd argLine = do
1602    session <- getSession
1603    breakSwitch session $ words argLine
1604
1605 breakSwitch :: Session -> [String] -> GHCi ()
1606 breakSwitch _session [] = do
1607    io $ putStrLn "The break command requires at least one argument."
1608 breakSwitch session args@(arg1:rest)
1609    | looksLikeModuleName arg1 = do
1610         mod <- wantInterpretedModule arg1
1611         breakByModule session mod rest
1612    | all isDigit arg1 = do
1613         (toplevel, _) <- io $ GHC.getContext session
1614         case toplevel of
1615            (mod : _) -> breakByModuleLine mod (read arg1) rest
1616            [] -> do
1617               io $ putStrLn "Cannot find default module for breakpoint."
1618               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1619    | otherwise = do -- try parsing it as an identifier
1620         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1621         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1622         if GHC.isGoodSrcLoc loc
1623                then findBreakAndSet (GHC.nameModule name) $
1624                          findBreakByCoord (Just (GHC.srcLocFile loc))
1625                                           (GHC.srcLocLine loc,
1626                                            GHC.srcLocCol loc)
1627                else noCanDo name $ text "can't find its location: " <> ppr loc
1628        where
1629           noCanDo n why = printForUser $
1630                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1631
1632 breakByModule :: Session -> Module -> [String] -> GHCi ()
1633 breakByModule session mod args@(arg1:rest)
1634    | all isDigit arg1 = do  -- looks like a line number
1635         breakByModuleLine mod (read arg1) rest
1636    | otherwise = io $ putStrLn "Invalid arguments to :break"
1637
1638 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1639 breakByModuleLine mod line args
1640    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1641    | [col] <- args, all isDigit col =
1642         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1643    | otherwise = io $ putStrLn "Invalid arguments to :break"
1644
1645 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1646 findBreakAndSet mod lookupTickTree = do
1647    tickArray <- getTickArray mod
1648    (breakArray, _) <- getModBreak mod
1649    case lookupTickTree tickArray of
1650       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1651       Just (tick, span) -> do
1652          success <- io $ setBreakFlag True breakArray tick
1653          session <- getSession
1654          if success
1655             then do
1656                (alreadySet, nm) <-
1657                      recordBreak $ BreakLocation
1658                              { breakModule = mod
1659                              , breakLoc = span
1660                              , breakTick = tick
1661                              , onBreakCmd = ""
1662                              }
1663                printForUser $
1664                   text "Breakpoint " <> ppr nm <>
1665                   if alreadySet
1666                      then text " was already set at " <> ppr span
1667                      else text " activated at " <> ppr span
1668             else do
1669             printForUser $ text "Breakpoint could not be activated at"
1670                                  <+> ppr span
1671
1672 -- When a line number is specified, the current policy for choosing
1673 -- the best breakpoint is this:
1674 --    - the leftmost complete subexpression on the specified line, or
1675 --    - the leftmost subexpression starting on the specified line, or
1676 --    - the rightmost subexpression enclosing the specified line
1677 --
1678 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1679 findBreakByLine line arr
1680   | not (inRange (bounds arr) line) = Nothing
1681   | otherwise =
1682     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1683     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1684     listToMaybe (sortBy rightmost ticks)
1685   where
1686         ticks = arr ! line
1687
1688         starts_here = [ tick | tick@(nm,span) <- ticks,
1689                                GHC.srcSpanStartLine span == line ]
1690
1691         (complete,incomplete) = partition ends_here starts_here
1692             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1693
1694 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1695                  -> Maybe (BreakIndex,SrcSpan)
1696 findBreakByCoord mb_file (line, col) arr
1697   | not (inRange (bounds arr) line) = Nothing
1698   | otherwise =
1699     listToMaybe (sortBy rightmost contains) `mplus`
1700     listToMaybe (sortBy leftmost_smallest after_here)
1701   where
1702         ticks = arr ! line
1703
1704         -- the ticks that span this coordinate
1705         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1706                             is_correct_file span ]
1707
1708         is_correct_file span
1709                  | Just f <- mb_file = GHC.srcSpanFile span == f
1710                  | otherwise         = True
1711
1712         after_here = [ tick | tick@(nm,span) <- ticks,
1713                               GHC.srcSpanStartLine span == line,
1714                               GHC.srcSpanStartCol span >= col ]
1715
1716
1717 leftmost_smallest  (_,a) (_,b) = a `compare` b
1718 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1719                                 `thenCmp`
1720                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1721 rightmost (_,a) (_,b) = b `compare` a
1722
1723 spans :: SrcSpan -> (Int,Int) -> Bool
1724 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1725    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1726
1727 -- for now, use ANSI bold on Unixy systems.  On Windows, we add a line
1728 -- of carets under the active expression instead.  The Windows console
1729 -- doesn't support ANSI escape sequences, and most Unix terminals
1730 -- (including xterm) do, so this is a reasonable guess until we have a
1731 -- proper termcap/terminfo library.
1732 #if !defined(mingw32_TARGET_OS)
1733 do_bold = True
1734 #else
1735 do_bold = False
1736 #endif
1737
1738 start_bold = BS.pack "\ESC[1m"
1739 end_bold   = BS.pack "\ESC[0m"
1740
1741 listCmd :: String -> GHCi ()
1742 listCmd "" = do
1743    mb_span <- getCurrentBreakSpan
1744    case mb_span of
1745       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1746       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1747                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
1748 listCmd str = list2 (words str)
1749
1750 list2 [arg] | all isDigit arg = do
1751     session <- getSession
1752     (toplevel, _) <- io $ GHC.getContext session
1753     case toplevel of
1754         [] -> io $ putStrLn "No module to list"
1755         (mod : _) -> listModuleLine mod (read arg)
1756 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1757         mod <- wantInterpretedModule arg1
1758         listModuleLine mod (read arg2)
1759 list2 [arg] = do
1760         wantNameFromInterpretedModule noCanDo arg $ \name -> do
1761         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1762         if GHC.isGoodSrcLoc loc
1763                then do
1764                   tickArray <- getTickArray (GHC.nameModule name)
1765                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1766                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
1767                                         tickArray
1768                   case mb_span of
1769                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
1770                     Just (_,span) -> io $ listAround span False
1771                else
1772                   noCanDo name $ text "can't find its location: " <>
1773                                  ppr loc
1774     where
1775         noCanDo n why = printForUser $
1776             text "cannot list source code for " <> ppr n <> text ": " <> why
1777 list2  _other =
1778         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
1779
1780 listModuleLine :: Module -> Int -> GHCi ()
1781 listModuleLine modl line = do
1782    session <- getSession
1783    graph <- io (GHC.getModuleGraph session)
1784    let this = filter ((== modl) . GHC.ms_mod) graph
1785    case this of
1786      [] -> panic "listModuleLine"
1787      summ:_ -> do
1788            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1789                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1790            io $ listAround (GHC.srcLocSpan loc) False
1791
1792 -- | list a section of a source file around a particular SrcSpan.
1793 -- If the highlight flag is True, also highlight the span using
1794 -- start_bold/end_bold.
1795 listAround span do_highlight = do
1796       pwd      <- getEnv "PWD"
1797       contents <- BS.readFile (pwd </> unpackFS file)
1798       let
1799           lines = BS.split '\n' contents
1800           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1801                         drop (line1 - 1 - pad_before) $ lines
1802           fst_line = max 1 (line1 - pad_before)
1803           line_nos = [ fst_line .. ]
1804
1805           highlighted | do_highlight = zipWith highlight line_nos these_lines
1806                       | otherwise   = these_lines
1807
1808           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1809           prefixed = zipWith BS.append bs_line_nos highlighted
1810       --
1811       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1812   where
1813         file  = GHC.srcSpanFile span
1814         line1 = GHC.srcSpanStartLine span
1815         col1  = GHC.srcSpanStartCol span
1816         line2 = GHC.srcSpanEndLine span
1817         col2  = GHC.srcSpanEndCol span
1818
1819         pad_before | line1 == 1 = 0
1820                    | otherwise  = 1
1821         pad_after = 1
1822
1823         highlight | do_bold   = highlight_bold
1824                   | otherwise = highlight_carets
1825
1826         highlight_bold no line
1827           | no == line1 && no == line2
1828           = let (a,r) = BS.splitAt col1 line
1829                 (b,c) = BS.splitAt (col2-col1) r
1830             in
1831             BS.concat [a,start_bold,b,end_bold,c]
1832           | no == line1
1833           = let (a,b) = BS.splitAt col1 line in
1834             BS.concat [a, start_bold, b]
1835           | no == line2
1836           = let (a,b) = BS.splitAt col2 line in
1837             BS.concat [a, end_bold, b]
1838           | otherwise   = line
1839
1840         highlight_carets no line
1841           | no == line1 && no == line2
1842           = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1843                                          BS.replicate (col2-col1) '^']
1844           | no == line1
1845           = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1846                                          BS.replicate (BS.length line-col1) '^']
1847           | no == line2
1848           = BS.concat [line, nl, indent, BS.replicate col2 '^']
1849           | otherwise   = line
1850          where
1851            indent = BS.pack "   "
1852            nl = BS.singleton '\n'
1853
1854 -- --------------------------------------------------------------------------
1855 -- Tick arrays
1856
1857 getTickArray :: Module -> GHCi TickArray
1858 getTickArray modl = do
1859    st <- getGHCiState
1860    let arrmap = tickarrays st
1861    case lookupModuleEnv arrmap modl of
1862       Just arr -> return arr
1863       Nothing  -> do
1864         (breakArray, ticks) <- getModBreak modl
1865         let arr = mkTickArray (assocs ticks)
1866         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1867         return arr
1868
1869 discardTickArrays :: GHCi ()
1870 discardTickArrays = do
1871    st <- getGHCiState
1872    setGHCiState st{tickarrays = emptyModuleEnv}
1873
1874 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1875 mkTickArray ticks
1876   = accumArray (flip (:)) [] (1, max_line)
1877         [ (line, (nm,span)) | (nm,span) <- ticks,
1878                               line <- srcSpanLines span ]
1879     where
1880         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1881         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1882                               GHC.srcSpanEndLine span ]
1883
1884 lookupModule :: String -> GHCi Module
1885 lookupModule modName
1886    = do session <- getSession
1887         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1888
1889 -- don't reset the counter back to zero?
1890 discardActiveBreakPoints :: GHCi ()
1891 discardActiveBreakPoints = do
1892    st <- getGHCiState
1893    mapM (turnOffBreak.snd) (breaks st)
1894    setGHCiState $ st { breaks = [] }
1895
1896 deleteBreak :: Int -> GHCi ()
1897 deleteBreak identity = do
1898    st <- getGHCiState
1899    let oldLocations    = breaks st
1900        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
1901    if null this
1902       then printForUser (text "Breakpoint" <+> ppr identity <+>
1903                          text "does not exist")
1904       else do
1905            mapM (turnOffBreak.snd) this
1906            setGHCiState $ st { breaks = rest }
1907
1908 turnOffBreak loc = do
1909   (arr, _) <- getModBreak (breakModule loc)
1910   io $ setBreakFlag False arr (breakTick loc)
1911
1912 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1913 getModBreak mod = do
1914    session <- getSession
1915    Just mod_info <- io $ GHC.getModuleInfo session mod
1916    let modBreaks  = GHC.modInfoModBreaks mod_info
1917    let array      = GHC.modBreaks_flags modBreaks
1918    let ticks      = GHC.modBreaks_locs  modBreaks
1919    return (array, ticks)
1920
1921 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1922 setBreakFlag toggle array index
1923    | toggle    = GHC.setBreakOn array index
1924    | otherwise = GHC.setBreakOff array index
1925