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