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, Resume )
  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 Config
  38 import StaticFlags
  39 import Linker
  40 import Util
  41 import FastString
  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                    breaks = emptyActiveBreakPoints,
 272                    tickarrays = emptyModuleEnv
 273                  }
 274
 275 #ifdef USE_READLINE
 276    Readline.resetTerminal Nothing
 277 #endif
 278
 279    return ()
 280
 281 prel_name = GHC.mkModuleName "Prelude"
 282
 283 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 284 runGHCi paths maybe_expr = do
 285   let read_dot_files = not opt_IgnoreDotGhci
 286
 287   when (read_dot_files) $ do
 288     -- Read in ./.ghci.
 289     let file = "./.ghci"
 290     exists <- io (doesFileExist file)
 291     when exists $ do
 292        dir_ok  <- io (checkPerms ".")
 293        file_ok <- io (checkPerms file)
 294        when (dir_ok && file_ok) $ do
 295           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 296           case either_hdl of
 297              Left e    -> return ()
 298              Right hdl -> fileLoop hdl False
 299
 300   when (read_dot_files) $ do
 301     -- Read in $HOME/.ghci
 302     either_dir <- io (IO.try (getEnv "HOME"))
 303     case either_dir of
 304        Left e -> return ()
 305        Right dir -> do
 306           cwd <- io (getCurrentDirectory)
 307           when (dir /= cwd) $ do
 308              let file = dir ++ "/.ghci"
 309              ok <- io (checkPerms file)
 310              when ok $ do
 311                either_hdl <- io (IO.try (openFile file ReadMode))
 312                case either_hdl of
 313                   Left e    -> return ()
 314                   Right hdl -> fileLoop hdl False
 315
 316   -- Perform a :load for files given on the GHCi command line
 317   -- When in -e mode, if the load fails then we want to stop
 318   -- immediately rather than going on to evaluate the expression.
 319   when (not (null paths)) $ do
 320      ok <- ghciHandle (\e -> do showException e; return Failed) $
 321                 loadModule paths
 322      when (isJust maybe_expr && failed ok) $
 323         io (exitWith (ExitFailure 1))
 324
 325   -- if verbosity is greater than 0, or we are connected to a
 326   -- terminal, display the prompt in the interactive loop.
 327   is_tty <- io (hIsTerminalDevice stdin)
 328   dflags <- getDynFlags
 329   let show_prompt = verbosity dflags > 0 || is_tty
 330
 331   case maybe_expr of
 332         Nothing ->
 333           do
 334 #if defined(mingw32_HOST_OS)
 335             -- The win32 Console API mutates the first character of
 336             -- type-ahead when reading from it in a non-buffered manner. Work
 337             -- around this by flushing the input buffer of type-ahead characters,
 338             -- but only if stdin is available.
 339             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 340             case flushed of
 341              Left err | isDoesNotExistError err -> return ()
 342                       | otherwise -> io (ioError err)
 343              Right () -> return ()
 344 #endif
 345             -- initialise the console if necessary
 346             io setUpConsole
 347
 348             -- enter the interactive loop
 349             interactiveLoop is_tty show_prompt
 350         Just expr -> do
 351             -- just evaluate the expression we were given
 352             runCommandEval expr
 353             return ()
 354
 355   -- and finally, exit
 356   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 357
 358
 359 interactiveLoop is_tty show_prompt =
 360   -- Ignore ^C exceptions caught here
 361   ghciHandleDyn (\e -> case e of
 362                         Interrupted -> do
 363 #if defined(mingw32_HOST_OS)
 364                                 io (putStrLn "")
 365 #endif
 366                                 interactiveLoop is_tty show_prompt
 367                         _other      -> return ()) $
 368
 369   ghciUnblock $ do -- unblock necessary if we recursed from the
 370                    -- exception handler above.
 371
 372   -- read commands from stdin
 373 #ifdef USE_READLINE
 374   if (is_tty)
 375         then readlineLoop
 376         else fileLoop stdin show_prompt
 377 #else
 378   fileLoop stdin show_prompt
 379 #endif
 380
 381
 382 -- NOTE: We only read .ghci files if they are owned by the current user,
 383 -- and aren't world writable.  Otherwise, we could be accidentally
 384 -- running code planted by a malicious third party.
 385
 386 -- Furthermore, We only read ./.ghci if . is owned by the current user
 387 -- and isn't writable by anyone else.  I think this is sufficient: we
 388 -- don't need to check .. and ../.. etc. because "."  always refers to
 389 -- the same directory while a process is running.
 390
 391 checkPerms :: String -> IO Bool
 392 checkPerms name =
 393 #ifdef mingw32_HOST_OS
 394   return True
 395 #else
 396   Util.handle (\_ -> return False) $ do
 397      st <- getFileStatus name
 398      me <- getRealUserID
 399      if fileOwner st /= me then do
 400         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 401         return False
 402       else do
 403         let mode =  fileMode st
 404         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 405            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 406            then do
 407                putStrLn $ "*** WARNING: " ++ name ++
 408                           " is writable by someone else, IGNORING!"
 409                return False
 410           else return True
 411 #endif
 412
 413 fileLoop :: Handle -> Bool -> GHCi ()
 414 fileLoop hdl show_prompt = do
 415    session <- getSession
 416    (mod,imports) <- io (GHC.getContext session)
 417    st <- getGHCiState
 418    resumes <- io $ GHC.getResumeContext session
 419    when show_prompt (io (putStr (mkPrompt mod imports resumes (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           | eval:rest <- resumes
 454           = (if not (null rest) then text "... " else empty)
 455             <> brackets (ppr (GHC.resumeSpan eval)) <+> 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    resumes <- io $ GHC.getResumeContext session
 474    l <- io (readline (mkPrompt mod imports resumes (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 $ runStmt stmt
 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 r <- runStmt stmt
 510             case r of
 511                 False -> io (exitWith (ExitFailure 1))
 512                   -- failure to run the command causes exit(1) for ghc -e.
 513                 _       -> return True
 514
 515 runStmt :: String -> GHCi Bool
 516 runStmt stmt
 517  | null (filter (not.isSpace) stmt) = return 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       afterRunStmt result
 524       return False
 525
 526
 527 afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
 528 afterRunStmt run_result = do
 529   mb_result <- switchOnRunResult run_result
 530
 531   -- possibly print the type and revert CAFs after evaluating an expression
 532   show_types <- isOptionSet ShowType
 533   session <- getSession
 534   case mb_result of
 535     Nothing    -> return ()
 536     Just (is_break,names) ->
 537             when (is_break || show_types) $
 538                   mapM_ (showTypeOfName session) names
 539
 540   flushInterpBuffers
 541   io installSignalHandlers
 542   b <- isOptionSet RevertCAFs
 543   io (when b revertCAFs)
 544
 545   return mb_result
 546
 547
 548 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
 549 switchOnRunResult GHC.RunFailed = return Nothing
 550 switchOnRunResult (GHC.RunException e) = throw e
 551 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
 552 switchOnRunResult (GHC.RunBreak threadId names info) = do
 553    session <- getSession
 554    Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
 555    let modBreaks  = GHC.modInfoModBreaks mod_info
 556    let ticks      = GHC.modBreaks_locs modBreaks
 557
 558    -- display information about the breakpoint
 559    let location = ticks ! GHC.breakInfo_number info
 560    printForUser $ ptext SLIT("Stopped at") <+> ppr location
 561
 562    -- run the command set with ":set stop <cmd>"
 563    st <- getGHCiState
 564    runCommand (stop st)
 565
 566    return (Just (True,names))
 567
 568
 569 showTypeOfName :: Session -> Name -> GHCi ()
 570 showTypeOfName session n
 571    = do maybe_tything <- io (GHC.lookupName session n)
 572         case maybe_tything of
 573           Nothing    -> return ()
 574           Just thing -> showTyThing thing
 575
 576 specialCommand :: String -> GHCi Bool
 577 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 578 specialCommand str = do
 579   let (cmd,rest) = break isSpace str
 580   maybe_cmd <- io (lookupCommand cmd)
 581   case maybe_cmd of
 582     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 583                                     ++ shortHelpText) >> return False)
 584     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 585
 586 lookupCommand :: String -> IO (Maybe Command)
 587 lookupCommand str = do
 588   cmds <- readIORef commands
 589   -- look for exact match first, then the first prefix match
 590   case [ c | c <- cmds, str == cmdName c ] of
 591      c:_ -> return (Just c)
 592      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 593                 [] -> return Nothing
 594                 c:_ -> return (Just c)
 595
 596 -----------------------------------------------------------------------------
 597 -- Commands
 598
 599 help :: String -> GHCi ()
 600 help _ = io (putStr helpText)
 601
 602 info :: String -> GHCi ()
 603 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 604 info s  = do { let names = words s
 605              ; session <- getSession
 606              ; dflags <- getDynFlags
 607              ; let exts = dopt Opt_GlasgowExts dflags
 608              ; mapM_ (infoThing exts session) names }
 609   where
 610     infoThing exts session str = io $ do
 611         names <- GHC.parseName session str
 612         let filtered = filterOutChildren names
 613         mb_stuffs <- mapM (GHC.getInfo session) filtered
 614         unqual <- GHC.getPrintUnqual session
 615         putStrLn (showSDocForUser unqual $
 616                    vcat (intersperse (text "") $
 617                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 618
 619   -- Filter out names whose parent is also there Good
 620   -- example is '[]', which is both a type and data
 621   -- constructor in the same type
 622 filterOutChildren :: [Name] -> [Name]
 623 filterOutChildren names = filter (not . parent_is_there) names
 624  where parent_is_there n
 625 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 626 -- ToDo!!
 627          | otherwise                       = False
 628
 629 pprInfo exts (thing, fixity, insts)
 630   =  pprTyThingInContextLoc exts thing
 631   $$ show_fixity fixity
 632   $$ vcat (map GHC.pprInstance insts)
 633   where
 634     show_fixity fix
 635         | fix == GHC.defaultFixity = empty
 636         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 637
 638 runMain :: String -> GHCi ()
 639 runMain args = do
 640   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 641   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 642   return ()
 643
 644 addModule :: [FilePath] -> GHCi ()
 645 addModule files = do
 646   io (revertCAFs)                       -- always revert CAFs on load/add.
 647   files <- mapM expandPath files
 648   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 649   session <- getSession
 650   io (mapM_ (GHC.addTarget session) targets)
 651   ok <- io (GHC.load session LoadAllTargets)
 652   afterLoad ok session
 653
 654 changeDirectory :: String -> GHCi ()
 655 changeDirectory dir = do
 656   session <- getSession
 657   graph <- io (GHC.getModuleGraph session)
 658   when (not (null graph)) $
 659         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 660   io (GHC.setTargets session [])
 661   io (GHC.load session LoadAllTargets)
 662   setContextAfterLoad session []
 663   io (GHC.workingDirectoryChanged session)
 664   dir <- expandPath dir
 665   io (setCurrentDirectory dir)
 666
 667 editFile :: String -> GHCi ()
 668 editFile str
 669   | null str  = do
 670         -- find the name of the "topmost" file loaded
 671      session <- getSession
 672      graph0 <- io (GHC.getModuleGraph session)
 673      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 674      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 675      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 676         Just file -> do_edit file
 677         Nothing   -> throwDyn (CmdLineError "unknown file name")
 678   | otherwise = do_edit str
 679   where
 680         do_edit file = do
 681            st <- getGHCiState
 682            let cmd = editor st
 683            when (null cmd) $
 684                 throwDyn (CmdLineError "editor not set, use :set editor")
 685            io $ system (cmd ++ ' ':file)
 686            return ()
 687
 688 defineMacro :: String -> GHCi ()
 689 defineMacro s = do
 690   let (macro_name, definition) = break isSpace s
 691   cmds <- io (readIORef commands)
 692   if (null macro_name)
 693         then throwDyn (CmdLineError "invalid macro name")
 694         else do
 695   if (macro_name `elem` map cmdName cmds)
 696         then throwDyn (CmdLineError
 697                 ("command '" ++ macro_name ++ "' is already defined"))
 698         else do
 699
 700   -- give the expression a type signature, so we can be sure we're getting
 701   -- something of the right type.
 702   let new_expr = '(' : definition ++ ") :: String -> IO String"
 703
 704   -- compile the expression
 705   cms <- getSession
 706   maybe_hv <- io (GHC.compileExpr cms new_expr)
 707   case maybe_hv of
 708      Nothing -> return ()
 709      Just hv -> io (writeIORef commands --
 710                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 711
 712 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 713 runMacro fun s = do
 714   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 715   stringLoop (lines str)
 716
 717 undefineMacro :: String -> GHCi ()
 718 undefineMacro macro_name = do
 719   cmds <- io (readIORef commands)
 720   if (macro_name `elem` map cmdName builtin_commands)
 721         then throwDyn (CmdLineError
 722                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 723         else do
 724   if (macro_name `notElem` map cmdName cmds)
 725         then throwDyn (CmdLineError
 726                 ("command '" ++ macro_name ++ "' not defined"))
 727         else do
 728   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 729
 730
 731 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 732 loadModule fs = timeIt (loadModule' fs)
 733
 734 loadModule_ :: [FilePath] -> GHCi ()
 735 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 736
 737 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 738 loadModule' files = do
 739   session <- getSession
 740
 741   -- unload first
 742   io (GHC.setTargets session [])
 743   io (GHC.load session LoadAllTargets)
 744
 745   -- expand tildes
 746   let (filenames, phases) = unzip files
 747   exp_filenames <- mapM expandPath filenames
 748   let files' = zip exp_filenames phases
 749   targets <- io (mapM (uncurry GHC.guessTarget) files')
 750
 751   -- NOTE: we used to do the dependency anal first, so that if it
 752   -- fails we didn't throw away the current set of modules.  This would
 753   -- require some re-working of the GHC interface, so we'll leave it
 754   -- as a ToDo for now.
 755
 756   io (GHC.setTargets session targets)
 757   ok <- io (GHC.load session LoadAllTargets)
 758   afterLoad ok session
 759   return ok
 760
 761 checkModule :: String -> GHCi ()
 762 checkModule m = do
 763   let modl = GHC.mkModuleName m
 764   session <- getSession
 765   result <- io (GHC.checkModule session modl)
 766   case result of
 767     Nothing -> io $ putStrLn "Nothing"
 768     Just r  -> io $ putStrLn (showSDoc (
 769         case GHC.checkedModuleInfo r of
 770            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 771                 let
 772                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 773                 in
 774                         (text "global names: " <+> ppr global) $$
 775                         (text "local  names: " <+> ppr local)
 776            _ -> empty))
 777   afterLoad (successIf (isJust result)) session
 778
 779 reloadModule :: String -> GHCi ()
 780 reloadModule "" = do
 781   io (revertCAFs)               -- always revert CAFs on reload.
 782   session <- getSession
 783   ok <- io (GHC.load session LoadAllTargets)
 784   afterLoad ok session
 785 reloadModule m = do
 786   io (revertCAFs)               -- always revert CAFs on reload.
 787   session <- getSession
 788   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 789   afterLoad ok session
 790
 791 afterLoad ok session = do
 792   io (revertCAFs)  -- always revert CAFs on load.
 793   discardTickArrays
 794   discardActiveBreakPoints
 795   graph <- io (GHC.getModuleGraph session)
 796   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 797   setContextAfterLoad session graph'
 798   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 799
 800 setContextAfterLoad session [] = do
 801   prel_mod <- getPrelude
 802   io (GHC.setContext session [] [prel_mod])
 803 setContextAfterLoad session ms = do
 804   -- load a target if one is available, otherwise load the topmost module.
 805   targets <- io (GHC.getTargets session)
 806   case [ m | Just m <- map (findTarget ms) targets ] of
 807         []    ->
 808           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 809           load_this (last graph')
 810         (m:_) ->
 811           load_this m
 812  where
 813    findTarget ms t
 814     = case filter (`matches` t) ms of
 815         []    -> Nothing
 816         (m:_) -> Just m
 817
 818    summary `matches` Target (TargetModule m) _
 819         = GHC.ms_mod_name summary == m
 820    summary `matches` Target (TargetFile f _) _
 821         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 822    summary `matches` target
 823         = False
 824
 825    load_this summary | m <- GHC.ms_mod summary = do
 826         b <- io (GHC.moduleIsInterpreted session m)
 827         if b then io (GHC.setContext session [m] [])
 828              else do
 829                    prel_mod <- getPrelude
 830                    io (GHC.setContext session []  [prel_mod,m])
 831
 832
 833 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 834 modulesLoadedMsg ok mods = do
 835   dflags <- getDynFlags
 836   when (verbosity dflags > 0) $ do
 837    let mod_commas
 838         | null mods = text "none."
 839         | otherwise = hsep (
 840             punctuate comma (map ppr mods)) <> text "."
 841    case ok of
 842     Failed ->
 843        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 844     Succeeded  ->
 845        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 846
 847
 848 typeOfExpr :: String -> GHCi ()
 849 typeOfExpr str
 850   = do cms <- getSession
 851        maybe_ty <- io (GHC.exprType cms str)
 852        case maybe_ty of
 853           Nothing -> return ()
 854           Just ty -> do ty' <- cleanType ty
 855                         printForUser $ text str <> text " :: " <> ppr ty'
 856
 857 kindOfType :: String -> GHCi ()
 858 kindOfType str
 859   = do cms <- getSession
 860        maybe_ty <- io (GHC.typeKind cms str)
 861        case maybe_ty of
 862           Nothing    -> return ()
 863           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 864
 865 quit :: String -> GHCi Bool
 866 quit _ = return True
 867
 868 shellEscape :: String -> GHCi Bool
 869 shellEscape str = io (system str >> return False)
 870
 871 -----------------------------------------------------------------------------
 872 -- Browsing a module's contents
 873
 874 browseCmd :: String -> GHCi ()
 875 browseCmd m =
 876   case words m of
 877     ['*':m] | looksLikeModuleName m -> browseModule m False
 878     [m]     | looksLikeModuleName m -> browseModule m True
 879     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 880
 881 browseModule m exports_only = do
 882   s <- getSession
 883   modl <- if exports_only then lookupModule s m
 884                           else wantInterpretedModule s m
 885
 886   -- Temporarily set the context to the module we're interested in,
 887   -- just so we can get an appropriate PrintUnqualified
 888   (as,bs) <- io (GHC.getContext s)
 889   prel_mod <- getPrelude
 890   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 891                       else GHC.setContext s [modl] [])
 892   unqual <- io (GHC.getPrintUnqual s)
 893   io (GHC.setContext s as bs)
 894
 895   mb_mod_info <- io $ GHC.getModuleInfo s modl
 896   case mb_mod_info of
 897     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 898     Just mod_info -> do
 899         let names
 900                | exports_only = GHC.modInfoExports mod_info
 901                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 902
 903             filtered = filterOutChildren names
 904
 905         things <- io $ mapM (GHC.lookupName s) filtered
 906
 907         dflags <- getDynFlags
 908         let exts = dopt Opt_GlasgowExts dflags
 909         io (putStrLn (showSDocForUser unqual (
 910                 vcat (map (pprTyThingInContext exts) (catMaybes things))
 911            )))
 912         -- ToDo: modInfoInstances currently throws an exception for
 913         -- package modules.  When it works, we can do this:
 914         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
 915
 916 -----------------------------------------------------------------------------
 917 -- Setting the module context
 918
 919 setContext str
 920   | all sensible mods = fn mods
 921   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 922   where
 923     (fn, mods) = case str of
 924                         '+':stuff -> (addToContext,      words stuff)
 925                         '-':stuff -> (removeFromContext, words stuff)
 926                         stuff     -> (newContext,        words stuff)
 927
 928     sensible ('*':m) = looksLikeModuleName m
 929     sensible m       = looksLikeModuleName m
 930
 931 separate :: Session -> [String] -> [Module] -> [Module]
 932         -> GHCi ([Module],[Module])
 933 separate session []           as bs = return (as,bs)
 934 separate session (('*':str):ms) as bs = do
 935    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
 936    b <- io $ GHC.moduleIsInterpreted session m
 937    if b then separate session ms (m:as) bs
 938         else throwDyn (CmdLineError ("module '"
 939                         ++ GHC.moduleNameString (GHC.moduleName m)
 940                         ++ "' is not interpreted"))
 941 separate session (str:ms) as bs = do
 942   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
 943   separate session ms as (m:bs)
 944
 945 newContext :: [String] -> GHCi ()
 946 newContext strs = do
 947   s <- getSession
 948   (as,bs) <- separate s strs [] []
 949   prel_mod <- getPrelude
 950   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
 951   io $ GHC.setContext s as bs'
 952
 953
 954 addToContext :: [String] -> GHCi ()
 955 addToContext strs = do
 956   s <- getSession
 957   (as,bs) <- io $ GHC.getContext s
 958
 959   (new_as,new_bs) <- separate s strs [] []
 960
 961   let as_to_add = new_as \\ (as ++ bs)
 962       bs_to_add = new_bs \\ (as ++ bs)
 963
 964   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
 965
 966
 967 removeFromContext :: [String] -> GHCi ()
 968 removeFromContext strs = do
 969   s <- getSession
 970   (as,bs) <- io $ GHC.getContext s
 971
 972   (as_to_remove,bs_to_remove) <- separate s strs [] []
 973
 974   let as' = as \\ (as_to_remove ++ bs_to_remove)
 975       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 976
 977   io $ GHC.setContext s as' bs'
 978
 979 ----------------------------------------------------------------------------
 980 -- Code for `:set'
 981
 982 -- set options in the interpreter.  Syntax is exactly the same as the
 983 -- ghc command line, except that certain options aren't available (-C,
 984 -- -E etc.)
 985 --
 986 -- This is pretty fragile: most options won't work as expected.  ToDo:
 987 -- figure out which ones & disallow them.
 988
 989 setCmd :: String -> GHCi ()
 990 setCmd ""
 991   = do st <- getGHCiState
 992        let opts = options st
 993        io $ putStrLn (showSDoc (
 994               text "options currently set: " <>
 995               if null opts
 996                    then text "none."
 997                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 998            ))
 999 setCmd str
1000   = case toArgs str of
1001         ("args":args) -> setArgs args
1002         ("prog":prog) -> setProg prog
1003         ("prompt":prompt) -> setPrompt (after 6)
1004         ("editor":cmd) -> setEditor (after 6)
1005         ("stop":cmd) -> setStop (after 4)
1006         wds -> setOptions wds
1007    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1008
1009 setArgs args = do
1010   st <- getGHCiState
1011   setGHCiState st{ args = args }
1012
1013 setProg [prog] = do
1014   st <- getGHCiState
1015   setGHCiState st{ progname = prog }
1016 setProg _ = do
1017   io (hPutStrLn stderr "syntax: :set prog <progname>")
1018
1019 setEditor cmd = do
1020   st <- getGHCiState
1021   setGHCiState st{ editor = cmd }
1022
1023 setStop cmd = do
1024   st <- getGHCiState
1025   setGHCiState st{ stop = cmd }
1026
1027 setPrompt value = do
1028   st <- getGHCiState
1029   if null value
1030       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1031       else setGHCiState st{ prompt = remQuotes value }
1032   where
1033      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1034      remQuotes x = x
1035
1036 setOptions wds =
1037    do -- first, deal with the GHCi opts (+s, +t, etc.)
1038       let (plus_opts, minus_opts)  = partition isPlus wds
1039       mapM_ setOpt plus_opts
1040
1041       -- then, dynamic flags
1042       dflags <- getDynFlags
1043       let pkg_flags = packageFlags dflags
1044       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1045
1046       if (not (null leftovers))
1047                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1048                                                 unwords leftovers))
1049                 else return ()
1050
1051       new_pkgs <- setDynFlags dflags'
1052
1053       -- if the package flags changed, we should reset the context
1054       -- and link the new packages.
1055       dflags <- getDynFlags
1056       when (packageFlags dflags /= pkg_flags) $ do
1057         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1058         session <- getSession
1059         io (GHC.setTargets session [])
1060         io (GHC.load session LoadAllTargets)
1061         io (linkPackages dflags new_pkgs)
1062         setContextAfterLoad session []
1063       return ()
1064
1065
1066 unsetOptions :: String -> GHCi ()
1067 unsetOptions str
1068   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1069        let opts = words str
1070            (minus_opts, rest1) = partition isMinus opts
1071            (plus_opts, rest2)  = partition isPlus rest1
1072
1073        if (not (null rest2))
1074           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1075           else do
1076
1077        mapM_ unsetOpt plus_opts
1078
1079        -- can't do GHC flags for now
1080        if (not (null minus_opts))
1081           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1082           else return ()
1083
1084 isMinus ('-':s) = True
1085 isMinus _ = False
1086
1087 isPlus ('+':s) = True
1088 isPlus _ = False
1089
1090 setOpt ('+':str)
1091   = case strToGHCiOpt str of
1092         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1093         Just o  -> setOption o
1094
1095 unsetOpt ('+':str)
1096   = case strToGHCiOpt str of
1097         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1098         Just o  -> unsetOption o
1099
1100 strToGHCiOpt :: String -> (Maybe GHCiOption)
1101 strToGHCiOpt "s" = Just ShowTiming
1102 strToGHCiOpt "t" = Just ShowType
1103 strToGHCiOpt "r" = Just RevertCAFs
1104 strToGHCiOpt _   = Nothing
1105
1106 optToStr :: GHCiOption -> String
1107 optToStr ShowTiming = "s"
1108 optToStr ShowType   = "t"
1109 optToStr RevertCAFs = "r"
1110
1111 -- ---------------------------------------------------------------------------
1112 -- code for `:show'
1113
1114 showCmd str =
1115   case words str of
1116         ["modules" ] -> showModules
1117         ["bindings"] -> showBindings
1118         ["linker"]   -> io showLinkerState
1119         ["breaks"] -> showBkptTable
1120         ["context"] -> showContext
1121         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings|breaks]")
1122
1123 showModules = do
1124   session <- getSession
1125   let show_one ms = do m <- io (GHC.showModule session ms)
1126                        io (putStrLn m)
1127   graph <- io (GHC.getModuleGraph session)
1128   mapM_ show_one graph
1129
1130 showBindings = do
1131   s <- getSession
1132   unqual <- io (GHC.getPrintUnqual s)
1133   bindings <- io (GHC.getBindings s)
1134   mapM_ showTyThing bindings
1135   return ()
1136
1137 showTyThing (AnId id) = do
1138   ty' <- cleanType (GHC.idType id)
1139   printForUser $ ppr id <> text " :: " <> ppr ty'
1140 showTyThing _  = return ()
1141
1142 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1143 cleanType :: Type -> GHCi Type
1144 cleanType ty = do
1145   dflags <- getDynFlags
1146   if dopt Opt_GlasgowExts dflags
1147         then return ty
1148         else return $! GHC.dropForAlls ty
1149
1150 showBkptTable :: GHCi ()
1151 showBkptTable = do
1152    activeBreaks <- getActiveBreakPoints
1153    printForUser $ ppr activeBreaks
1154
1155 showContext :: GHCi ()
1156 showContext = do
1157    session <- getSession
1158    resumes <- io $ GHC.getResumeContext session
1159    printForUser $ vcat (map pp_resume (reverse resumes))
1160   where
1161    pp_resume resume =
1162         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1163         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1164
1165
1166 -- -----------------------------------------------------------------------------
1167 -- Completion
1168
1169 completeNone :: String -> IO [String]
1170 completeNone w = return []
1171
1172 #ifdef USE_READLINE
1173 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1174 completeWord w start end = do
1175   line <- Readline.getLineBuffer
1176   case w of
1177      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1178      _other
1179         | Just c <- is_cmd line -> do
1180            maybe_cmd <- lookupCommand c
1181            let (n,w') = selectWord (words' 0 line)
1182            case maybe_cmd of
1183              Nothing -> return Nothing
1184              Just (_,_,False,complete) -> wrapCompleter complete w
1185              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1186                                                               return (map (drop n) rets)
1187                                          in wrapCompleter complete' w'
1188         | otherwise     -> do
1189                 --printf "complete %s, start = %d, end = %d\n" w start end
1190                 wrapCompleter completeIdentifier w
1191     where words' _ [] = []
1192           words' n str = let (w,r) = break isSpace str
1193                              (s,r') = span isSpace r
1194                          in (n,w):words' (n+length w+length s) r'
1195           -- In a Haskell expression we want to parse 'a-b' as three words
1196           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1197           -- only be a single word.
1198           selectWord [] = (0,w)
1199           selectWord ((offset,x):xs)
1200               | offset+length x >= start = (start-offset,take (end-offset) x)
1201               | otherwise = selectWord xs
1202
1203 is_cmd line
1204  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1205  | otherwise = Nothing
1206
1207 completeCmd w = do
1208   cmds <- readIORef commands
1209   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1210
1211 completeMacro w = do
1212   cmds <- readIORef commands
1213   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1214   return (filter (w `isPrefixOf`) cmds')
1215
1216 completeIdentifier w = do
1217   s <- restoreSession
1218   rdrs <- GHC.getRdrNamesInScope s
1219   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1220
1221 completeModule w = do
1222   s <- restoreSession
1223   dflags <- GHC.getSessionDynFlags s
1224   let pkg_mods = allExposedModules dflags
1225   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1226
1227 completeHomeModule w = do
1228   s <- restoreSession
1229   g <- GHC.getModuleGraph s
1230   let home_mods = map GHC.ms_mod_name g
1231   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1232
1233 completeSetOptions w = do
1234   return (filter (w `isPrefixOf`) options)
1235     where options = "args":"prog":allFlags
1236
1237 completeFilename = Readline.filenameCompletionFunction
1238
1239 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1240
1241 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1242 unionComplete f1 f2 w = do
1243   s1 <- f1 w
1244   s2 <- f2 w
1245   return (s1 ++ s2)
1246
1247 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1248 wrapCompleter fun w =  do
1249   strs <- fun w
1250   case strs of
1251     []  -> return Nothing
1252     [x] -> return (Just (x,[]))
1253     xs  -> case getCommonPrefix xs of
1254                 ""   -> return (Just ("",xs))
1255                 pref -> return (Just (pref,xs))
1256
1257 getCommonPrefix :: [String] -> String
1258 getCommonPrefix [] = ""
1259 getCommonPrefix (s:ss) = foldl common s ss
1260   where common s "" = ""
1261         common "" s = ""
1262         common (c:cs) (d:ds)
1263            | c == d = c : common cs ds
1264            | otherwise = ""
1265
1266 allExposedModules :: DynFlags -> [ModuleName]
1267 allExposedModules dflags
1268  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1269  where
1270   pkg_db = pkgIdMap (pkgState dflags)
1271 #else
1272 completeCmd        = completeNone
1273 completeMacro      = completeNone
1274 completeIdentifier = completeNone
1275 completeModule     = completeNone
1276 completeHomeModule = completeNone
1277 completeSetOptions = completeNone
1278 completeFilename   = completeNone
1279 completeHomeModuleOrFile=completeNone
1280 completeBkpt       = completeNone
1281 #endif
1282
1283 -- ---------------------------------------------------------------------------
1284 -- User code exception handling
1285
1286 -- This is the exception handler for exceptions generated by the
1287 -- user's code and exceptions coming from children sessions;
1288 -- it normally just prints out the exception.  The
1289 -- handler must be recursive, in case showing the exception causes
1290 -- more exceptions to be raised.
1291 --
1292 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1293 -- raising another exception.  We therefore don't put the recursive
1294 -- handler arond the flushing operation, so if stderr is closed
1295 -- GHCi will just die gracefully rather than going into an infinite loop.
1296 handler :: Exception -> GHCi Bool
1297
1298 handler exception = do
1299   flushInterpBuffers
1300   io installSignalHandlers
1301   ghciHandle handler (showException exception >> return False)
1302
1303 showException (DynException dyn) =
1304   case fromDynamic dyn of
1305     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1306     Just Interrupted      -> io (putStrLn "Interrupted.")
1307     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1308     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1309     Just other_ghc_ex     -> io (print other_ghc_ex)
1310
1311 showException other_exception
1312   = io (putStrLn ("*** Exception: " ++ show other_exception))
1313
1314 -----------------------------------------------------------------------------
1315 -- recursive exception handlers
1316
1317 -- Don't forget to unblock async exceptions in the handler, or if we're
1318 -- in an exception loop (eg. let a = error a in a) the ^C exception
1319 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1320
1321 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1322 ghciHandle h (GHCi m) = GHCi $ \s ->
1323    Exception.catch (m s)
1324         (\e -> unGHCi (ghciUnblock (h e)) s)
1325
1326 ghciUnblock :: GHCi a -> GHCi a
1327 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1328
1329
1330 -- ----------------------------------------------------------------------------
1331 -- Utils
1332
1333 expandPath :: String -> GHCi String
1334 expandPath path =
1335   case dropWhile isSpace path of
1336    ('~':d) -> do
1337         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1338         return (tilde ++ '/':d)
1339    other ->
1340         return other
1341
1342 -- ----------------------------------------------------------------------------
1343 -- Windows console setup
1344
1345 setUpConsole :: IO ()
1346 setUpConsole = do
1347 #ifdef mingw32_HOST_OS
1348         -- On Windows we need to set a known code page, otherwise the characters
1349         -- we read from the console will be be in some strange encoding, and
1350         -- similarly for characters we write to the console.
1351         --
1352         -- At the moment, GHCi pretends all input is Latin-1.  In the
1353         -- future we should support UTF-8, but for now we set the code pages
1354         -- to Latin-1.
1355         --
1356         -- It seems you have to set the font in the console window to
1357         -- a Unicode font in order for output to work properly,
1358         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1359         -- (see MSDN for SetConsoleOutputCP()).
1360         --
1361         setConsoleCP 28591       -- ISO Latin-1
1362         setConsoleOutputCP 28591 -- ISO Latin-1
1363 #endif
1364         return ()
1365
1366 -- -----------------------------------------------------------------------------
1367 -- commands for debugger
1368
1369 sprintCmd = pprintCommand False False
1370 printCmd  = pprintCommand True False
1371 forceCmd  = pprintCommand False True
1372
1373 pprintCommand bind force str = do
1374   session <- getSession
1375   io $ pprintClosureCommand session bind force str
1376
1377 stepCmd :: String -> GHCi Bool
1378 stepCmd [] = doContinue True
1379 stepCmd expression = do
1380    runCommand expression
1381
1382 continueCmd :: String -> GHCi Bool
1383 continueCmd [] = doContinue False
1384 continueCmd other = do
1385    io $ putStrLn "The continue command accepts no arguments."
1386    return False
1387
1388 doContinue :: Bool -> GHCi Bool
1389 doContinue step = do
1390   session <- getSession
1391   let resume | step      = GHC.stepResume
1392              | otherwise = GHC.resume
1393   runResult <- io $ resume session
1394   afterRunStmt runResult
1395   return False
1396
1397 abandonCmd :: String -> GHCi ()
1398 abandonCmd "" = do
1399   s <- getSession
1400   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1401   when (not b) $ io $ putStrLn "There is no computation running."
1402   return ()
1403 abandonCmd _ = do
1404    io $ putStrLn "The abandon command accepts no arguments."
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 (Just (GHC.srcLocFile loc))
1458                                           (GHC.srcLocLine loc,
1459                                            GHC.srcLocCol loc)
1460                else noCanDo $ text "can't find its location: " <>
1461                               ppr loc
1462            where
1463              noCanDo why = printForUser $
1464                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1465
1466
1467 wantInterpretedModule :: Session -> String -> GHCi Module
1468 wantInterpretedModule session str = do
1469    modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1470    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1471    when (not is_interpreted) $
1472        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1473    return modl
1474
1475 breakByModule :: Session -> Module -> [String] -> GHCi ()
1476 breakByModule session mod args@(arg1:rest)
1477    | all isDigit arg1 = do  -- looks like a line number
1478         breakByModuleLine mod (read arg1) rest
1479    | otherwise = io $ putStrLn "Invalid arguments to :break"
1480
1481 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1482 breakByModuleLine mod line args
1483    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1484    | [col] <- args, all isDigit col =
1485         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1486    | otherwise = io $ putStrLn "Invalid arguments to :break"
1487
1488 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1489 findBreakAndSet mod lookupTickTree = do
1490    tickArray <- getTickArray mod
1491    (breakArray, _) <- getModBreak mod
1492    case lookupTickTree tickArray of
1493       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1494       Just (tick, span) -> do
1495          success <- io $ setBreakFlag True breakArray tick
1496          session <- getSession
1497          if success
1498             then do
1499                (alreadySet, nm) <-
1500                      recordBreak $ BreakLocation
1501                              { breakModule = mod
1502                              , breakLoc = span
1503                              , breakTick = tick
1504                              }
1505                printForUser $
1506                   text "Breakpoint " <> ppr nm <>
1507                   if alreadySet
1508                      then text " was already set at " <> ppr span
1509                      else text " activated at " <> ppr span
1510             else do
1511             printForUser $ text "Breakpoint could not be activated at"
1512                                  <+> ppr span
1513
1514 -- When a line number is specified, the current policy for choosing
1515 -- the best breakpoint is this:
1516 --    - the leftmost complete subexpression on the specified line, or
1517 --    - the leftmost subexpression starting on the specified line, or
1518 --    - the rightmost subexpression enclosing the specified line
1519 --
1520 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1521 findBreakByLine line arr
1522   | not (inRange (bounds arr) line) = Nothing
1523   | otherwise =
1524     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1525     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1526     listToMaybe (sortBy rightmost ticks)
1527   where
1528         ticks = arr ! line
1529
1530         starts_here = [ tick | tick@(nm,span) <- ticks,
1531                                GHC.srcSpanStartLine span == line ]
1532
1533         (complete,incomplete) = partition ends_here starts_here
1534             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1535
1536 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1537                  -> Maybe (BreakIndex,SrcSpan)
1538 findBreakByCoord mb_file (line, col) arr
1539   | not (inRange (bounds arr) line) = Nothing
1540   | otherwise =
1541     listToMaybe (sortBy rightmost contains)
1542   where
1543         ticks = arr ! line
1544
1545         -- the ticks that span this coordinate
1546         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1547                             is_correct_file span ]
1548
1549         is_correct_file span
1550                  | Just f <- mb_file = GHC.srcSpanFile span == f
1551                  | otherwise         = True
1552
1553
1554 leftmost_smallest  (_,a) (_,b) = a `compare` b
1555 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1556                                 `thenCmp`
1557                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1558 rightmost (_,a) (_,b) = b `compare` a
1559
1560 spans :: SrcSpan -> (Int,Int) -> Bool
1561 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1562    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1563
1564 start_bold = BS.pack "\ESC[1m"
1565 end_bold   = BS.pack "\ESC[0m"
1566
1567 listCmd :: String -> GHCi ()
1568 listCmd str = do
1569    session <- getSession
1570    resumes <- io $ GHC.getResumeContext session
1571    case resumes of
1572       []  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1573       eval:_ -> io $ listAround (GHC.resumeSpan eval) True
1574
1575 -- | list a section of a source file around a particular SrcSpan.
1576 -- If the highlight flag is True, also highlight the span using
1577 -- start_bold/end_bold.
1578 listAround span do_highlight = do
1579       contents <- BS.readFile (unpackFS file)
1580       let
1581           lines = BS.split '\n' contents
1582           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1583                         drop (line1 - 1 - pad_before) $ lines
1584           fst_line = max 1 (line1 - pad_before)
1585           line_nos = [ fst_line .. ]
1586
1587           highlighted | do_highlight = zipWith highlight line_nos these_lines
1588                       | otherwise   = these_lines
1589
1590           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
1591           prefixed = zipWith BS.append bs_line_nos highlighted
1592       --
1593       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1594   where
1595         file  = GHC.srcSpanFile span
1596         line1 = GHC.srcSpanStartLine span
1597         col1  = GHC.srcSpanStartCol span
1598         line2 = GHC.srcSpanEndLine span
1599         col2  = GHC.srcSpanEndCol span
1600
1601         pad_before | line1 == 1 = 0
1602                    | otherwise  = 1
1603         pad_after = 1
1604
1605         highlight no line
1606           | no == line1 && no == line2
1607           = let (a,r) = BS.splitAt col1 line
1608                 (b,c) = BS.splitAt (col2-col1) r
1609             in
1610             BS.concat [a,start_bold,b,end_bold,c]
1611           | no == line1
1612           = let (a,b) = BS.splitAt col1 line in
1613             BS.concat [a, start_bold, b]
1614           | no == line2
1615           = let (a,b) = BS.splitAt col2 line in
1616             BS.concat [a, end_bold, b]
1617           | otherwise   = line
1618
1619 -- --------------------------------------------------------------------------
1620 -- Tick arrays
1621
1622 getTickArray :: Module -> GHCi TickArray
1623 getTickArray modl = do
1624    st <- getGHCiState
1625    let arrmap = tickarrays st
1626    case lookupModuleEnv arrmap modl of
1627       Just arr -> return arr
1628       Nothing  -> do
1629         (breakArray, ticks) <- getModBreak modl
1630         let arr = mkTickArray (assocs ticks)
1631         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1632         return arr
1633
1634 discardTickArrays :: GHCi ()
1635 discardTickArrays = do
1636    st <- getGHCiState
1637    setGHCiState st{tickarrays = emptyModuleEnv}
1638
1639 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1640 mkTickArray ticks
1641   = accumArray (flip (:)) [] (1, max_line)
1642         [ (line, (nm,span)) | (nm,span) <- ticks,
1643                               line <- srcSpanLines span ]
1644     where
1645         max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
1646         srcSpanLines span = [ GHC.srcSpanStartLine span ..
1647                               GHC.srcSpanEndLine span ]
1648
1649 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1650 getModBreak mod = do
1651    session <- getSession
1652    Just mod_info <- io $ GHC.getModuleInfo session mod
1653    let modBreaks  = GHC.modInfoModBreaks mod_info
1654    let array      = GHC.modBreaks_flags modBreaks
1655    let ticks      = GHC.modBreaks_locs  modBreaks
1656    return (array, ticks)
1657
1658 lookupModule :: Session -> String -> GHCi Module
1659 lookupModule session modName
1660    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1661
1662 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1663 setBreakFlag toggle array index
1664    | toggle    = GHC.setBreakOn array index
1665    | otherwise = GHC.setBreakOff array index
1666
1667
1668 {- these should probably go to the GHC API at some point -}
1669 enableBreakPoint  :: Session -> Module -> Int -> IO ()
1670 enableBreakPoint session mod index = return ()
1671
1672 disableBreakPoint :: Session -> Module -> Int -> IO ()
1673 disableBreakPoint session mod index = return ()
1674
1675 activeBreakPoints :: Session -> IO [(Module,Int)]
1676 activeBreakPoints session = return []
1677
1678 enableSingleStep  :: Session -> IO ()
1679 enableSingleStep session = return ()
1680
1681 disableSingleStep :: Session -> IO ()
1682 disableSingleStep session = return ()