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