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