ghc/InteractiveUI.hs

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