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           | (span,_,_):rest <- resumes
 455           = (if not (null rest) then text "... " else empty)
 456             <> brackets (ppr span) <+> 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 result
 525
 526 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
 527 switchOnRunResult GHC.RunFailed = return Nothing
 528 switchOnRunResult (GHC.RunException e) = throw e
 529 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
 530 switchOnRunResult (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 location threadId resume
 541
 542    -- run the command set with ":set stop <cmd>"
 543    st <- getGHCiState
 544    runCommand (stop st)
 545
 546    return (Just (True,names))
 547
 548 -- possibly print the type and revert CAFs after evaluating an expression
 549 finishEvalExpr mb_names
 550  = do show_types <- isOptionSet ShowType
 551       session <- getSession
 552       case mb_names of
 553         Nothing    -> return ()
 554         Just (is_break,names) ->
 555                 when (is_break || show_types) $
 556                       mapM_ (showTypeOfName session) names
 557
 558       flushInterpBuffers
 559       io installSignalHandlers
 560       b <- isOptionSet RevertCAFs
 561       io (when b revertCAFs)
 562
 563 showTypeOfName :: Session -> Name -> GHCi ()
 564 showTypeOfName session n
 565    = do maybe_tything <- io (GHC.lookupName session n)
 566         case maybe_tything of
 567           Nothing    -> return ()
 568           Just thing -> showTyThing thing
 569
 570 specialCommand :: String -> GHCi Bool
 571 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 572 specialCommand str = do
 573   let (cmd,rest) = break isSpace str
 574   maybe_cmd <- io (lookupCommand cmd)
 575   case maybe_cmd of
 576     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 577                                     ++ shortHelpText) >> return False)
 578     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 579
 580 lookupCommand :: String -> IO (Maybe Command)
 581 lookupCommand str = do
 582   cmds <- readIORef commands
 583   -- look for exact match first, then the first prefix match
 584   case [ c | c <- cmds, str == cmdName c ] of
 585      c:_ -> return (Just c)
 586      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 587                 [] -> return Nothing
 588                 c:_ -> return (Just c)
 589
 590 -----------------------------------------------------------------------------
 591 -- Commands
 592
 593 help :: String -> GHCi ()
 594 help _ = io (putStr helpText)
 595
 596 info :: String -> GHCi ()
 597 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 598 info s  = do { let names = words s
 599              ; session <- getSession
 600              ; dflags <- getDynFlags
 601              ; let exts = dopt Opt_GlasgowExts dflags
 602              ; mapM_ (infoThing exts session) names }
 603   where
 604     infoThing exts session str = io $ do
 605         names <- GHC.parseName session str
 606         let filtered = filterOutChildren names
 607         mb_stuffs <- mapM (GHC.getInfo session) filtered
 608         unqual <- GHC.getPrintUnqual session
 609         putStrLn (showSDocForUser unqual $
 610                    vcat (intersperse (text "") $
 611                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 612
 613   -- Filter out names whose parent is also there Good
 614   -- example is '[]', which is both a type and data
 615   -- constructor in the same type
 616 filterOutChildren :: [Name] -> [Name]
 617 filterOutChildren names = filter (not . parent_is_there) names
 618  where parent_is_there n
 619 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 620 -- ToDo!!
 621          | otherwise                       = False
 622
 623 pprInfo exts (thing, fixity, insts)
 624   =  pprTyThingInContextLoc exts thing
 625   $$ show_fixity fixity
 626   $$ vcat (map GHC.pprInstance insts)
 627   where
 628     show_fixity fix
 629         | fix == GHC.defaultFixity = empty
 630         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 631
 632 runMain :: String -> GHCi ()
 633 runMain args = do
 634   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 635   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 636   return ()
 637
 638 addModule :: [FilePath] -> GHCi ()
 639 addModule files = do
 640   io (revertCAFs)                       -- always revert CAFs on load/add.
 641   files <- mapM expandPath files
 642   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 643   session <- getSession
 644   io (mapM_ (GHC.addTarget session) targets)
 645   ok <- io (GHC.load session LoadAllTargets)
 646   afterLoad ok session
 647
 648 changeDirectory :: String -> GHCi ()
 649 changeDirectory dir = do
 650   session <- getSession
 651   graph <- io (GHC.getModuleGraph session)
 652   when (not (null graph)) $
 653         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 654   io (GHC.setTargets session [])
 655   io (GHC.load session LoadAllTargets)
 656   setContextAfterLoad session []
 657   io (GHC.workingDirectoryChanged session)
 658   dir <- expandPath dir
 659   io (setCurrentDirectory dir)
 660
 661 editFile :: String -> GHCi ()
 662 editFile str
 663   | null str  = do
 664         -- find the name of the "topmost" file loaded
 665      session <- getSession
 666      graph0 <- io (GHC.getModuleGraph session)
 667      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 668      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 669      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 670         Just file -> do_edit file
 671         Nothing   -> throwDyn (CmdLineError "unknown file name")
 672   | otherwise = do_edit str
 673   where
 674         do_edit file = do
 675            st <- getGHCiState
 676            let cmd = editor st
 677            when (null cmd) $
 678                 throwDyn (CmdLineError "editor not set, use :set editor")
 679            io $ system (cmd ++ ' ':file)
 680            return ()
 681
 682 defineMacro :: String -> GHCi ()
 683 defineMacro s = do
 684   let (macro_name, definition) = break isSpace s
 685   cmds <- io (readIORef commands)
 686   if (null macro_name)
 687         then throwDyn (CmdLineError "invalid macro name")
 688         else do
 689   if (macro_name `elem` map cmdName cmds)
 690         then throwDyn (CmdLineError
 691                 ("command '" ++ macro_name ++ "' is already defined"))
 692         else do
 693
 694   -- give the expression a type signature, so we can be sure we're getting
 695   -- something of the right type.
 696   let new_expr = '(' : definition ++ ") :: String -> IO String"
 697
 698   -- compile the expression
 699   cms <- getSession
 700   maybe_hv <- io (GHC.compileExpr cms new_expr)
 701   case maybe_hv of
 702      Nothing -> return ()
 703      Just hv -> io (writeIORef commands --
 704                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 705
 706 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 707 runMacro fun s = do
 708   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 709   stringLoop (lines str)
 710
 711 undefineMacro :: String -> GHCi ()
 712 undefineMacro macro_name = do
 713   cmds <- io (readIORef commands)
 714   if (macro_name `elem` map cmdName builtin_commands)
 715         then throwDyn (CmdLineError
 716                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 717         else do
 718   if (macro_name `notElem` map cmdName cmds)
 719         then throwDyn (CmdLineError
 720                 ("command '" ++ macro_name ++ "' not defined"))
 721         else do
 722   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 723
 724
 725 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 726 loadModule fs = timeIt (loadModule' fs)
 727
 728 loadModule_ :: [FilePath] -> GHCi ()
 729 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 730
 731 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 732 loadModule' files = do
 733   session <- getSession
 734
 735   -- unload first
 736   io (GHC.setTargets session [])
 737   io (GHC.load session LoadAllTargets)
 738
 739   -- expand tildes
 740   let (filenames, phases) = unzip files
 741   exp_filenames <- mapM expandPath filenames
 742   let files' = zip exp_filenames phases
 743   targets <- io (mapM (uncurry GHC.guessTarget) files')
 744
 745   -- NOTE: we used to do the dependency anal first, so that if it
 746   -- fails we didn't throw away the current set of modules.  This would
 747   -- require some re-working of the GHC interface, so we'll leave it
 748   -- as a ToDo for now.
 749
 750   io (GHC.setTargets session targets)
 751   ok <- io (GHC.load session LoadAllTargets)
 752   afterLoad ok session
 753   return ok
 754
 755 checkModule :: String -> GHCi ()
 756 checkModule m = do
 757   let modl = GHC.mkModuleName m
 758   session <- getSession
 759   result <- io (GHC.checkModule session modl)
 760   case result of
 761     Nothing -> io $ putStrLn "Nothing"
 762     Just r  -> io $ putStrLn (showSDoc (
 763         case GHC.checkedModuleInfo r of
 764            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 765                 let
 766                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 767                 in
 768                         (text "global names: " <+> ppr global) $$
 769                         (text "local  names: " <+> ppr local)
 770            _ -> empty))
 771   afterLoad (successIf (isJust result)) session
 772
 773 reloadModule :: String -> GHCi ()
 774 reloadModule "" = do
 775   io (revertCAFs)               -- always revert CAFs on reload.
 776   session <- getSession
 777   ok <- io (GHC.load session LoadAllTargets)
 778   afterLoad ok session
 779 reloadModule m = do
 780   io (revertCAFs)               -- always revert CAFs on reload.
 781   session <- getSession
 782   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 783   afterLoad ok session
 784
 785 afterLoad ok session = do
 786   io (revertCAFs)  -- always revert CAFs on load.
 787   discardResumeContext
 788   discardTickArrays
 789   discardActiveBreakPoints
 790   graph <- io (GHC.getModuleGraph session)
 791   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 792   setContextAfterLoad session graph'
 793   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 794
 795 setContextAfterLoad session [] = do
 796   prel_mod <- getPrelude
 797   io (GHC.setContext session [] [prel_mod])
 798 setContextAfterLoad session ms = do
 799   -- load a target if one is available, otherwise load the topmost module.
 800   targets <- io (GHC.getTargets session)
 801   case [ m | Just m <- map (findTarget ms) targets ] of
 802         []    ->
 803           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 804           load_this (last graph')
 805         (m:_) ->
 806           load_this m
 807  where
 808    findTarget ms t
 809     = case filter (`matches` t) ms of
 810         []    -> Nothing
 811         (m:_) -> Just m
 812
 813    summary `matches` Target (TargetModule m) _
 814         = GHC.ms_mod_name summary == m
 815    summary `matches` Target (TargetFile f _) _
 816         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 817    summary `matches` target
 818         = False
 819
 820    load_this summary | m <- GHC.ms_mod summary = do
 821         b <- io (GHC.moduleIsInterpreted session m)
 822         if b then io (GHC.setContext session [m] [])
 823              else do
 824                    prel_mod <- getPrelude
 825                    io (GHC.setContext session []  [prel_mod,m])
 826
 827
 828 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 829 modulesLoadedMsg ok mods = do
 830   dflags <- getDynFlags
 831   when (verbosity dflags > 0) $ do
 832    let mod_commas
 833         | null mods = text "none."
 834         | otherwise = hsep (
 835             punctuate comma (map ppr mods)) <> text "."
 836    case ok of
 837     Failed ->
 838        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 839     Succeeded  ->
 840        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 841
 842
 843 typeOfExpr :: String -> GHCi ()
 844 typeOfExpr str
 845   = do cms <- getSession
 846        maybe_ty <- io (GHC.exprType cms str)
 847        case maybe_ty of
 848           Nothing -> return ()
 849           Just ty -> do ty' <- cleanType ty
 850                         printForUser $ text str <> text " :: " <> ppr ty'
 851
 852 kindOfType :: String -> GHCi ()
 853 kindOfType str
 854   = do cms <- getSession
 855        maybe_ty <- io (GHC.typeKind cms str)
 856        case maybe_ty of
 857           Nothing    -> return ()
 858           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 859
 860 quit :: String -> GHCi Bool
 861 quit _ = return True
 862
 863 shellEscape :: String -> GHCi Bool
 864 shellEscape str = io (system str >> return False)
 865
 866 -----------------------------------------------------------------------------
 867 -- Browsing a module's contents
 868
 869 browseCmd :: String -> GHCi ()
 870 browseCmd m =
 871   case words m of
 872     ['*':m] | looksLikeModuleName m -> browseModule m False
 873     [m]     | looksLikeModuleName m -> browseModule m True
 874     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 875
 876 browseModule m exports_only = do
 877   s <- getSession
 878   modl <- if exports_only then lookupModule s m
 879                           else wantInterpretedModule s m
 880
 881   -- Temporarily set the context to the module we're interested in,
 882   -- just so we can get an appropriate PrintUnqualified
 883   (as,bs) <- io (GHC.getContext s)
 884   prel_mod <- getPrelude
 885   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 886                       else GHC.setContext s [modl] [])
 887   unqual <- io (GHC.getPrintUnqual s)
 888   io (GHC.setContext s as bs)
 889
 890   mb_mod_info <- io $ GHC.getModuleInfo s modl
 891   case mb_mod_info of
 892     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 893     Just mod_info -> do
 894         let names
 895                | exports_only = GHC.modInfoExports mod_info
 896                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 897
 898             filtered = filterOutChildren names
 899
 900         things <- io $ mapM (GHC.lookupName s) filtered
 901
 902         dflags <- getDynFlags
 903         let exts = dopt Opt_GlasgowExts dflags
 904         io (putStrLn (showSDocForUser unqual (
 905                 vcat (map (pprTyThingInContext exts) (catMaybes things))
 906            )))
 907         -- ToDo: modInfoInstances currently throws an exception for
 908         -- package modules.  When it works, we can do this:
 909         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
 910
 911 -----------------------------------------------------------------------------
 912 -- Setting the module context
 913
 914 setContext str
 915   | all sensible mods = fn mods
 916   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 917   where
 918     (fn, mods) = case str of
 919                         '+':stuff -> (addToContext,      words stuff)
 920                         '-':stuff -> (removeFromContext, words stuff)
 921                         stuff     -> (newContext,        words stuff)
 922
 923     sensible ('*':m) = looksLikeModuleName m
 924     sensible m       = looksLikeModuleName m
 925
 926 separate :: Session -> [String] -> [Module] -> [Module]
 927         -> GHCi ([Module],[Module])
 928 separate session []           as bs = return (as,bs)
 929 separate session (('*':str):ms) as bs = do
 930    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
 931    b <- io $ GHC.moduleIsInterpreted session m
 932    if b then separate session ms (m:as) bs
 933         else throwDyn (CmdLineError ("module '"
 934                         ++ GHC.moduleNameString (GHC.moduleName m)
 935                         ++ "' is not interpreted"))
 936 separate session (str:ms) as bs = do
 937   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
 938   separate session ms as (m:bs)
 939
 940 newContext :: [String] -> GHCi ()
 941 newContext strs = do
 942   s <- getSession
 943   (as,bs) <- separate s strs [] []
 944   prel_mod <- getPrelude
 945   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
 946   io $ GHC.setContext s as bs'
 947
 948
 949 addToContext :: [String] -> GHCi ()
 950 addToContext strs = do
 951   s <- getSession
 952   (as,bs) <- io $ GHC.getContext s
 953
 954   (new_as,new_bs) <- separate s strs [] []
 955
 956   let as_to_add = new_as \\ (as ++ bs)
 957       bs_to_add = new_bs \\ (as ++ bs)
 958
 959   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
 960
 961
 962 removeFromContext :: [String] -> GHCi ()
 963 removeFromContext strs = do
 964   s <- getSession
 965   (as,bs) <- io $ GHC.getContext s
 966
 967   (as_to_remove,bs_to_remove) <- separate s strs [] []
 968
 969   let as' = as \\ (as_to_remove ++ bs_to_remove)
 970       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 971
 972   io $ GHC.setContext s as' bs'
 973
 974 ----------------------------------------------------------------------------
 975 -- Code for `:set'
 976
 977 -- set options in the interpreter.  Syntax is exactly the same as the
 978 -- ghc command line, except that certain options aren't available (-C,
 979 -- -E etc.)
 980 --
 981 -- This is pretty fragile: most options won't work as expected.  ToDo:
 982 -- figure out which ones & disallow them.
 983
 984 setCmd :: String -> GHCi ()
 985 setCmd ""
 986   = do st <- getGHCiState
 987        let opts = options st
 988        io $ putStrLn (showSDoc (
 989               text "options currently set: " <>
 990               if null opts
 991                    then text "none."
 992                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 993            ))
 994 setCmd str
 995   = case toArgs str of
 996         ("args":args) -> setArgs args
 997         ("prog":prog) -> setProg prog
 998         ("prompt":prompt) -> setPrompt (after 6)
 999         ("editor":cmd) -> setEditor (after 6)
1000         ("stop":cmd) -> setStop (after 4)
1001         wds -> setOptions wds
1002    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1003
1004 setArgs args = do
1005   st <- getGHCiState
1006   setGHCiState st{ args = args }
1007
1008 setProg [prog] = do
1009   st <- getGHCiState
1010   setGHCiState st{ progname = prog }
1011 setProg _ = do
1012   io (hPutStrLn stderr "syntax: :set prog <progname>")
1013
1014 setEditor cmd = do
1015   st <- getGHCiState
1016   setGHCiState st{ editor = cmd }
1017
1018 setStop cmd = do
1019   st <- getGHCiState
1020   setGHCiState st{ stop = cmd }
1021
1022 setPrompt value = do
1023   st <- getGHCiState
1024   if null value
1025       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1026       else setGHCiState st{ prompt = remQuotes value }
1027   where
1028      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1029      remQuotes x = x
1030
1031 setOptions wds =
1032    do -- first, deal with the GHCi opts (+s, +t, etc.)
1033       let (plus_opts, minus_opts)  = partition isPlus wds
1034       mapM_ setOpt plus_opts
1035
1036       -- then, dynamic flags
1037       dflags <- getDynFlags
1038       let pkg_flags = packageFlags dflags
1039       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1040
1041       if (not (null leftovers))
1042                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1043                                                 unwords leftovers))
1044                 else return ()
1045
1046       new_pkgs <- setDynFlags dflags'
1047
1048       -- if the package flags changed, we should reset the context
1049       -- and link the new packages.
1050       dflags <- getDynFlags
1051       when (packageFlags dflags /= pkg_flags) $ do
1052         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1053         session <- getSession
1054         io (GHC.setTargets session [])
1055         io (GHC.load session LoadAllTargets)
1056         io (linkPackages dflags new_pkgs)
1057         setContextAfterLoad session []
1058       return ()
1059
1060
1061 unsetOptions :: String -> GHCi ()
1062 unsetOptions str
1063   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1064        let opts = words str
1065            (minus_opts, rest1) = partition isMinus opts
1066            (plus_opts, rest2)  = partition isPlus rest1
1067
1068        if (not (null rest2))
1069           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1070           else do
1071
1072        mapM_ unsetOpt plus_opts
1073
1074        -- can't do GHC flags for now
1075        if (not (null minus_opts))
1076           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1077           else return ()
1078
1079 isMinus ('-':s) = True
1080 isMinus _ = False
1081
1082 isPlus ('+':s) = True
1083 isPlus _ = False
1084
1085 setOpt ('+':str)
1086   = case strToGHCiOpt str of
1087         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1088         Just o  -> setOption o
1089
1090 unsetOpt ('+':str)
1091   = case strToGHCiOpt str of
1092         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1093         Just o  -> unsetOption o
1094
1095 strToGHCiOpt :: String -> (Maybe GHCiOption)
1096 strToGHCiOpt "s" = Just ShowTiming
1097 strToGHCiOpt "t" = Just ShowType
1098 strToGHCiOpt "r" = Just RevertCAFs
1099 strToGHCiOpt _   = Nothing
1100
1101 optToStr :: GHCiOption -> String
1102 optToStr ShowTiming = "s"
1103 optToStr ShowType   = "t"
1104 optToStr RevertCAFs = "r"
1105
1106 -- ---------------------------------------------------------------------------
1107 -- code for `:show'
1108
1109 showCmd str =
1110   case words str of
1111         ["modules" ] -> showModules
1112         ["bindings"] -> showBindings
1113         ["linker"]   -> io showLinkerState
1114         ["breaks"] -> showBkptTable
1115         ["context"] -> showContext
1116         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings|breaks]")
1117
1118 showModules = do
1119   session <- getSession
1120   let show_one ms = do m <- io (GHC.showModule session ms)
1121                        io (putStrLn m)
1122   graph <- io (GHC.getModuleGraph session)
1123   mapM_ show_one graph
1124
1125 showBindings = do
1126   s <- getSession
1127   unqual <- io (GHC.getPrintUnqual s)
1128   bindings <- io (GHC.getBindings s)
1129   mapM_ showTyThing bindings
1130   return ()
1131
1132 showTyThing (AnId id) = do
1133   ty' <- cleanType (GHC.idType id)
1134   printForUser $ ppr id <> text " :: " <> ppr ty'
1135 showTyThing _  = return ()
1136
1137 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1138 cleanType :: Type -> GHCi Type
1139 cleanType ty = do
1140   dflags <- getDynFlags
1141   if dopt Opt_GlasgowExts dflags
1142         then return ty
1143         else return $! GHC.dropForAlls ty
1144
1145 showBkptTable :: GHCi ()
1146 showBkptTable = do
1147    activeBreaks <- getActiveBreakPoints
1148    printForUser $ ppr activeBreaks
1149
1150 showContext :: GHCi ()
1151 showContext = do
1152    st <- getGHCiState
1153    printForUser $ vcat (map pp_resume (resume st))
1154   where
1155    pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
1156
1157 -- -----------------------------------------------------------------------------
1158 -- Completion
1159
1160 completeNone :: String -> IO [String]
1161 completeNone w = return []
1162
1163 #ifdef USE_READLINE
1164 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1165 completeWord w start end = do
1166   line <- Readline.getLineBuffer
1167   case w of
1168      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1169      _other
1170         | Just c <- is_cmd line -> do
1171            maybe_cmd <- lookupCommand c
1172            let (n,w') = selectWord (words' 0 line)
1173            case maybe_cmd of
1174              Nothing -> return Nothing
1175              Just (_,_,False,complete) -> wrapCompleter complete w
1176              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1177                                                               return (map (drop n) rets)
1178                                          in wrapCompleter complete' w'
1179         | otherwise     -> do
1180                 --printf "complete %s, start = %d, end = %d\n" w start end
1181                 wrapCompleter completeIdentifier w
1182     where words' _ [] = []
1183           words' n str = let (w,r) = break isSpace str
1184                              (s,r') = span isSpace r
1185                          in (n,w):words' (n+length w+length s) r'
1186           -- In a Haskell expression we want to parse 'a-b' as three words
1187           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1188           -- only be a single word.
1189           selectWord [] = (0,w)
1190           selectWord ((offset,x):xs)
1191               | offset+length x >= start = (start-offset,take (end-offset) x)
1192               | otherwise = selectWord xs
1193
1194 is_cmd line
1195  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1196  | otherwise = Nothing
1197
1198 completeCmd w = do
1199   cmds <- readIORef commands
1200   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1201
1202 completeMacro w = do
1203   cmds <- readIORef commands
1204   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1205   return (filter (w `isPrefixOf`) cmds')
1206
1207 completeIdentifier w = do
1208   s <- restoreSession
1209   rdrs <- GHC.getRdrNamesInScope s
1210   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1211
1212 completeModule w = do
1213   s <- restoreSession
1214   dflags <- GHC.getSessionDynFlags s
1215   let pkg_mods = allExposedModules dflags
1216   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1217
1218 completeHomeModule w = do
1219   s <- restoreSession
1220   g <- GHC.getModuleGraph s
1221   let home_mods = map GHC.ms_mod_name g
1222   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1223
1224 completeSetOptions w = do
1225   return (filter (w `isPrefixOf`) options)
1226     where options = "args":"prog":allFlags
1227
1228 completeFilename = Readline.filenameCompletionFunction
1229
1230 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1231
1232 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1233 unionComplete f1 f2 w = do
1234   s1 <- f1 w
1235   s2 <- f2 w
1236   return (s1 ++ s2)
1237
1238 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1239 wrapCompleter fun w =  do
1240   strs <- fun w
1241   case strs of
1242     []  -> return Nothing
1243     [x] -> return (Just (x,[]))
1244     xs  -> case getCommonPrefix xs of
1245                 ""   -> return (Just ("",xs))
1246                 pref -> return (Just (pref,xs))
1247
1248 getCommonPrefix :: [String] -> String
1249 getCommonPrefix [] = ""
1250 getCommonPrefix (s:ss) = foldl common s ss
1251   where common s "" = ""
1252         common "" s = ""
1253         common (c:cs) (d:ds)
1254            | c == d = c : common cs ds
1255            | otherwise = ""
1256
1257 allExposedModules :: DynFlags -> [ModuleName]
1258 allExposedModules dflags
1259  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1260  where
1261   pkg_db = pkgIdMap (pkgState dflags)
1262 #else
1263 completeCmd        = completeNone
1264 completeMacro      = completeNone
1265 completeIdentifier = completeNone
1266 completeModule     = completeNone
1267 completeHomeModule = completeNone
1268 completeSetOptions = completeNone
1269 completeFilename   = completeNone
1270 completeHomeModuleOrFile=completeNone
1271 completeBkpt       = completeNone
1272 #endif
1273
1274 -- ---------------------------------------------------------------------------
1275 -- User code exception handling
1276
1277 -- This is the exception handler for exceptions generated by the
1278 -- user's code and exceptions coming from children sessions;
1279 -- it normally just prints out the exception.  The
1280 -- handler must be recursive, in case showing the exception causes
1281 -- more exceptions to be raised.
1282 --
1283 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1284 -- raising another exception.  We therefore don't put the recursive
1285 -- handler arond the flushing operation, so if stderr is closed
1286 -- GHCi will just die gracefully rather than going into an infinite loop.
1287 handler :: Exception -> GHCi Bool
1288
1289 handler exception = do
1290   flushInterpBuffers
1291   io installSignalHandlers
1292   ghciHandle handler (showException exception >> return False)
1293
1294 showException (DynException dyn) =
1295   case fromDynamic dyn of
1296     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1297     Just Interrupted      -> io (putStrLn "Interrupted.")
1298     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1299     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1300     Just other_ghc_ex     -> io (print other_ghc_ex)
1301
1302 showException other_exception
1303   = io (putStrLn ("*** Exception: " ++ show other_exception))
1304
1305 -----------------------------------------------------------------------------
1306 -- recursive exception handlers
1307
1308 -- Don't forget to unblock async exceptions in the handler, or if we're
1309 -- in an exception loop (eg. let a = error a in a) the ^C exception
1310 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1311
1312 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1313 ghciHandle h (GHCi m) = GHCi $ \s ->
1314    Exception.catch (m s)
1315         (\e -> unGHCi (ghciUnblock (h e)) s)
1316
1317 ghciUnblock :: GHCi a -> GHCi a
1318 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1319
1320
1321 -- ----------------------------------------------------------------------------
1322 -- Utils
1323
1324 expandPath :: String -> GHCi String
1325 expandPath path =
1326   case dropWhile isSpace path of
1327    ('~':d) -> do
1328         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1329         return (tilde ++ '/':d)
1330    other ->
1331         return other
1332
1333 -- ----------------------------------------------------------------------------
1334 -- Windows console setup
1335
1336 setUpConsole :: IO ()
1337 setUpConsole = do
1338 #ifdef mingw32_HOST_OS
1339         -- On Windows we need to set a known code page, otherwise the characters
1340         -- we read from the console will be be in some strange encoding, and
1341         -- similarly for characters we write to the console.
1342         --
1343         -- At the moment, GHCi pretends all input is Latin-1.  In the
1344         -- future we should support UTF-8, but for now we set the code pages
1345         -- to Latin-1.
1346         --
1347         -- It seems you have to set the font in the console window to
1348         -- a Unicode font in order for output to work properly,
1349         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1350         -- (see MSDN for SetConsoleOutputCP()).
1351         --
1352         setConsoleCP 28591       -- ISO Latin-1
1353         setConsoleOutputCP 28591 -- ISO Latin-1
1354 #endif
1355         return ()
1356
1357 -- -----------------------------------------------------------------------------
1358 -- commands for debugger
1359
1360 sprintCmd = pprintCommand False False
1361 printCmd  = pprintCommand True False
1362 forceCmd  = pprintCommand False True
1363
1364 pprintCommand bind force str = do
1365   session <- getSession
1366   io $ pprintClosureCommand session bind force str
1367
1368 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1369
1370 stepCmd :: String -> GHCi Bool
1371 stepCmd [] = doContinue setStepFlag
1372 stepCmd expression = do
1373    io $ setStepFlag
1374    runCommand expression
1375
1376 continueCmd :: String -> GHCi Bool
1377 continueCmd [] = doContinue $ return ()
1378 continueCmd other = do
1379    io $ putStrLn "The continue command accepts no arguments."
1380    return False
1381
1382 doContinue :: IO () -> GHCi Bool
1383 doContinue actionBeforeCont = do
1384    resumeAction <- popResume
1385    case resumeAction of
1386       Nothing -> do
1387          io $ putStrLn "There is no computation running."
1388          return False
1389       Just (_,_,handle) -> do
1390          io $ actionBeforeCont
1391          session <- getSession
1392          runResult <- io $ GHC.resume session handle
1393          names <- switchOnRunResult runResult
1394          finishEvalExpr names
1395          return False
1396
1397 abandonCmd :: String -> GHCi ()
1398 abandonCmd "" = do
1399    mb_res <- popResume
1400    case mb_res of
1401       Nothing -> do
1402          io $ putStrLn "There is no computation running."
1403       Just (span,_,_) ->
1404          return ()
1405          -- the prompt will change to indicate the new context
1406
1407 deleteCmd :: String -> GHCi ()
1408 deleteCmd argLine = do
1409    deleteSwitch $ words argLine
1410    where
1411    deleteSwitch :: [String] -> GHCi ()
1412    deleteSwitch [] =
1413       io $ putStrLn "The delete command requires at least one argument."
1414    -- delete all break points
1415    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1416    deleteSwitch idents = do
1417       mapM_ deleteOneBreak idents
1418       where
1419       deleteOneBreak :: String -> GHCi ()
1420       deleteOneBreak str
1421          | all isDigit str = deleteBreak (read str)
1422          | otherwise = return ()
1423
1424 -- handle the "break" command
1425 breakCmd :: String -> GHCi ()
1426 breakCmd argLine = do
1427    session <- getSession
1428    breakSwitch session $ words argLine
1429
1430 breakSwitch :: Session -> [String] -> GHCi ()
1431 breakSwitch _session [] = do
1432    io $ putStrLn "The break command requires at least one argument."
1433 breakSwitch session args@(arg1:rest)
1434    | looksLikeModuleName arg1 = do
1435         mod <- wantInterpretedModule session arg1
1436         breakByModule session mod rest
1437    | all isDigit arg1 = do
1438         (toplevel, _) <- io $ GHC.getContext session
1439         case toplevel of
1440            (mod : _) -> breakByModuleLine mod (read arg1) rest
1441            [] -> do
1442               io $ putStrLn "Cannot find default module for breakpoint."
1443               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1444    | otherwise = do -- assume it's a name
1445         names <- io $ GHC.parseName session arg1
1446         case names of
1447           []    -> return ()
1448           (n:_) -> do
1449             let loc  = GHC.nameSrcLoc n
1450                 modl = GHC.nameModule n
1451             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1452             if not is_interpreted
1453                then noCanDo $ text "module " <> ppr modl <>
1454                               text " is not interpreted"
1455                else do
1456             if GHC.isGoodSrcLoc loc
1457                then findBreakAndSet (GHC.nameModule n) $
1458                          findBreakByCoord (Just (GHC.srcLocFile loc))
1459                                           (GHC.srcLocLine loc,
1460                                            GHC.srcLocCol loc)
1461                else noCanDo $ text "can't find its location: " <>
1462                               ppr loc
1463            where
1464              noCanDo why = printForUser $
1465                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1466
1467
1468 wantInterpretedModule :: Session -> String -> GHCi Module
1469 wantInterpretedModule session str = do
1470    modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1471    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1472    when (not is_interpreted) $
1473        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1474    return modl
1475
1476 breakByModule :: Session -> Module -> [String] -> GHCi ()
1477 breakByModule session mod args@(arg1:rest)
1478    | all isDigit arg1 = do  -- looks like a line number
1479         breakByModuleLine mod (read arg1) rest
1480    | otherwise = io $ putStrLn "Invalid arguments to :break"
1481
1482 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1483 breakByModuleLine mod line args
1484    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1485    | [col] <- args, all isDigit col =
1486         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1487    | otherwise = io $ putStrLn "Invalid arguments to :break"
1488
1489 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1490 findBreakAndSet mod lookupTickTree = do
1491    tickArray <- getTickArray mod
1492    (breakArray, _) <- getModBreak mod
1493    case lookupTickTree tickArray of
1494       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1495       Just (tick, span) -> do
1496          success <- io $ setBreakFlag True breakArray tick
1497          session <- getSession
1498          if success
1499             then do
1500                (alreadySet, nm) <-
1501                      recordBreak $ BreakLocation
1502                              { breakModule = mod
1503                              , breakLoc = span
1504                              , breakTick = tick
1505                              }
1506                printForUser $
1507                   text "Breakpoint " <> ppr nm <>
1508                   if alreadySet
1509                      then text " was already set at " <> ppr span
1510                      else text " activated at " <> ppr span
1511             else do
1512             printForUser $ text "Breakpoint could not be activated at"
1513                                  <+> ppr span
1514
1515 -- When a line number is specified, the current policy for choosing
1516 -- the best breakpoint is this:
1517 --    - the leftmost complete subexpression on the specified line, or
1518 --    - the leftmost subexpression starting on the specified line, or
1519 --    - the rightmost subexpression enclosing the specified line
1520 --
1521 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1522 findBreakByLine line arr
1523   | not (inRange (bounds arr) line) = Nothing
1524   | otherwise =
1525     listToMaybe (sortBy leftmost_largest  complete)   `mplus`
1526     listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1527     listToMaybe (sortBy rightmost ticks)
1528   where
1529         ticks = arr ! line
1530
1531         starts_here = [ tick | tick@(nm,span) <- ticks,
1532                                GHC.srcSpanStartLine span == line ]
1533
1534         (complete,incomplete) = partition ends_here starts_here
1535             where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1536
1537 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1538                  -> Maybe (BreakIndex,SrcSpan)
1539 findBreakByCoord mb_file (line, col) arr
1540   | not (inRange (bounds arr) line) = Nothing
1541   | otherwise =
1542     listToMaybe (sortBy rightmost contains)
1543   where
1544         ticks = arr ! line
1545
1546         -- the ticks that span this coordinate
1547         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1548                             is_correct_file span ]
1549
1550         is_correct_file span
1551                  | Just f <- mb_file = GHC.srcSpanFile span == f
1552                  | otherwise         = True
1553
1554
1555 leftmost_smallest  (_,a) (_,b) = a `compare` b
1556 leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1557                                 `thenCmp`
1558                                  (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1559 rightmost (_,a) (_,b) = b `compare` a
1560
1561 spans :: SrcSpan -> (Int,Int) -> Bool
1562 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1563    where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1564
1565 start_bold = BS.pack "\ESC[1m"
1566 end_bold   = BS.pack "\ESC[0m"
1567
1568 listCmd :: String -> GHCi ()
1569 listCmd str = do
1570    st <- getGHCiState
1571    case resume st of
1572       []  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1573       (span,_,_):_ -> io $ listAround span 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 ()