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