compiler/ghci/InteractiveUI.hs

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