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, Id )
  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                let namesSorted = sortBy compareNames names
 635                tythings <- catMaybes `liftM`
 636                               io (mapM (GHC.lookupName session) namesSorted)
 637
 638                printTypeAndContents session [id | AnId id <- tythings]
 639                maybe (return ()) runBreakCmd mb_info
 640                -- run the command set with ":set stop <cmd>"
 641                st <- getGHCiState
 642                enqueueCommands [stop st]
 643                return ()
 644          | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
 645                         afterRunStmt step_here >> return ()
 646      _ -> return ()
 647
 648   flushInterpBuffers
 649   io installSignalHandlers
 650   b <- isOptionSet RevertCAFs
 651   io (when b revertCAFs)
 652
 653   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 654
 655 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 656 runBreakCmd info = do
 657   let mod = GHC.breakInfo_module info
 658       nm  = GHC.breakInfo_number info
 659   st <- getGHCiState
 660   case  [ loc | (_,loc) <- breaks st,
 661                 breakModule loc == mod, breakTick loc == nm ] of
 662         []  -> return ()
 663         loc:_ | null cmd  -> return ()
 664               | otherwise -> do enqueueCommands [cmd]; return ()
 665               where cmd = onBreakCmd loc
 666
 667 printTypeOfNames :: Session -> [Name] -> GHCi ()
 668 printTypeOfNames session names
 669  = mapM_ (printTypeOfName session) $ sortBy compareNames names
 670
 671 compareNames :: Name -> Name -> Ordering
 672 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
 673     where compareWith n = (getOccString n, getSrcSpan n)
 674
 675 printTypeOfName :: Session -> Name -> GHCi ()
 676 printTypeOfName session n
 677    = do maybe_tything <- io (GHC.lookupName session n)
 678         case maybe_tything of
 679             Nothing    -> return ()
 680             Just thing -> printTyThing thing
 681
 682 printTypeAndContents :: Session -> [Id] -> GHCi ()
 683 printTypeAndContents session ids = do
 684               terms <- mapM (io . GHC.obtainTermB session 10 False) ids
 685               docs_terms <- mapM (io . showTerm session) terms
 686               dflags <- getDynFlags
 687               let pefas = dopt Opt_PrintExplicitForalls dflags
 688               printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
 689                                             (map (pprTyThing pefas . AnId) ids)
 690                                             docs_terms
 691
 692
 693 specialCommand :: String -> GHCi Bool
 694 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 695 specialCommand str = do
 696   let (cmd,rest) = break isSpace str
 697   maybe_cmd <- io (lookupCommand cmd)
 698   case maybe_cmd of
 699     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 700                                     ++ shortHelpText) >> return False)
 701     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 702
 703 lookupCommand :: String -> IO (Maybe Command)
 704 lookupCommand str = do
 705   macros <- readIORef macros_ref
 706   let cmds = builtin_commands ++ macros
 707   -- look for exact match first, then the first prefix match
 708   case [ c | c <- cmds, str == cmdName c ] of
 709      c:_ -> return (Just c)
 710      [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
 711                 [] -> return Nothing
 712                 c:_ -> return (Just c)
 713
 714
 715 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
 716 getCurrentBreakSpan = do
 717   session <- getSession
 718   resumes <- io $ GHC.getResumeContext session
 719   case resumes of
 720     [] -> return Nothing
 721     (r:_) -> do
 722         let ix = GHC.resumeHistoryIx r
 723         if ix == 0
 724            then return (Just (GHC.resumeSpan r))
 725            else do
 726                 let hist = GHC.resumeHistory r !! (ix-1)
 727                 span <- io $ GHC.getHistorySpan session hist
 728                 return (Just span)
 729
 730 getCurrentBreakModule :: GHCi (Maybe Module)
 731 getCurrentBreakModule = do
 732   session <- getSession
 733   resumes <- io $ GHC.getResumeContext session
 734   case resumes of
 735     [] -> return Nothing
 736     (r:_) -> do
 737         let ix = GHC.resumeHistoryIx r
 738         if ix == 0
 739            then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
 740            else do
 741                 let hist = GHC.resumeHistory r !! (ix-1)
 742                 return $ Just $ GHC.getHistoryModule  hist
 743
 744 -----------------------------------------------------------------------------
 745 -- Commands
 746
 747 noArgs :: GHCi () -> String -> GHCi ()
 748 noArgs m "" = m
 749 noArgs _ _  = io $ putStrLn "This command takes no arguments"
 750
 751 help :: String -> GHCi ()
 752 help _ = io (putStr helpText)
 753
 754 info :: String -> GHCi ()
 755 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 756 info s  = do { let names = words s
 757              ; session <- getSession
 758              ; dflags <- getDynFlags
 759              ; let pefas = dopt Opt_PrintExplicitForalls dflags
 760              ; mapM_ (infoThing pefas session) names }
 761   where
 762     infoThing pefas session str = io $ do
 763         names     <- GHC.parseName session str
 764         mb_stuffs <- mapM (GHC.getInfo session) names
 765         let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
 766         unqual <- GHC.getPrintUnqual session
 767         putStrLn (showSDocForUser unqual $
 768                    vcat (intersperse (text "") $
 769                          map (pprInfo pefas) filtered))
 770
 771   -- Filter out names whose parent is also there Good
 772   -- example is '[]', which is both a type and data
 773   -- constructor in the same type
 774 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
 775 filterOutChildren get_thing xs
 776   = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
 777   where
 778     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 779
 780 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
 781 pprInfo pefas (thing, fixity, insts)
 782   =  pprTyThingInContextLoc pefas thing
 783   $$ show_fixity fixity
 784   $$ vcat (map GHC.pprInstance insts)
 785   where
 786     show_fixity fix
 787         | fix == GHC.defaultFixity = empty
 788         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 789
 790 runMain :: String -> GHCi ()
 791 runMain args = do
 792   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 793   enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
 794
 795 addModule :: [FilePath] -> GHCi ()
 796 addModule files = do
 797   io (revertCAFs)                       -- always revert CAFs on load/add.
 798   files <- mapM expandPath files
 799   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 800   session <- getSession
 801   io (mapM_ (GHC.addTarget session) targets)
 802   ok <- io (GHC.load session LoadAllTargets)
 803   afterLoad ok session Nothing
 804
 805 changeDirectory :: String -> GHCi ()
 806 changeDirectory dir = do
 807   session <- getSession
 808   graph <- io (GHC.getModuleGraph session)
 809   when (not (null graph)) $
 810         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 811   io (GHC.setTargets session [])
 812   io (GHC.load session LoadAllTargets)
 813   setContextAfterLoad session []
 814   io (GHC.workingDirectoryChanged session)
 815   dir <- expandPath dir
 816   io (setCurrentDirectory dir)
 817
 818 editFile :: String -> GHCi ()
 819 editFile str =
 820   do file <- if null str then chooseEditFile else return str
 821      st <- getGHCiState
 822      let cmd = editor st
 823      when (null cmd)
 824        $ throwDyn (CmdLineError "editor not set, use :set editor")
 825      io $ system (cmd ++ ' ':file)
 826      return ()
 827
 828 -- The user didn't specify a file so we pick one for them.
 829 -- Our strategy is to pick the first module that failed to load,
 830 -- or otherwise the first target.
 831 --
 832 -- XXX: Can we figure out what happened if the depndecy analysis fails
 833 --      (e.g., because the porgrammeer mistyped the name of a module)?
 834 -- XXX: Can we figure out the location of an error to pass to the editor?
 835 -- XXX: if we could figure out the list of errors that occured during the
 836 -- last load/reaload, then we could start the editor focused on the first
 837 -- of those.
 838 chooseEditFile :: GHCi String
 839 chooseEditFile =
 840   do session <- getSession
 841      let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
 842
 843      graph <- io (GHC.getModuleGraph session)
 844      failed_graph <- filterM hasFailed graph
 845      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
 846          pick xs  = case xs of
 847                       x : _ -> GHC.ml_hs_file (GHC.ms_location x)
 848                       _     -> Nothing
 849
 850      case pick (order failed_graph) of
 851        Just file -> return file
 852        Nothing   ->
 853          do targets <- io (GHC.getTargets session)
 854             case msum (map fromTarget targets) of
 855               Just file -> return file
 856               Nothing   -> throwDyn (CmdLineError "No files to edit.")
 857
 858   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
 859         fromTarget _ = Nothing -- when would we get a module target?
 860
 861 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
 862 defineMacro overwrite s = do
 863   let (macro_name, definition) = break isSpace s
 864   macros <- io (readIORef macros_ref)
 865   let defined = map cmdName macros
 866   if (null macro_name)
 867         then if null defined
 868                 then io $ putStrLn "no macros defined"
 869                 else io $ putStr ("the following macros are defined:\n" ++
 870                                   unlines defined)
 871         else do
 872   if (not overwrite && macro_name `elem` defined)
 873         then throwDyn (CmdLineError
 874                 ("macro '" ++ macro_name ++ "' is already defined"))
 875         else do
 876
 877   let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
 878
 879   -- give the expression a type signature, so we can be sure we're getting
 880   -- something of the right type.
 881   let new_expr = '(' : definition ++ ") :: String -> IO String"
 882
 883   -- compile the expression
 884   cms <- getSession
 885   maybe_hv <- io (GHC.compileExpr cms new_expr)
 886   case maybe_hv of
 887      Nothing -> return ()
 888      Just hv -> io (writeIORef macros_ref --
 889                     (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
 890
 891 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 892 runMacro fun s = do
 893   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 894   enqueueCommands (lines str)
 895   return False
 896
 897 undefineMacro :: String -> GHCi ()
 898 undefineMacro str = mapM_ undef (words str)
 899  where undef macro_name = do
 900         cmds <- io (readIORef macros_ref)
 901         if (macro_name `notElem` map cmdName cmds)
 902            then throwDyn (CmdLineError
 903                 ("macro '" ++ macro_name ++ "' is not defined"))
 904            else do
 905             io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
 906
 907 cmdCmd :: String -> GHCi ()
 908 cmdCmd str = do
 909   let expr = '(' : str ++ ") :: IO String"
 910   session <- getSession
 911   maybe_hv <- io (GHC.compileExpr session expr)
 912   case maybe_hv of
 913     Nothing -> return ()
 914     Just hv -> do
 915         cmds <- io $ (unsafeCoerce# hv :: IO String)
 916         enqueueCommands (lines cmds)
 917         return ()
 918
 919 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 920 loadModule fs = timeIt (loadModule' fs)
 921
 922 loadModule_ :: [FilePath] -> GHCi ()
 923 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 924
 925 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 926 loadModule' files = do
 927   session <- getSession
 928
 929   -- unload first
 930   discardActiveBreakPoints
 931   io (GHC.setTargets session [])
 932   io (GHC.load session LoadAllTargets)
 933
 934   -- expand tildes
 935   let (filenames, phases) = unzip files
 936   exp_filenames <- mapM expandPath filenames
 937   let files' = zip exp_filenames phases
 938   targets <- io (mapM (uncurry GHC.guessTarget) files')
 939
 940   -- NOTE: we used to do the dependency anal first, so that if it
 941   -- fails we didn't throw away the current set of modules.  This would
 942   -- require some re-working of the GHC interface, so we'll leave it
 943   -- as a ToDo for now.
 944
 945   io (GHC.setTargets session targets)
 946   doLoad session False LoadAllTargets
 947
 948 checkModule :: String -> GHCi ()
 949 checkModule m = do
 950   let modl = GHC.mkModuleName m
 951   session <- getSession
 952   result <- io (GHC.checkModule session modl False)
 953   case result of
 954     Nothing -> io $ putStrLn "Nothing"
 955     Just r  -> io $ putStrLn (showSDoc (
 956         case GHC.checkedModuleInfo r of
 957            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 958                 let
 959                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 960                 in
 961                         (text "global names: " <+> ppr global) $$
 962                         (text "local  names: " <+> ppr local)
 963            _ -> empty))
 964   afterLoad (successIf (isJust result)) session Nothing
 965
 966 reloadModule :: String -> GHCi ()
 967 reloadModule m = do
 968   session <- getSession
 969   doLoad session True $ if null m then LoadAllTargets
 970                                   else LoadUpTo (GHC.mkModuleName m)
 971   return ()
 972
 973 doLoad :: Session -> Bool -> LoadHowMuch -> GHCi SuccessFlag
 974 doLoad session retain_context howmuch = do
 975   -- turn off breakpoints before we load: we can't turn them off later, because
 976   -- the ModBreaks will have gone away.
 977   discardActiveBreakPoints
 978   context <- io $ GHC.getContext session
 979   ok <- io (GHC.load session howmuch)
 980   afterLoad ok session (if retain_context then Just context else Nothing)
 981   return ok
 982
 983 afterLoad :: SuccessFlag -> Session -> Maybe ([Module],[Module]) -> GHCi ()
 984 afterLoad ok session maybe_context = do
 985   io (revertCAFs)  -- always revert CAFs on load.
 986   discardTickArrays
 987   loaded_mods <- getLoadedModules session
 988
 989   -- try to retain the old module context for :reload.  This might
 990   -- not be possible, for example if some modules have gone away, so
 991   -- we attempt to set the same context, backing off to the default
 992   -- context if that fails.
 993   case maybe_context of
 994      Nothing -> setContextAfterLoad session loaded_mods
 995      Just (as,bs) -> do
 996         r <- io $ Exception.try (GHC.setContext session as bs)
 997         case r of
 998            Left _err -> setContextAfterLoad session loaded_mods
 999            Right _   -> return ()
1000
1001   modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
1002
1003 setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()
1004 setContextAfterLoad session [] = do
1005   prel_mod <- getPrelude
1006   io (GHC.setContext session [] [prel_mod])
1007 setContextAfterLoad session ms = do
1008   -- load a target if one is available, otherwise load the topmost module.
1009   targets <- io (GHC.getTargets session)
1010   case [ m | Just m <- map (findTarget ms) targets ] of
1011         []    ->
1012           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1013           load_this (last graph')
1014         (m:_) ->
1015           load_this m
1016  where
1017    findTarget ms t
1018     = case filter (`matches` t) ms of
1019         []    -> Nothing
1020         (m:_) -> Just m
1021
1022    summary `matches` Target (TargetModule m) _
1023         = GHC.ms_mod_name summary == m
1024    summary `matches` Target (TargetFile f _) _
1025         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
1026    _ `matches` _
1027         = False
1028
1029    load_this summary | m <- GHC.ms_mod summary = do
1030         b <- io (GHC.moduleIsInterpreted session m)
1031         if b then io (GHC.setContext session [m] [])
1032              else do
1033                    prel_mod <- getPrelude
1034                    io (GHC.setContext session []  [prel_mod,m])
1035
1036
1037 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1038 modulesLoadedMsg ok mods = do
1039   dflags <- getDynFlags
1040   when (verbosity dflags > 0) $ do
1041    let mod_commas
1042         | null mods = text "none."
1043         | otherwise = hsep (
1044             punctuate comma (map ppr mods)) <> text "."
1045    case ok of
1046     Failed ->
1047        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1048     Succeeded  ->
1049        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1050
1051
1052 typeOfExpr :: String -> GHCi ()
1053 typeOfExpr str
1054   = do cms <- getSession
1055        maybe_ty <- io (GHC.exprType cms str)
1056        case maybe_ty of
1057           Nothing -> return ()
1058           Just ty -> do dflags <- getDynFlags
1059                         let pefas = dopt Opt_PrintExplicitForalls dflags
1060                         printForUser $ text str <+> dcolon
1061                                         <+> pprTypeForUser pefas ty
1062
1063 kindOfType :: String -> GHCi ()
1064 kindOfType str
1065   = do cms <- getSession
1066        maybe_ty <- io (GHC.typeKind cms str)
1067        case maybe_ty of
1068           Nothing    -> return ()
1069           Just ty    -> printForUser $ text str <+> dcolon <+> ppr ty
1070
1071 quit :: String -> GHCi Bool
1072 quit _ = return True
1073
1074 shellEscape :: String -> GHCi Bool
1075 shellEscape str = io (system str >> return False)
1076
1077 -----------------------------------------------------------------------------
1078 -- Browsing a module's contents
1079
1080 browseCmd :: Bool -> String -> GHCi ()
1081 browseCmd bang m =
1082   case words m of
1083     ['*':s] | looksLikeModuleName s -> do
1084         m <-  wantInterpretedModule s
1085         browseModule bang m False
1086     [s] | looksLikeModuleName s -> do
1087         m <- lookupModule s
1088         browseModule bang m True
1089     [] -> do
1090         s <- getSession
1091         (as,bs) <- io $ GHC.getContext s
1092                 -- Guess which module the user wants to browse.  Pick
1093                 -- modules that are interpreted first.  The most
1094                 -- recently-added module occurs last, it seems.
1095         case (as,bs) of
1096           (as@(_:_), _)   -> browseModule bang (last as) True
1097           ([],  bs@(_:_)) -> browseModule bang (last bs) True
1098           ([],  [])  -> throwDyn (CmdLineError ":browse: no current module")
1099     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
1100
1101 -- without bang, show items in context of their parents and omit children
1102 -- with bang, show class methods and data constructors separately, and
1103 --            indicate import modules, to aid qualifying unqualified names
1104 -- with sorted, sort items alphabetically
1105 browseModule :: Bool -> Module -> Bool -> GHCi ()
1106 browseModule bang modl exports_only = do
1107   s <- getSession
1108   -- Temporarily set the context to the module we're interested in,
1109   -- just so we can get an appropriate PrintUnqualified
1110   (as,bs) <- io (GHC.getContext s)
1111   prel_mod <- getPrelude
1112   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1113                       else GHC.setContext s [modl] [])
1114   unqual <- io (GHC.getPrintUnqual s)
1115   io (GHC.setContext s as bs)
1116
1117   mb_mod_info <- io $ GHC.getModuleInfo s modl
1118   case mb_mod_info of
1119     Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1120                                 GHC.moduleNameString (GHC.moduleName modl)))
1121     Just mod_info -> do
1122         dflags <- getDynFlags
1123         let names
1124                | exports_only = GHC.modInfoExports mod_info
1125                | otherwise    = GHC.modInfoTopLevelScope mod_info
1126                                 `orElse` []
1127
1128                 -- sort alphabetically name, but putting
1129                 -- locally-defined identifiers first.
1130                 -- We would like to improve this; see #1799.
1131             sorted_names = loc_sort local ++ occ_sort external
1132                 where
1133                 (local,external) = partition ((==modl) . nameModule) names
1134                 occ_sort = sortBy (compare `on` nameOccName)
1135                 -- try to sort by src location.  If the first name in
1136                 -- our list has a good source location, then they all should.
1137                 loc_sort names
1138                       | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1139                       = sortBy (compare `on` nameSrcSpan) names
1140                       | otherwise
1141                       = occ_sort names
1142
1143         mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1144         let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1145
1146         rdr_env <- io $ GHC.getGRE s
1147
1148         let pefas              = dopt Opt_PrintExplicitForalls dflags
1149             things | bang      = catMaybes mb_things
1150                    | otherwise = filtered_things
1151             pretty | bang      = pprTyThing
1152                    | otherwise = pprTyThingInContext
1153
1154             labels  [] = text "-- not currently imported"
1155             labels  l  = text $ intercalate "\n" $ map qualifier l
1156             qualifier  = maybe "-- defined locally"
1157                              (("-- imported from "++) . intercalate ", "
1158                                . map GHC.moduleNameString)
1159             importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1160             modNames   = map (importInfo . GHC.getName) things
1161
1162             -- annotate groups of imports with their import modules
1163             -- the default ordering is somewhat arbitrary, so we group
1164             -- by header and sort groups; the names themselves should
1165             -- really come in order of source appearance.. (trac #1799)
1166             annotate mts = concatMap (\(m,ts)->labels m:ts)
1167                          $ sortBy cmpQualifiers $ group mts
1168               where cmpQualifiers =
1169                       compare `on` (map (fmap (map moduleNameFS)) . fst)
1170             group []            = []
1171             group mts@((m,_):_) = (m,map snd g) : group ng
1172               where (g,ng) = partition ((==m).fst) mts
1173
1174         let prettyThings = map (pretty pefas) things
1175             prettyThings' | bang      = annotate $ zip modNames prettyThings
1176                           | otherwise = prettyThings
1177         io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1178         -- ToDo: modInfoInstances currently throws an exception for
1179         -- package modules.  When it works, we can do this:
1180         --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1181
1182 -----------------------------------------------------------------------------
1183 -- Setting the module context
1184
1185 setContext :: String -> GHCi ()
1186 setContext str
1187   | all sensible mods = fn mods
1188   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1189   where
1190     (fn, mods) = case str of
1191                         '+':stuff -> (addToContext,      words stuff)
1192                         '-':stuff -> (removeFromContext, words stuff)
1193                         stuff     -> (newContext,        words stuff)
1194
1195     sensible ('*':m) = looksLikeModuleName m
1196     sensible m       = looksLikeModuleName m
1197
1198 separate :: Session -> [String] -> [Module] -> [Module]
1199         -> GHCi ([Module],[Module])
1200 separate _       []             as bs = return (as,bs)
1201 separate session (('*':str):ms) as bs = do
1202   m <- wantInterpretedModule str
1203   separate session ms (m:as) bs
1204 separate session (str:ms) as bs = do
1205   m <- lookupModule str
1206   separate session ms as (m:bs)
1207
1208 newContext :: [String] -> GHCi ()
1209 newContext strs = do
1210   s <- getSession
1211   (as,bs) <- separate s strs [] []
1212   prel_mod <- getPrelude
1213   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1214   io $ GHC.setContext s as bs'
1215
1216
1217 addToContext :: [String] -> GHCi ()
1218 addToContext strs = do
1219   s <- getSession
1220   (as,bs) <- io $ GHC.getContext s
1221
1222   (new_as,new_bs) <- separate s strs [] []
1223
1224   let as_to_add = new_as \\ (as ++ bs)
1225       bs_to_add = new_bs \\ (as ++ bs)
1226
1227   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1228
1229
1230 removeFromContext :: [String] -> GHCi ()
1231 removeFromContext strs = do
1232   s <- getSession
1233   (as,bs) <- io $ GHC.getContext s
1234
1235   (as_to_remove,bs_to_remove) <- separate s strs [] []
1236
1237   let as' = as \\ (as_to_remove ++ bs_to_remove)
1238       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1239
1240   io $ GHC.setContext s as' bs'
1241
1242 ----------------------------------------------------------------------------
1243 -- Code for `:set'
1244
1245 -- set options in the interpreter.  Syntax is exactly the same as the
1246 -- ghc command line, except that certain options aren't available (-C,
1247 -- -E etc.)
1248 --
1249 -- This is pretty fragile: most options won't work as expected.  ToDo:
1250 -- figure out which ones & disallow them.
1251
1252 setCmd :: String -> GHCi ()
1253 setCmd ""
1254   = do st <- getGHCiState
1255        let opts = options st
1256        io $ putStrLn (showSDoc (
1257               text "options currently set: " <>
1258               if null opts
1259                    then text "none."
1260                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1261            ))
1262        dflags <- getDynFlags
1263        io $ putStrLn (showSDoc (
1264           vcat (text "GHCi-specific dynamic flag settings:"
1265                :map (flagSetting dflags) ghciFlags)
1266           ))
1267        io $ putStrLn (showSDoc (
1268           vcat (text "other dynamic, non-language, flag settings:"
1269                :map (flagSetting dflags) nonLanguageDynFlags)
1270           ))
1271   where flagSetting dflags (str,f)
1272           | dopt f dflags = text "  " <> text "-f"    <> text str
1273           | otherwise     = text "  " <> text "-fno-" <> text str
1274         (ghciFlags,others)  = partition (\(_,f)->f `elem` flags)
1275                                         DynFlags.fFlags
1276         nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1277                                      others
1278         flags = [Opt_PrintExplicitForalls
1279                 ,Opt_PrintBindResult
1280                 ,Opt_BreakOnException
1281                 ,Opt_BreakOnError
1282                 ,Opt_PrintEvldWithShow
1283                 ]
1284 setCmd str
1285   = case toArgs str of
1286         ("args":args) -> setArgs args
1287         ("prog":prog) -> setProg prog
1288         ("prompt":_)  -> setPrompt (after 6)
1289         ("editor":_)  -> setEditor (after 6)
1290         ("stop":_)    -> setStop (after 4)
1291         wds -> setOptions wds
1292    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1293
1294 setArgs, setProg, setOptions :: [String] -> GHCi ()
1295 setEditor, setStop, setPrompt :: String -> GHCi ()
1296
1297 setArgs args = do
1298   st <- getGHCiState
1299   setGHCiState st{ args = args }
1300
1301 setProg [prog] = do
1302   st <- getGHCiState
1303   setGHCiState st{ progname = prog }
1304 setProg _ = do
1305   io (hPutStrLn stderr "syntax: :set prog <progname>")
1306
1307 setEditor cmd = do
1308   st <- getGHCiState
1309   setGHCiState st{ editor = cmd }
1310
1311 setStop str@(c:_) | isDigit c
1312   = do let (nm_str,rest) = break (not.isDigit) str
1313            nm = read nm_str
1314        st <- getGHCiState
1315        let old_breaks = breaks st
1316        if all ((/= nm) . fst) old_breaks
1317               then printForUser (text "Breakpoint" <+> ppr nm <+>
1318                                  text "does not exist")
1319               else do
1320        let new_breaks = map fn old_breaks
1321            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1322                       | otherwise = (i,loc)
1323        setGHCiState st{ breaks = new_breaks }
1324 setStop cmd = do
1325   st <- getGHCiState
1326   setGHCiState st{ stop = cmd }
1327
1328 setPrompt value = do
1329   st <- getGHCiState
1330   if null value
1331       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1332       else setGHCiState st{ prompt = remQuotes value }
1333   where
1334      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1335      remQuotes x = x
1336
1337 setOptions wds =
1338    do -- first, deal with the GHCi opts (+s, +t, etc.)
1339       let (plus_opts, minus_opts)  = partitionWith isPlus wds
1340       mapM_ setOpt plus_opts
1341       -- then, dynamic flags
1342       newDynFlags minus_opts
1343
1344 newDynFlags :: [String] -> GHCi ()
1345 newDynFlags minus_opts = do
1346       dflags <- getDynFlags
1347       let pkg_flags = packageFlags dflags
1348       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1349
1350       if (not (null leftovers))
1351                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1352                                                 unwords leftovers))
1353                 else return ()
1354
1355       new_pkgs <- setDynFlags dflags'
1356
1357       -- if the package flags changed, we should reset the context
1358       -- and link the new packages.
1359       dflags <- getDynFlags
1360       when (packageFlags dflags /= pkg_flags) $ do
1361         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1362         session <- getSession
1363         io (GHC.setTargets session [])
1364         io (GHC.load session LoadAllTargets)
1365         io (linkPackages dflags new_pkgs)
1366         setContextAfterLoad session []
1367       return ()
1368
1369
1370 unsetOptions :: String -> GHCi ()
1371 unsetOptions str
1372   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1373        let opts = words str
1374            (minus_opts, rest1) = partition isMinus opts
1375            (plus_opts, rest2)  = partitionWith isPlus rest1
1376
1377        if (not (null rest2))
1378           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1379           else do
1380
1381        mapM_ unsetOpt plus_opts
1382
1383        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1384            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1385
1386        no_flags <- mapM no_flag minus_opts
1387        newDynFlags no_flags
1388
1389 isMinus :: String -> Bool
1390 isMinus ('-':_) = True
1391 isMinus _ = False
1392
1393 isPlus :: String -> Either String String
1394 isPlus ('+':opt) = Left opt
1395 isPlus other     = Right other
1396
1397 setOpt, unsetOpt :: String -> GHCi ()
1398
1399 setOpt str
1400   = case strToGHCiOpt str of
1401         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1402         Just o  -> setOption o
1403
1404 unsetOpt str
1405   = case strToGHCiOpt str of
1406         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1407         Just o  -> unsetOption o
1408
1409 strToGHCiOpt :: String -> (Maybe GHCiOption)
1410 strToGHCiOpt "s" = Just ShowTiming
1411 strToGHCiOpt "t" = Just ShowType
1412 strToGHCiOpt "r" = Just RevertCAFs
1413 strToGHCiOpt _   = Nothing
1414
1415 optToStr :: GHCiOption -> String
1416 optToStr ShowTiming = "s"
1417 optToStr ShowType   = "t"
1418 optToStr RevertCAFs = "r"
1419
1420 -- ---------------------------------------------------------------------------
1421 -- code for `:show'
1422
1423 showCmd :: String -> GHCi ()
1424 showCmd str = do
1425   st <- getGHCiState
1426   case words str of
1427         ["args"]     -> io $ putStrLn (show (args st))
1428         ["prog"]     -> io $ putStrLn (show (progname st))
1429         ["prompt"]   -> io $ putStrLn (show (prompt st))
1430         ["editor"]   -> io $ putStrLn (show (editor st))
1431         ["stop"]     -> io $ putStrLn (show (stop st))
1432         ["modules" ] -> showModules
1433         ["bindings"] -> showBindings
1434         ["linker"]   -> io showLinkerState
1435         ["breaks"]   -> showBkptTable
1436         ["context"]  -> showContext
1437         ["packages"]  -> showPackages
1438         ["languages"]  -> showLanguages
1439         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1440
1441 showModules :: GHCi ()
1442 showModules = do
1443   session <- getSession
1444   loaded_mods <- getLoadedModules session
1445         -- we want *loaded* modules only, see #1734
1446   let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1447   mapM_ show_one loaded_mods
1448
1449 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1450 getLoadedModules session = do
1451   graph <- io (GHC.getModuleGraph session)
1452   filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1453
1454 showBindings :: GHCi ()
1455 showBindings = do
1456   s <- getSession
1457   bindings <- io (GHC.getBindings s)
1458   printTypeAndContents s [ id | AnId id <- sortBy compareTyThings bindings]
1459
1460 compareTyThings :: TyThing -> TyThing -> Ordering
1461 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1462
1463 printTyThing :: TyThing -> GHCi ()
1464 printTyThing tyth = do dflags <- getDynFlags
1465                        let pefas = dopt Opt_PrintExplicitForalls dflags
1466                        printForUser (pprTyThing pefas tyth)
1467
1468 showBkptTable :: GHCi ()
1469 showBkptTable = do
1470   st <- getGHCiState
1471   printForUser $ prettyLocations (breaks st)
1472
1473 showContext :: GHCi ()
1474 showContext = do
1475    session <- getSession
1476    resumes <- io $ GHC.getResumeContext session
1477    printForUser $ vcat (map pp_resume (reverse resumes))
1478   where
1479    pp_resume resume =
1480         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1481         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1482
1483 showPackages :: GHCi ()
1484 showPackages = do
1485   pkg_flags <- fmap packageFlags getDynFlags
1486   io $ putStrLn $ showSDoc $ vcat $
1487     text ("active package flags:"++if null pkg_flags then " none" else "")
1488     : map showFlag pkg_flags
1489   pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1490   io $ putStrLn $ showSDoc $ vcat $
1491     text "packages currently loaded:"
1492     : map (nest 2 . text . packageIdString) pkg_ids
1493   where showFlag (ExposePackage p) = text $ "  -package " ++ p
1494         showFlag (HidePackage p)   = text $ "  -hide-package " ++ p
1495         showFlag (IgnorePackage p) = text $ "  -ignore-package " ++ p
1496
1497 showLanguages :: GHCi ()
1498 showLanguages = do
1499    dflags <- getDynFlags
1500    io $ putStrLn $ showSDoc $ vcat $
1501       text "active language flags:" :
1502       [text ("  -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1503
1504 -- -----------------------------------------------------------------------------
1505 -- Completion
1506
1507 completeNone :: String -> IO [String]
1508 completeNone _w = return []
1509
1510 completeMacro, completeIdentifier, completeModule,
1511     completeHomeModule, completeSetOptions, completeFilename,
1512     completeHomeModuleOrFile
1513     :: String -> IO [String]
1514
1515 #ifdef USE_READLINE
1516 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1517 completeWord w start end = do
1518   line <- Readline.getLineBuffer
1519   let line_words = words (dropWhile isSpace line)
1520   case w of
1521      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1522      _other
1523         | ((':':c) : _) <- line_words -> do
1524            maybe_cmd <- lookupCommand c
1525            let (n,w') = selectWord (words' 0 line)
1526            case maybe_cmd of
1527              Nothing -> return Nothing
1528              Just (_,_,False,complete) -> wrapCompleter complete w
1529              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1530                                                               return (map (drop n) rets)
1531                                          in wrapCompleter complete' w'
1532         | ("import" : _) <- line_words ->
1533                 wrapCompleter completeModule w
1534         | otherwise     -> do
1535                 --printf "complete %s, start = %d, end = %d\n" w start end
1536                 wrapCompleter completeIdentifier w
1537     where words' _ [] = []
1538           words' n str = let (w,r) = break isSpace str
1539                              (s,r') = span isSpace r
1540                          in (n,w):words' (n+length w+length s) r'
1541           -- In a Haskell expression we want to parse 'a-b' as three words
1542           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1543           -- only be a single word.
1544           selectWord [] = (0,w)
1545           selectWord ((offset,x):xs)
1546               | offset+length x >= start = (start-offset,take (end-offset) x)
1547               | otherwise = selectWord xs
1548
1549 completeCmd :: String -> IO [String]
1550 completeCmd w = do
1551   cmds <- readIORef macros_ref
1552   return (filter (w `isPrefixOf`) (map (':':)
1553              (map cmdName (builtin_commands ++ cmds))))
1554
1555 completeMacro w = do
1556   cmds <- readIORef macros_ref
1557   return (filter (w `isPrefixOf`) (map cmdName cmds))
1558
1559 completeIdentifier w = do
1560   s <- restoreSession
1561   rdrs <- GHC.getRdrNamesInScope s
1562   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1563
1564 completeModule w = do
1565   s <- restoreSession
1566   dflags <- GHC.getSessionDynFlags s
1567   let pkg_mods = allExposedModules dflags
1568   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1569
1570 completeHomeModule w = do
1571   s <- restoreSession
1572   g <- GHC.getModuleGraph s
1573   let home_mods = map GHC.ms_mod_name g
1574   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1575
1576 completeSetOptions w = do
1577   return (filter (w `isPrefixOf`) options)
1578     where options = "args":"prog":allFlags
1579
1580 completeFilename = Readline.filenameCompletionFunction
1581
1582 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1583
1584 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1585 unionComplete f1 f2 w = do
1586   s1 <- f1 w
1587   s2 <- f2 w
1588   return (s1 ++ s2)
1589
1590 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1591 wrapCompleter fun w =  do
1592   strs <- fun w
1593   case strs of
1594     []  -> return Nothing
1595     [x] -> return (Just (x,[]))
1596     xs  -> case getCommonPrefix xs of
1597                 ""   -> return (Just ("",xs))
1598                 pref -> return (Just (pref,xs))
1599
1600 getCommonPrefix :: [String] -> String
1601 getCommonPrefix [] = ""
1602 getCommonPrefix (s:ss) = foldl common s ss
1603   where common _s "" = ""
1604         common "" _s = ""
1605         common (c:cs) (d:ds)
1606            | c == d = c : common cs ds
1607            | otherwise = ""
1608
1609 allExposedModules :: DynFlags -> [ModuleName]
1610 allExposedModules dflags
1611  = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1612  where
1613   pkg_db = pkgIdMap (pkgState dflags)
1614 #else
1615 completeMacro      = completeNone
1616 completeIdentifier = completeNone
1617 completeModule     = completeNone
1618 completeHomeModule = completeNone
1619 completeSetOptions = completeNone
1620 completeFilename   = completeNone
1621 completeHomeModuleOrFile=completeNone
1622 #endif
1623
1624 -- ---------------------------------------------------------------------------
1625 -- User code exception handling
1626
1627 -- This is the exception handler for exceptions generated by the
1628 -- user's code and exceptions coming from children sessions;
1629 -- it normally just prints out the exception.  The
1630 -- handler must be recursive, in case showing the exception causes
1631 -- more exceptions to be raised.
1632 --
1633 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1634 -- raising another exception.  We therefore don't put the recursive
1635 -- handler arond the flushing operation, so if stderr is closed
1636 -- GHCi will just die gracefully rather than going into an infinite loop.
1637 handler :: Exception -> GHCi Bool
1638
1639 handler exception = do
1640   flushInterpBuffers
1641   io installSignalHandlers
1642   ghciHandle handler (showException exception >> return False)
1643
1644 showException :: Exception -> GHCi ()
1645 showException (DynException dyn) =
1646   case fromDynamic dyn of
1647     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1648     Just Interrupted      -> io (putStrLn "Interrupted.")
1649     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1650     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1651     Just other_ghc_ex     -> io (print other_ghc_ex)
1652
1653 showException other_exception
1654   = io (putStrLn ("*** Exception: " ++ show other_exception))
1655
1656 -----------------------------------------------------------------------------
1657 -- recursive exception handlers
1658
1659 -- Don't forget to unblock async exceptions in the handler, or if we're
1660 -- in an exception loop (eg. let a = error a in a) the ^C exception
1661 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1662
1663 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1664 ghciHandle h (GHCi m) = GHCi $ \s ->
1665    Exception.catch (m s)
1666         (\e -> unGHCi (ghciUnblock (h e)) s)
1667
1668 ghciUnblock :: GHCi a -> GHCi a
1669 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1670
1671
1672 -- ----------------------------------------------------------------------------
1673 -- Utils
1674
1675 expandPath :: String -> GHCi String
1676 expandPath path =
1677   case dropWhile isSpace path of
1678    ('~':d) -> do
1679         tilde <- io getHomeDirectory -- will fail if HOME not defined
1680         return (tilde ++ '/':d)
1681    other ->
1682         return other
1683
1684 wantInterpretedModule :: String -> GHCi Module
1685 wantInterpretedModule str = do
1686    session <- getSession
1687    modl <- lookupModule str
1688    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1689    when (not is_interpreted) $
1690        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1691    return modl
1692
1693 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1694                               -> (Name -> GHCi ())
1695                               -> GHCi ()
1696 wantNameFromInterpretedModule noCanDo str and_then = do
1697    session <- getSession
1698    names <- io $ GHC.parseName session str
1699    case names of
1700       []    -> return ()
1701       (n:_) -> do
1702             let modl = GHC.nameModule n
1703             if not (GHC.isExternalName n)
1704                then noCanDo n $ ppr n <>
1705                                 text " is not defined in an interpreted module"
1706                else do
1707             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1708             if not is_interpreted
1709                then noCanDo n $ text "module " <> ppr modl <>
1710                                 text " is not interpreted"
1711                else and_then n
1712
1713 -- ----------------------------------------------------------------------------
1714 -- Windows console setup
1715
1716 setUpConsole :: IO ()
1717 setUpConsole = do
1718 #ifdef mingw32_HOST_OS
1719         -- On Windows we need to set a known code page, otherwise the characters
1720         -- we read from the console will be be in some strange encoding, and
1721         -- similarly for characters we write to the console.
1722         --
1723         -- At the moment, GHCi pretends all input is Latin-1.  In the
1724         -- future we should support UTF-8, but for now we set the code
1725         -- pages to Latin-1.  Doing it this way does lead to problems,
1726         -- however: see bug #1649.
1727         --
1728         -- It seems you have to set the font in the console window to
1729         -- a Unicode font in order for output to work properly,
1730         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1731         -- (see MSDN for SetConsoleOutputCP()).
1732         --
1733         -- This call has been known to hang on some machines, see bug #1483
1734         --
1735         setConsoleCP 28591       -- ISO Latin-1
1736         setConsoleOutputCP 28591 -- ISO Latin-1
1737 #endif
1738         return ()
1739
1740 -- -----------------------------------------------------------------------------
1741 -- commands for debugger
1742
1743 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1744 sprintCmd = pprintCommand False False
1745 printCmd  = pprintCommand True False
1746 forceCmd  = pprintCommand False True
1747
1748 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1749 pprintCommand bind force str = do
1750   session <- getSession
1751   io $ pprintClosureCommand session bind force str
1752
1753 stepCmd :: String -> GHCi ()
1754 stepCmd []         = doContinue (const True) GHC.SingleStep
1755 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1756
1757 stepLocalCmd :: String -> GHCi ()
1758 stepLocalCmd  [] = do
1759   mb_span <- getCurrentBreakSpan
1760   case mb_span of
1761     Nothing  -> stepCmd []
1762     Just loc -> do
1763        Just mod <- getCurrentBreakModule
1764        current_toplevel_decl <- enclosingTickSpan mod loc
1765        doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1766
1767 stepLocalCmd expression = stepCmd expression
1768
1769 stepModuleCmd :: String -> GHCi ()
1770 stepModuleCmd  [] = do
1771   mb_span <- getCurrentBreakSpan
1772   case mb_span of
1773     Nothing  -> stepCmd []
1774     Just _ -> do
1775        Just span <- getCurrentBreakSpan
1776        let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1777        doContinue f GHC.SingleStep
1778
1779 stepModuleCmd expression = stepCmd expression
1780
1781 -- | Returns the span of the largest tick containing the srcspan given
1782 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1783 enclosingTickSpan mod src = do
1784   ticks <- getTickArray mod
1785   let line = srcSpanStartLine src
1786   ASSERT (inRange (bounds ticks) line) do
1787   let enclosing_spans = [ span | (_,span) <- ticks ! line
1788                                , srcSpanEnd span >= srcSpanEnd src]
1789   return . head . sortBy leftmost_largest $ enclosing_spans
1790
1791 traceCmd :: String -> GHCi ()
1792 traceCmd []         = doContinue (const True) GHC.RunAndLogSteps
1793 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1794
1795 continueCmd :: String -> GHCi ()
1796 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1797
1798 -- doContinue :: SingleStep -> GHCi ()
1799 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1800 doContinue pred step = do
1801   session <- getSession
1802   runResult <- io $ GHC.resume session step
1803   afterRunStmt pred runResult
1804   return ()
1805
1806 abandonCmd :: String -> GHCi ()
1807 abandonCmd = noArgs $ do
1808   s <- getSession
1809   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1810   when (not b) $ io $ putStrLn "There is no computation running."
1811   return ()
1812
1813 deleteCmd :: String -> GHCi ()
1814 deleteCmd argLine = do
1815    deleteSwitch $ words argLine
1816    where
1817    deleteSwitch :: [String] -> GHCi ()
1818    deleteSwitch [] =
1819       io $ putStrLn "The delete command requires at least one argument."
1820    -- delete all break points
1821    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1822    deleteSwitch idents = do
1823       mapM_ deleteOneBreak idents
1824       where
1825       deleteOneBreak :: String -> GHCi ()
1826       deleteOneBreak str
1827          | all isDigit str = deleteBreak (read str)
1828          | otherwise = return ()
1829
1830 historyCmd :: String -> GHCi ()
1831 historyCmd arg
1832   | null arg        = history 20
1833   | all isDigit arg = history (read arg)
1834   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1835   where
1836   history num = do
1837     s <- getSession
1838     resumes <- io $ GHC.getResumeContext s
1839     case resumes of
1840       [] -> io $ putStrLn "Not stopped at a breakpoint"
1841       (r:_) -> do
1842         let hist = GHC.resumeHistory r
1843             (took,rest) = splitAt num hist
1844         spans <- mapM (io . GHC.getHistorySpan s) took
1845         let nums  = map (printf "-%-3d:") [(1::Int)..]
1846         let names = map GHC.historyEnclosingDecl took
1847         printForUser (vcat(zipWith3
1848                              (\x y z -> x <+> y <+> z)
1849                              (map text nums)
1850                              (map (bold . ppr) names)
1851                              (map (parens . ppr) spans)))
1852         io $ putStrLn $ if null rest then "<end of history>" else "..."
1853
1854 bold :: SDoc -> SDoc
1855 bold c | do_bold   = text start_bold <> c <> text end_bold
1856        | otherwise = c
1857
1858 backCmd :: String -> GHCi ()
1859 backCmd = noArgs $ do
1860   s <- getSession
1861   (names, _, span) <- io $ GHC.back s
1862   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1863   printTypeOfNames s names
1864    -- run the command set with ":set stop <cmd>"
1865   st <- getGHCiState
1866   enqueueCommands [stop st]
1867
1868 forwardCmd :: String -> GHCi ()
1869 forwardCmd = noArgs $ do
1870   s <- getSession
1871   (names, ix, span) <- io $ GHC.forward s
1872   printForUser $ (if (ix == 0)
1873                     then ptext SLIT("Stopped at")
1874                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1875   printTypeOfNames s names
1876    -- run the command set with ":set stop <cmd>"
1877   st <- getGHCiState
1878   enqueueCommands [stop st]
1879
1880 -- handle the "break" command
1881 breakCmd :: String -> GHCi ()
1882 breakCmd argLine = do
1883    session <- getSession
1884    breakSwitch session $ words argLine
1885
1886 breakSwitch :: Session -> [String] -> GHCi ()
1887 breakSwitch _session [] = do
1888    io $ putStrLn "The break command requires at least one argument."
1889 breakSwitch session (arg1:rest)
1890    | looksLikeModuleName arg1 = do
1891         mod <- wantInterpretedModule arg1
1892         breakByModule mod rest
1893    | all isDigit arg1 = do
1894         (toplevel, _) <- io $ GHC.getContext session
1895         case toplevel of
1896            (mod : _) -> breakByModuleLine mod (read arg1) rest
1897            [] -> do
1898               io $ putStrLn "Cannot find default module for breakpoint."
1899               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1900    | otherwise = do -- try parsing it as an identifier
1901         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1902         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1903         if GHC.isGoodSrcLoc loc
1904                then findBreakAndSet (GHC.nameModule name) $
1905                          findBreakByCoord (Just (GHC.srcLocFile loc))
1906                                           (GHC.srcLocLine loc,
1907                                            GHC.srcLocCol loc)
1908                else noCanDo name $ text "can't find its location: " <> ppr loc
1909        where
1910           noCanDo n why = printForUser $
1911                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1912
1913 breakByModule :: Module -> [String] -> GHCi ()
1914 breakByModule mod (arg1:rest)
1915    | all isDigit arg1 = do  -- looks like a line number
1916         breakByModuleLine mod (read arg1) rest
1917 breakByModule _ _
1918    = breakSyntax
1919
1920 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1921 breakByModuleLine mod line args
1922    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1923    | [col] <- args, all isDigit col =
1924         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1925    | otherwise = breakSyntax
1926
1927 breakSyntax :: a
1928 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1929
1930 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1931 findBreakAndSet mod lookupTickTree = do
1932    tickArray <- getTickArray mod
1933    (breakArray, _) <- getModBreak mod
1934    case lookupTickTree tickArray of
1935       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1936       Just (tick, span) -> do
1937          success <- io $ setBreakFlag True breakArray tick
1938          if success
1939             then do
1940                (alreadySet, nm) <-
1941                      recordBreak $ BreakLocation
1942                              { breakModule = mod
1943                              , breakLoc = span
1944                              , breakTick = tick
1945                              , onBreakCmd = ""
1946                              }
1947                printForUser $
1948                   text "Breakpoint " <> ppr nm <>
1949                   if alreadySet
1950                      then text " was already set at " <> ppr span
1951                      else text " activated at " <> ppr span
1952             else do
1953             printForUser $ text "Breakpoint could not be activated at"
1954                                  <+> ppr span
1955
1956 -- When a line number is specified, the current policy for choosing
1957 -- the best breakpoint is this:
1958 --    - the leftmost complete subexpression on the specified line, or
1959 --    - the leftmost subexpression starting on the specified line, or
1960 --    - the rightmost subexpression enclosing the specified line
1961 --
1962 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1963 findBreakByLine line arr
1964   | not (inRange (bounds arr) line) = Nothing
1965   | otherwise =
1966     listToMaybe (sortBy (leftmost_largest `on` snd)  complete)   `mplus`
1967     listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1968     listToMaybe (sortBy (rightmost `on` snd) ticks)
1969   where
1970         ticks = arr ! line
1971
1972         starts_here = [ tick | tick@(_,span) <- ticks,
1973                                GHC.srcSpanStartLine span == line ]
1974
1975         (complete,incomplete) = partition ends_here starts_here
1976             where ends_here (_,span) = GHC.srcSpanEndLine span == line
1977
1978 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1979                  -> Maybe (BreakIndex,SrcSpan)
1980 findBreakByCoord mb_file (line, col) arr
1981   | not (inRange (bounds arr) line) = Nothing
1982   | otherwise =
1983     listToMaybe (sortBy (rightmost `on` snd) contains ++
1984                  sortBy (leftmost_smallest `on` snd) after_here)
1985   where
1986         ticks = arr ! line
1987
1988         -- the ticks that span this coordinate
1989         contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
1990                             is_correct_file span ]
1991
1992         is_correct_file span
1993                  | Just f <- mb_file = GHC.srcSpanFile span == f
1994                  | otherwise         = True
1995
1996         after_here = [ tick | tick@(_,span) <- ticks,
1997                               GHC.srcSpanStartLine span == line,
1998                               GHC.srcSpanStartCol span >= col ]
1999
2000 -- For now, use ANSI bold on terminals that we know support it.
2001 -- Otherwise, we add a line of carets under the active expression instead.
2002 -- In particular, on Windows and when running the testsuite (which sets
2003 -- TERM to vt100 for other reasons) we get carets.
2004 -- We really ought to use a proper termcap/terminfo library.
2005 do_bold :: Bool
2006 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2007     where mTerm = System.Environment.getEnv "TERM"
2008                   `Exception.catch` \_ -> return "TERM not set"
2009
2010 start_bold :: String
2011 start_bold = "\ESC[1m"
2012 end_bold :: String
2013 end_bold   = "\ESC[0m"
2014
2015 listCmd :: String -> GHCi ()
2016 listCmd "" = do
2017    mb_span <- getCurrentBreakSpan
2018    case mb_span of
2019       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2020       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2021                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
2022 listCmd str = list2 (words str)
2023
2024 list2 :: [String] -> GHCi ()
2025 list2 [arg] | all isDigit arg = do
2026     session <- getSession
2027     (toplevel, _) <- io $ GHC.getContext session
2028     case toplevel of
2029         [] -> io $ putStrLn "No module to list"
2030         (mod : _) -> listModuleLine mod (read arg)
2031 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2032         mod <- wantInterpretedModule arg1
2033         listModuleLine mod (read arg2)
2034 list2 [arg] = do
2035         wantNameFromInterpretedModule noCanDo arg $ \name -> do
2036         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2037         if GHC.isGoodSrcLoc loc
2038                then do
2039                   tickArray <- getTickArray (GHC.nameModule name)
2040                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2041                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
2042                                         tickArray
2043                   case mb_span of
2044                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
2045                     Just (_,span) -> io $ listAround span False
2046                else
2047                   noCanDo name $ text "can't find its location: " <>
2048                                  ppr loc
2049     where
2050         noCanDo n why = printForUser $
2051             text "cannot list source code for " <> ppr n <> text ": " <> why
2052 list2  _other =
2053         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
2054
2055 listModuleLine :: Module -> Int -> GHCi ()
2056 listModuleLine modl line = do
2057    session <- getSession
2058    graph <- io (GHC.getModuleGraph session)
2059    let this = filter ((== modl) . GHC.ms_mod) graph
2060    case this of
2061      [] -> panic "listModuleLine"
2062      summ:_ -> do
2063            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2064                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2065            io $ listAround (GHC.srcLocSpan loc) False
2066
2067 -- | list a section of a source file around a particular SrcSpan.
2068 -- If the highlight flag is True, also highlight the span using
2069 -- start_bold/end_bold.
2070 listAround :: SrcSpan -> Bool -> IO ()
2071 listAround span do_highlight = do
2072       contents <- BS.readFile (unpackFS file)
2073       let
2074           lines = BS.split '\n' contents
2075           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2076                         drop (line1 - 1 - pad_before) $ lines
2077           fst_line = max 1 (line1 - pad_before)
2078           line_nos = [ fst_line .. ]
2079
2080           highlighted | do_highlight = zipWith highlight line_nos these_lines
2081                       | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]
2082
2083           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
2084           prefixed = zipWith ($) highlighted bs_line_nos
2085       --
2086       BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2087   where
2088         file  = GHC.srcSpanFile span
2089         line1 = GHC.srcSpanStartLine span
2090         col1  = GHC.srcSpanStartCol span
2091         line2 = GHC.srcSpanEndLine span
2092         col2  = GHC.srcSpanEndCol span
2093
2094         pad_before | line1 == 1 = 0
2095                    | otherwise  = 1
2096         pad_after = 1
2097
2098         highlight | do_bold   = highlight_bold
2099                   | otherwise = highlight_carets
2100
2101         highlight_bold no line prefix
2102           | no == line1 && no == line2
2103           = let (a,r) = BS.splitAt col1 line
2104                 (b,c) = BS.splitAt (col2-col1) r
2105             in
2106             BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2107           | no == line1
2108           = let (a,b) = BS.splitAt col1 line in
2109             BS.concat [prefix, a, BS.pack start_bold, b]
2110           | no == line2
2111           = let (a,b) = BS.splitAt col2 line in
2112             BS.concat [prefix, a, BS.pack end_bold, b]
2113           | otherwise   = BS.concat [prefix, line]
2114
2115         highlight_carets no line prefix
2116           | no == line1 && no == line2
2117           = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2118                                          BS.replicate (col2-col1) '^']
2119           | no == line1
2120           = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2121                                          prefix, line]
2122           | no == line2
2123           = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2124                                          BS.pack "^^"]
2125           | otherwise   = BS.concat [prefix, line]
2126          where
2127            indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
2128            nl = BS.singleton '\n'
2129
2130 -- --------------------------------------------------------------------------
2131 -- Tick arrays
2132
2133 getTickArray :: Module -> GHCi TickArray
2134 getTickArray modl = do
2135    st <- getGHCiState
2136    let arrmap = tickarrays st
2137    case lookupModuleEnv arrmap modl of
2138       Just arr -> return arr
2139       Nothing  -> do
2140         (_breakArray, ticks) <- getModBreak modl
2141         let arr = mkTickArray (assocs ticks)
2142         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2143         return arr
2144
2145 discardTickArrays :: GHCi ()
2146 discardTickArrays = do
2147    st <- getGHCiState
2148    setGHCiState st{tickarrays = emptyModuleEnv}
2149
2150 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2151 mkTickArray ticks
2152   = accumArray (flip (:)) [] (1, max_line)
2153         [ (line, (nm,span)) | (nm,span) <- ticks,
2154                               line <- srcSpanLines span ]
2155     where
2156         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2157         srcSpanLines span = [ GHC.srcSpanStartLine span ..
2158                               GHC.srcSpanEndLine span ]
2159
2160 lookupModule :: String -> GHCi Module
2161 lookupModule modName
2162    = do session <- getSession
2163         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2164
2165 -- don't reset the counter back to zero?
2166 discardActiveBreakPoints :: GHCi ()
2167 discardActiveBreakPoints = do
2168    st <- getGHCiState
2169    mapM (turnOffBreak.snd) (breaks st)
2170    setGHCiState $ st { breaks = [] }
2171
2172 deleteBreak :: Int -> GHCi ()
2173 deleteBreak identity = do
2174    st <- getGHCiState
2175    let oldLocations    = breaks st
2176        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
2177    if null this
2178       then printForUser (text "Breakpoint" <+> ppr identity <+>
2179                          text "does not exist")
2180       else do
2181            mapM (turnOffBreak.snd) this
2182            setGHCiState $ st { breaks = rest }
2183
2184 turnOffBreak :: BreakLocation -> GHCi Bool
2185 turnOffBreak loc = do
2186   (arr, _) <- getModBreak (breakModule loc)
2187   io $ setBreakFlag False arr (breakTick loc)
2188
2189 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2190 getModBreak mod = do
2191    session <- getSession
2192    Just mod_info <- io $ GHC.getModuleInfo session mod
2193    let modBreaks  = GHC.modInfoModBreaks mod_info
2194    let array      = GHC.modBreaks_flags modBreaks
2195    let ticks      = GHC.modBreaks_locs  modBreaks
2196    return (array, ticks)
2197
2198 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2199 setBreakFlag toggle array index
2200    | toggle    = GHC.setBreakOn array index
2201    | otherwise = GHC.setBreakOff array index
2202