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