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