compiler/ghci/InteractiveUI.hs

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