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