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