ghc/InteractiveUI.hs

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