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