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