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