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