ghc/InteractiveUI.hs

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