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