ghc/InteractiveUI.hs

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