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