compiler/ghci/InteractiveUI.hs

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