compiler/ghci/InteractiveUI.hs

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