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 import Debugger
  19
  20 -- The GHC interface
  21 import qualified GHC
  22 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  23                           Type, Module, ModuleName, TyThing(..), Phase,
  24                           BreakIndex, Name, SrcSpan )
  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 forceCmd,             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 printCmd,             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 sprintCmd,            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 sprintCmd = pprintCommand False False
1360 printCmd  = pprintCommand True False
1361 forceCmd  = pprintCommand False True
1362
1363 pprintCommand bind force str = do
1364   session <- getSession
1365   io $ pprintClosureCommand session bind force str
1366
1367 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1368
1369 stepCmd :: String -> GHCi Bool
1370 stepCmd [] = doContinue setStepFlag
1371 stepCmd expression = do
1372    io $ setStepFlag
1373    runCommand expression
1374
1375 continueCmd :: String -> GHCi Bool
1376 continueCmd [] = doContinue $ return ()
1377 continueCmd other = do
1378    io $ putStrLn "The continue command accepts no arguments."
1379    return False
1380
1381 doContinue :: IO () -> GHCi Bool
1382 doContinue actionBeforeCont = do
1383    resumeAction <- popResume
1384    case resumeAction of
1385       Nothing -> do
1386          io $ putStrLn "There is no computation running."
1387          return False
1388       Just (_,_,handle) -> do
1389          io $ actionBeforeCont
1390          session <- getSession
1391          runResult <- io $ GHC.resume session handle
1392          names <- switchOnRunResult runResult
1393          finishEvalExpr names
1394          return False
1395
1396 abandonCmd :: String -> GHCi ()
1397 abandonCmd "" = do
1398    mb_res <- popResume
1399    case mb_res of
1400       Nothing -> do
1401          io $ putStrLn "There is no computation running."
1402       Just (span,_,_) ->
1403          return ()
1404          -- the prompt will change to indicate the new context
1405
1406 deleteCmd :: String -> GHCi ()
1407 deleteCmd argLine = do
1408    deleteSwitch $ words argLine
1409    where
1410    deleteSwitch :: [String] -> GHCi ()
1411    deleteSwitch [] =
1412       io $ putStrLn "The delete command requires at least one argument."
1413    -- delete all break points
1414    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1415    deleteSwitch idents = do
1416       mapM_ deleteOneBreak idents
1417       where
1418       deleteOneBreak :: String -> GHCi ()
1419       deleteOneBreak str
1420          | all isDigit str = deleteBreak (read str)
1421          | otherwise = return ()
1422
1423 -- handle the "break" command
1424 breakCmd :: String -> GHCi ()
1425 breakCmd argLine = do
1426    session <- getSession
1427    breakSwitch session $ words argLine
1428
1429 breakSwitch :: Session -> [String] -> GHCi ()
1430 breakSwitch _session [] = do
1431    io $ putStrLn "The break command requires at least one argument."
1432 breakSwitch session args@(arg1:rest)
1433    | looksLikeModuleName arg1 = do
1434         mod <- wantInterpretedModule session arg1
1435         breakByModule session mod rest
1436    | all isDigit arg1 = do
1437         (toplevel, _) <- io $ GHC.getContext session
1438         case toplevel of
1439            (mod : _) -> breakByModuleLine mod (read arg1) rest
1440            [] -> do
1441               io $ putStrLn "Cannot find default module for breakpoint."
1442               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1443    | otherwise = do -- assume it's a name
1444         names <- io $ GHC.parseName session arg1
1445         case names of
1446           []    -> return ()
1447           (n:_) -> do
1448             let loc  = GHC.nameSrcLoc n
1449                 modl = GHC.nameModule n
1450             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1451             if not is_interpreted
1452                then noCanDo $ text "module " <> ppr modl <>
1453                               text " is not interpreted"
1454                else do
1455             if GHC.isGoodSrcLoc loc
1456                then findBreakAndSet (GHC.nameModule n) $
1457                          findBreakByCoord (GHC.srcLocLine loc,
1458                                            GHC.srcLocCol loc)
1459                else noCanDo $ text "can't find its location: " <>
1460                               ppr loc
1461            where
1462              noCanDo why = printForUser $
1463                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1464
1465
1466 wantInterpretedModule :: Session -> String -> GHCi Module
1467 wantInterpretedModule session str = do
1468    modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1469    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1470    when (not is_interpreted) $
1471        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1472    return modl
1473
1474 breakByModule :: Session -> Module -> [String] -> GHCi ()
1475 breakByModule session mod args@(arg1:rest)
1476    | all isDigit arg1 = do  -- looks like a line number
1477         breakByModuleLine mod (read arg1) rest
1478    | otherwise = io $ putStrLn "Invalid arguments to :break"
1479
1480 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1481 breakByModuleLine mod line args
1482    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1483    | [col] <- args, all isDigit col =
1484         findBreakAndSet mod $ findBreakByCoord (line, read col)
1485    | otherwise = io $ putStrLn "Invalid arguments to :break"
1486
1487 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1488 findBreakAndSet mod lookupTickTree = do
1489    tickArray <- getTickArray mod
1490    (breakArray, _) <- getModBreak mod
1491    case lookupTickTree tickArray of
1492       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1493       Just (tick, span) -> do
1494          success <- io $ setBreakFlag True breakArray tick
1495          session <- getSession
1496          if success
1497             then do
1498                (alreadySet, nm) <-
1499                      recordBreak $ BreakLocation
1500                              { breakModule = mod
1501                              , breakLoc = span
1502                              , breakTick = tick
1503                              }
1504                printForUser $
1505                   text "Breakpoint " <> ppr nm <>
1506                   if alreadySet
1507                      then text " was already set at " <> ppr span
1508                      else text " activated at " <> ppr span
1509             else do
1510             printForUser $ text "Breakpoint could not be activated at"
1511                                  <+> ppr span
1512
1513 -- When a line number is specified, the current policy for choosing
1514 -- the best breakpoint is this:
1515 --    - the leftmost complete subexpression on the specified line, or
1516 --    - the leftmost subexpression starting on the specified line, or
1517 --    - the rightmost subexpression enclosing the specified line
1518 --
1519 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1520 findBreakByLine line arr
1521   | not (inRange (bounds arr) line) = Nothing
1522   | otherwise =
1523     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1524     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1525     listToMaybe (sortBy rightmost ticks)
1526   where
1527         ticks = arr ! line
1528
1529         starts_here = [ tick | tick@(nm,span) <- ticks,
1530                                GHC.srcSpanStartLine span == line ]
1531
1532         (complete,incomplete) = partition ends_here starts_here
1533             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1534
1535 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1536 findBreakByCoord (line, col) arr
1537   | not (inRange (bounds arr) line) = Nothing
1538   | otherwise =
1539     listToMaybe (sortBy rightmost contains)
1540   where
1541         ticks = arr ! line
1542
1543         -- the ticks that span this coordinate
1544         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1545
1546 leftmost_smallest  (_,a) (_,b) = a `compare` b
1547 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1548                                 `thenCmp`
1549                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1550 rightmost (_,a) (_,b) = b `compare` a
1551
1552 spans :: SrcSpan -> (Int,Int) -> Bool
1553 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1554    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1555
1556 start_bold = BS.pack "\ESC[1m"
1557 end_bold   = BS.pack "\ESC[0m"
1558
1559 listCmd :: String -> GHCi ()
1560 listCmd str = do
1561    st <- getGHCiState
1562    case resume st of
1563       []  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1564       (span,_,_):_ -> io $ listAround span True
1565
1566 -- | list a section of a source file around a particular SrcSpan.
1567 -- If the highlight flag is True, also highlight the span using
1568 -- start_bold/end_bold.
1569 listAround span do_highlight = do
1570       contents <- BS.readFile (unpackFS file)
1571       let
1572           lines = BS.split '\n' contents
1573           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1574                         drop (line1 - 1 - pad_before) $ lines
1575           fst_line = max 1 (line1 - pad_before)
1576           line_nos = [ fst_line .. ]
1577
1578           highlighted | do_highlight = zipWith highlight line_nos these_lines
1579                       | otherwise   = these_lines
1580
1581           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1582           prefixed = zipWith BS.append bs_line_nos highlighted
1583       --
1584       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1585   where
1586         file  = GHC.srcSpanFile span
1587         line1 = GHC.srcSpanStartLine span
1588         col1  = GHC.srcSpanStartCol span
1589         line2 = GHC.srcSpanEndLine span
1590         col2  = GHC.srcSpanEndCol span
1591
1592         pad_before | line1 == 1 = 0
1593                    | otherwise  = 1
1594         pad_after = 1
1595
1596         highlight no line
1597           | no == line1 && no == line2
1598           = let (a,r) = BS.splitAt col1 line
1599                 (b,c) = BS.splitAt (col2-col1) r
1600             in
1601             BS.concat [a,start_bold,b,end_bold,c]
1602           | no == line1
1603           = let (a,b) = BS.splitAt col1 line in
1604             BS.concat [a, start_bold, b]
1605           | no == line2
1606           = let (a,b) = BS.splitAt col2 line in
1607             BS.concat [a, end_bold, b]
1608           | otherwise   = line
1609
1610 -- --------------------------------------------------------------------------
1611 -- Tick arrays
1612
1613 getTickArray :: Module -> GHCi TickArray
1614 getTickArray modl = do
1615    st <- getGHCiState
1616    let arrmap = tickarrays st
1617    case lookupModuleEnv arrmap modl of
1618       Just arr -> return arr
1619       Nothing  -> do
1620         (breakArray, ticks) <- getModBreak modl
1621         let arr = mkTickArray (assocs ticks)
1622         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1623         return arr
1624
1625 discardTickArrays :: GHCi ()
1626 discardTickArrays = do
1627    st <- getGHCiState
1628    setGHCiState st{tickarrays = emptyModuleEnv}
1629
1630 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1631 mkTickArray ticks
1632   = accumArray (flip (:)) [] (1, max_line)
1633         [ (line, (nm,span)) | (nm,span) <- ticks,
1634                               line <- srcSpanLines span ]
1635     where
1636         max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
1637         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1638                               GHC.srcSpanEndLine span ]
1639
1640 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1641 getModBreak mod = do
1642    session <- getSession
1643    Just mod_info <- io $ GHC.getModuleInfo session mod
1644    let modBreaks  = GHC.modInfoModBreaks mod_info
1645    let array      = GHC.modBreaks_flags modBreaks
1646    let ticks      = GHC.modBreaks_locs  modBreaks
1647    return (array, ticks)
1648
1649 lookupModule :: Session -> String -> GHCi Module
1650 lookupModule session modName
1651    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1652
1653 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1654 setBreakFlag toggle array index
1655    | toggle    = GHC.setBreakOn array index
1656    | otherwise = GHC.setBreakOff array index
1657
1658
1659 {- these should probably go to the GHC API at some point -}
1660 enableBreakPoint  :: Session -> Module -> Int -> IO ()
1661 enableBreakPoint session mod index = return ()
1662
1663 disableBreakPoint :: Session -> Module -> Int -> IO ()
1664 disableBreakPoint session mod index = return ()
1665
1666 activeBreakPoints :: Session -> IO [(Module,Int)]
1667 activeBreakPoints session = return []
1668
1669 enableSingleStep  :: Session -> IO ()
1670 enableSingleStep session = return ()
1671
1672 disableSingleStep :: Session -> IO ()
1673 disableSingleStep session = return ()