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