ghc/InteractiveUI.hs

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