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 module InteractiveUI (
  10         interactiveUI,
  11         ghciWelcomeMsg
  12    ) where
  13
  14 #include "HsVersions.h"
  15
  16 import GhciMonad
  17
  18 -- The GHC interface
  19 import qualified GHC
  20 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  21                           Type, Module, ModuleName, TyThing(..), Phase,
  22                           BreakIndex )
  23 import Debugger
  24 import DynFlags
  25 import Packages
  26 import PackageConfig
  27 import UniqFM
  28 import PprTyThing
  29 import Outputable       hiding (printForUser)
  30 import Module           -- for ModuleEnv
  31
  32 -- for createtags
  33 import Name
  34 import OccName
  35 import SrcLoc
  36
  37 -- Other random utilities
  38 import Digraph
  39 import BasicTypes hiding (isTopLevel)
  40 import Panic      hiding (showException)
  41 import Config
  42 import StaticFlags
  43 import Linker
  44 import Util
  45
  46 #ifndef mingw32_HOST_OS
  47 import System.Posix
  48 #if __GLASGOW_HASKELL__ > 504
  49         hiding (getEnv)
  50 #endif
  51 #else
  52 import GHC.ConsoleHandler ( flushConsole )
  53 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  54 import qualified System.Win32
  55 #endif
  56
  57 #ifdef USE_READLINE
  58 import Control.Concurrent       ( yield )       -- Used in readline loop
  59 import System.Console.Readline as Readline
  60 #endif
  61
  62 --import SystemExts
  63
  64 import Control.Exception as Exception
  65 -- import Control.Concurrent
  66
  67 import Data.List
  68 import Data.Maybe
  69 import System.Cmd
  70 import System.Environment
  71 import System.Exit      ( exitWith, ExitCode(..) )
  72 import System.Directory
  73 import System.IO
  74 import System.IO.Error as IO
  75 import Data.Char
  76 import Data.Dynamic
  77 import Data.Array
  78 import Control.Monad as Monad
  79
  80 import Foreign.StablePtr        ( newStablePtr )
  81 import GHC.Exts         ( unsafeCoerce# )
  82 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  83
  84 import Data.IORef       ( IORef, readIORef, writeIORef )
  85
  86 import System.Posix.Internals ( setNonBlockingFD )
  87
  88 -----------------------------------------------------------------------------
  89
  90 ghciWelcomeMsg =
  91  "   ___         ___ _\n"++
  92  "  / _ \\ /\\  /\\/ __(_)\n"++
  93  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
  94  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
  95  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  96
  97 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
  98 cmdName (n,_,_,_) = n
  99
 100 GLOBAL_VAR(commands, builtin_commands, [Command])
 101
 102 builtin_commands :: [Command]
 103 builtin_commands = [
 104         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 105   ("?",         keepGoing help,                 False, completeNone),
 106   ("add",       keepGoingPaths addModule,       False, completeFilename),
 107   ("break",     breakCmd,                       False, completeIdentifier),
 108   ("browse",    keepGoing browseCmd,            False, completeModule),
 109   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 110   ("check",     keepGoing checkModule,          False, completeHomeModule),
 111   ("continue",  continueCmd,                    False, completeNone),
 112   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 113   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 114   ("delete",    deleteCmd,                      False, completeNone),
 115   ("e",         keepGoing editFile,             False, completeFilename),
 116   ("edit",      keepGoing editFile,             False, completeFilename),
 117   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 118   ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
 119   ("help",      keepGoing help,                 False, completeNone),
 120   ("info",      keepGoing info,                 False, completeIdentifier),
 121   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 122   ("load",      keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
 123   ("module",    keepGoing setContext,           False, completeModule),
 124   ("main",      keepGoing runMain,              False, completeIdentifier),
 125   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
 126   ("quit",      quit,                           False, completeNone),
 127   ("reload",    keepGoing reloadModule,         False, completeNone),
 128   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 129   ("show",      keepGoing showCmd,              False, completeNone),
 130   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
 131   ("step",      stepCmd,                        False, completeIdentifier),
 132   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 133   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 134   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 135   ]
 136
 137 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 138 keepGoing a str = a str >> return False
 139
 140 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 141 keepGoingPaths a str = a (toArgs str) >> return False
 142
 143 shortHelpText = "use :? for help.\n"
 144
 145 helpText =
 146  " Commands available from the prompt:\n" ++
 147  "\n" ++
 148  "   <stmt>                      evaluate/run <stmt>\n" ++
 149  "   :add <filename> ...         add module(s) to the current target set\n" ++
 150  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 151  "   :break <name>               set a breakpoint on the specified function\n" ++
 152  "   :browse [*]<module>         display the names defined by <module>\n" ++
 153  "   :cd <dir>                   change directory to <dir>\n" ++
 154  "   :continue                   resume after a breakpoint\n" ++
 155  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 156  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 157  "   :delete <number>            delete the specified breakpoint\n" ++
 158  "   :delete *                   delete all breakpoints\n" ++
 159  "   :edit <file>                edit file\n" ++
 160  "   :edit                       edit last module\n" ++
 161  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 162 -- "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 163  "   :help, :?                   display this list of commands\n" ++
 164  "   :info [<name> ...]          display information about the given names\n" ++
 165  "   :kind <type>                show the kind of <type>\n" ++
 166  "   :load <filename> ...        load module(s) and their dependents\n" ++
 167  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 168  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 169  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 170  "   :quit                       exit GHCi\n" ++
 171  "   :reload                     reload the current module set\n" ++
 172  "\n" ++
 173  "   :set <option> ...           set options\n" ++
 174  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 175  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 176  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 177  "   :set editor <cmd>           set the command used for :edit\n" ++
 178  "\n" ++
 179  "   :show breaks                show active breakpoints\n" ++
 180  "   :show context               show the breakpoint context\n" ++
 181  "   :show modules               show the currently loaded modules\n" ++
 182  "   :show bindings              show the current bindings made at the prompt\n" ++
 183  "\n" ++
 184  "   :sprint [<name> ...]        simplifed version of :print\n" ++
 185  "   :step                       single-step after stopping at a breakpoint\n"++
 186  "   :step <expr>                single-step into <expr>\n"++
 187  "   :type <expr>                show the type of <expr>\n" ++
 188  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 189  "   :unset <option> ...         unset options\n" ++
 190  "   :!<command>                 run the shell command <command>\n" ++
 191  "\n" ++
 192  " Options for ':set' and ':unset':\n" ++
 193  "\n" ++
 194  "    +r            revert top-level expressions after each evaluation\n" ++
 195  "    +s            print timing/memory stats after each evaluation\n" ++
 196  "    +t            print type after evaluation\n" ++
 197  "    -<flags>      most GHC command line flags can also be set here\n" ++
 198  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 199  "\n"
 200 -- Todo: add help for breakpoint commands here
 201
 202 findEditor = do
 203   getEnv "EDITOR"
 204     `IO.catch` \_ -> do
 205 #if mingw32_HOST_OS
 206         win <- System.Win32.getWindowsDirectory
 207         return (win `joinFileName` "notepad.exe")
 208 #else
 209         return ""
 210 #endif
 211
 212 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 213 interactiveUI session srcs maybe_expr = do
 214    -- HACK! If we happen to get into an infinite loop (eg the user
 215    -- types 'let x=x in x' at the prompt), then the thread will block
 216    -- on a blackhole, and become unreachable during GC.  The GC will
 217    -- detect that it is unreachable and send it the NonTermination
 218    -- exception.  However, since the thread is unreachable, everything
 219    -- it refers to might be finalized, including the standard Handles.
 220    -- This sounds like a bug, but we don't have a good solution right
 221    -- now.
 222    newStablePtr stdin
 223    newStablePtr stdout
 224    newStablePtr stderr
 225
 226         -- Initialise buffering for the *interpreted* I/O system
 227    initInterpBuffering session
 228
 229    when (isNothing maybe_expr) $ do
 230         -- Only for GHCi (not runghc and ghc -e):
 231         -- Turn buffering off for the compiled program's stdout/stderr
 232         turnOffBuffering
 233         -- Turn buffering off for GHCi's stdout
 234         hFlush stdout
 235         hSetBuffering stdout NoBuffering
 236         -- We don't want the cmd line to buffer any input that might be
 237         -- intended for the program, so unbuffer stdin.
 238         hSetBuffering stdin NoBuffering
 239
 240         -- initial context is just the Prelude
 241    prel_mod <- GHC.findModule session prel_name (Just basePackageId)
 242    GHC.setContext session [] [prel_mod]
 243
 244 #ifdef USE_READLINE
 245    Readline.initialize
 246    Readline.setAttemptedCompletionFunction (Just completeWord)
 247    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 248
 249    let symbols = "!#$%&*+/<=>?@\\^|-~"
 250        specials = "(),;[]`{}"
 251        spaces = " \t\n"
 252        word_break_chars = spaces ++ specials ++ symbols
 253
 254    Readline.setBasicWordBreakCharacters word_break_chars
 255    Readline.setCompleterWordBreakCharacters word_break_chars
 256 #endif
 257
 258    default_editor <- findEditor
 259
 260    startGHCi (runGHCi srcs maybe_expr)
 261         GHCiState{ progname = "<interactive>",
 262                    args = [],
 263                    prompt = "%s> ",
 264                    editor = default_editor,
 265                    session = session,
 266                    options = [],
 267                    prelude = prel_mod,
 268                    resume = [],
 269                    breaks = emptyActiveBreakPoints,
 270                    tickarrays = emptyModuleEnv
 271                  }
 272
 273 #ifdef USE_READLINE
 274    Readline.resetTerminal Nothing
 275 #endif
 276
 277    return ()
 278
 279 prel_name = GHC.mkModuleName "Prelude"
 280
 281 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 282 runGHCi paths maybe_expr = do
 283   let read_dot_files = not opt_IgnoreDotGhci
 284
 285   when (read_dot_files) $ do
 286     -- Read in ./.ghci.
 287     let file = "./.ghci"
 288     exists <- io (doesFileExist file)
 289     when exists $ do
 290        dir_ok  <- io (checkPerms ".")
 291        file_ok <- io (checkPerms file)
 292        when (dir_ok && file_ok) $ do
 293           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 294           case either_hdl of
 295              Left e    -> return ()
 296              Right hdl -> fileLoop hdl False
 297
 298   when (read_dot_files) $ do
 299     -- Read in $HOME/.ghci
 300     either_dir <- io (IO.try (getEnv "HOME"))
 301     case either_dir of
 302        Left e -> return ()
 303        Right dir -> do
 304           cwd <- io (getCurrentDirectory)
 305           when (dir /= cwd) $ do
 306              let file = dir ++ "/.ghci"
 307              ok <- io (checkPerms file)
 308              when ok $ do
 309                either_hdl <- io (IO.try (openFile file ReadMode))
 310                case either_hdl of
 311                   Left e    -> return ()
 312                   Right hdl -> fileLoop hdl False
 313
 314   -- Perform a :load for files given on the GHCi command line
 315   -- When in -e mode, if the load fails then we want to stop
 316   -- immediately rather than going on to evaluate the expression.
 317   when (not (null paths)) $ do
 318      ok <- ghciHandle (\e -> do showException e; return Failed) $
 319                 loadModule paths
 320      when (isJust maybe_expr && failed ok) $
 321         io (exitWith (ExitFailure 1))
 322
 323   -- if verbosity is greater than 0, or we are connected to a
 324   -- terminal, display the prompt in the interactive loop.
 325   is_tty <- io (hIsTerminalDevice stdin)
 326   dflags <- getDynFlags
 327   let show_prompt = verbosity dflags > 0 || is_tty
 328
 329   case maybe_expr of
 330         Nothing ->
 331           do
 332 #if defined(mingw32_HOST_OS)
 333             -- The win32 Console API mutates the first character of
 334             -- type-ahead when reading from it in a non-buffered manner. Work
 335             -- around this by flushing the input buffer of type-ahead characters,
 336             -- but only if stdin is available.
 337             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 338             case flushed of
 339              Left err | isDoesNotExistError err -> return ()
 340                       | otherwise -> io (ioError err)
 341              Right () -> return ()
 342 #endif
 343             -- initialise the console if necessary
 344             io setUpConsole
 345
 346             -- enter the interactive loop
 347             interactiveLoop is_tty show_prompt
 348         Just expr -> do
 349             -- just evaluate the expression we were given
 350             runCommandEval expr
 351             return ()
 352
 353   -- and finally, exit
 354   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 355
 356
 357 interactiveLoop is_tty show_prompt =
 358   -- Ignore ^C exceptions caught here
 359   ghciHandleDyn (\e -> case e of
 360                         Interrupted -> do
 361 #if defined(mingw32_HOST_OS)
 362                                 io (putStrLn "")
 363 #endif
 364                                 interactiveLoop is_tty show_prompt
 365                         _other      -> return ()) $
 366
 367   ghciUnblock $ do -- unblock necessary if we recursed from the
 368                    -- exception handler above.
 369
 370   -- read commands from stdin
 371 #ifdef USE_READLINE
 372   if (is_tty)
 373         then readlineLoop
 374         else fileLoop stdin show_prompt
 375 #else
 376   fileLoop stdin show_prompt
 377 #endif
 378
 379
 380 -- NOTE: We only read .ghci files if they are owned by the current user,
 381 -- and aren't world writable.  Otherwise, we could be accidentally
 382 -- running code planted by a malicious third party.
 383
 384 -- Furthermore, We only read ./.ghci if . is owned by the current user
 385 -- and isn't writable by anyone else.  I think this is sufficient: we
 386 -- don't need to check .. and ../.. etc. because "."  always refers to
 387 -- the same directory while a process is running.
 388
 389 checkPerms :: String -> IO Bool
 390 checkPerms name =
 391 #ifdef mingw32_HOST_OS
 392   return True
 393 #else
 394   Util.handle (\_ -> return False) $ do
 395      st <- getFileStatus name
 396      me <- getRealUserID
 397      if fileOwner st /= me then do
 398         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 399         return False
 400       else do
 401         let mode =  fileMode st
 402         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 403            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 404            then do
 405                putStrLn $ "*** WARNING: " ++ name ++
 406                           " is writable by someone else, IGNORING!"
 407                return False
 408           else return True
 409 #endif
 410
 411 fileLoop :: Handle -> Bool -> GHCi ()
 412 fileLoop hdl show_prompt = do
 413    session <- getSession
 414    (mod,imports) <- io (GHC.getContext session)
 415    st <- getGHCiState
 416    when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
 417    l <- io (IO.try (hGetLine hdl))
 418    case l of
 419         Left e | isEOFError e              -> return ()
 420                | InvalidArgument <- etype  -> return ()
 421                | otherwise                 -> io (ioError e)
 422                 where etype = ioeGetErrorType e
 423                 -- treat InvalidArgument in the same way as EOF:
 424                 -- this can happen if the user closed stdin, or
 425                 -- perhaps did getContents which closes stdin at
 426                 -- EOF.
 427         Right l ->
 428           case removeSpaces l of
 429             "" -> fileLoop hdl show_prompt
 430             l  -> do quit <- runCommand l
 431                      if quit then return () else fileLoop hdl show_prompt
 432
 433 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
 434 stringLoop [] = return False
 435 stringLoop (s:ss) = do
 436    case removeSpaces s of
 437         "" -> stringLoop ss
 438         l  -> do quit <- runCommand l
 439                  if quit then return True else stringLoop ss
 440
 441 mkPrompt toplevs exports prompt
 442   = showSDoc $ f prompt
 443     where
 444         f ('%':'s':xs) = perc_s <> f xs
 445         f ('%':'%':xs) = char '%' <> f xs
 446         f (x:xs) = char x <> f xs
 447         f [] = empty
 448
 449         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 450                  hsep (map (ppr . GHC.moduleName) exports)
 451
 452
 453 #ifdef USE_READLINE
 454 readlineLoop :: GHCi ()
 455 readlineLoop = do
 456    session <- getSession
 457    (mod,imports) <- io (GHC.getContext session)
 458    io yield
 459    saveSession -- for use by completion
 460    st <- getGHCiState
 461    l <- io (readline (mkPrompt mod imports (prompt st))
 462                 `finally` setNonBlockingFD 0)
 463                 -- readline sometimes puts stdin into blocking mode,
 464                 -- so we need to put it back for the IO library
 465    splatSavedSession
 466    case l of
 467         Nothing -> return ()
 468         Just l  ->
 469           case removeSpaces l of
 470             "" -> readlineLoop
 471             l  -> do
 472                   io (addHistory l)
 473                   quit <- runCommand l
 474                   if quit then return () else readlineLoop
 475 #endif
 476
 477 runCommand :: String -> GHCi Bool
 478 runCommand c = ghciHandle handler (doCommand c)
 479   where
 480     doCommand (':' : command) = specialCommand command
 481     doCommand stmt
 482        = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 483             return False
 484
 485 -- This version is for the GHC command-line option -e.  The only difference
 486 -- from runCommand is that it catches the ExitException exception and
 487 -- exits, rather than printing out the exception.
 488 runCommandEval c = ghciHandle handleEval (doCommand c)
 489   where
 490     handleEval (ExitException code) = io (exitWith code)
 491     handleEval e                    = do handler e
 492                                          io (exitWith (ExitFailure 1))
 493
 494     doCommand (':' : command) = specialCommand command
 495     doCommand stmt
 496        = do nms <- runStmt stmt
 497             case nms of
 498                 Nothing -> io (exitWith (ExitFailure 1))
 499                   -- failure to run the command causes exit(1) for ghc -e.
 500                 _       -> finishEvalExpr nms
 501
 502 runStmt :: String -> GHCi (Maybe (Bool,[Name]))
 503 runStmt stmt
 504  | null (filter (not.isSpace) stmt) = return (Just (False,[]))
 505  | otherwise
 506  = do st <- getGHCiState
 507       session <- getSession
 508       result <- io $ withProgName (progname st) $ withArgs (args st) $
 509                      GHC.runStmt session stmt
 510       switchOnRunResult result
 511
 512 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
 513 switchOnRunResult GHC.RunFailed = return Nothing
 514 switchOnRunResult (GHC.RunException e) = throw e
 515 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
 516 switchOnRunResult (GHC.RunBreak threadId names info resume) = do
 517    session <- getSession
 518    Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
 519    let modBreaks  = GHC.modInfoModBreaks mod_info
 520    let ticks      = GHC.modBreaks_locs modBreaks
 521
 522    -- display information about the breakpoint
 523    let location = ticks ! breakInfo_number info
 524    printForUser $ ptext SLIT("Stopped at") <+> ppr location
 525
 526    pushResume location threadId resume
 527    return (Just (True,names))
 528
 529 -- possibly print the type and revert CAFs after evaluating an expression
 530 finishEvalExpr mb_names
 531  = do show_types <- isOptionSet ShowType
 532       session <- getSession
 533       case mb_names of
 534         Nothing    -> return ()
 535         Just (is_break,names) ->
 536                 when (is_break || show_types) $
 537                       mapM_ (showTypeOfName session) names
 538
 539       flushInterpBuffers
 540       io installSignalHandlers
 541       b <- isOptionSet RevertCAFs
 542       io (when b revertCAFs)
 543       return True
 544
 545 showTypeOfName :: Session -> Name -> GHCi ()
 546 showTypeOfName session n
 547    = do maybe_tything <- io (GHC.lookupName session n)
 548         case maybe_tything of
 549           Nothing    -> return ()
 550           Just thing -> showTyThing thing
 551
 552 specialCommand :: String -> GHCi Bool
 553 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 554 specialCommand str = do
 555   let (cmd,rest) = break isSpace str
 556   maybe_cmd <- io (lookupCommand cmd)
 557   case maybe_cmd of
 558     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 559                                     ++ shortHelpText) >> return False)
 560     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 561
 562 lookupCommand :: String -> IO (Maybe Command)
 563 lookupCommand str = do
 564   cmds <- readIORef commands
 565   -- look for exact match first, then the first prefix match
 566   case [ c | c <- cmds, str == cmdName c ] of
 567      c:_ -> return (Just c)
 568      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 569                 [] -> return Nothing
 570                 c:_ -> return (Just c)
 571
 572 -----------------------------------------------------------------------------
 573 -- Commands
 574
 575 help :: String -> GHCi ()
 576 help _ = io (putStr helpText)
 577
 578 info :: String -> GHCi ()
 579 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 580 info s  = do { let names = words s
 581              ; session <- getSession
 582              ; dflags <- getDynFlags
 583              ; let exts = dopt Opt_GlasgowExts dflags
 584              ; mapM_ (infoThing exts session) names }
 585   where
 586     infoThing exts session str = io $ do
 587         names <- GHC.parseName session str
 588         let filtered = filterOutChildren names
 589         mb_stuffs <- mapM (GHC.getInfo session) filtered
 590         unqual <- GHC.getPrintUnqual session
 591         putStrLn (showSDocForUser unqual $
 592                    vcat (intersperse (text "") $
 593                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 594
 595   -- Filter out names whose parent is also there Good
 596   -- example is '[]', which is both a type and data
 597   -- constructor in the same type
 598 filterOutChildren :: [Name] -> [Name]
 599 filterOutChildren names = filter (not . parent_is_there) names
 600  where parent_is_there n
 601 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 602 -- ToDo!!
 603          | otherwise                       = False
 604
 605 pprInfo exts (thing, fixity, insts)
 606   =  pprTyThingInContextLoc exts thing
 607   $$ show_fixity fixity
 608   $$ vcat (map GHC.pprInstance insts)
 609   where
 610     show_fixity fix
 611         | fix == GHC.defaultFixity = empty
 612         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 613
 614 -----------------------------------------------------------------------------
 615 -- Commands
 616
 617 runMain :: String -> GHCi ()
 618 runMain args = do
 619   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 620   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 621   return ()
 622
 623 addModule :: [FilePath] -> GHCi ()
 624 addModule files = do
 625   io (revertCAFs)                       -- always revert CAFs on load/add.
 626   files <- mapM expandPath files
 627   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 628   session <- getSession
 629   io (mapM_ (GHC.addTarget session) targets)
 630   ok <- io (GHC.load session LoadAllTargets)
 631   afterLoad ok session
 632
 633 changeDirectory :: String -> GHCi ()
 634 changeDirectory dir = do
 635   session <- getSession
 636   graph <- io (GHC.getModuleGraph session)
 637   when (not (null graph)) $
 638         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 639   io (GHC.setTargets session [])
 640   io (GHC.load session LoadAllTargets)
 641   setContextAfterLoad session []
 642   io (GHC.workingDirectoryChanged session)
 643   dir <- expandPath dir
 644   io (setCurrentDirectory dir)
 645
 646 editFile :: String -> GHCi ()
 647 editFile str
 648   | null str  = do
 649         -- find the name of the "topmost" file loaded
 650      session <- getSession
 651      graph0 <- io (GHC.getModuleGraph session)
 652      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 653      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 654      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 655         Just file -> do_edit file
 656         Nothing   -> throwDyn (CmdLineError "unknown file name")
 657   | otherwise = do_edit str
 658   where
 659         do_edit file = do
 660            st <- getGHCiState
 661            let cmd = editor st
 662            when (null cmd) $
 663                 throwDyn (CmdLineError "editor not set, use :set editor")
 664            io $ system (cmd ++ ' ':file)
 665            return ()
 666
 667 defineMacro :: String -> GHCi ()
 668 defineMacro s = do
 669   let (macro_name, definition) = break isSpace s
 670   cmds <- io (readIORef commands)
 671   if (null macro_name)
 672         then throwDyn (CmdLineError "invalid macro name")
 673         else do
 674   if (macro_name `elem` map cmdName cmds)
 675         then throwDyn (CmdLineError
 676                 ("command '" ++ macro_name ++ "' is already defined"))
 677         else do
 678
 679   -- give the expression a type signature, so we can be sure we're getting
 680   -- something of the right type.
 681   let new_expr = '(' : definition ++ ") :: String -> IO String"
 682
 683   -- compile the expression
 684   cms <- getSession
 685   maybe_hv <- io (GHC.compileExpr cms new_expr)
 686   case maybe_hv of
 687      Nothing -> return ()
 688      Just hv -> io (writeIORef commands --
 689                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 690
 691 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 692 runMacro fun s = do
 693   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 694   stringLoop (lines str)
 695
 696 undefineMacro :: String -> GHCi ()
 697 undefineMacro macro_name = do
 698   cmds <- io (readIORef commands)
 699   if (macro_name `elem` map cmdName builtin_commands)
 700         then throwDyn (CmdLineError
 701                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 702         else do
 703   if (macro_name `notElem` map cmdName cmds)
 704         then throwDyn (CmdLineError
 705                 ("command '" ++ macro_name ++ "' not defined"))
 706         else do
 707   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 708
 709
 710 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 711 loadModule fs = timeIt (loadModule' fs)
 712
 713 loadModule_ :: [FilePath] -> GHCi ()
 714 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 715
 716 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 717 loadModule' files = do
 718   session <- getSession
 719
 720   -- unload first
 721   io (GHC.setTargets session [])
 722   io (GHC.load session LoadAllTargets)
 723
 724   -- expand tildes
 725   let (filenames, phases) = unzip files
 726   exp_filenames <- mapM expandPath filenames
 727   let files' = zip exp_filenames phases
 728   targets <- io (mapM (uncurry GHC.guessTarget) files')
 729
 730   -- NOTE: we used to do the dependency anal first, so that if it
 731   -- fails we didn't throw away the current set of modules.  This would
 732   -- require some re-working of the GHC interface, so we'll leave it
 733   -- as a ToDo for now.
 734
 735   io (GHC.setTargets session targets)
 736   ok <- io (GHC.load session LoadAllTargets)
 737   afterLoad ok session
 738   return ok
 739
 740 checkModule :: String -> GHCi ()
 741 checkModule m = do
 742   let modl = GHC.mkModuleName m
 743   session <- getSession
 744   result <- io (GHC.checkModule session modl)
 745   case result of
 746     Nothing -> io $ putStrLn "Nothing"
 747     Just r  -> io $ putStrLn (showSDoc (
 748         case GHC.checkedModuleInfo r of
 749            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 750                 let
 751                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 752                 in
 753                         (text "global names: " <+> ppr global) $$
 754                         (text "local  names: " <+> ppr local)
 755            _ -> empty))
 756   afterLoad (successIf (isJust result)) session
 757
 758 reloadModule :: String -> GHCi ()
 759 reloadModule "" = do
 760   io (revertCAFs)               -- always revert CAFs on reload.
 761   session <- getSession
 762   ok <- io (GHC.load session LoadAllTargets)
 763   afterLoad ok session
 764 reloadModule m = do
 765   io (revertCAFs)               -- always revert CAFs on reload.
 766   session <- getSession
 767   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 768   afterLoad ok session
 769
 770 afterLoad ok session = do
 771   io (revertCAFs)  -- always revert CAFs on load.
 772   discardResumeContext
 773   discardTickArrays
 774   discardActiveBreakPoints
 775   graph <- io (GHC.getModuleGraph session)
 776   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 777   setContextAfterLoad session graph'
 778   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 779
 780 setContextAfterLoad session [] = do
 781   prel_mod <- getPrelude
 782   io (GHC.setContext session [] [prel_mod])
 783 setContextAfterLoad session ms = do
 784   -- load a target if one is available, otherwise load the topmost module.
 785   targets <- io (GHC.getTargets session)
 786   case [ m | Just m <- map (findTarget ms) targets ] of
 787         []    ->
 788           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 789           load_this (last graph')
 790         (m:_) ->
 791           load_this m
 792  where
 793    findTarget ms t
 794     = case filter (`matches` t) ms of
 795         []    -> Nothing
 796         (m:_) -> Just m
 797
 798    summary `matches` Target (TargetModule m) _
 799         = GHC.ms_mod_name summary == m
 800    summary `matches` Target (TargetFile f _) _
 801         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 802    summary `matches` target
 803         = False
 804
 805    load_this summary | m <- GHC.ms_mod summary = do
 806         b <- io (GHC.moduleIsInterpreted session m)
 807         if b then io (GHC.setContext session [m] [])
 808              else do
 809                    prel_mod <- getPrelude
 810                    io (GHC.setContext session []  [prel_mod,m])
 811
 812
 813 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 814 modulesLoadedMsg ok mods = do
 815   dflags <- getDynFlags
 816   when (verbosity dflags > 0) $ do
 817    let mod_commas
 818         | null mods = text "none."
 819         | otherwise = hsep (
 820             punctuate comma (map ppr mods)) <> text "."
 821    case ok of
 822     Failed ->
 823        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 824     Succeeded  ->
 825        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 826
 827
 828 typeOfExpr :: String -> GHCi ()
 829 typeOfExpr str
 830   = do cms <- getSession
 831        maybe_ty <- io (GHC.exprType cms str)
 832        case maybe_ty of
 833           Nothing -> return ()
 834           Just ty -> do ty' <- cleanType ty
 835                         printForUser $ text str <> text " :: " <> ppr ty'
 836
 837 kindOfType :: String -> GHCi ()
 838 kindOfType str
 839   = do cms <- getSession
 840        maybe_ty <- io (GHC.typeKind cms str)
 841        case maybe_ty of
 842           Nothing    -> return ()
 843           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 844
 845 quit :: String -> GHCi Bool
 846 quit _ = return True
 847
 848 shellEscape :: String -> GHCi Bool
 849 shellEscape str = io (system str >> return False)
 850
 851 -----------------------------------------------------------------------------
 852 -- create tags file for currently loaded modules.
 853
 854 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 855
 856 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 857 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 858
 859 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 860 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 861
 862 data TagsKind = ETags | CTags
 863
 864 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 865 ghciCreateTagsFile kind file = do
 866   session <- getSession
 867   io $ createTagsFile session kind file
 868
 869 -- ToDo:
 870 --      - remove restriction that all modules must be interpreted
 871 --        (problem: we don't know source locations for entities unless
 872 --        we compiled the module.
 873 --
 874 --      - extract createTagsFile so it can be used from the command-line
 875 --        (probably need to fix first problem before this is useful).
 876 --
 877 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 878 createTagsFile session tagskind tagFile = do
 879   graph <- GHC.getModuleGraph session
 880   let ms = map GHC.ms_mod graph
 881       tagModule m = do
 882         is_interpreted <- GHC.moduleIsInterpreted session m
 883         -- should we just skip these?
 884         when (not is_interpreted) $
 885           throwDyn (CmdLineError ("module '"
 886                                 ++ GHC.moduleNameString (GHC.moduleName m)
 887                                 ++ "' is not interpreted"))
 888         mbModInfo <- GHC.getModuleInfo session m
 889         let unqual
 890               | Just modinfo <- mbModInfo,
 891                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 892               | otherwise = GHC.alwaysQualify
 893
 894         case mbModInfo of
 895           Just modInfo -> return $! listTags unqual modInfo
 896           _            -> return []
 897
 898   mtags <- mapM tagModule ms
 899   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 900   case either_res of
 901     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 902     Right _ -> return ()
 903
 904 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 905 listTags unqual modInfo =
 906            [ tagInfo unqual name loc
 907            | name <- GHC.modInfoExports modInfo
 908            , let loc = nameSrcLoc name
 909            , isGoodSrcLoc loc
 910            ]
 911
 912 type TagInfo = (String -- tag name
 913                ,String -- file name
 914                ,Int    -- line number
 915                ,Int    -- column number
 916                )
 917
 918 -- get tag info, for later translation into Vim or Emacs style
 919 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 920 tagInfo unqual name loc
 921     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 922       , showSDocForUser unqual $ ftext (srcLocFile loc)
 923       , srcLocLine loc
 924       , srcLocCol loc
 925       )
 926
 927 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 928 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 929   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 930   IO.try (writeFile file tags)
 931 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 932   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 933       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 934   tagGroups <- mapM tagFileGroup groups
 935   IO.try (writeFile file $ concat tagGroups)
 936   where
 937     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
 938     tagFileGroup group@((_,fileName,_,_):_) = do
 939       file <- readFile fileName -- need to get additional info from sources..
 940       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 941           sortedGroup = sortLe byLine group
 942           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 943       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 944     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
 945       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 946     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
 947       showETag tagInfo line pos : perFile tags count pos lines
 948     perFile tags count pos lines = []
 949
 950 -- simple ctags format, for Vim et al
 951 showTag :: TagInfo -> String
 952 showTag (tag,file,lineNo,colNo)
 953     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 954
 955 -- etags format, for Emacs/XEmacs
 956 showETag :: TagInfo -> String -> Int -> String
 957 showETag (tag,file,lineNo,colNo) line charPos
 958     =  take colNo line ++ tag
 959     ++ "\x7f" ++ tag
 960     ++ "\x01" ++ show lineNo
 961     ++ "," ++ show charPos
 962
 963 -----------------------------------------------------------------------------
 964 -- Browsing a module's contents
 965
 966 browseCmd :: String -> GHCi ()
 967 browseCmd m =
 968   case words m of
 969     ['*':m] | looksLikeModuleName m -> browseModule m False
 970     [m]     | looksLikeModuleName m -> browseModule m True
 971     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 972
 973 browseModule m exports_only = do
 974   s <- getSession
 975   modl <- if exports_only then lookupModule s m
 976                           else wantInterpretedModule s m
 977
 978   -- Temporarily set the context to the module we're interested in,
 979   -- just so we can get an appropriate PrintUnqualified
 980   (as,bs) <- io (GHC.getContext s)
 981   prel_mod <- getPrelude
 982   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 983                       else GHC.setContext s [modl] [])
 984   unqual <- io (GHC.getPrintUnqual s)
 985   io (GHC.setContext s as bs)
 986
 987   mb_mod_info <- io $ GHC.getModuleInfo s modl
 988   case mb_mod_info of
 989     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 990     Just mod_info -> do
 991         let names
 992                | exports_only = GHC.modInfoExports mod_info
 993                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 994
 995             filtered = filterOutChildren names
 996
 997         things <- io $ mapM (GHC.lookupName s) filtered
 998
 999         dflags <- getDynFlags
1000         let exts = dopt Opt_GlasgowExts dflags
1001         io (putStrLn (showSDocForUser unqual (
1002                 vcat (map (pprTyThingInContext exts) (catMaybes things))
1003            )))
1004         -- ToDo: modInfoInstances currently throws an exception for
1005         -- package modules.  When it works, we can do this:
1006         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1007
1008 -----------------------------------------------------------------------------
1009 -- Setting the module context
1010
1011 setContext str
1012   | all sensible mods = fn mods
1013   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1014   where
1015     (fn, mods) = case str of
1016                         '+':stuff -> (addToContext,      words stuff)
1017                         '-':stuff -> (removeFromContext, words stuff)
1018                         stuff     -> (newContext,        words stuff)
1019
1020     sensible ('*':m) = looksLikeModuleName m
1021     sensible m       = looksLikeModuleName m
1022
1023 separate :: Session -> [String] -> [Module] -> [Module]
1024         -> GHCi ([Module],[Module])
1025 separate session []           as bs = return (as,bs)
1026 separate session (('*':str):ms) as bs = do
1027    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1028    b <- io $ GHC.moduleIsInterpreted session m
1029    if b then separate session ms (m:as) bs
1030         else throwDyn (CmdLineError ("module '"
1031                         ++ GHC.moduleNameString (GHC.moduleName m)
1032                         ++ "' is not interpreted"))
1033 separate session (str:ms) as bs = do
1034   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1035   separate session ms as (m:bs)
1036
1037 newContext :: [String] -> GHCi ()
1038 newContext strs = do
1039   s <- getSession
1040   (as,bs) <- separate s strs [] []
1041   prel_mod <- getPrelude
1042   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1043   io $ GHC.setContext s as bs'
1044
1045
1046 addToContext :: [String] -> GHCi ()
1047 addToContext strs = do
1048   s <- getSession
1049   (as,bs) <- io $ GHC.getContext s
1050
1051   (new_as,new_bs) <- separate s strs [] []
1052
1053   let as_to_add = new_as \\ (as ++ bs)
1054       bs_to_add = new_bs \\ (as ++ bs)
1055
1056   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1057
1058
1059 removeFromContext :: [String] -> GHCi ()
1060 removeFromContext strs = do
1061   s <- getSession
1062   (as,bs) <- io $ GHC.getContext s
1063
1064   (as_to_remove,bs_to_remove) <- separate s strs [] []
1065
1066   let as' = as \\ (as_to_remove ++ bs_to_remove)
1067       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1068
1069   io $ GHC.setContext s as' bs'
1070
1071 ----------------------------------------------------------------------------
1072 -- Code for `:set'
1073
1074 -- set options in the interpreter.  Syntax is exactly the same as the
1075 -- ghc command line, except that certain options aren't available (-C,
1076 -- -E etc.)
1077 --
1078 -- This is pretty fragile: most options won't work as expected.  ToDo:
1079 -- figure out which ones & disallow them.
1080
1081 setCmd :: String -> GHCi ()
1082 setCmd ""
1083   = do st <- getGHCiState
1084        let opts = options st
1085        io $ putStrLn (showSDoc (
1086               text "options currently set: " <>
1087               if null opts
1088                    then text "none."
1089                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1090            ))
1091 setCmd str
1092   = case toArgs str of
1093         ("args":args) -> setArgs args
1094         ("prog":prog) -> setProg prog
1095         ("prompt":prompt) -> setPrompt (after 6)
1096         ("editor":cmd) -> setEditor (after 6)
1097         wds -> setOptions wds
1098    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1099
1100 setArgs args = do
1101   st <- getGHCiState
1102   setGHCiState st{ args = args }
1103
1104 setProg [prog] = do
1105   st <- getGHCiState
1106   setGHCiState st{ progname = prog }
1107 setProg _ = do
1108   io (hPutStrLn stderr "syntax: :set prog <progname>")
1109
1110 setEditor cmd = do
1111   st <- getGHCiState
1112   setGHCiState st{ editor = cmd }
1113
1114 setPrompt value = do
1115   st <- getGHCiState
1116   if null value
1117       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1118       else setGHCiState st{ prompt = remQuotes value }
1119   where
1120      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1121      remQuotes x = x
1122
1123 setOptions wds =
1124    do -- first, deal with the GHCi opts (+s, +t, etc.)
1125       let (plus_opts, minus_opts)  = partition isPlus wds
1126       mapM_ setOpt plus_opts
1127
1128       -- then, dynamic flags
1129       dflags <- getDynFlags
1130       let pkg_flags = packageFlags dflags
1131       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1132
1133       if (not (null leftovers))
1134                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1135                                                 unwords leftovers))
1136                 else return ()
1137
1138       new_pkgs <- setDynFlags dflags'
1139
1140       -- if the package flags changed, we should reset the context
1141       -- and link the new packages.
1142       dflags <- getDynFlags
1143       when (packageFlags dflags /= pkg_flags) $ do
1144         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1145         session <- getSession
1146         io (GHC.setTargets session [])
1147         io (GHC.load session LoadAllTargets)
1148         io (linkPackages dflags new_pkgs)
1149         setContextAfterLoad session []
1150       return ()
1151
1152
1153 unsetOptions :: String -> GHCi ()
1154 unsetOptions str
1155   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1156        let opts = words str
1157            (minus_opts, rest1) = partition isMinus opts
1158            (plus_opts, rest2)  = partition isPlus rest1
1159
1160        if (not (null rest2))
1161           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1162           else do
1163
1164        mapM_ unsetOpt plus_opts
1165
1166        -- can't do GHC flags for now
1167        if (not (null minus_opts))
1168           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1169           else return ()
1170
1171 isMinus ('-':s) = True
1172 isMinus _ = False
1173
1174 isPlus ('+':s) = True
1175 isPlus _ = False
1176
1177 setOpt ('+':str)
1178   = case strToGHCiOpt str of
1179         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1180         Just o  -> setOption o
1181
1182 unsetOpt ('+':str)
1183   = case strToGHCiOpt str of
1184         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1185         Just o  -> unsetOption o
1186
1187 strToGHCiOpt :: String -> (Maybe GHCiOption)
1188 strToGHCiOpt "s" = Just ShowTiming
1189 strToGHCiOpt "t" = Just ShowType
1190 strToGHCiOpt "r" = Just RevertCAFs
1191 strToGHCiOpt _   = Nothing
1192
1193 optToStr :: GHCiOption -> String
1194 optToStr ShowTiming = "s"
1195 optToStr ShowType   = "t"
1196 optToStr RevertCAFs = "r"
1197
1198 -- ---------------------------------------------------------------------------
1199 -- code for `:show'
1200
1201 showCmd str =
1202   case words str of
1203         ["modules" ] -> showModules
1204         ["bindings"] -> showBindings
1205         ["linker"]   -> io showLinkerState
1206         ["breaks"] -> showBkptTable
1207         ["context"] -> showContext
1208         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings|breaks]")
1209
1210 showModules = do
1211   session <- getSession
1212   let show_one ms = do m <- io (GHC.showModule session ms)
1213                        io (putStrLn m)
1214   graph <- io (GHC.getModuleGraph session)
1215   mapM_ show_one graph
1216
1217 showBindings = do
1218   s <- getSession
1219   unqual <- io (GHC.getPrintUnqual s)
1220   bindings <- io (GHC.getBindings s)
1221   mapM_ showTyThing bindings
1222   return ()
1223
1224 showTyThing (AnId id) = do
1225   ty' <- cleanType (GHC.idType id)
1226   printForUser $ ppr id <> text " :: " <> ppr ty'
1227 showTyThing _  = return ()
1228
1229 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1230 cleanType :: Type -> GHCi Type
1231 cleanType ty = do
1232   dflags <- getDynFlags
1233   if dopt Opt_GlasgowExts dflags
1234         then return ty
1235         else return $! GHC.dropForAlls ty
1236
1237 showBkptTable :: GHCi ()
1238 showBkptTable = do
1239    activeBreaks <- getActiveBreakPoints
1240    printForUser $ ppr activeBreaks
1241
1242 showContext :: GHCi ()
1243 showContext = do
1244    st <- getGHCiState
1245    printForUser $ vcat (map pp_resume (resume st))
1246   where
1247    pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
1248
1249 -- -----------------------------------------------------------------------------
1250 -- Completion
1251
1252 completeNone :: String -> IO [String]
1253 completeNone w = return []
1254
1255 #ifdef USE_READLINE
1256 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1257 completeWord w start end = do
1258   line <- Readline.getLineBuffer
1259   case w of
1260      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1261      _other
1262         | Just c <- is_cmd line -> do
1263            maybe_cmd <- lookupCommand c
1264            let (n,w') = selectWord (words' 0 line)
1265            case maybe_cmd of
1266              Nothing -> return Nothing
1267              Just (_,_,False,complete) -> wrapCompleter complete w
1268              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1269                                                               return (map (drop n) rets)
1270                                          in wrapCompleter complete' w'
1271         | otherwise     -> do
1272                 --printf "complete %s, start = %d, end = %d\n" w start end
1273                 wrapCompleter completeIdentifier w
1274     where words' _ [] = []
1275           words' n str = let (w,r) = break isSpace str
1276                              (s,r') = span isSpace r
1277                          in (n,w):words' (n+length w+length s) r'
1278           -- In a Haskell expression we want to parse 'a-b' as three words
1279           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1280           -- only be a single word.
1281           selectWord [] = (0,w)
1282           selectWord ((offset,x):xs)
1283               | offset+length x >= start = (start-offset,take (end-offset) x)
1284               | otherwise = selectWord xs
1285
1286 is_cmd line
1287  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1288  | otherwise = Nothing
1289
1290 completeCmd w = do
1291   cmds <- readIORef commands
1292   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1293
1294 completeMacro w = do
1295   cmds <- readIORef commands
1296   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1297   return (filter (w `isPrefixOf`) cmds')
1298
1299 completeIdentifier w = do
1300   s <- restoreSession
1301   rdrs <- GHC.getRdrNamesInScope s
1302   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1303
1304 completeModule w = do
1305   s <- restoreSession
1306   dflags <- GHC.getSessionDynFlags s
1307   let pkg_mods = allExposedModules dflags
1308   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1309
1310 completeHomeModule w = do
1311   s <- restoreSession
1312   g <- GHC.getModuleGraph s
1313   let home_mods = map GHC.ms_mod_name g
1314   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1315
1316 completeSetOptions w = do
1317   return (filter (w `isPrefixOf`) options)
1318     where options = "args":"prog":allFlags
1319
1320 completeFilename = Readline.filenameCompletionFunction
1321
1322 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1323
1324 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1325 unionComplete f1 f2 w = do
1326   s1 <- f1 w
1327   s2 <- f2 w
1328   return (s1 ++ s2)
1329
1330 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1331 wrapCompleter fun w =  do
1332   strs <- fun w
1333   case strs of
1334     []  -> return Nothing
1335     [x] -> return (Just (x,[]))
1336     xs  -> case getCommonPrefix xs of
1337                 ""   -> return (Just ("",xs))
1338                 pref -> return (Just (pref,xs))
1339
1340 getCommonPrefix :: [String] -> String
1341 getCommonPrefix [] = ""
1342 getCommonPrefix (s:ss) = foldl common s ss
1343   where common s "" = ""
1344         common "" s = ""
1345         common (c:cs) (d:ds)
1346            | c == d = c : common cs ds
1347            | otherwise = ""
1348
1349 allExposedModules :: DynFlags -> [ModuleName]
1350 allExposedModules dflags
1351  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1352  where
1353   pkg_db = pkgIdMap (pkgState dflags)
1354 #else
1355 completeCmd        = completeNone
1356 completeMacro      = completeNone
1357 completeIdentifier = completeNone
1358 completeModule     = completeNone
1359 completeHomeModule = completeNone
1360 completeSetOptions = completeNone
1361 completeFilename   = completeNone
1362 completeHomeModuleOrFile=completeNone
1363 completeBkpt       = completeNone
1364 #endif
1365
1366 -- ---------------------------------------------------------------------------
1367 -- User code exception handling
1368
1369 -- This is the exception handler for exceptions generated by the
1370 -- user's code and exceptions coming from children sessions;
1371 -- it normally just prints out the exception.  The
1372 -- handler must be recursive, in case showing the exception causes
1373 -- more exceptions to be raised.
1374 --
1375 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1376 -- raising another exception.  We therefore don't put the recursive
1377 -- handler arond the flushing operation, so if stderr is closed
1378 -- GHCi will just die gracefully rather than going into an infinite loop.
1379 handler :: Exception -> GHCi Bool
1380
1381 handler exception = do
1382   flushInterpBuffers
1383   io installSignalHandlers
1384   ghciHandle handler (showException exception >> return False)
1385
1386 showException (DynException dyn) =
1387   case fromDynamic dyn of
1388     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1389     Just Interrupted      -> io (putStrLn "Interrupted.")
1390     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1391     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1392     Just other_ghc_ex     -> io (print other_ghc_ex)
1393
1394 showException other_exception
1395   = io (putStrLn ("*** Exception: " ++ show other_exception))
1396
1397 -----------------------------------------------------------------------------
1398 -- recursive exception handlers
1399
1400 -- Don't forget to unblock async exceptions in the handler, or if we're
1401 -- in an exception loop (eg. let a = error a in a) the ^C exception
1402 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1403
1404 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1405 ghciHandle h (GHCi m) = GHCi $ \s ->
1406    Exception.catch (m s)
1407         (\e -> unGHCi (ghciUnblock (h e)) s)
1408
1409 ghciUnblock :: GHCi a -> GHCi a
1410 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1411
1412
1413 -- ----------------------------------------------------------------------------
1414 -- Utils
1415
1416 expandPath :: String -> GHCi String
1417 expandPath path =
1418   case dropWhile isSpace path of
1419    ('~':d) -> do
1420         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1421         return (tilde ++ '/':d)
1422    other ->
1423         return other
1424
1425 -- ----------------------------------------------------------------------------
1426 -- Windows console setup
1427
1428 setUpConsole :: IO ()
1429 setUpConsole = do
1430 #ifdef mingw32_HOST_OS
1431         -- On Windows we need to set a known code page, otherwise the characters
1432         -- we read from the console will be be in some strange encoding, and
1433         -- similarly for characters we write to the console.
1434         --
1435         -- At the moment, GHCi pretends all input is Latin-1.  In the
1436         -- future we should support UTF-8, but for now we set the code pages
1437         -- to Latin-1.
1438         --
1439         -- It seems you have to set the font in the console window to
1440         -- a Unicode font in order for output to work properly,
1441         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1442         -- (see MSDN for SetConsoleOutputCP()).
1443         --
1444         setConsoleCP 28591       -- ISO Latin-1
1445         setConsoleOutputCP 28591 -- ISO Latin-1
1446 #endif
1447         return ()
1448
1449 -- commands for debugger
1450 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1451
1452 stepCmd :: String -> GHCi Bool
1453 stepCmd [] = doContinue setStepFlag
1454 stepCmd expression = do
1455    io $ setStepFlag
1456    runCommand expression
1457
1458 continueCmd :: String -> GHCi Bool
1459 continueCmd [] = doContinue $ return ()
1460 continueCmd other = do
1461    io $ putStrLn "The continue command accepts no arguments."
1462    return False
1463
1464 doContinue :: IO () -> GHCi Bool
1465 doContinue actionBeforeCont = do
1466    resumeAction <- popResume
1467    case resumeAction of
1468       Nothing -> do
1469          io $ putStrLn "There is no computation running."
1470          return False
1471       Just (_,_,handle) -> do
1472          io $ actionBeforeCont
1473          session <- getSession
1474          runResult <- io $ GHC.resume session handle
1475          names <- switchOnRunResult runResult
1476          finishEvalExpr names
1477          return False
1478
1479 deleteCmd :: String -> GHCi Bool
1480 deleteCmd argLine = do
1481    deleteSwitch $ words argLine
1482    return False
1483    where
1484    deleteSwitch :: [String] -> GHCi ()
1485    deleteSwitch [] =
1486       io $ putStrLn "The delete command requires at least one argument."
1487    -- delete all break points
1488    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1489    deleteSwitch idents = do
1490       mapM_ deleteOneBreak idents
1491       where
1492       deleteOneBreak :: String -> GHCi ()
1493       deleteOneBreak str
1494          | all isDigit str = deleteBreak (read str)
1495          | otherwise = return ()
1496
1497 -- handle the "break" command
1498 breakCmd :: String -> GHCi Bool
1499 breakCmd argLine = do
1500    session <- getSession
1501    breakSwitch session $ words argLine
1502    return False
1503
1504 breakSwitch :: Session -> [String] -> GHCi ()
1505 breakSwitch _session [] = do
1506    io $ putStrLn "The break command requires at least one argument."
1507 breakSwitch session args@(arg1:rest)
1508    | looksLikeModuleName arg1 = do
1509         mod <- wantInterpretedModule session arg1
1510         breakByModule session mod rest
1511    | all isDigit arg1 = do
1512         (toplevel, _) <- io $ GHC.getContext session
1513         case toplevel of
1514            (mod : _) -> breakByModuleLine mod (read arg1) rest
1515            [] -> do
1516               io $ putStrLn "Cannot find default module for breakpoint."
1517               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1518    | otherwise = do -- assume it's a name
1519         names <- io $ GHC.parseName session arg1
1520         case names of
1521           []    -> return ()
1522           (n:_) -> do
1523             let loc  = nameSrcLoc n
1524                 modl = nameModule n
1525             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1526             if not is_interpreted
1527                then noCanDo $ text "module " <> ppr modl <>
1528                               text " is not interpreted"
1529                else do
1530             if isGoodSrcLoc loc
1531                then findBreakAndSet (nameModule n) $
1532                          findBreakByCoord (srcLocLine loc, srcLocCol loc)
1533                else noCanDo $ text "can't find its location: " <>
1534                               ppr loc
1535            where
1536              noCanDo why = printForUser $
1537                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1538
1539
1540 wantInterpretedModule :: Session -> String -> GHCi Module
1541 wantInterpretedModule session str = do
1542    modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1543    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1544    when (not is_interpreted) $
1545        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1546    return modl
1547
1548 breakByModule :: Session -> Module -> [String] -> GHCi ()
1549 breakByModule session mod args@(arg1:rest)
1550    | all isDigit arg1 = do  -- looks like a line number
1551         breakByModuleLine mod (read arg1) rest
1552    | otherwise = io $ putStrLn "Invalid arguments to :break"
1553
1554 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1555 breakByModuleLine mod line args
1556    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1557    | [col] <- args, all isDigit col =
1558         findBreakAndSet mod $ findBreakByCoord (line, read col)
1559    | otherwise = io $ putStrLn "Invalid arguments to :break"
1560
1561 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1562 findBreakAndSet mod lookupTickTree = do
1563    tickArray <- getTickArray mod
1564    (breakArray, _) <- getModBreak mod
1565    case lookupTickTree tickArray of
1566       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1567       Just (tick, span) -> do
1568          success <- io $ setBreakFlag True breakArray tick
1569          session <- getSession
1570          if success
1571             then do
1572                (alreadySet, nm) <-
1573                      recordBreak $ BreakLocation
1574                              { breakModule = mod
1575                              , breakLoc = span
1576                              , breakTick = tick
1577                              }
1578                printForUser $
1579                   text "Breakpoint " <> ppr nm <>
1580                   if alreadySet
1581                      then text " was already set at " <> ppr span
1582                      else text " activated at " <> ppr span
1583             else do
1584             printForUser $ text "Breakpoint could not be activated at"
1585                                  <+> ppr span
1586
1587 -- When a line number is specified, the current policy for choosing
1588 -- the best breakpoint is this:
1589 --    - the leftmost complete subexpression on the specified line, or
1590 --    - the leftmost subexpression starting on the specified line, or
1591 --    - the rightmost subexpression enclosing the specified line
1592 --
1593 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1594 findBreakByLine line arr
1595   | not (inRange (bounds arr) line) = Nothing
1596   | otherwise =
1597     listToMaybe (sortBy leftmost complete)   `mplus`
1598     listToMaybe (sortBy leftmost incomplete) `mplus`
1599     listToMaybe (sortBy rightmost ticks)
1600   where
1601         ticks = arr ! line
1602
1603         starts_here = [ tick | tick@(nm,span) <- ticks,
1604                                srcSpanStartLine span == line ]
1605
1606         (complete,incomplete) = partition ends_here starts_here
1607             where ends_here (nm,span) = srcSpanEndLine span == line
1608
1609 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1610 findBreakByCoord (line, col) arr
1611   | not (inRange (bounds arr) line) = Nothing
1612   | otherwise =
1613     listToMaybe (sortBy rightmost contains)
1614   where
1615         ticks = arr ! line
1616
1617         -- the ticks that span this coordinate
1618         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1619
1620 leftmost  (_,a) (_,b) = a `compare` b
1621 rightmost (_,a) (_,b) = b `compare` a
1622
1623 spans :: SrcSpan -> (Int,Int) -> Bool
1624 spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
1625    where loc = mkSrcLoc (srcSpanFile span) l c
1626
1627
1628 -- --------------------------------------------------------------------------
1629 -- Tick arrays
1630
1631 getTickArray :: Module -> GHCi TickArray
1632 getTickArray modl = do
1633    st <- getGHCiState
1634    let arrmap = tickarrays st
1635    case lookupModuleEnv arrmap modl of
1636       Just arr -> return arr
1637       Nothing  -> do
1638         (breakArray, ticks) <- getModBreak modl
1639         let arr = mkTickArray (assocs ticks)
1640         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1641         return arr
1642
1643 discardTickArrays :: GHCi ()
1644 discardTickArrays = do
1645    st <- getGHCiState
1646    setGHCiState st{tickarrays = emptyModuleEnv}
1647
1648 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1649 mkTickArray ticks
1650   = accumArray (flip (:)) [] (1, max_line)
1651         [ (line, (nm,span)) | (nm,span) <- ticks,
1652                               line <- srcSpanLines span ]
1653     where
1654         max_line = maximum (map srcSpanEndLine (map snd ticks))
1655         srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
1656
1657 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1658 getModBreak mod = do
1659    session <- getSession
1660    Just mod_info <- io $ GHC.getModuleInfo session mod
1661    let modBreaks  = GHC.modInfoModBreaks mod_info
1662    let array      = GHC.modBreaks_flags modBreaks
1663    let ticks      = GHC.modBreaks_locs  modBreaks
1664    return (array, ticks)
1665
1666 lookupModule :: Session -> String -> GHCi Module
1667 lookupModule session modName
1668    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1669
1670 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1671 setBreakFlag toggle array index
1672    | toggle    = GHC.setBreakOn array index
1673    | otherwise = GHC.setBreakOff array index
1674
1675
1676 {- these should probably go to the GHC API at some point -}
1677 enableBreakPoint  :: Session -> Module -> Int -> IO ()
1678 enableBreakPoint session mod index = return ()
1679
1680 disableBreakPoint :: Session -> Module -> Int -> IO ()
1681 disableBreakPoint session mod index = return ()
1682
1683 activeBreakPoints :: Session -> IO [(Module,Int)]
1684 activeBreakPoints session = return []
1685
1686 enableSingleStep  :: Session -> IO ()
1687 enableSingleStep session = return ()
1688
1689 disableSingleStep :: Session -> IO ()
1690 disableSingleStep session = return ()