compiler/ghci/InteractiveUI.hs

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