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