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   | null str  = do
 728         -- find the name of the "topmost" file loaded
 729      session <- getSession
 730      graph0 <- io (GHC.getModuleGraph session)
 731      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 732      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 733      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 734         Just file -> do_edit file
 735         Nothing   -> throwDyn (CmdLineError "unknown file name")
 736   | otherwise = do_edit str
 737   where
 738         do_edit file = do
 739            st <- getGHCiState
 740            let cmd = editor st
 741            when (null cmd) $
 742                 throwDyn (CmdLineError "editor not set, use :set editor")
 743            io $ system (cmd ++ ' ':file)
 744            return ()
 745
 746 defineMacro :: String -> GHCi ()
 747 defineMacro s = do
 748   let (macro_name, definition) = break isSpace s
 749   cmds <- io (readIORef commands)
 750   if (null macro_name)
 751         then throwDyn (CmdLineError "invalid macro name")
 752         else do
 753   if (macro_name `elem` map cmdName cmds)
 754         then throwDyn (CmdLineError
 755                 ("command '" ++ macro_name ++ "' is already defined"))
 756         else do
 757
 758   -- give the expression a type signature, so we can be sure we're getting
 759   -- something of the right type.
 760   let new_expr = '(' : definition ++ ") :: String -> IO String"
 761
 762   -- compile the expression
 763   cms <- getSession
 764   maybe_hv <- io (GHC.compileExpr cms new_expr)
 765   case maybe_hv of
 766      Nothing -> return ()
 767      Just hv -> io (writeIORef commands --
 768                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 769
 770 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 771 runMacro fun s = do
 772   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 773   enqueueCommands (lines str)
 774   return False
 775
 776 undefineMacro :: String -> GHCi ()
 777 undefineMacro macro_name = do
 778   cmds <- io (readIORef commands)
 779   if (macro_name `elem` map cmdName builtin_commands)
 780         then throwDyn (CmdLineError
 781                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 782         else do
 783   if (macro_name `notElem` map cmdName cmds)
 784         then throwDyn (CmdLineError
 785                 ("command '" ++ macro_name ++ "' not defined"))
 786         else do
 787   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 788
 789 cmdCmd :: String -> GHCi ()
 790 cmdCmd str = do
 791   let expr = '(' : str ++ ") :: IO String"
 792   session <- getSession
 793   maybe_hv <- io (GHC.compileExpr session expr)
 794   case maybe_hv of
 795     Nothing -> return ()
 796     Just hv -> do
 797         cmds <- io $ (unsafeCoerce# hv :: IO String)
 798         enqueueCommands (lines cmds)
 799         return ()
 800
 801 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 802 loadModule fs = timeIt (loadModule' fs)
 803
 804 loadModule_ :: [FilePath] -> GHCi ()
 805 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 806
 807 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 808 loadModule' files = do
 809   session <- getSession
 810
 811   -- unload first
 812   discardActiveBreakPoints
 813   io (GHC.setTargets session [])
 814   io (GHC.load session LoadAllTargets)
 815
 816   -- expand tildes
 817   let (filenames, phases) = unzip files
 818   exp_filenames <- mapM expandPath filenames
 819   let files' = zip exp_filenames phases
 820   targets <- io (mapM (uncurry GHC.guessTarget) files')
 821
 822   -- NOTE: we used to do the dependency anal first, so that if it
 823   -- fails we didn't throw away the current set of modules.  This would
 824   -- require some re-working of the GHC interface, so we'll leave it
 825   -- as a ToDo for now.
 826
 827   io (GHC.setTargets session targets)
 828   doLoad session LoadAllTargets
 829
 830 checkModule :: String -> GHCi ()
 831 checkModule m = do
 832   let modl = GHC.mkModuleName m
 833   session <- getSession
 834   result <- io (GHC.checkModule session modl)
 835   case result of
 836     Nothing -> io $ putStrLn "Nothing"
 837     Just r  -> io $ putStrLn (showSDoc (
 838         case GHC.checkedModuleInfo r of
 839            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 840                 let
 841                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 842                 in
 843                         (text "global names: " <+> ppr global) $$
 844                         (text "local  names: " <+> ppr local)
 845            _ -> empty))
 846   afterLoad (successIf (isJust result)) session
 847
 848 reloadModule :: String -> GHCi ()
 849 reloadModule "" = do
 850   io (revertCAFs)               -- always revert CAFs on reload.
 851   discardActiveBreakPoints
 852   session <- getSession
 853   doLoad session LoadAllTargets
 854   return ()
 855 reloadModule m = do
 856   io (revertCAFs)               -- always revert CAFs on reload.
 857   discardActiveBreakPoints
 858   session <- getSession
 859   doLoad session (LoadUpTo (GHC.mkModuleName m))
 860   return ()
 861
 862 doLoad session howmuch = do
 863   -- turn off breakpoints before we load: we can't turn them off later, because
 864   -- the ModBreaks will have gone away.
 865   discardActiveBreakPoints
 866   ok <- io (GHC.load session howmuch)
 867   afterLoad ok session
 868   return ok
 869
 870 afterLoad ok session = do
 871   io (revertCAFs)  -- always revert CAFs on load.
 872   discardTickArrays
 873   graph <- io (GHC.getModuleGraph session)
 874   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 875   setContextAfterLoad session graph'
 876   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 877
 878 setContextAfterLoad session [] = do
 879   prel_mod <- getPrelude
 880   io (GHC.setContext session [] [prel_mod])
 881 setContextAfterLoad session ms = do
 882   -- load a target if one is available, otherwise load the topmost module.
 883   targets <- io (GHC.getTargets session)
 884   case [ m | Just m <- map (findTarget ms) targets ] of
 885         []    ->
 886           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 887           load_this (last graph')
 888         (m:_) ->
 889           load_this m
 890  where
 891    findTarget ms t
 892     = case filter (`matches` t) ms of
 893         []    -> Nothing
 894         (m:_) -> Just m
 895
 896    summary `matches` Target (TargetModule m) _
 897         = GHC.ms_mod_name summary == m
 898    summary `matches` Target (TargetFile f _) _
 899         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 900    summary `matches` target
 901         = False
 902
 903    load_this summary | m <- GHC.ms_mod summary = do
 904         b <- io (GHC.moduleIsInterpreted session m)
 905         if b then io (GHC.setContext session [m] [])
 906              else do
 907                    prel_mod <- getPrelude
 908                    io (GHC.setContext session []  [prel_mod,m])
 909
 910
 911 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 912 modulesLoadedMsg ok mods = do
 913   dflags <- getDynFlags
 914   when (verbosity dflags > 0) $ do
 915    let mod_commas
 916         | null mods = text "none."
 917         | otherwise = hsep (
 918             punctuate comma (map ppr mods)) <> text "."
 919    case ok of
 920     Failed ->
 921        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 922     Succeeded  ->
 923        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 924
 925
 926 typeOfExpr :: String -> GHCi ()
 927 typeOfExpr str
 928   = do cms <- getSession
 929        maybe_ty <- io (GHC.exprType cms str)
 930        case maybe_ty of
 931           Nothing -> return ()
 932           Just ty -> do ty' <- cleanType ty
 933                         printForUser $ text str <> text " :: " <> ppr ty'
 934
 935 kindOfType :: String -> GHCi ()
 936 kindOfType str
 937   = do cms <- getSession
 938        maybe_ty <- io (GHC.typeKind cms str)
 939        case maybe_ty of
 940           Nothing    -> return ()
 941           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 942
 943 quit :: String -> GHCi Bool
 944 quit _ = return True
 945
 946 shellEscape :: String -> GHCi Bool
 947 shellEscape str = io (system str >> return False)
 948
 949 -----------------------------------------------------------------------------
 950 -- Browsing a module's contents
 951
 952 browseCmd :: String -> GHCi ()
 953 browseCmd m =
 954   case words m of
 955     ['*':m] | looksLikeModuleName m -> browseModule m False
 956     [m]     | looksLikeModuleName m -> browseModule m True
 957     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 958
 959 browseModule m exports_only = do
 960   s <- getSession
 961   modl <- if exports_only then lookupModule m
 962                           else wantInterpretedModule m
 963
 964   -- Temporarily set the context to the module we're interested in,
 965   -- just so we can get an appropriate PrintUnqualified
 966   (as,bs) <- io (GHC.getContext s)
 967   prel_mod <- getPrelude
 968   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 969                       else GHC.setContext s [modl] [])
 970   unqual <- io (GHC.getPrintUnqual s)
 971   io (GHC.setContext s as bs)
 972
 973   mb_mod_info <- io $ GHC.getModuleInfo s modl
 974   case mb_mod_info of
 975     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 976     Just mod_info -> do
 977         let names
 978                | exports_only = GHC.modInfoExports mod_info
 979                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 980
 981             filtered = filterOutChildren names
 982
 983         things <- io $ mapM (GHC.lookupName s) filtered
 984
 985         dflags <- getDynFlags
 986         let exts = dopt Opt_GlasgowExts dflags
 987         io (putStrLn (showSDocForUser unqual (
 988                 vcat (map (pprTyThingInContext exts) (catMaybes things))
 989            )))
 990         -- ToDo: modInfoInstances currently throws an exception for
 991         -- package modules.  When it works, we can do this:
 992         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
 993
 994 -----------------------------------------------------------------------------
 995 -- Setting the module context
 996
 997 setContext str
 998   | all sensible mods = fn mods
 999   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1000   where
1001     (fn, mods) = case str of
1002                         '+':stuff -> (addToContext,      words stuff)
1003                         '-':stuff -> (removeFromContext, words stuff)
1004                         stuff     -> (newContext,        words stuff)
1005
1006     sensible ('*':m) = looksLikeModuleName m
1007     sensible m       = looksLikeModuleName m
1008
1009 separate :: Session -> [String] -> [Module] -> [Module]
1010         -> GHCi ([Module],[Module])
1011 separate session []           as bs = return (as,bs)
1012 separate session (('*':str):ms) as bs = do
1013    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1014    b <- io $ GHC.moduleIsInterpreted session m
1015    if b then separate session ms (m:as) bs
1016         else throwDyn (CmdLineError ("module '"
1017                         ++ GHC.moduleNameString (GHC.moduleName m)
1018                         ++ "' is not interpreted"))
1019 separate session (str:ms) as bs = do
1020   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1021   separate session ms as (m:bs)
1022
1023 newContext :: [String] -> GHCi ()
1024 newContext strs = do
1025   s <- getSession
1026   (as,bs) <- separate s strs [] []
1027   prel_mod <- getPrelude
1028   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1029   io $ GHC.setContext s as bs'
1030
1031
1032 addToContext :: [String] -> GHCi ()
1033 addToContext strs = do
1034   s <- getSession
1035   (as,bs) <- io $ GHC.getContext s
1036
1037   (new_as,new_bs) <- separate s strs [] []
1038
1039   let as_to_add = new_as \\ (as ++ bs)
1040       bs_to_add = new_bs \\ (as ++ bs)
1041
1042   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1043
1044
1045 removeFromContext :: [String] -> GHCi ()
1046 removeFromContext strs = do
1047   s <- getSession
1048   (as,bs) <- io $ GHC.getContext s
1049
1050   (as_to_remove,bs_to_remove) <- separate s strs [] []
1051
1052   let as' = as \\ (as_to_remove ++ bs_to_remove)
1053       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1054
1055   io $ GHC.setContext s as' bs'
1056
1057 ----------------------------------------------------------------------------
1058 -- Code for `:set'
1059
1060 -- set options in the interpreter.  Syntax is exactly the same as the
1061 -- ghc command line, except that certain options aren't available (-C,
1062 -- -E etc.)
1063 --
1064 -- This is pretty fragile: most options won't work as expected.  ToDo:
1065 -- figure out which ones & disallow them.
1066
1067 setCmd :: String -> GHCi ()
1068 setCmd ""
1069   = do st <- getGHCiState
1070        let opts = options st
1071        io $ putStrLn (showSDoc (
1072               text "options currently set: " <>
1073               if null opts
1074                    then text "none."
1075                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1076            ))
1077 setCmd str
1078   = case toArgs str of
1079         ("args":args) -> setArgs args
1080         ("prog":prog) -> setProg prog
1081         ("prompt":prompt) -> setPrompt (after 6)
1082         ("editor":cmd) -> setEditor (after 6)
1083         ("stop":cmd) -> setStop (after 4)
1084         wds -> setOptions wds
1085    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1086
1087 setArgs args = do
1088   st <- getGHCiState
1089   setGHCiState st{ args = args }
1090
1091 setProg [prog] = do
1092   st <- getGHCiState
1093   setGHCiState st{ progname = prog }
1094 setProg _ = do
1095   io (hPutStrLn stderr "syntax: :set prog <progname>")
1096
1097 setEditor cmd = do
1098   st <- getGHCiState
1099   setGHCiState st{ editor = cmd }
1100
1101 setStop str@(c:_) | isDigit c
1102   = do let (nm_str,rest) = break (not.isDigit) str
1103            nm = read nm_str
1104        st <- getGHCiState
1105        let old_breaks = breaks st
1106        if all ((/= nm) . fst) old_breaks
1107               then printForUser (text "Breakpoint" <+> ppr nm <+>
1108                                  text "does not exist")
1109               else do
1110        let new_breaks = map fn old_breaks
1111            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1112                       | otherwise = (i,loc)
1113        setGHCiState st{ breaks = new_breaks }
1114 setStop cmd = do
1115   st <- getGHCiState
1116   setGHCiState st{ stop = cmd }
1117
1118 setPrompt value = do
1119   st <- getGHCiState
1120   if null value
1121       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1122       else setGHCiState st{ prompt = remQuotes value }
1123   where
1124      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1125      remQuotes x = x
1126
1127 setOptions wds =
1128    do -- first, deal with the GHCi opts (+s, +t, etc.)
1129       let (plus_opts, minus_opts)  = partition isPlus wds
1130       mapM_ setOpt plus_opts
1131       -- then, dynamic flags
1132       newDynFlags minus_opts
1133
1134 newDynFlags minus_opts = do
1135       dflags <- getDynFlags
1136       let pkg_flags = packageFlags dflags
1137       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1138
1139       if (not (null leftovers))
1140                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1141                                                 unwords leftovers))
1142                 else return ()
1143
1144       new_pkgs <- setDynFlags dflags'
1145
1146       -- if the package flags changed, we should reset the context
1147       -- and link the new packages.
1148       dflags <- getDynFlags
1149       when (packageFlags dflags /= pkg_flags) $ do
1150         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1151         session <- getSession
1152         io (GHC.setTargets session [])
1153         io (GHC.load session LoadAllTargets)
1154         io (linkPackages dflags new_pkgs)
1155         setContextAfterLoad session []
1156       return ()
1157
1158
1159 unsetOptions :: String -> GHCi ()
1160 unsetOptions str
1161   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1162        let opts = words str
1163            (minus_opts, rest1) = partition isMinus opts
1164            (plus_opts, rest2)  = partition isPlus rest1
1165
1166        if (not (null rest2))
1167           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1168           else do
1169
1170        mapM_ unsetOpt plus_opts
1171
1172        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1173            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1174
1175        no_flags <- mapM no_flag minus_opts
1176        newDynFlags no_flags
1177
1178 isMinus ('-':s) = True
1179 isMinus _ = False
1180
1181 isPlus ('+':s) = True
1182 isPlus _ = False
1183
1184 setOpt ('+':str)
1185   = case strToGHCiOpt str of
1186         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1187         Just o  -> setOption o
1188
1189 unsetOpt ('+':str)
1190   = case strToGHCiOpt str of
1191         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1192         Just o  -> unsetOption o
1193
1194 strToGHCiOpt :: String -> (Maybe GHCiOption)
1195 strToGHCiOpt "s" = Just ShowTiming
1196 strToGHCiOpt "t" = Just ShowType
1197 strToGHCiOpt "r" = Just RevertCAFs
1198 strToGHCiOpt _   = Nothing
1199
1200 optToStr :: GHCiOption -> String
1201 optToStr ShowTiming = "s"
1202 optToStr ShowType   = "t"
1203 optToStr RevertCAFs = "r"
1204
1205 -- ---------------------------------------------------------------------------
1206 -- code for `:show'
1207
1208 showCmd str = do
1209   st <- getGHCiState
1210   case words str of
1211         ["args"]     -> io $ putStrLn (show (args st))
1212         ["prog"]     -> io $ putStrLn (show (progname st))
1213         ["prompt"]   -> io $ putStrLn (show (prompt st))
1214         ["editor"]   -> io $ putStrLn (show (editor st))
1215         ["stop"]     -> io $ putStrLn (show (stop st))
1216         ["modules" ] -> showModules
1217         ["bindings"] -> showBindings
1218         ["linker"]   -> io showLinkerState
1219         ["breaks"]   -> showBkptTable
1220         ["context"]  -> showContext
1221         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1222
1223 showModules = do
1224   session <- getSession
1225   let show_one ms = do m <- io (GHC.showModule session ms)
1226                        io (putStrLn m)
1227   graph <- io (GHC.getModuleGraph session)
1228   mapM_ show_one graph
1229
1230 showBindings = do
1231   s <- getSession
1232   unqual <- io (GHC.getPrintUnqual s)
1233   bindings <- io (GHC.getBindings s)
1234   mapM_ showTyThing bindings
1235   return ()
1236
1237 showTyThing (AnId id) = do
1238   ty' <- cleanType (GHC.idType id)
1239   printForUser $ ppr id <> text " :: " <> ppr ty'
1240 showTyThing _  = return ()
1241
1242 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1243 cleanType :: Type -> GHCi Type
1244 cleanType ty = do
1245   dflags <- getDynFlags
1246   if dopt Opt_GlasgowExts dflags
1247         then return ty
1248         else return $! GHC.dropForAlls ty
1249
1250 showBkptTable :: GHCi ()
1251 showBkptTable = do
1252   st <- getGHCiState
1253   printForUser $ prettyLocations (breaks st)
1254
1255 showContext :: GHCi ()
1256 showContext = do
1257    session <- getSession
1258    resumes <- io $ GHC.getResumeContext session
1259    printForUser $ vcat (map pp_resume (reverse resumes))
1260   where
1261    pp_resume resume =
1262         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1263         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1264
1265
1266 -- -----------------------------------------------------------------------------
1267 -- Completion
1268
1269 completeNone :: String -> IO [String]
1270 completeNone w = return []
1271
1272 #ifdef USE_READLINE
1273 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1274 completeWord w start end = do
1275   line <- Readline.getLineBuffer
1276   case w of
1277      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1278      _other
1279         | Just c <- is_cmd line -> do
1280            maybe_cmd <- lookupCommand c
1281            let (n,w') = selectWord (words' 0 line)
1282            case maybe_cmd of
1283              Nothing -> return Nothing
1284              Just (_,_,False,complete) -> wrapCompleter complete w
1285              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1286                                                               return (map (drop n) rets)
1287                                          in wrapCompleter complete' w'
1288         | otherwise     -> do
1289                 --printf "complete %s, start = %d, end = %d\n" w start end
1290                 wrapCompleter completeIdentifier w
1291     where words' _ [] = []
1292           words' n str = let (w,r) = break isSpace str
1293                              (s,r') = span isSpace r
1294                          in (n,w):words' (n+length w+length s) r'
1295           -- In a Haskell expression we want to parse 'a-b' as three words
1296           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1297           -- only be a single word.
1298           selectWord [] = (0,w)
1299           selectWord ((offset,x):xs)
1300               | offset+length x >= start = (start-offset,take (end-offset) x)
1301               | otherwise = selectWord xs
1302
1303 is_cmd line
1304  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1305  | otherwise = Nothing
1306
1307 completeCmd w = do
1308   cmds <- readIORef commands
1309   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1310
1311 completeMacro w = do
1312   cmds <- readIORef commands
1313   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1314   return (filter (w `isPrefixOf`) cmds')
1315
1316 completeIdentifier w = do
1317   s <- restoreSession
1318   rdrs <- GHC.getRdrNamesInScope s
1319   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1320
1321 completeModule w = do
1322   s <- restoreSession
1323   dflags <- GHC.getSessionDynFlags s
1324   let pkg_mods = allExposedModules dflags
1325   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1326
1327 completeHomeModule w = do
1328   s <- restoreSession
1329   g <- GHC.getModuleGraph s
1330   let home_mods = map GHC.ms_mod_name g
1331   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1332
1333 completeSetOptions w = do
1334   return (filter (w `isPrefixOf`) options)
1335     where options = "args":"prog":allFlags
1336
1337 completeFilename = Readline.filenameCompletionFunction
1338
1339 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1340
1341 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1342 unionComplete f1 f2 w = do
1343   s1 <- f1 w
1344   s2 <- f2 w
1345   return (s1 ++ s2)
1346
1347 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1348 wrapCompleter fun w =  do
1349   strs <- fun w
1350   case strs of
1351     []  -> return Nothing
1352     [x] -> return (Just (x,[]))
1353     xs  -> case getCommonPrefix xs of
1354                 ""   -> return (Just ("",xs))
1355                 pref -> return (Just (pref,xs))
1356
1357 getCommonPrefix :: [String] -> String
1358 getCommonPrefix [] = ""
1359 getCommonPrefix (s:ss) = foldl common s ss
1360   where common s "" = ""
1361         common "" s = ""
1362         common (c:cs) (d:ds)
1363            | c == d = c : common cs ds
1364            | otherwise = ""
1365
1366 allExposedModules :: DynFlags -> [ModuleName]
1367 allExposedModules dflags
1368  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1369  where
1370   pkg_db = pkgIdMap (pkgState dflags)
1371 #else
1372 completeCmd        = completeNone
1373 completeMacro      = completeNone
1374 completeIdentifier = completeNone
1375 completeModule     = completeNone
1376 completeHomeModule = completeNone
1377 completeSetOptions = completeNone
1378 completeFilename   = completeNone
1379 completeHomeModuleOrFile=completeNone
1380 completeBkpt       = completeNone
1381 #endif
1382
1383 -- ---------------------------------------------------------------------------
1384 -- User code exception handling
1385
1386 -- This is the exception handler for exceptions generated by the
1387 -- user's code and exceptions coming from children sessions;
1388 -- it normally just prints out the exception.  The
1389 -- handler must be recursive, in case showing the exception causes
1390 -- more exceptions to be raised.
1391 --
1392 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1393 -- raising another exception.  We therefore don't put the recursive
1394 -- handler arond the flushing operation, so if stderr is closed
1395 -- GHCi will just die gracefully rather than going into an infinite loop.
1396 handler :: Exception -> GHCi Bool
1397
1398 handler exception = do
1399   flushInterpBuffers
1400   io installSignalHandlers
1401   ghciHandle handler (showException exception >> return False)
1402
1403 showException (DynException dyn) =
1404   case fromDynamic dyn of
1405     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1406     Just Interrupted      -> io (putStrLn "Interrupted.")
1407     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1408     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1409     Just other_ghc_ex     -> io (print other_ghc_ex)
1410
1411 showException other_exception
1412   = io (putStrLn ("*** Exception: " ++ show other_exception))
1413
1414 -----------------------------------------------------------------------------
1415 -- recursive exception handlers
1416
1417 -- Don't forget to unblock async exceptions in the handler, or if we're
1418 -- in an exception loop (eg. let a = error a in a) the ^C exception
1419 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1420
1421 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1422 ghciHandle h (GHCi m) = GHCi $ \s ->
1423    Exception.catch (m s)
1424         (\e -> unGHCi (ghciUnblock (h e)) s)
1425
1426 ghciUnblock :: GHCi a -> GHCi a
1427 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1428
1429
1430 -- ----------------------------------------------------------------------------
1431 -- Utils
1432
1433 expandPath :: String -> GHCi String
1434 expandPath path =
1435   case dropWhile isSpace path of
1436    ('~':d) -> do
1437         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1438         return (tilde ++ '/':d)
1439    other ->
1440         return other
1441
1442 wantInterpretedModule :: String -> GHCi Module
1443 wantInterpretedModule str = do
1444    session <- getSession
1445    modl <- lookupModule str
1446    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1447    when (not is_interpreted) $
1448        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1449    return modl
1450
1451 wantNameFromInterpretedModule noCanDo str and_then = do
1452    session <- getSession
1453    names <- io $ GHC.parseName session str
1454    case names of
1455       []    -> return ()
1456       (n:_) -> do
1457             let modl = GHC.nameModule n
1458             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1459             if not is_interpreted
1460                then noCanDo n $ text "module " <> ppr modl <>
1461                                 text " is not interpreted"
1462                else and_then n
1463
1464 -- ----------------------------------------------------------------------------
1465 -- Windows console setup
1466
1467 setUpConsole :: IO ()
1468 setUpConsole = do
1469 #ifdef mingw32_HOST_OS
1470         -- On Windows we need to set a known code page, otherwise the characters
1471         -- we read from the console will be be in some strange encoding, and
1472         -- similarly for characters we write to the console.
1473         --
1474         -- At the moment, GHCi pretends all input is Latin-1.  In the
1475         -- future we should support UTF-8, but for now we set the code pages
1476         -- to Latin-1.
1477         --
1478         -- It seems you have to set the font in the console window to
1479         -- a Unicode font in order for output to work properly,
1480         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1481         -- (see MSDN for SetConsoleOutputCP()).
1482         --
1483         setConsoleCP 28591       -- ISO Latin-1
1484         setConsoleOutputCP 28591 -- ISO Latin-1
1485 #endif
1486         return ()
1487
1488 -- -----------------------------------------------------------------------------
1489 -- commands for debugger
1490
1491 sprintCmd = pprintCommand False False
1492 printCmd  = pprintCommand True False
1493 forceCmd  = pprintCommand False True
1494
1495 pprintCommand bind force str = do
1496   session <- getSession
1497   io $ pprintClosureCommand session bind force str
1498
1499 stepCmd :: String -> GHCi ()
1500 stepCmd []         = doContinue GHC.SingleStep
1501 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1502
1503 traceCmd :: String -> GHCi ()
1504 traceCmd []         = doContinue GHC.RunAndLogSteps
1505 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1506
1507 continueCmd :: String -> GHCi ()
1508 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1509
1510 doContinue :: SingleStep -> GHCi ()
1511 doContinue step = do
1512   session <- getSession
1513   runResult <- io $ GHC.resume session step
1514   afterRunStmt runResult
1515   return ()
1516
1517 abandonCmd :: String -> GHCi ()
1518 abandonCmd = noArgs $ do
1519   s <- getSession
1520   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1521   when (not b) $ io $ putStrLn "There is no computation running."
1522   return ()
1523
1524 deleteCmd :: String -> GHCi ()
1525 deleteCmd argLine = do
1526    deleteSwitch $ words argLine
1527    where
1528    deleteSwitch :: [String] -> GHCi ()
1529    deleteSwitch [] =
1530       io $ putStrLn "The delete command requires at least one argument."
1531    -- delete all break points
1532    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1533    deleteSwitch idents = do
1534       mapM_ deleteOneBreak idents
1535       where
1536       deleteOneBreak :: String -> GHCi ()
1537       deleteOneBreak str
1538          | all isDigit str = deleteBreak (read str)
1539          | otherwise = return ()
1540
1541 historyCmd :: String -> GHCi ()
1542 historyCmd arg
1543   | null arg        = history 20
1544   | all isDigit arg = history (read arg)
1545   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1546   where
1547   history num = do
1548     s <- getSession
1549     resumes <- io $ GHC.getResumeContext s
1550     case resumes of
1551       [] -> io $ putStrLn "Not stopped at a breakpoint"
1552       (r:rs) -> do
1553         let hist = GHC.resumeHistory r
1554             (took,rest) = splitAt num hist
1555         spans <- mapM (io . GHC.getHistorySpan s) took
1556         let nums = map (printf "-%-3d:") [(1::Int)..]
1557         printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1558         io $ putStrLn $ if null rest then "<end of history>" else "..."
1559
1560 backCmd :: String -> GHCi ()
1561 backCmd = noArgs $ do
1562   s <- getSession
1563   (names, ix, span) <- io $ GHC.back s
1564   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1565   mapM_ (showTypeOfName s) names
1566    -- run the command set with ":set stop <cmd>"
1567   st <- getGHCiState
1568   enqueueCommands [stop st]
1569
1570 forwardCmd :: String -> GHCi ()
1571 forwardCmd = noArgs $ do
1572   s <- getSession
1573   (names, ix, span) <- io $ GHC.forward s
1574   printForUser $ (if (ix == 0)
1575                     then ptext SLIT("Stopped at")
1576                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1577   mapM_ (showTypeOfName s) names
1578    -- run the command set with ":set stop <cmd>"
1579   st <- getGHCiState
1580   enqueueCommands [stop st]
1581
1582 -- handle the "break" command
1583 breakCmd :: String -> GHCi ()
1584 breakCmd argLine = do
1585    session <- getSession
1586    breakSwitch session $ words argLine
1587
1588 breakSwitch :: Session -> [String] -> GHCi ()
1589 breakSwitch _session [] = do
1590    io $ putStrLn "The break command requires at least one argument."
1591 breakSwitch session args@(arg1:rest)
1592    | looksLikeModuleName arg1 = do
1593         mod <- wantInterpretedModule arg1
1594         breakByModule session mod rest
1595    | all isDigit arg1 = do
1596         (toplevel, _) <- io $ GHC.getContext session
1597         case toplevel of
1598            (mod : _) -> breakByModuleLine mod (read arg1) rest
1599            [] -> do
1600               io $ putStrLn "Cannot find default module for breakpoint."
1601               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1602    | otherwise = do -- try parsing it as an identifier
1603         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1604         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1605         if GHC.isGoodSrcLoc loc
1606                then findBreakAndSet (GHC.nameModule name) $
1607                          findBreakByCoord (Just (GHC.srcLocFile loc))
1608                                           (GHC.srcLocLine loc,
1609                                            GHC.srcLocCol loc)
1610                else noCanDo name $ text "can't find its location: " <> ppr loc
1611        where
1612           noCanDo n why = printForUser $
1613                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1614
1615 breakByModule :: Session -> Module -> [String] -> GHCi ()
1616 breakByModule session mod args@(arg1:rest)
1617    | all isDigit arg1 = do  -- looks like a line number
1618         breakByModuleLine mod (read arg1) rest
1619    | otherwise = io $ putStrLn "Invalid arguments to :break"
1620
1621 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1622 breakByModuleLine mod line args
1623    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1624    | [col] <- args, all isDigit col =
1625         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1626    | otherwise = io $ putStrLn "Invalid arguments to :break"
1627
1628 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1629 findBreakAndSet mod lookupTickTree = do
1630    tickArray <- getTickArray mod
1631    (breakArray, _) <- getModBreak mod
1632    case lookupTickTree tickArray of
1633       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1634       Just (tick, span) -> do
1635          success <- io $ setBreakFlag True breakArray tick
1636          session <- getSession
1637          if success
1638             then do
1639                (alreadySet, nm) <-
1640                      recordBreak $ BreakLocation
1641                              { breakModule = mod
1642                              , breakLoc = span
1643                              , breakTick = tick
1644                              , onBreakCmd = ""
1645                              }
1646                printForUser $
1647                   text "Breakpoint " <> ppr nm <>
1648                   if alreadySet
1649                      then text " was already set at " <> ppr span
1650                      else text " activated at " <> ppr span
1651             else do
1652             printForUser $ text "Breakpoint could not be activated at"
1653                                  <+> ppr span
1654
1655 -- When a line number is specified, the current policy for choosing
1656 -- the best breakpoint is this:
1657 --    - the leftmost complete subexpression on the specified line, or
1658 --    - the leftmost subexpression starting on the specified line, or
1659 --    - the rightmost subexpression enclosing the specified line
1660 --
1661 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1662 findBreakByLine line arr
1663   | not (inRange (bounds arr) line) = Nothing
1664   | otherwise =
1665     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1666     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1667     listToMaybe (sortBy rightmost ticks)
1668   where
1669         ticks = arr ! line
1670
1671         starts_here = [ tick | tick@(nm,span) <- ticks,
1672                                GHC.srcSpanStartLine span == line ]
1673
1674         (complete,incomplete) = partition ends_here starts_here
1675             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1676
1677 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1678                  -> Maybe (BreakIndex,SrcSpan)
1679 findBreakByCoord mb_file (line, col) arr
1680   | not (inRange (bounds arr) line) = Nothing
1681   | otherwise =
1682     listToMaybe (sortBy rightmost contains) `mplus`
1683     listToMaybe (sortBy leftmost_smallest after_here)
1684   where
1685         ticks = arr ! line
1686
1687         -- the ticks that span this coordinate
1688         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1689                             is_correct_file span ]
1690
1691         is_correct_file span
1692                  | Just f <- mb_file = GHC.srcSpanFile span == f
1693                  | otherwise         = True
1694
1695         after_here = [ tick | tick@(nm,span) <- ticks,
1696                               GHC.srcSpanStartLine span == line,
1697                               GHC.srcSpanStartCol span >= col ]
1698
1699
1700 leftmost_smallest  (_,a) (_,b) = a `compare` b
1701 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1702                                 `thenCmp`
1703                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1704 rightmost (_,a) (_,b) = b `compare` a
1705
1706 spans :: SrcSpan -> (Int,Int) -> Bool
1707 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1708    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1709
1710 -- for now, use ANSI bold on Unixy systems.  On Windows, we add a line
1711 -- of carets under the active expression instead.  The Windows console
1712 -- doesn't support ANSI escape sequences, and most Unix terminals
1713 -- (including xterm) do, so this is a reasonable guess until we have a
1714 -- proper termcap/terminfo library.
1715 #if !defined(mingw32_TARGET_OS)
1716 do_bold = True
1717 #else
1718 do_bold = False
1719 #endif
1720
1721 start_bold = BS.pack "\ESC[1m"
1722 end_bold   = BS.pack "\ESC[0m"
1723
1724 listCmd :: String -> GHCi ()
1725 listCmd "" = do
1726    mb_span <- getCurrentBreakSpan
1727    case mb_span of
1728       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1729       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1730                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
1731 listCmd str = list2 (words str)
1732
1733 list2 [arg] | all isDigit arg = do
1734     session <- getSession
1735     (toplevel, _) <- io $ GHC.getContext session
1736     case toplevel of
1737         [] -> io $ putStrLn "No module to list"
1738         (mod : _) -> listModuleLine mod (read arg)
1739 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1740         mod <- wantInterpretedModule arg1
1741         listModuleLine mod (read arg2)
1742 list2 [arg] = do
1743         wantNameFromInterpretedModule noCanDo arg $ \name -> do
1744         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1745         if GHC.isGoodSrcLoc loc
1746                then do
1747                   tickArray <- getTickArray (GHC.nameModule name)
1748                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1749                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
1750                                         tickArray
1751                   case mb_span of
1752                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
1753                     Just (_,span) -> io $ listAround span False
1754                else
1755                   noCanDo name $ text "can't find its location: " <>
1756                                  ppr loc
1757     where
1758         noCanDo n why = printForUser $
1759             text "cannot list source code for " <> ppr n <> text ": " <> why
1760 list2  _other =
1761         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
1762
1763 listModuleLine :: Module -> Int -> GHCi ()
1764 listModuleLine modl line = do
1765    session <- getSession
1766    graph <- io (GHC.getModuleGraph session)
1767    let this = filter ((== modl) . GHC.ms_mod) graph
1768    case this of
1769      [] -> panic "listModuleLine"
1770      summ:_ -> do
1771            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1772                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1773            io $ listAround (GHC.srcLocSpan loc) False
1774
1775 -- | list a section of a source file around a particular SrcSpan.
1776 -- If the highlight flag is True, also highlight the span using
1777 -- start_bold/end_bold.
1778 listAround span do_highlight = do
1779       pwd      <- getEnv "PWD"
1780       contents <- BS.readFile (pwd </> unpackFS file)
1781       let
1782           lines = BS.split '\n' contents
1783           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1784                         drop (line1 - 1 - pad_before) $ lines
1785           fst_line = max 1 (line1 - pad_before)
1786           line_nos = [ fst_line .. ]
1787
1788           highlighted | do_highlight = zipWith highlight line_nos these_lines
1789                       | otherwise   = these_lines
1790
1791           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1792           prefixed = zipWith BS.append bs_line_nos highlighted
1793       --
1794       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1795   where
1796         file  = GHC.srcSpanFile span
1797         line1 = GHC.srcSpanStartLine span
1798         col1  = GHC.srcSpanStartCol span
1799         line2 = GHC.srcSpanEndLine span
1800         col2  = GHC.srcSpanEndCol span
1801
1802         pad_before | line1 == 1 = 0
1803                    | otherwise  = 1
1804         pad_after = 1
1805
1806         highlight | do_bold   = highlight_bold
1807                   | otherwise = highlight_carets
1808
1809         highlight_bold no line
1810           | no == line1 && no == line2
1811           = let (a,r) = BS.splitAt col1 line
1812                 (b,c) = BS.splitAt (col2-col1) r
1813             in
1814             BS.concat [a,start_bold,b,end_bold,c]
1815           | no == line1
1816           = let (a,b) = BS.splitAt col1 line in
1817             BS.concat [a, start_bold, b]
1818           | no == line2
1819           = let (a,b) = BS.splitAt col2 line in
1820             BS.concat [a, end_bold, b]
1821           | otherwise   = line
1822
1823         highlight_carets no line
1824           | no == line1 && no == line2
1825           = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1826                                          BS.replicate (col2-col1) '^']
1827           | no == line1
1828           = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1829                                          BS.replicate (BS.length line-col1) '^']
1830           | no == line2
1831           = BS.concat [line, nl, indent, BS.replicate col2 '^']
1832           | otherwise   = line
1833          where
1834            indent = BS.pack "   "
1835            nl = BS.singleton '\n'
1836
1837 -- --------------------------------------------------------------------------
1838 -- Tick arrays
1839
1840 getTickArray :: Module -> GHCi TickArray
1841 getTickArray modl = do
1842    st <- getGHCiState
1843    let arrmap = tickarrays st
1844    case lookupModuleEnv arrmap modl of
1845       Just arr -> return arr
1846       Nothing  -> do
1847         (breakArray, ticks) <- getModBreak modl
1848         let arr = mkTickArray (assocs ticks)
1849         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1850         return arr
1851
1852 discardTickArrays :: GHCi ()
1853 discardTickArrays = do
1854    st <- getGHCiState
1855    setGHCiState st{tickarrays = emptyModuleEnv}
1856
1857 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1858 mkTickArray ticks
1859   = accumArray (flip (:)) [] (1, max_line)
1860         [ (line, (nm,span)) | (nm,span) <- ticks,
1861                               line <- srcSpanLines span ]
1862     where
1863         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1864         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1865                               GHC.srcSpanEndLine span ]
1866
1867 lookupModule :: String -> GHCi Module
1868 lookupModule modName
1869    = do session <- getSession
1870         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1871
1872 -- don't reset the counter back to zero?
1873 discardActiveBreakPoints :: GHCi ()
1874 discardActiveBreakPoints = do
1875    st <- getGHCiState
1876    mapM (turnOffBreak.snd) (breaks st)
1877    setGHCiState $ st { breaks = [] }
1878
1879 deleteBreak :: Int -> GHCi ()
1880 deleteBreak identity = do
1881    st <- getGHCiState
1882    let oldLocations    = breaks st
1883        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
1884    if null this
1885       then printForUser (text "Breakpoint" <+> ppr identity <+>
1886                          text "does not exist")
1887       else do
1888            mapM (turnOffBreak.snd) this
1889            setGHCiState $ st { breaks = rest }
1890
1891 turnOffBreak loc = do
1892   (arr, _) <- getModBreak (breakModule loc)
1893   io $ setBreakFlag False arr (breakTick loc)
1894
1895 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1896 getModBreak mod = do
1897    session <- getSession
1898    Just mod_info <- io $ GHC.getModuleInfo session mod
1899    let modBreaks  = GHC.modInfoModBreaks mod_info
1900    let array      = GHC.modBreaks_flags modBreaks
1901    let ticks      = GHC.modBreaks_locs  modBreaks
1902    return (array, ticks)
1903
1904 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1905 setBreakFlag toggle array index
1906    | toggle    = GHC.setBreakOn array index
1907    | otherwise = GHC.setBreakOff array index
1908