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