ghc/InteractiveUI.hs

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