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, Name, 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
  30 -- Other random utilities
  31 import Digraph
  32 import BasicTypes hiding (isTopLevel)
  33 import Panic      hiding (showException)
  34 import Config
  35 import StaticFlags
  36 import Linker
  37 import Util
  38 import FastString
  39
  40 #ifndef mingw32_HOST_OS
  41 import System.Posix hiding (getEnv)
  42 #else
  43 import GHC.ConsoleHandler ( flushConsole )
  44 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  45 import qualified System.Win32
  46 #endif
  47
  48 #ifdef USE_READLINE
  49 import Control.Concurrent       ( yield )       -- Used in readline loop
  50 import System.Console.Readline as Readline
  51 #endif
  52
  53 --import SystemExts
  54
  55 import Control.Exception as Exception
  56 -- import Control.Concurrent
  57
  58 import qualified Data.ByteString.Char8 as BS
  59 import Data.List
  60 import Data.Maybe
  61 import System.Cmd
  62 import System.Environment
  63 import System.Exit      ( exitWith, ExitCode(..) )
  64 import System.Directory
  65 import System.IO
  66 import System.IO.Error as IO
  67 import Data.Char
  68 import Data.Dynamic
  69 import Data.Array
  70 import Control.Monad as Monad
  71 import Text.Printf
  72
  73 import Foreign.StablePtr        ( newStablePtr )
  74 import GHC.Exts         ( unsafeCoerce# )
  75 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  76
  77 import Data.IORef       ( IORef, readIORef, writeIORef )
  78
  79 import System.Posix.Internals ( setNonBlockingFD )
  80
  81 -----------------------------------------------------------------------------
  82
  83 ghciWelcomeMsg =
  84  "   ___         ___ _\n"++
  85  "  / _ \\ /\\  /\\/ __(_)\n"++
  86  " / /_\\// /_/ / /  | |    GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
  87  "/ /_\\\\/ __  / /___| |    http://www.haskell.org/ghc/\n"++
  88  "\\____/\\/ /_/\\____/|_|    Type :? for help.\n"
  89
  90 ghciShortWelcomeMsg =
  91     "GHCi, version " ++ cProjectVersion ++
  92     ": http://www.haskell.org/ghc/  :? for help"
  93
  94 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
  95 cmdName (n,_,_,_) = n
  96
  97 GLOBAL_VAR(commands, builtin_commands, [Command])
  98
  99 builtin_commands :: [Command]
 100 builtin_commands = [
 101         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 102   ("?",         keepGoing help,                 False, completeNone),
 103   ("add",       keepGoingPaths addModule,       False, completeFilename),
 104   ("abandon",   keepGoing abandonCmd,           False, completeNone),
 105   ("break",     keepGoing breakCmd,             False, completeIdentifier),
 106   ("back",      keepGoing backCmd,              False, completeNone),
 107   ("browse",    keepGoing browseCmd,            False, completeModule),
 108   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 109   ("check",     keepGoing checkModule,          False, completeHomeModule),
 110   ("continue",  keepGoing continueCmd,          False, completeNone),
 111   ("cmd",       keepGoing cmdCmd,               False, completeIdentifier),
 112   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 113   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 114   ("delete",    keepGoing deleteCmd,            False, completeNone),
 115   ("e",         keepGoing editFile,             False, completeFilename),
 116   ("edit",      keepGoing editFile,             False, completeFilename),
 117   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 118   ("force",     keepGoing forceCmd,             False, completeIdentifier),
 119   ("forward",   keepGoing forwardCmd,           False, completeNone),
 120   ("help",      keepGoing help,                 False, completeNone),
 121   ("history",   keepGoing historyCmd,           False, completeNone),
 122   ("info",      keepGoing info,                 False, completeIdentifier),
 123   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 124   ("load",      keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
 125   ("list",      keepGoing listCmd,              False, completeNone),
 126   ("module",    keepGoing setContext,           False, completeModule),
 127   ("main",      keepGoing runMain,              False, completeIdentifier),
 128   ("print",     keepGoing printCmd,             False, completeIdentifier),
 129   ("quit",      quit,                           False, completeNone),
 130   ("reload",    keepGoing reloadModule,         False, completeNone),
 131   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 132   ("show",      keepGoing showCmd,              False, completeNone),
 133   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
 134   ("step",      keepGoing stepCmd,              False, completeIdentifier),
 135   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 136   ("trace",     keepGoing traceCmd,             False, completeIdentifier),
 137   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 138   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 139   ]
 140
 141 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 142 keepGoing a str = a str >> return False
 143
 144 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 145 keepGoingPaths a str = a (toArgs str) >> return False
 146
 147 shortHelpText = "use :? for help.\n"
 148
 149 helpText =
 150  " Commands available from the prompt:\n" ++
 151  "\n" ++
 152  "   <statement>                 evaluate/run <statement>\n" ++
 153  "   :add <filename> ...         add module(s) to the current target set\n" ++
 154  "   :browse [*]<module>         display the names defined by <module>\n" ++
 155  "   :cd <dir>                   change directory to <dir>\n" ++
 156  "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
 157  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 158  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 159  "   :edit <file>                edit file\n" ++
 160  "   :edit                       edit last module\n" ++
 161  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 162  "   :help, :?                   display this list of commands\n" ++
 163  "   :info [<name> ...]          display information about the given names\n" ++
 164  "   :kind <type>                show the kind of <type>\n" ++
 165  "   :load <filename> ...        load module(s) and their dependents\n" ++
 166  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 167  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 168  "   :quit                       exit GHCi\n" ++
 169  "   :reload                     reload the current module set\n" ++
 170  "   :type <expr>                show the type of <expr>\n" ++
 171  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 172  "   :!<command>                 run the shell command <command>\n" ++
 173  "\n" ++
 174  " -- Commands for debugging:\n" ++
 175  "\n" ++
 176  "   :abandon                    at a breakpoint, abandon current computation\n" ++
 177  "   :back                       go back in the history (after :trace)\n" ++
 178  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 179  "   :break <name>               set a breakpoint on the specified function\n" ++
 180  "   :continue                   resume after a breakpoint\n" ++
 181  "   :delete <number>            delete the specified breakpoint\n" ++
 182  "   :delete *                   delete all breakpoints\n" ++
 183  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 184  "   :forward                    go forward in the history (after :back)\n" ++
 185  "   :history [<n>]              show the last <n> items in the history (after :trace)\n" ++
 186  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 187  "   :sprint [<name> ...]        simplifed version of :print\n" ++
 188  "   :step                       single-step after stopping at a breakpoint\n"++
 189  "   :step <expr>                single-step into <expr>\n"++
 190  "   :trace                      trace after stopping at a breakpoint\n"++
 191  "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
 192
 193  "\n" ++
 194  " -- Commands for changing settings:\n" ++
 195  "\n" ++
 196  "   :set <option> ...           set options\n" ++
 197  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 198  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 199  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 200  "   :set editor <cmd>           set the command used for :edit\n" ++
 201  "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
 202  "   :unset <option> ...         unset options\n" ++
 203  "\n" ++
 204  "  Options for ':set' and ':unset':\n" ++
 205  "\n" ++
 206  "    +r            revert top-level expressions after each evaluation\n" ++
 207  "    +s            print timing/memory stats after each evaluation\n" ++
 208  "    +t            print type after evaluation\n" ++
 209  "    -<flags>      most GHC command line flags can also be set here\n" ++
 210  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 211  "\n" ++
 212  " -- Commands for displaying information:\n" ++
 213  "\n" ++
 214  "   :show bindings              show the current bindings made at the prompt\n" ++
 215  "   :show breaks                show the active breakpoints\n" ++
 216  "   :show context               show the breakpoint context\n" ++
 217  "   :show modules               show the currently loaded modules\n" ++
 218  "   :show <setting>             show anything that can be set with :set (e.g. args)\n" ++
 219  "\n"
 220
 221 findEditor = do
 222   getEnv "EDITOR"
 223     `IO.catch` \_ -> do
 224 #if mingw32_HOST_OS
 225         win <- System.Win32.getWindowsDirectory
 226         return (win `joinFileName` "notepad.exe")
 227 #else
 228         return ""
 229 #endif
 230
 231 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 232 interactiveUI session srcs maybe_expr = do
 233    -- HACK! If we happen to get into an infinite loop (eg the user
 234    -- types 'let x=x in x' at the prompt), then the thread will block
 235    -- on a blackhole, and become unreachable during GC.  The GC will
 236    -- detect that it is unreachable and send it the NonTermination
 237    -- exception.  However, since the thread is unreachable, everything
 238    -- it refers to might be finalized, including the standard Handles.
 239    -- This sounds like a bug, but we don't have a good solution right
 240    -- now.
 241    newStablePtr stdin
 242    newStablePtr stdout
 243    newStablePtr stderr
 244
 245     -- Initialise buffering for the *interpreted* I/O system
 246    initInterpBuffering session
 247
 248    when (isNothing maybe_expr) $ do
 249         -- Only for GHCi (not runghc and ghc -e):
 250
 251         -- Turn buffering off for the compiled program's stdout/stderr
 252         turnOffBuffering
 253         -- Turn buffering off for GHCi's stdout
 254         hFlush stdout
 255         hSetBuffering stdout NoBuffering
 256         -- We don't want the cmd line to buffer any input that might be
 257         -- intended for the program, so unbuffer stdin.
 258         hSetBuffering stdin NoBuffering
 259
 260         -- initial context is just the Prelude
 261    prel_mod <- GHC.findModule session prel_name (Just basePackageId)
 262    GHC.setContext session [] [prel_mod]
 263
 264 #ifdef USE_READLINE
 265    Readline.initialize
 266    Readline.setAttemptedCompletionFunction (Just completeWord)
 267    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 268
 269    let symbols = "!#$%&*+/<=>?@\\^|-~"
 270        specials = "(),;[]`{}"
 271        spaces = " \t\n"
 272        word_break_chars = spaces ++ specials ++ symbols
 273
 274    Readline.setBasicWordBreakCharacters word_break_chars
 275    Readline.setCompleterWordBreakCharacters word_break_chars
 276 #endif
 277
 278    default_editor <- findEditor
 279
 280    startGHCi (runGHCi srcs maybe_expr)
 281         GHCiState{ progname = "<interactive>",
 282                    args = [],
 283                    prompt = "%s> ",
 284                    stop = "",
 285                    editor = default_editor,
 286                    session = session,
 287                    options = [],
 288                    prelude = prel_mod,
 289                    break_ctr = 0,
 290                    breaks = [],
 291                    tickarrays = emptyModuleEnv,
 292                    cmdqueue = []
 293                  }
 294
 295 #ifdef USE_READLINE
 296    Readline.resetTerminal Nothing
 297 #endif
 298
 299    return ()
 300
 301 prel_name = GHC.mkModuleName "Prelude"
 302
 303 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 304 runGHCi paths maybe_expr = do
 305   let read_dot_files = not opt_IgnoreDotGhci
 306
 307   when (read_dot_files) $ do
 308     -- Read in ./.ghci.
 309     let file = "./.ghci"
 310     exists <- io (doesFileExist file)
 311     when exists $ do
 312        dir_ok  <- io (checkPerms ".")
 313        file_ok <- io (checkPerms file)
 314        when (dir_ok && file_ok) $ do
 315           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 316           case either_hdl of
 317              Left e    -> return ()
 318              Right hdl -> fileLoop hdl False
 319
 320   when (read_dot_files) $ do
 321     -- Read in $HOME/.ghci
 322     either_dir <- io (IO.try (getEnv "HOME"))
 323     case either_dir of
 324        Left e -> return ()
 325        Right dir -> do
 326           cwd <- io (getCurrentDirectory)
 327           when (dir /= cwd) $ do
 328              let file = dir ++ "/.ghci"
 329              ok <- io (checkPerms file)
 330              when ok $ do
 331                either_hdl <- io (IO.try (openFile file ReadMode))
 332                case either_hdl of
 333                   Left e    -> return ()
 334                   Right hdl -> fileLoop hdl False
 335
 336   -- Perform a :load for files given on the GHCi command line
 337   -- When in -e mode, if the load fails then we want to stop
 338   -- immediately rather than going on to evaluate the expression.
 339   when (not (null paths)) $ do
 340      ok <- ghciHandle (\e -> do showException e; return Failed) $
 341                 loadModule paths
 342      when (isJust maybe_expr && failed ok) $
 343         io (exitWith (ExitFailure 1))
 344
 345   -- if verbosity is greater than 0, or we are connected to a
 346   -- terminal, display the prompt in the interactive loop.
 347   is_tty <- io (hIsTerminalDevice stdin)
 348   dflags <- getDynFlags
 349   let show_prompt = verbosity dflags > 0 || is_tty
 350
 351   case maybe_expr of
 352         Nothing ->
 353           do
 354 #if defined(mingw32_HOST_OS)
 355             -- The win32 Console API mutates the first character of
 356             -- type-ahead when reading from it in a non-buffered manner. Work
 357             -- around this by flushing the input buffer of type-ahead characters,
 358             -- but only if stdin is available.
 359             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 360             case flushed of
 361              Left err | isDoesNotExistError err -> return ()
 362                       | otherwise -> io (ioError err)
 363              Right () -> return ()
 364 #endif
 365             -- initialise the console if necessary
 366             io setUpConsole
 367
 368             let msg = if dopt Opt_ShortGhciBanner dflags
 369                       then ghciShortWelcomeMsg
 370                       else ghciWelcomeMsg
 371             when (verbosity dflags >= 1) $ io $ putStrLn msg
 372
 373             -- enter the interactive loop
 374             interactiveLoop is_tty show_prompt
 375         Just expr -> do
 376             -- just evaluate the expression we were given
 377             runCommandEval expr
 378             return ()
 379
 380   -- and finally, exit
 381   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 382
 383
 384 interactiveLoop is_tty show_prompt =
 385   -- Ignore ^C exceptions caught here
 386   ghciHandleDyn (\e -> case e of
 387                         Interrupted -> do
 388 #if defined(mingw32_HOST_OS)
 389                                 io (putStrLn "")
 390 #endif
 391                                 interactiveLoop is_tty show_prompt
 392                         _other      -> return ()) $
 393
 394   ghciUnblock $ do -- unblock necessary if we recursed from the
 395                    -- exception handler above.
 396
 397   -- read commands from stdin
 398 #ifdef USE_READLINE
 399   if (is_tty)
 400         then readlineLoop
 401         else fileLoop stdin show_prompt
 402 #else
 403   fileLoop stdin show_prompt
 404 #endif
 405
 406
 407 -- NOTE: We only read .ghci files if they are owned by the current user,
 408 -- and aren't world writable.  Otherwise, we could be accidentally
 409 -- running code planted by a malicious third party.
 410
 411 -- Furthermore, We only read ./.ghci if . is owned by the current user
 412 -- and isn't writable by anyone else.  I think this is sufficient: we
 413 -- don't need to check .. and ../.. etc. because "."  always refers to
 414 -- the same directory while a process is running.
 415
 416 checkPerms :: String -> IO Bool
 417 checkPerms name =
 418 #ifdef mingw32_HOST_OS
 419   return True
 420 #else
 421   Util.handle (\_ -> return False) $ do
 422      st <- getFileStatus name
 423      me <- getRealUserID
 424      if fileOwner st /= me then do
 425         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 426         return False
 427       else do
 428         let mode =  fileMode st
 429         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 430            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 431            then do
 432                putStrLn $ "*** WARNING: " ++ name ++
 433                           " is writable by someone else, IGNORING!"
 434                return False
 435           else return True
 436 #endif
 437
 438 fileLoop :: Handle -> Bool -> GHCi ()
 439 fileLoop hdl show_prompt = do
 440    when show_prompt $ do
 441         prompt <- mkPrompt
 442         (io (putStr prompt))
 443    l <- io (IO.try (hGetLine hdl))
 444    case l of
 445         Left e | isEOFError e              -> return ()
 446                | InvalidArgument <- etype  -> return ()
 447                | otherwise                 -> io (ioError e)
 448                 where etype = ioeGetErrorType e
 449                 -- treat InvalidArgument in the same way as EOF:
 450                 -- this can happen if the user closed stdin, or
 451                 -- perhaps did getContents which closes stdin at
 452                 -- EOF.
 453         Right l ->
 454           case removeSpaces l of
 455             "" -> fileLoop hdl show_prompt
 456             l  -> do quit <- runCommands l
 457                      if quit then return () else fileLoop hdl show_prompt
 458
 459 mkPrompt = do
 460   session <- getSession
 461   (toplevs,exports) <- io (GHC.getContext session)
 462   resumes <- io $ GHC.getResumeContext session
 463
 464   context_bit <-
 465         case resumes of
 466             [] -> return empty
 467             r:rs -> do
 468                 let ix = GHC.resumeHistoryIx r
 469                 if ix == 0
 470                    then return (brackets (ppr (GHC.resumeSpan r)) <> space)
 471                    else do
 472                         let hist = GHC.resumeHistory r !! (ix-1)
 473                         span <- io $ GHC.getHistorySpan session hist
 474                         return (brackets (ppr (negate ix) <> char ':'
 475                                           <+> ppr span) <> space)
 476   let
 477         dots | r:rs <- resumes, not (null rs) = text "... "
 478              | otherwise = empty
 479
 480         modules_bit =
 481              hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 482              hsep (map (ppr . GHC.moduleName) exports)
 483
 484         deflt_prompt = dots <> context_bit <> modules_bit
 485
 486         f ('%':'s':xs) = deflt_prompt <> f xs
 487         f ('%':'%':xs) = char '%' <> f xs
 488         f (x:xs) = char x <> f xs
 489         f [] = empty
 490    --
 491   st <- getGHCiState
 492   return (showSDoc (f (prompt st)))
 493
 494
 495 #ifdef USE_READLINE
 496 readlineLoop :: GHCi ()
 497 readlineLoop = do
 498    session <- getSession
 499    (mod,imports) <- io (GHC.getContext session)
 500    io yield
 501    saveSession -- for use by completion
 502    st <- getGHCiState
 503    mb_span <- getCurrentBreakSpan
 504    prompt <- mkPrompt
 505    l <- io (readline prompt `finally` setNonBlockingFD 0)
 506                 -- readline sometimes puts stdin into blocking mode,
 507                 -- so we need to put it back for the IO library
 508    splatSavedSession
 509    case l of
 510         Nothing -> return ()
 511         Just l  ->
 512           case removeSpaces l of
 513             "" -> readlineLoop
 514             l  -> do
 515                   io (addHistory l)
 516                   quit <- runCommands l
 517                   if quit then return () else readlineLoop
 518 #endif
 519
 520 runCommands :: String -> GHCi Bool
 521 runCommands cmd = do
 522         q <- ghciHandle handler (doCommand cmd)
 523         if q then return True else runNext
 524   where
 525        runNext = do
 526           st <- getGHCiState
 527           case cmdqueue st of
 528             []   -> return False
 529             c:cs -> do setGHCiState st{ cmdqueue = cs }
 530                        runCommands c
 531
 532        doCommand (':' : cmd) = specialCommand cmd
 533        doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
 534                                   return False
 535
 536 enqueueCommands :: [String] -> GHCi ()
 537 enqueueCommands cmds = do
 538   st <- getGHCiState
 539   setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
 540
 541
 542 -- This version is for the GHC command-line option -e.  The only difference
 543 -- from runCommand is that it catches the ExitException exception and
 544 -- exits, rather than printing out the exception.
 545 runCommandEval c = ghciHandle handleEval (doCommand c)
 546   where
 547     handleEval (ExitException code) = io (exitWith code)
 548     handleEval e                    = do handler e
 549                                          io (exitWith (ExitFailure 1))
 550
 551     doCommand (':' : command) = specialCommand command
 552     doCommand stmt
 553        = do r <- runStmt stmt GHC.RunToCompletion
 554             case r of
 555                 False -> io (exitWith (ExitFailure 1))
 556                   -- failure to run the command causes exit(1) for ghc -e.
 557                 _       -> return True
 558
 559 runStmt :: String -> SingleStep -> GHCi Bool
 560 runStmt stmt step
 561  | null (filter (not.isSpace) stmt) = return False
 562  | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
 563  | otherwise
 564  = do st <- getGHCiState
 565       session <- getSession
 566       result <- io $ withProgName (progname st) $ withArgs (args st) $
 567                      GHC.runStmt session stmt step
 568       afterRunStmt result
 569
 570
 571 afterRunStmt :: GHC.RunResult -> GHCi Bool
 572                                  -- False <=> the statement failed to compile
 573 afterRunStmt (GHC.RunException e) = throw e
 574 afterRunStmt run_result = do
 575   session <- getSession
 576   case run_result of
 577      GHC.RunOk names -> do
 578         show_types <- isOptionSet ShowType
 579         when show_types $ mapM_ (showTypeOfName session) names
 580      GHC.RunBreak _ names mb_info -> do
 581         resumes <- io $ GHC.getResumeContext session
 582         printForUser $ ptext SLIT("Stopped at") <+>
 583                        ppr (GHC.resumeSpan (head resumes))
 584         mapM_ (showTypeOfName session) names
 585         maybe (return ()) runBreakCmd mb_info
 586         -- run the command set with ":set stop <cmd>"
 587         st <- getGHCiState
 588         enqueueCommands [stop st]
 589         return ()
 590      _ -> return ()
 591
 592   flushInterpBuffers
 593   io installSignalHandlers
 594   b <- isOptionSet RevertCAFs
 595   io (when b revertCAFs)
 596
 597   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 598
 599 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 600 runBreakCmd info = do
 601   let mod = GHC.breakInfo_module info
 602       nm  = GHC.breakInfo_number info
 603   st <- getGHCiState
 604   case  [ loc | (i,loc) <- breaks st,
 605                 breakModule loc == mod, breakTick loc == nm ] of
 606         []  -> return ()
 607         loc:_ | null cmd  -> return ()
 608               | otherwise -> do enqueueCommands [cmd]; return ()
 609               where cmd = onBreakCmd loc
 610
 611 showTypeOfName :: Session -> Name -> GHCi ()
 612 showTypeOfName session n
 613    = do maybe_tything <- io (GHC.lookupName session n)
 614         case maybe_tything of
 615           Nothing    -> return ()
 616           Just thing -> showTyThing 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, prefixMatch str 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 exts = dopt Opt_GlasgowExts dflags
 670              ; mapM_ (infoThing exts session) names }
 671   where
 672     infoThing exts session str = io $ do
 673         names <- GHC.parseName session str
 674         let filtered = filterOutChildren names
 675         mb_stuffs <- mapM (GHC.getInfo session) filtered
 676         unqual <- GHC.getPrintUnqual session
 677         putStrLn (showSDocForUser unqual $
 678                    vcat (intersperse (text "") $
 679                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 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 :: [Name] -> [Name]
 685 filterOutChildren names = filter (not . parent_is_there) names
 686  where parent_is_there n
 687 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 688 -- ToDo!!
 689          | otherwise                       = False
 690
 691 pprInfo exts (thing, fixity, insts)
 692   =  pprTyThingInContextLoc exts 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)
 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    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1000
1001             filtered = filterOutChildren names
1002
1003         things <- io $ mapM (GHC.lookupName s) filtered
1004
1005         dflags <- getDynFlags
1006         let exts = dopt Opt_GlasgowExts dflags
1007         io (putStrLn (showSDocForUser unqual (
1008                 vcat (map (pprTyThingInContext exts) (catMaybes 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_ showTyThing bindings
1255   return ()
1256
1257 showTyThing (AnId id) = do
1258   ty' <- cleanType (GHC.idType id)
1259   printForUser $ ppr id <> text " :: " <> ppr ty'
1260 showTyThing _  = return ()
1261
1262 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1263 cleanType :: Type -> GHCi Type
1264 cleanType ty = do
1265   dflags <- getDynFlags
1266   if dopt Opt_GlasgowExts dflags
1267         then return ty
1268         else return $! GHC.dropForAlls ty
1269
1270 showBkptTable :: GHCi ()
1271 showBkptTable = do
1272   st <- getGHCiState
1273   printForUser $ prettyLocations (breaks st)
1274
1275 showContext :: GHCi ()
1276 showContext = do
1277    session <- getSession
1278    resumes <- io $ GHC.getResumeContext session
1279    printForUser $ vcat (map pp_resume (reverse resumes))
1280   where
1281    pp_resume resume =
1282         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1283         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1284
1285
1286 -- -----------------------------------------------------------------------------
1287 -- Completion
1288
1289 completeNone :: String -> IO [String]
1290 completeNone w = return []
1291
1292 #ifdef USE_READLINE
1293 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1294 completeWord w start end = do
1295   line <- Readline.getLineBuffer
1296   case w of
1297      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1298      _other
1299         | Just c <- is_cmd line -> do
1300            maybe_cmd <- lookupCommand c
1301            let (n,w') = selectWord (words' 0 line)
1302            case maybe_cmd of
1303              Nothing -> return Nothing
1304              Just (_,_,False,complete) -> wrapCompleter complete w
1305              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1306                                                               return (map (drop n) rets)
1307                                          in wrapCompleter complete' w'
1308         | otherwise     -> do
1309                 --printf "complete %s, start = %d, end = %d\n" w start end
1310                 wrapCompleter completeIdentifier w
1311     where words' _ [] = []
1312           words' n str = let (w,r) = break isSpace str
1313                              (s,r') = span isSpace r
1314                          in (n,w):words' (n+length w+length s) r'
1315           -- In a Haskell expression we want to parse 'a-b' as three words
1316           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1317           -- only be a single word.
1318           selectWord [] = (0,w)
1319           selectWord ((offset,x):xs)
1320               | offset+length x >= start = (start-offset,take (end-offset) x)
1321               | otherwise = selectWord xs
1322
1323 is_cmd line
1324  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1325  | otherwise = Nothing
1326
1327 completeCmd w = do
1328   cmds <- readIORef commands
1329   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1330
1331 completeMacro w = do
1332   cmds <- readIORef commands
1333   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1334   return (filter (w `isPrefixOf`) cmds')
1335
1336 completeIdentifier w = do
1337   s <- restoreSession
1338   rdrs <- GHC.getRdrNamesInScope s
1339   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1340
1341 completeModule w = do
1342   s <- restoreSession
1343   dflags <- GHC.getSessionDynFlags s
1344   let pkg_mods = allExposedModules dflags
1345   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1346
1347 completeHomeModule w = do
1348   s <- restoreSession
1349   g <- GHC.getModuleGraph s
1350   let home_mods = map GHC.ms_mod_name g
1351   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1352
1353 completeSetOptions w = do
1354   return (filter (w `isPrefixOf`) options)
1355     where options = "args":"prog":allFlags
1356
1357 completeFilename = Readline.filenameCompletionFunction
1358
1359 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1360
1361 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1362 unionComplete f1 f2 w = do
1363   s1 <- f1 w
1364   s2 <- f2 w
1365   return (s1 ++ s2)
1366
1367 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1368 wrapCompleter fun w =  do
1369   strs <- fun w
1370   case strs of
1371     []  -> return Nothing
1372     [x] -> return (Just (x,[]))
1373     xs  -> case getCommonPrefix xs of
1374                 ""   -> return (Just ("",xs))
1375                 pref -> return (Just (pref,xs))
1376
1377 getCommonPrefix :: [String] -> String
1378 getCommonPrefix [] = ""
1379 getCommonPrefix (s:ss) = foldl common s ss
1380   where common s "" = ""
1381         common "" s = ""
1382         common (c:cs) (d:ds)
1383            | c == d = c : common cs ds
1384            | otherwise = ""
1385
1386 allExposedModules :: DynFlags -> [ModuleName]
1387 allExposedModules dflags
1388  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1389  where
1390   pkg_db = pkgIdMap (pkgState dflags)
1391 #else
1392 completeCmd        = completeNone
1393 completeMacro      = completeNone
1394 completeIdentifier = completeNone
1395 completeModule     = completeNone
1396 completeHomeModule = completeNone
1397 completeSetOptions = completeNone
1398 completeFilename   = completeNone
1399 completeHomeModuleOrFile=completeNone
1400 completeBkpt       = completeNone
1401 #endif
1402
1403 -- ---------------------------------------------------------------------------
1404 -- User code exception handling
1405
1406 -- This is the exception handler for exceptions generated by the
1407 -- user's code and exceptions coming from children sessions;
1408 -- it normally just prints out the exception.  The
1409 -- handler must be recursive, in case showing the exception causes
1410 -- more exceptions to be raised.
1411 --
1412 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1413 -- raising another exception.  We therefore don't put the recursive
1414 -- handler arond the flushing operation, so if stderr is closed
1415 -- GHCi will just die gracefully rather than going into an infinite loop.
1416 handler :: Exception -> GHCi Bool
1417
1418 handler exception = do
1419   flushInterpBuffers
1420   io installSignalHandlers
1421   ghciHandle handler (showException exception >> return False)
1422
1423 showException (DynException dyn) =
1424   case fromDynamic dyn of
1425     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1426     Just Interrupted      -> io (putStrLn "Interrupted.")
1427     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1428     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1429     Just other_ghc_ex     -> io (print other_ghc_ex)
1430
1431 showException other_exception
1432   = io (putStrLn ("*** Exception: " ++ show other_exception))
1433
1434 -----------------------------------------------------------------------------
1435 -- recursive exception handlers
1436
1437 -- Don't forget to unblock async exceptions in the handler, or if we're
1438 -- in an exception loop (eg. let a = error a in a) the ^C exception
1439 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1440
1441 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1442 ghciHandle h (GHCi m) = GHCi $ \s ->
1443    Exception.catch (m s)
1444         (\e -> unGHCi (ghciUnblock (h e)) s)
1445
1446 ghciUnblock :: GHCi a -> GHCi a
1447 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1448
1449
1450 -- ----------------------------------------------------------------------------
1451 -- Utils
1452
1453 expandPath :: String -> GHCi String
1454 expandPath path =
1455   case dropWhile isSpace path of
1456    ('~':d) -> do
1457         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1458         return (tilde ++ '/':d)
1459    other ->
1460         return other
1461
1462 wantInterpretedModule :: String -> GHCi Module
1463 wantInterpretedModule str = do
1464    session <- getSession
1465    modl <- lookupModule str
1466    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1467    when (not is_interpreted) $
1468        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1469    return modl
1470
1471 wantNameFromInterpretedModule noCanDo str and_then = do
1472    session <- getSession
1473    names <- io $ GHC.parseName session str
1474    case names of
1475       []    -> return ()
1476       (n:_) -> do
1477             let modl = GHC.nameModule n
1478             if not (GHC.isExternalName n)
1479                then noCanDo n $ ppr n <>
1480                                 text " is not defined in an interpreted module"
1481                else do
1482             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1483             if not is_interpreted
1484                then noCanDo n $ text "module " <> ppr modl <>
1485                                 text " is not interpreted"
1486                else and_then n
1487
1488 -- ----------------------------------------------------------------------------
1489 -- Windows console setup
1490
1491 setUpConsole :: IO ()
1492 setUpConsole = do
1493 #ifdef mingw32_HOST_OS
1494         -- On Windows we need to set a known code page, otherwise the characters
1495         -- we read from the console will be be in some strange encoding, and
1496         -- similarly for characters we write to the console.
1497         --
1498         -- At the moment, GHCi pretends all input is Latin-1.  In the
1499         -- future we should support UTF-8, but for now we set the code pages
1500         -- to Latin-1.
1501         --
1502         -- It seems you have to set the font in the console window to
1503         -- a Unicode font in order for output to work properly,
1504         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1505         -- (see MSDN for SetConsoleOutputCP()).
1506         --
1507         setConsoleCP 28591       -- ISO Latin-1
1508         setConsoleOutputCP 28591 -- ISO Latin-1
1509 #endif
1510         return ()
1511
1512 -- -----------------------------------------------------------------------------
1513 -- commands for debugger
1514
1515 sprintCmd = pprintCommand False False
1516 printCmd  = pprintCommand True False
1517 forceCmd  = pprintCommand False True
1518
1519 pprintCommand bind force str = do
1520   session <- getSession
1521   io $ pprintClosureCommand session bind force str
1522
1523 stepCmd :: String -> GHCi ()
1524 stepCmd []         = doContinue GHC.SingleStep
1525 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1526
1527 traceCmd :: String -> GHCi ()
1528 traceCmd []         = doContinue GHC.RunAndLogSteps
1529 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1530
1531 continueCmd :: String -> GHCi ()
1532 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1533
1534 doContinue :: SingleStep -> GHCi ()
1535 doContinue step = do
1536   session <- getSession
1537   runResult <- io $ GHC.resume session step
1538   afterRunStmt runResult
1539   return ()
1540
1541 abandonCmd :: String -> GHCi ()
1542 abandonCmd = noArgs $ do
1543   s <- getSession
1544   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1545   when (not b) $ io $ putStrLn "There is no computation running."
1546   return ()
1547
1548 deleteCmd :: String -> GHCi ()
1549 deleteCmd argLine = do
1550    deleteSwitch $ words argLine
1551    where
1552    deleteSwitch :: [String] -> GHCi ()
1553    deleteSwitch [] =
1554       io $ putStrLn "The delete command requires at least one argument."
1555    -- delete all break points
1556    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1557    deleteSwitch idents = do
1558       mapM_ deleteOneBreak idents
1559       where
1560       deleteOneBreak :: String -> GHCi ()
1561       deleteOneBreak str
1562          | all isDigit str = deleteBreak (read str)
1563          | otherwise = return ()
1564
1565 historyCmd :: String -> GHCi ()
1566 historyCmd arg
1567   | null arg        = history 20
1568   | all isDigit arg = history (read arg)
1569   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1570   where
1571   history num = do
1572     s <- getSession
1573     resumes <- io $ GHC.getResumeContext s
1574     case resumes of
1575       [] -> io $ putStrLn "Not stopped at a breakpoint"
1576       (r:rs) -> do
1577         let hist = GHC.resumeHistory r
1578             (took,rest) = splitAt num hist
1579         spans <- mapM (io . GHC.getHistorySpan s) took
1580         let nums = map (printf "-%-3d:") [(1::Int)..]
1581         printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1582         io $ putStrLn $ if null rest then "<end of history>" else "..."
1583
1584 backCmd :: String -> GHCi ()
1585 backCmd = noArgs $ do
1586   s <- getSession
1587   (names, ix, span) <- io $ GHC.back s
1588   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1589   mapM_ (showTypeOfName s) names
1590    -- run the command set with ":set stop <cmd>"
1591   st <- getGHCiState
1592   enqueueCommands [stop st]
1593
1594 forwardCmd :: String -> GHCi ()
1595 forwardCmd = noArgs $ do
1596   s <- getSession
1597   (names, ix, span) <- io $ GHC.forward s
1598   printForUser $ (if (ix == 0)
1599                     then ptext SLIT("Stopped at")
1600                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1601   mapM_ (showTypeOfName s) names
1602    -- run the command set with ":set stop <cmd>"
1603   st <- getGHCiState
1604   enqueueCommands [stop st]
1605
1606 -- handle the "break" command
1607 breakCmd :: String -> GHCi ()
1608 breakCmd argLine = do
1609    session <- getSession
1610    breakSwitch session $ words argLine
1611
1612 breakSwitch :: Session -> [String] -> GHCi ()
1613 breakSwitch _session [] = do
1614    io $ putStrLn "The break command requires at least one argument."
1615 breakSwitch session args@(arg1:rest)
1616    | looksLikeModuleName arg1 = do
1617         mod <- wantInterpretedModule arg1
1618         breakByModule session mod rest
1619    | all isDigit arg1 = do
1620         (toplevel, _) <- io $ GHC.getContext session
1621         case toplevel of
1622            (mod : _) -> breakByModuleLine mod (read arg1) rest
1623            [] -> do
1624               io $ putStrLn "Cannot find default module for breakpoint."
1625               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1626    | otherwise = do -- try parsing it as an identifier
1627         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1628         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1629         if GHC.isGoodSrcLoc loc
1630                then findBreakAndSet (GHC.nameModule name) $
1631                          findBreakByCoord (Just (GHC.srcLocFile loc))
1632                                           (GHC.srcLocLine loc,
1633                                            GHC.srcLocCol loc)
1634                else noCanDo name $ text "can't find its location: " <> ppr loc
1635        where
1636           noCanDo n why = printForUser $
1637                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1638
1639 breakByModule :: Session -> Module -> [String] -> GHCi ()
1640 breakByModule session mod args@(arg1:rest)
1641    | all isDigit arg1 = do  -- looks like a line number
1642         breakByModuleLine mod (read arg1) rest
1643    | otherwise = io $ putStrLn "Invalid arguments to :break"
1644
1645 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1646 breakByModuleLine mod line args
1647    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1648    | [col] <- args, all isDigit col =
1649         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1650    | otherwise = io $ putStrLn "Invalid arguments to :break"
1651
1652 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1653 findBreakAndSet mod lookupTickTree = do
1654    tickArray <- getTickArray mod
1655    (breakArray, _) <- getModBreak mod
1656    case lookupTickTree tickArray of
1657       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1658       Just (tick, span) -> do
1659          success <- io $ setBreakFlag True breakArray tick
1660          session <- getSession
1661          if success
1662             then do
1663                (alreadySet, nm) <-
1664                      recordBreak $ BreakLocation
1665                              { breakModule = mod
1666                              , breakLoc = span
1667                              , breakTick = tick
1668                              , onBreakCmd = ""
1669                              }
1670                printForUser $
1671                   text "Breakpoint " <> ppr nm <>
1672                   if alreadySet
1673                      then text " was already set at " <> ppr span
1674                      else text " activated at " <> ppr span
1675             else do
1676             printForUser $ text "Breakpoint could not be activated at"
1677                                  <+> ppr span
1678
1679 -- When a line number is specified, the current policy for choosing
1680 -- the best breakpoint is this:
1681 --    - the leftmost complete subexpression on the specified line, or
1682 --    - the leftmost subexpression starting on the specified line, or
1683 --    - the rightmost subexpression enclosing the specified line
1684 --
1685 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1686 findBreakByLine line arr
1687   | not (inRange (bounds arr) line) = Nothing
1688   | otherwise =
1689     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1690     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1691     listToMaybe (sortBy rightmost ticks)
1692   where
1693         ticks = arr ! line
1694
1695         starts_here = [ tick | tick@(nm,span) <- ticks,
1696                                GHC.srcSpanStartLine span == line ]
1697
1698         (complete,incomplete) = partition ends_here starts_here
1699             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1700
1701 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1702                  -> Maybe (BreakIndex,SrcSpan)
1703 findBreakByCoord mb_file (line, col) arr
1704   | not (inRange (bounds arr) line) = Nothing
1705   | otherwise =
1706     listToMaybe (sortBy rightmost contains) `mplus`
1707     listToMaybe (sortBy leftmost_smallest after_here)
1708   where
1709         ticks = arr ! line
1710
1711         -- the ticks that span this coordinate
1712         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1713                             is_correct_file span ]
1714
1715         is_correct_file span
1716                  | Just f <- mb_file = GHC.srcSpanFile span == f
1717                  | otherwise         = True
1718
1719         after_here = [ tick | tick@(nm,span) <- ticks,
1720                               GHC.srcSpanStartLine span == line,
1721                               GHC.srcSpanStartCol span >= col ]
1722
1723
1724 leftmost_smallest  (_,a) (_,b) = a `compare` b
1725 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1726                                 `thenCmp`
1727                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1728 rightmost (_,a) (_,b) = b `compare` a
1729
1730 spans :: SrcSpan -> (Int,Int) -> Bool
1731 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1732    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1733
1734 -- for now, use ANSI bold on Unixy systems.  On Windows, we add a line
1735 -- of carets under the active expression instead.  The Windows console
1736 -- doesn't support ANSI escape sequences, and most Unix terminals
1737 -- (including xterm) do, so this is a reasonable guess until we have a
1738 -- proper termcap/terminfo library.
1739 #if !defined(mingw32_TARGET_OS)
1740 do_bold = True
1741 #else
1742 do_bold = False
1743 #endif
1744
1745 start_bold = BS.pack "\ESC[1m"
1746 end_bold   = BS.pack "\ESC[0m"
1747
1748 listCmd :: String -> GHCi ()
1749 listCmd "" = do
1750    mb_span <- getCurrentBreakSpan
1751    case mb_span of
1752       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1753       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1754                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
1755 listCmd str = list2 (words str)
1756
1757 list2 [arg] | all isDigit arg = do
1758     session <- getSession
1759     (toplevel, _) <- io $ GHC.getContext session
1760     case toplevel of
1761         [] -> io $ putStrLn "No module to list"
1762         (mod : _) -> listModuleLine mod (read arg)
1763 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1764         mod <- wantInterpretedModule arg1
1765         listModuleLine mod (read arg2)
1766 list2 [arg] = do
1767         wantNameFromInterpretedModule noCanDo arg $ \name -> do
1768         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1769         if GHC.isGoodSrcLoc loc
1770                then do
1771                   tickArray <- getTickArray (GHC.nameModule name)
1772                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1773                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
1774                                         tickArray
1775                   case mb_span of
1776                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
1777                     Just (_,span) -> io $ listAround span False
1778                else
1779                   noCanDo name $ text "can't find its location: " <>
1780                                  ppr loc
1781     where
1782         noCanDo n why = printForUser $
1783             text "cannot list source code for " <> ppr n <> text ": " <> why
1784 list2  _other =
1785         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
1786
1787 listModuleLine :: Module -> Int -> GHCi ()
1788 listModuleLine modl line = do
1789    session <- getSession
1790    graph <- io (GHC.getModuleGraph session)
1791    let this = filter ((== modl) . GHC.ms_mod) graph
1792    case this of
1793      [] -> panic "listModuleLine"
1794      summ:_ -> do
1795            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1796                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1797            io $ listAround (GHC.srcLocSpan loc) False
1798
1799 -- | list a section of a source file around a particular SrcSpan.
1800 -- If the highlight flag is True, also highlight the span using
1801 -- start_bold/end_bold.
1802 listAround span do_highlight = do
1803       pwd      <- getEnv "PWD"
1804       contents <- BS.readFile (pwd `joinFileName` unpackFS file)
1805       let
1806           lines = BS.split '\n' contents
1807           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1808                         drop (line1 - 1 - pad_before) $ lines
1809           fst_line = max 1 (line1 - pad_before)
1810           line_nos = [ fst_line .. ]
1811
1812           highlighted | do_highlight = zipWith highlight line_nos these_lines
1813                       | otherwise   = these_lines
1814
1815           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1816           prefixed = zipWith BS.append bs_line_nos highlighted
1817       --
1818       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1819   where
1820         file  = GHC.srcSpanFile span
1821         line1 = GHC.srcSpanStartLine span
1822         col1  = GHC.srcSpanStartCol span
1823         line2 = GHC.srcSpanEndLine span
1824         col2  = GHC.srcSpanEndCol span
1825
1826         pad_before | line1 == 1 = 0
1827                    | otherwise  = 1
1828         pad_after = 1
1829
1830         highlight | do_bold   = highlight_bold
1831                   | otherwise = highlight_carets
1832
1833         highlight_bold no line
1834           | no == line1 && no == line2
1835           = let (a,r) = BS.splitAt col1 line
1836                 (b,c) = BS.splitAt (col2-col1) r
1837             in
1838             BS.concat [a,start_bold,b,end_bold,c]
1839           | no == line1
1840           = let (a,b) = BS.splitAt col1 line in
1841             BS.concat [a, start_bold, b]
1842           | no == line2
1843           = let (a,b) = BS.splitAt col2 line in
1844             BS.concat [a, end_bold, b]
1845           | otherwise   = line
1846
1847         highlight_carets no line
1848           | no == line1 && no == line2
1849           = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1850                                          BS.replicate (col2-col1) '^']
1851           | no == line1
1852           = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1853                                          BS.replicate (BS.length line-col1) '^']
1854           | no == line2
1855           = BS.concat [line, nl, indent, BS.replicate col2 '^']
1856           | otherwise   = line
1857          where
1858            indent = BS.pack "   "
1859            nl = BS.singleton '\n'
1860
1861 -- --------------------------------------------------------------------------
1862 -- Tick arrays
1863
1864 getTickArray :: Module -> GHCi TickArray
1865 getTickArray modl = do
1866    st <- getGHCiState
1867    let arrmap = tickarrays st
1868    case lookupModuleEnv arrmap modl of
1869       Just arr -> return arr
1870       Nothing  -> do
1871         (breakArray, ticks) <- getModBreak modl
1872         let arr = mkTickArray (assocs ticks)
1873         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1874         return arr
1875
1876 discardTickArrays :: GHCi ()
1877 discardTickArrays = do
1878    st <- getGHCiState
1879    setGHCiState st{tickarrays = emptyModuleEnv}
1880
1881 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1882 mkTickArray ticks
1883   = accumArray (flip (:)) [] (1, max_line)
1884         [ (line, (nm,span)) | (nm,span) <- ticks,
1885                               line <- srcSpanLines span ]
1886     where
1887         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1888         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1889                               GHC.srcSpanEndLine span ]
1890
1891 lookupModule :: String -> GHCi Module
1892 lookupModule modName
1893    = do session <- getSession
1894         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1895
1896 -- don't reset the counter back to zero?
1897 discardActiveBreakPoints :: GHCi ()
1898 discardActiveBreakPoints = do
1899    st <- getGHCiState
1900    mapM (turnOffBreak.snd) (breaks st)
1901    setGHCiState $ st { breaks = [] }
1902
1903 deleteBreak :: Int -> GHCi ()
1904 deleteBreak identity = do
1905    st <- getGHCiState
1906    let oldLocations    = breaks st
1907        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
1908    if null this
1909       then printForUser (text "Breakpoint" <+> ppr identity <+>
1910                          text "does not exist")
1911       else do
1912            mapM (turnOffBreak.snd) this
1913            setGHCiState $ st { breaks = rest }
1914
1915 turnOffBreak loc = do
1916   (arr, _) <- getModBreak (breakModule loc)
1917   io $ setBreakFlag False arr (breakTick loc)
1918
1919 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1920 getModBreak mod = do
1921    session <- getSession
1922    Just mod_info <- io $ GHC.getModuleInfo session mod
1923    let modBreaks  = GHC.modInfoModBreaks mod_info
1924    let array      = GHC.modBreaks_flags modBreaks
1925    let ticks      = GHC.modBreaks_locs  modBreaks
1926    return (array, ticks)
1927
1928 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1929 setBreakFlag toggle array index
1930    | toggle    = GHC.setBreakOn array index
1931    | otherwise = GHC.setBreakOff array index
1932