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