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