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