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