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