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