compiler/ghci/InteractiveUI.hs

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