ghc/InteractiveUI.hs

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