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