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
  18 -- The GHC interface
  19 import qualified GHC
  20 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  21                           Type, Module, ModuleName, TyThing(..), Phase )
  22 import DynFlags
  23 import Packages
  24 import PackageConfig
  25 import UniqFM
  26 import PprTyThing
  27 import Outputable
  28
  29 -- for createtags
  30 import Name
  31 import OccName
  32 import SrcLoc
  33
  34 -- Other random utilities
  35 import Digraph
  36 import BasicTypes hiding (isTopLevel)
  37 import Panic      hiding (showException)
  38 import Config
  39 import StaticFlags
  40 import Linker
  41 import Util
  42
  43 -- The debugger
  44 import Breakpoints
  45 import Debugger hiding  ( addModule )
  46 import HscTypes
  47 import Id
  48 import Var       ( globaliseId )
  49 import IdInfo
  50 import NameEnv
  51 import RdrName
  52 import Module
  53 import Type
  54 import TcType
  55
  56 #ifndef mingw32_HOST_OS
  57 import System.Posix
  58 #if __GLASGOW_HASKELL__ > 504
  59         hiding (getEnv)
  60 #endif
  61 #else
  62 import GHC.ConsoleHandler ( flushConsole )
  63 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  64 import qualified System.Win32
  65 #endif
  66
  67 #ifdef USE_READLINE
  68 import Control.Concurrent       ( yield )       -- Used in readline loop
  69 import System.Console.Readline as Readline
  70 #endif
  71
  72 --import SystemExts
  73
  74 import Control.Exception as Exception
  75 -- import Control.Concurrent
  76
  77 import Numeric
  78 import Data.List
  79 import Data.Int         ( Int64 )
  80 import Data.Maybe       ( isJust, isNothing, fromMaybe, catMaybes )
  81 import System.Cmd
  82 import System.Environment
  83 import System.Exit      ( exitWith, ExitCode(..) )
  84 import System.Directory
  85 import System.IO
  86 import System.IO.Error as IO
  87 import Data.Char
  88 import Control.Monad as Monad
  89 import Foreign.StablePtr        ( newStablePtr )
  90
  91 import GHC.Exts         ( unsafeCoerce# )
  92 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  93
  94 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  95
  96 import System.Posix.Internals ( setNonBlockingFD )
  97
  98 -----------------------------------------------------------------------------
  99
 100 ghciWelcomeMsg =
 101  "   ___         ___ _\n"++
 102  "  / _ \\ /\\  /\\/ __(_)\n"++
 103  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
 104  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
 105  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
 106
 107 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 108 cmdName (n,_,_,_) = n
 109
 110 GLOBAL_VAR(commands, builtin_commands, [Command])
 111
 112 builtin_commands :: [Command]
 113 builtin_commands = [
 114   ("add",       tlC$ keepGoingPaths addModule,  False, completeFilename),
 115   ("browse",    keepGoing browseCmd,            False, completeModule),
 116   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 117   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 118   ("e",         keepGoing editFile,             False, completeFilename),
 119         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 120   ("edit",      keepGoing editFile,             False, completeFilename),
 121   ("help",      keepGoing help,                 False, completeNone),
 122   ("?",         keepGoing help,                 False, completeNone),
 123   ("info",      keepGoing info,                 False, completeIdentifier),
 124   ("load",      tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
 125   ("module",    keepGoing setContext,           False, completeModule),
 126   ("main",      tlC$ keepGoing runMain,         False, completeIdentifier),
 127   ("reload",    tlC$ keepGoing reloadModule,    False, completeNone),
 128   ("check",     keepGoing checkModule,          False, completeHomeModule),
 129   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 130   ("show",      keepGoing showCmd,              False, completeNone),
 131   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 132   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 133   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 134 #if defined(GHCI)
 135   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
 136   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
 137   ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
 138   ("breakpoint",keepGoing bkptOptions,          False, completeBkpt),
 139 #endif
 140   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 141   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions),
 142   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 143   ("quit",      quit,                           False, completeNone)
 144   ]
 145
 146 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 147 keepGoing a str = a str >> return False
 148
 149 -- tlC: Top Level Command
 150 tlC ::  (String -> GHCi Bool) -> (String -> GHCi Bool)
 151 tlC a str = do
 152     top_level <- isTopLevel
 153     if not top_level
 154        then throwDyn (CmdLineError "Command only allowed at Top Level")
 155        else a str
 156
 157 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 158 keepGoingPaths a str = a (toArgs str) >> return False
 159
 160 shortHelpText = "use :? for help.\n"
 161
 162 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 163 helpText =
 164  " Commands available from the prompt:\n" ++
 165  "\n" ++
 166  "   <stmt>                      evaluate/run <stmt>\n" ++
 167  "   :add <filename> ...         add module(s) to the current target set\n" ++
 168  "   :breakpoint <option>        commands for the GHCi debugger\n" ++
 169  "   :browse [*]<module>         display the names defined by <module>\n" ++
 170  "   :cd <dir>                   change directory to <dir>\n" ++
 171  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 172  "   :edit <file>                edit file\n" ++
 173  "   :edit                       edit last module\n" ++
 174  "   :help, :?                   display this list of commands\n" ++
 175  "   :info [<name> ...]          display information about the given names\n" ++
 176  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 177  "   :sprint [<name> ...]        prints a value without forcing its computation(simpler)\n" ++
 178  "   :load <filename> ...        load module(s) and their dependents\n" ++
 179  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 180  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 181  "   :reload                     reload the current module set\n" ++
 182  "\n" ++
 183  "   :set <option> ...           set options\n" ++
 184  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 185  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 186  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 187  "   :set editor <cmd>           set the command used for :edit\n" ++
 188  "\n" ++
 189  "   :show modules               show the currently loaded modules\n" ++
 190  "   :show bindings              show the current bindings made at the prompt\n" ++
 191  "\n" ++
 192  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 193  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 194  "   :type <expr>                show the type of <expr>\n" ++
 195  "   :kind <type>                show the kind of <type>\n" ++
 196  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 197  "   :unset <option> ...         unset options\n" ++
 198  "   :quit                       exit GHCi\n" ++
 199  "   :!<command>                 run the shell command <command>\n" ++
 200  "\n" ++
 201  " Options for ':set' and ':unset':\n" ++
 202  "\n" ++
 203  "    +r            revert top-level expressions after each evaluation\n" ++
 204  "    +s            print timing/memory stats after each evaluation\n" ++
 205  "    +t            print type after evaluation\n" ++
 206  "    -<flags>      most GHC command line flags can also be set here\n" ++
 207  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 208  "\n" ++
 209  " Options for ':breakpoint':\n" ++
 210  "   list                                     list the current breakpoints\n" ++
 211  "   add Module line [col]                    add a new breakpoint\n" ++
 212  "   del (breakpoint# | Module line [col])    delete a breakpoint\n" ++
 213  "   stop                   Stop a computation and return to the top level\n" ++
 214  "   step [count]           Step by step execution (DISABLED)\n"
 215
 216 findEditor = do
 217   getEnv "EDITOR"
 218     `IO.catch` \_ -> do
 219 #if mingw32_HOST_OS
 220         win <- System.Win32.getWindowsDirectory
 221         return (win `joinFileName` "notepad.exe")
 222 #else
 223         return ""
 224 #endif
 225
 226 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 227 interactiveUI session srcs maybe_expr = do
 228    -- HACK! If we happen to get into an infinite loop (eg the user
 229    -- types 'let x=x in x' at the prompt), then the thread will block
 230    -- on a blackhole, and become unreachable during GC.  The GC will
 231    -- detect that it is unreachable and send it the NonTermination
 232    -- exception.  However, since the thread is unreachable, everything
 233    -- it refers to might be finalized, including the standard Handles.
 234    -- This sounds like a bug, but we don't have a good solution right
 235    -- now.
 236    newStablePtr stdin
 237    newStablePtr stdout
 238    newStablePtr stderr
 239
 240         -- Initialise buffering for the *interpreted* I/O system
 241    initInterpBuffering session
 242
 243    when (isNothing maybe_expr) $ do
 244         -- Only for GHCi (not runghc and ghc -e):
 245         -- Turn buffering off for the compiled program's stdout/stderr
 246         turnOffBuffering
 247         -- Turn buffering off for GHCi's stdout
 248         hFlush stdout
 249         hSetBuffering stdout NoBuffering
 250         -- We don't want the cmd line to buffer any input that might be
 251         -- intended for the program, so unbuffer stdin.
 252         hSetBuffering stdin NoBuffering
 253
 254         -- initial context is just the Prelude
 255    prel_mod <- GHC.findModule session prel_name Nothing
 256    GHC.setContext session [] [prel_mod]
 257
 258 #ifdef USE_READLINE
 259    Readline.initialize
 260    Readline.setAttemptedCompletionFunction (Just completeWord)
 261    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 262
 263    let symbols = "!#$%&*+/<=>?@\\^|-~"
 264        specials = "(),;[]`{}"
 265        spaces = " \t\n"
 266        word_break_chars = spaces ++ specials ++ symbols
 267
 268    Readline.setBasicWordBreakCharacters word_break_chars
 269    Readline.setCompleterWordBreakCharacters word_break_chars
 270 #endif
 271
 272    bkptTable <- newIORef emptyBkptTable
 273    GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
 274    default_editor <- findEditor
 275
 276    startGHCi (runGHCi srcs maybe_expr)
 277         GHCiState{ progname = "<interactive>",
 278                    args = [],
 279                    prompt = "%s> ",
 280                    editor = default_editor,
 281                    session = session,
 282                    options = [],
 283                    prelude = prel_mod,
 284                    bkptTable = bkptTable,
 285                    topLevel  = True
 286                  }
 287
 288 #ifdef USE_READLINE
 289    Readline.resetTerminal Nothing
 290 #endif
 291
 292    return ()
 293
 294 prel_name = GHC.mkModuleName "Prelude"
 295
 296 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 297 runGHCi paths maybe_expr = do
 298   let read_dot_files = not opt_IgnoreDotGhci
 299
 300   when (read_dot_files) $ do
 301     -- Read in ./.ghci.
 302     let file = "./.ghci"
 303     exists <- io (doesFileExist file)
 304     when exists $ do
 305        dir_ok  <- io (checkPerms ".")
 306        file_ok <- io (checkPerms file)
 307        when (dir_ok && file_ok) $ do
 308           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 309           case either_hdl of
 310              Left e    -> return ()
 311              Right hdl -> fileLoop hdl False
 312
 313   when (read_dot_files) $ do
 314     -- Read in $HOME/.ghci
 315     either_dir <- io (IO.try (getEnv "HOME"))
 316     case either_dir of
 317        Left e -> return ()
 318        Right dir -> do
 319           cwd <- io (getCurrentDirectory)
 320           when (dir /= cwd) $ do
 321              let file = dir ++ "/.ghci"
 322              ok <- io (checkPerms file)
 323              when ok $ do
 324                either_hdl <- io (IO.try (openFile file ReadMode))
 325                case either_hdl of
 326                   Left e    -> return ()
 327                   Right hdl -> fileLoop hdl False
 328
 329   -- Perform a :load for files given on the GHCi command line
 330   -- When in -e mode, if the load fails then we want to stop
 331   -- immediately rather than going on to evaluate the expression.
 332   when (not (null paths)) $ do
 333      ok <- ghciHandle (\e -> do showException e; return Failed) $
 334                 loadModule paths
 335      when (isJust maybe_expr && failed ok) $
 336         io (exitWith (ExitFailure 1))
 337
 338   -- if verbosity is greater than 0, or we are connected to a
 339   -- terminal, display the prompt in the interactive loop.
 340   is_tty <- io (hIsTerminalDevice stdin)
 341   dflags <- getDynFlags
 342   let show_prompt = verbosity dflags > 0 || is_tty
 343
 344   case maybe_expr of
 345         Nothing ->
 346           do
 347 #if defined(mingw32_HOST_OS)
 348             -- The win32 Console API mutates the first character of
 349             -- type-ahead when reading from it in a non-buffered manner. Work
 350             -- around this by flushing the input buffer of type-ahead characters,
 351             -- but only if stdin is available.
 352             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 353             case flushed of
 354              Left err | isDoesNotExistError err -> return ()
 355                       | otherwise -> io (ioError err)
 356              Right () -> return ()
 357 #endif
 358             -- initialise the console if necessary
 359             io setUpConsole
 360
 361             -- enter the interactive loop
 362             interactiveLoop is_tty show_prompt
 363         Just expr -> do
 364             -- just evaluate the expression we were given
 365             runCommandEval expr
 366             return ()
 367
 368   -- and finally, exit
 369   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 370
 371
 372 interactiveLoop is_tty show_prompt =
 373   -- Ignore ^C exceptions caught here
 374   ghciHandleDyn (\e -> case e of
 375                         Interrupted -> do
 376 #if defined(mingw32_HOST_OS)
 377                                 io (putStrLn "")
 378 #endif
 379                                 interactiveLoop is_tty show_prompt
 380                         _other      -> return ()) $
 381
 382   ghciUnblock $ do -- unblock necessary if we recursed from the
 383                    -- exception handler above.
 384
 385   -- read commands from stdin
 386 #ifdef USE_READLINE
 387   if (is_tty)
 388         then readlineLoop
 389         else fileLoop stdin show_prompt
 390 #else
 391   fileLoop stdin show_prompt
 392 #endif
 393
 394
 395 -- NOTE: We only read .ghci files if they are owned by the current user,
 396 -- and aren't world writable.  Otherwise, we could be accidentally
 397 -- running code planted by a malicious third party.
 398
 399 -- Furthermore, We only read ./.ghci if . is owned by the current user
 400 -- and isn't writable by anyone else.  I think this is sufficient: we
 401 -- don't need to check .. and ../.. etc. because "."  always refers to
 402 -- the same directory while a process is running.
 403
 404 checkPerms :: String -> IO Bool
 405 checkPerms name =
 406 #ifdef mingw32_HOST_OS
 407   return True
 408 #else
 409   Util.handle (\_ -> return False) $ do
 410      st <- getFileStatus name
 411      me <- getRealUserID
 412      if fileOwner st /= me then do
 413         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 414         return False
 415       else do
 416         let mode =  fileMode st
 417         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 418            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 419            then do
 420                putStrLn $ "*** WARNING: " ++ name ++
 421                           " is writable by someone else, IGNORING!"
 422                return False
 423           else return True
 424 #endif
 425
 426 fileLoop :: Handle -> Bool -> GHCi ()
 427 fileLoop hdl show_prompt = do
 428    session <- getSession
 429    (mod,imports) <- io (GHC.getContext session)
 430    st <- getGHCiState
 431    when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
 432    l <- io (IO.try (hGetLine hdl))
 433    case l of
 434         Left e | isEOFError e              -> return ()
 435                | InvalidArgument <- etype  -> return ()
 436                | otherwise                 -> io (ioError e)
 437                 where etype = ioeGetErrorType e
 438                 -- treat InvalidArgument in the same way as EOF:
 439                 -- this can happen if the user closed stdin, or
 440                 -- perhaps did getContents which closes stdin at
 441                 -- EOF.
 442         Right l ->
 443           case removeSpaces l of
 444             "" -> fileLoop hdl show_prompt
 445             l  -> do quit <- runCommand l
 446                      if quit then return () else fileLoop hdl show_prompt
 447
 448 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
 449 stringLoop [] = return False
 450 stringLoop (s:ss) = do
 451    case removeSpaces s of
 452         "" -> stringLoop ss
 453         l  -> do quit <- runCommand l
 454                  if quit then return True else stringLoop ss
 455
 456 mkPrompt toplevs exports prompt
 457   = showSDoc $ f prompt
 458     where
 459         f ('%':'s':xs) = perc_s <> f xs
 460         f ('%':'%':xs) = char '%' <> f xs
 461         f (x:xs) = char x <> f xs
 462         f [] = empty
 463
 464         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 465                  hsep (map (ppr . GHC.moduleName) exports)
 466
 467
 468 #ifdef USE_READLINE
 469 readlineLoop :: GHCi ()
 470 readlineLoop = do
 471    session <- getSession
 472    (mod,imports) <- io (GHC.getContext session)
 473    io yield
 474    saveSession -- for use by completion
 475    st <- getGHCiState
 476    l <- io (readline (mkPrompt mod imports (prompt st))
 477                 `finally` setNonBlockingFD 0)
 478                 -- readline sometimes puts stdin into blocking mode,
 479                 -- so we need to put it back for the IO library
 480    splatSavedSession
 481    case l of
 482         Nothing -> return ()
 483         Just l  ->
 484           case removeSpaces l of
 485             "" -> readlineLoop
 486             l  -> do
 487                   io (addHistory l)
 488                   quit <- runCommand l
 489                   if quit then return () else readlineLoop
 490 #endif
 491
 492 runCommand :: String -> GHCi Bool
 493 runCommand c = ghciHandle handler (doCommand c)
 494   where
 495     doCommand (':' : command) = specialCommand command
 496     doCommand stmt
 497        = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 498             return False
 499
 500 -- This version is for the GHC command-line option -e.  The only difference
 501 -- from runCommand is that it catches the ExitException exception and
 502 -- exits, rather than printing out the exception.
 503 runCommandEval c = ghciHandle handleEval (doCommand c)
 504   where
 505     handleEval (ExitException code) = io (exitWith code)
 506     handleEval e                    = do handler e
 507                                          io (exitWith (ExitFailure 1))
 508
 509     doCommand (':' : command) = specialCommand command
 510     doCommand stmt
 511        = do nms <- runStmt stmt
 512             case nms of
 513                 Nothing -> io (exitWith (ExitFailure 1))
 514                   -- failure to run the command causes exit(1) for ghc -e.
 515                 _       -> finishEvalExpr nms
 516
 517 runStmt :: String -> GHCi (Maybe [Name])
 518 runStmt stmt
 519  | null (filter (not.isSpace) stmt) = return (Just [])
 520  | otherwise
 521  = do st <- getGHCiState
 522       session <- getSession
 523       result <- io $ withProgName (progname st) $ withArgs (args st) $
 524                      GHC.runStmt session stmt
 525       case result of
 526         GHC.RunFailed      -> return Nothing
 527         GHC.RunException e -> throw e  -- this is caught by runCommand(Eval)
 528         GHC.RunOk names    -> return (Just names)
 529
 530 -- possibly print the type and revert CAFs after evaluating an expression
 531 finishEvalExpr mb_names
 532  = do b <- isOptionSet ShowType
 533       session <- getSession
 534       case mb_names of
 535         Nothing    -> return ()
 536         Just names -> when b (mapM_ (showTypeOfName session) names)
 537
 538       flushInterpBuffers
 539       io installSignalHandlers
 540       b <- isOptionSet RevertCAFs
 541       io (when b revertCAFs)
 542       return True
 543
 544 showTypeOfName :: Session -> Name -> GHCi ()
 545 showTypeOfName session n
 546    = do maybe_tything <- io (GHC.lookupName session n)
 547         case maybe_tything of
 548           Nothing    -> return ()
 549           Just thing -> showTyThing thing
 550
 551 specialCommand :: String -> GHCi Bool
 552 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 553 specialCommand str = do
 554   let (cmd,rest) = break isSpace str
 555   maybe_cmd <- io (lookupCommand cmd)
 556   case maybe_cmd of
 557     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 558                                     ++ shortHelpText) >> return False)
 559     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 560
 561 lookupCommand :: String -> IO (Maybe Command)
 562 lookupCommand str = do
 563   cmds <- readIORef commands
 564   -- look for exact match first, then the first prefix match
 565   case [ c | c <- cmds, str == cmdName c ] of
 566      c:_ -> return (Just c)
 567      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 568                 [] -> return Nothing
 569                 c:_ -> return (Just c)
 570
 571 -----------------------------------------------------------------------------
 572 -- Commands
 573
 574 help :: String -> GHCi ()
 575 help _ = io (putStr helpText)
 576
 577 info :: String -> GHCi ()
 578 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 579 info s  = do { let names = words s
 580              ; session <- getSession
 581              ; dflags <- getDynFlags
 582              ; let exts = dopt Opt_GlasgowExts dflags
 583              ; mapM_ (infoThing exts session) names }
 584   where
 585     infoThing exts session str = io $ do
 586         names <- GHC.parseName session str
 587         let filtered = filterOutChildren names
 588         mb_stuffs <- mapM (GHC.getInfo session) filtered
 589         unqual <- GHC.getPrintUnqual session
 590         putStrLn (showSDocForUser unqual $
 591                    vcat (intersperse (text "") $
 592                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 593
 594   -- Filter out names whose parent is also there Good
 595   -- example is '[]', which is both a type and data
 596   -- constructor in the same type
 597 filterOutChildren :: [Name] -> [Name]
 598 filterOutChildren names = filter (not . parent_is_there) names
 599  where parent_is_there n
 600 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 601 -- ToDo!!
 602          | otherwise                       = False
 603
 604 pprInfo exts (thing, fixity, insts)
 605   =  pprTyThingInContextLoc exts thing
 606   $$ show_fixity fixity
 607   $$ vcat (map GHC.pprInstance insts)
 608   where
 609     show_fixity fix
 610         | fix == GHC.defaultFixity = empty
 611         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 612
 613 -----------------------------------------------------------------------------
 614 -- Commands
 615
 616 runMain :: String -> GHCi ()
 617 runMain args = do
 618   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 619   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 620   return ()
 621
 622 addModule :: [FilePath] -> GHCi ()
 623 addModule files = do
 624   io (revertCAFs)                       -- always revert CAFs on load/add.
 625   files <- mapM expandPath files
 626   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 627   session <- getSession
 628   io (mapM_ (GHC.addTarget session) targets)
 629   ok <- io (GHC.load session LoadAllTargets)
 630   afterLoad ok session
 631
 632 changeDirectory :: String -> GHCi ()
 633 changeDirectory dir = do
 634   session <- getSession
 635   graph <- io (GHC.getModuleGraph session)
 636   when (not (null graph)) $
 637         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 638   io (GHC.setTargets session [])
 639   io (GHC.load session LoadAllTargets)
 640   setContextAfterLoad session []
 641   io (GHC.workingDirectoryChanged session)
 642   dir <- expandPath dir
 643   io (setCurrentDirectory dir)
 644
 645 editFile :: String -> GHCi ()
 646 editFile str
 647   | null str  = do
 648         -- find the name of the "topmost" file loaded
 649      session <- getSession
 650      graph0 <- io (GHC.getModuleGraph session)
 651      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 652      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 653      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 654         Just file -> do_edit file
 655         Nothing   -> throwDyn (CmdLineError "unknown file name")
 656   | otherwise = do_edit str
 657   where
 658         do_edit file = do
 659            st <- getGHCiState
 660            let cmd = editor st
 661            when (null cmd) $
 662                 throwDyn (CmdLineError "editor not set, use :set editor")
 663            io $ system (cmd ++ ' ':file)
 664            return ()
 665
 666 defineMacro :: String -> GHCi ()
 667 defineMacro s = do
 668   let (macro_name, definition) = break isSpace s
 669   cmds <- io (readIORef commands)
 670   if (null macro_name)
 671         then throwDyn (CmdLineError "invalid macro name")
 672         else do
 673   if (macro_name `elem` map cmdName cmds)
 674         then throwDyn (CmdLineError
 675                 ("command '" ++ macro_name ++ "' is already defined"))
 676         else do
 677
 678   -- give the expression a type signature, so we can be sure we're getting
 679   -- something of the right type.
 680   let new_expr = '(' : definition ++ ") :: String -> IO String"
 681
 682   -- compile the expression
 683   cms <- getSession
 684   maybe_hv <- io (GHC.compileExpr cms new_expr)
 685   case maybe_hv of
 686      Nothing -> return ()
 687      Just hv -> io (writeIORef commands --
 688                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 689
 690 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 691 runMacro fun s = do
 692   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 693   stringLoop (lines str)
 694
 695 undefineMacro :: String -> GHCi ()
 696 undefineMacro macro_name = do
 697   cmds <- io (readIORef commands)
 698   if (macro_name `elem` map cmdName builtin_commands)
 699         then throwDyn (CmdLineError
 700                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 701         else do
 702   if (macro_name `notElem` map cmdName cmds)
 703         then throwDyn (CmdLineError
 704                 ("command '" ++ macro_name ++ "' not defined"))
 705         else do
 706   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 707
 708
 709 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 710 loadModule fs = timeIt (loadModule' fs)
 711
 712 loadModule_ :: [FilePath] -> GHCi ()
 713 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 714
 715 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 716 loadModule' files = do
 717   session <- getSession
 718
 719   -- unload first
 720   io (GHC.setTargets session [])
 721   io (GHC.load session LoadAllTargets)
 722
 723   -- expand tildes
 724   let (filenames, phases) = unzip files
 725   exp_filenames <- mapM expandPath filenames
 726   let files' = zip exp_filenames phases
 727   targets <- io (mapM (uncurry GHC.guessTarget) files')
 728
 729   -- NOTE: we used to do the dependency anal first, so that if it
 730   -- fails we didn't throw away the current set of modules.  This would
 731   -- require some re-working of the GHC interface, so we'll leave it
 732   -- as a ToDo for now.
 733
 734   io (GHC.setTargets session targets)
 735   ok <- io (GHC.load session LoadAllTargets)
 736   afterLoad ok session
 737   return ok
 738
 739 checkModule :: String -> GHCi ()
 740 checkModule m = do
 741   let modl = GHC.mkModuleName m
 742   session <- getSession
 743   result <- io (GHC.checkModule session modl)
 744   case result of
 745     Nothing -> io $ putStrLn "Nothing"
 746     Just r  -> io $ putStrLn (showSDoc (
 747         case GHC.checkedModuleInfo r of
 748            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 749                 let
 750                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 751                 in
 752                         (text "global names: " <+> ppr global) $$
 753                         (text "local  names: " <+> ppr local)
 754            _ -> empty))
 755   afterLoad (successIf (isJust result)) session
 756
 757 reloadModule :: String -> GHCi ()
 758 reloadModule "" = do
 759   io (revertCAFs)               -- always revert CAFs on reload.
 760   session <- getSession
 761   ok <- io (GHC.load session LoadAllTargets)
 762   afterLoad ok session
 763 reloadModule m = do
 764   io (revertCAFs)               -- always revert CAFs on reload.
 765   session <- getSession
 766   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 767   afterLoad ok session
 768
 769 afterLoad ok session = do
 770   io (revertCAFs)  -- always revert CAFs on load.
 771   graph <- io (GHC.getModuleGraph session)
 772   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 773   setContextAfterLoad session graph'
 774   refreshBkptTable graph'
 775   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 776
 777 setContextAfterLoad session [] = do
 778   prel_mod <- getPrelude
 779   io (GHC.setContext session [] [prel_mod])
 780 setContextAfterLoad session ms = do
 781   -- load a target if one is available, otherwise load the topmost module.
 782   targets <- io (GHC.getTargets session)
 783   case [ m | Just m <- map (findTarget ms) targets ] of
 784         []    ->
 785           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 786           load_this (last graph')
 787         (m:_) ->
 788           load_this m
 789  where
 790    findTarget ms t
 791     = case filter (`matches` t) ms of
 792         []    -> Nothing
 793         (m:_) -> Just m
 794
 795    summary `matches` Target (TargetModule m) _
 796         = GHC.ms_mod_name summary == m
 797    summary `matches` Target (TargetFile f _) _
 798         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 799    summary `matches` target
 800         = False
 801
 802    load_this summary | m <- GHC.ms_mod summary = do
 803         b <- io (GHC.moduleIsInterpreted session m)
 804         if b then io (GHC.setContext session [m] [])
 805              else do
 806                    prel_mod <- getPrelude
 807                    io (GHC.setContext session []  [prel_mod,m])
 808
 809
 810 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 811 modulesLoadedMsg ok mods = do
 812   dflags <- getDynFlags
 813   when (verbosity dflags > 0) $ do
 814    let mod_commas
 815         | null mods = text "none."
 816         | otherwise = hsep (
 817             punctuate comma (map ppr mods)) <> text "."
 818    case ok of
 819     Failed ->
 820        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 821     Succeeded  ->
 822        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 823
 824
 825 typeOfExpr :: String -> GHCi ()
 826 typeOfExpr str
 827   = do cms <- getSession
 828        maybe_ty <- io (GHC.exprType cms str)
 829        case maybe_ty of
 830           Nothing -> return ()
 831           Just ty -> do ty' <- cleanType ty
 832                         tystr <- showForUser (ppr ty')
 833                         io (putStrLn (str ++ " :: " ++ tystr))
 834
 835 kindOfType :: String -> GHCi ()
 836 kindOfType str
 837   = do cms <- getSession
 838        maybe_ty <- io (GHC.typeKind cms str)
 839        case maybe_ty of
 840           Nothing    -> return ()
 841           Just ty    -> do tystr <- showForUser (ppr ty)
 842                            io (putStrLn (str ++ " :: " ++ tystr))
 843
 844 quit :: String -> GHCi Bool
 845 quit _ = return True
 846
 847 shellEscape :: String -> GHCi Bool
 848 shellEscape str = io (system str >> return False)
 849
 850 -----------------------------------------------------------------------------
 851 -- create tags file for currently loaded modules.
 852
 853 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 854
 855 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 856 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 857
 858 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 859 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 860
 861 data TagsKind = ETags | CTags
 862
 863 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 864 ghciCreateTagsFile kind file = do
 865   session <- getSession
 866   io $ createTagsFile session kind file
 867
 868 -- ToDo:
 869 --      - remove restriction that all modules must be interpreted
 870 --        (problem: we don't know source locations for entities unless
 871 --        we compiled the module.
 872 --
 873 --      - extract createTagsFile so it can be used from the command-line
 874 --        (probably need to fix first problem before this is useful).
 875 --
 876 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 877 createTagsFile session tagskind tagFile = do
 878   graph <- GHC.getModuleGraph session
 879   let ms = map GHC.ms_mod graph
 880       tagModule m = do
 881         is_interpreted <- GHC.moduleIsInterpreted session m
 882         -- should we just skip these?
 883         when (not is_interpreted) $
 884           throwDyn (CmdLineError ("module '"
 885                                 ++ GHC.moduleNameString (GHC.moduleName m)
 886                                 ++ "' is not interpreted"))
 887         mbModInfo <- GHC.getModuleInfo session m
 888         let unqual
 889               | Just modinfo <- mbModInfo,
 890                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 891               | otherwise = GHC.alwaysQualify
 892
 893         case mbModInfo of
 894           Just modInfo -> return $! listTags unqual modInfo
 895           _            -> return []
 896
 897   mtags <- mapM tagModule ms
 898   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 899   case either_res of
 900     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 901     Right _ -> return ()
 902
 903 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 904 listTags unqual modInfo =
 905            [ tagInfo unqual name loc
 906            | name <- GHC.modInfoExports modInfo
 907            , let loc = nameSrcLoc name
 908            , isGoodSrcLoc loc
 909            ]
 910
 911 type TagInfo = (String -- tag name
 912                ,String -- file name
 913                ,Int    -- line number
 914                ,Int    -- column number
 915                )
 916
 917 -- get tag info, for later translation into Vim or Emacs style
 918 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 919 tagInfo unqual name loc
 920     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 921       , showSDocForUser unqual $ ftext (srcLocFile loc)
 922       , srcLocLine loc
 923       , srcLocCol loc
 924       )
 925
 926 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 927 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 928   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 929   IO.try (writeFile file tags)
 930 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 931   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 932       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 933   tagGroups <- mapM tagFileGroup groups
 934   IO.try (writeFile file $ concat tagGroups)
 935   where
 936     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
 937     tagFileGroup group@((_,fileName,_,_):_) = do
 938       file <- readFile fileName -- need to get additional info from sources..
 939       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 940           sortedGroup = sortLe byLine group
 941           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 942       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 943     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
 944       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 945     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
 946       showETag tagInfo line pos : perFile tags count pos lines
 947     perFile tags count pos lines = []
 948
 949 -- simple ctags format, for Vim et al
 950 showTag :: TagInfo -> String
 951 showTag (tag,file,lineNo,colNo)
 952     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 953
 954 -- etags format, for Emacs/XEmacs
 955 showETag :: TagInfo -> String -> Int -> String
 956 showETag (tag,file,lineNo,colNo) line charPos
 957     =  take colNo line ++ tag
 958     ++ "\x7f" ++ tag
 959     ++ "\x01" ++ show lineNo
 960     ++ "," ++ show charPos
 961
 962 -----------------------------------------------------------------------------
 963 -- Browsing a module's contents
 964
 965 browseCmd :: String -> GHCi ()
 966 browseCmd m =
 967   case words m of
 968     ['*':m] | looksLikeModuleName m -> browseModule m False
 969     [m]     | looksLikeModuleName m -> browseModule m True
 970     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 971
 972 browseModule m exports_only = do
 973   s <- getSession
 974   modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
 975   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
 976   when (not is_interpreted && not exports_only) $
 977         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 978
 979   -- Temporarily set the context to the module we're interested in,
 980   -- just so we can get an appropriate PrintUnqualified
 981   (as,bs) <- io (GHC.getContext s)
 982   prel_mod <- getPrelude
 983   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 984                       else GHC.setContext s [modl] [])
 985   unqual <- io (GHC.getPrintUnqual s)
 986   io (GHC.setContext s as bs)
 987
 988   mb_mod_info <- io $ GHC.getModuleInfo s modl
 989   case mb_mod_info of
 990     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 991     Just mod_info -> do
 992         let names
 993                | exports_only = GHC.modInfoExports mod_info
 994                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 995
 996             filtered = filterOutChildren names
 997
 998         things <- io $ mapM (GHC.lookupName s) filtered
 999
1000         dflags <- getDynFlags
1001         let exts = dopt Opt_GlasgowExts dflags
1002         io (putStrLn (showSDocForUser unqual (
1003                 vcat (map (pprTyThingInContext exts) (catMaybes things))
1004            )))
1005         -- ToDo: modInfoInstances currently throws an exception for
1006         -- package modules.  When it works, we can do this:
1007         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1008
1009 -----------------------------------------------------------------------------
1010 -- Setting the module context
1011
1012 setContext str
1013   | all sensible mods = fn mods
1014   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1015   where
1016     (fn, mods) = case str of
1017                         '+':stuff -> (addToContext,      words stuff)
1018                         '-':stuff -> (removeFromContext, words stuff)
1019                         stuff     -> (newContext,        words stuff)
1020
1021     sensible ('*':m) = looksLikeModuleName m
1022     sensible m       = looksLikeModuleName m
1023
1024 separate :: Session -> [String] -> [Module] -> [Module]
1025         -> GHCi ([Module],[Module])
1026 separate session []           as bs = return (as,bs)
1027 separate session (('*':str):ms) as bs = do
1028    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1029    b <- io $ GHC.moduleIsInterpreted session m
1030    if b then separate session ms (m:as) bs
1031         else throwDyn (CmdLineError ("module '"
1032                         ++ GHC.moduleNameString (GHC.moduleName m)
1033                         ++ "' is not interpreted"))
1034 separate session (str:ms) as bs = do
1035   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1036   separate session ms as (m:bs)
1037
1038 newContext :: [String] -> GHCi ()
1039 newContext strs = do
1040   s <- getSession
1041   (as,bs) <- separate s strs [] []
1042   prel_mod <- getPrelude
1043   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1044   io $ GHC.setContext s as bs'
1045
1046
1047 addToContext :: [String] -> GHCi ()
1048 addToContext strs = do
1049   s <- getSession
1050   (as,bs) <- io $ GHC.getContext s
1051
1052   (new_as,new_bs) <- separate s strs [] []
1053
1054   let as_to_add = new_as \\ (as ++ bs)
1055       bs_to_add = new_bs \\ (as ++ bs)
1056
1057   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1058
1059
1060 removeFromContext :: [String] -> GHCi ()
1061 removeFromContext strs = do
1062   s <- getSession
1063   (as,bs) <- io $ GHC.getContext s
1064
1065   (as_to_remove,bs_to_remove) <- separate s strs [] []
1066
1067   let as' = as \\ (as_to_remove ++ bs_to_remove)
1068       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1069
1070   io $ GHC.setContext s as' bs'
1071
1072 ----------------------------------------------------------------------------
1073 -- Code for `:set'
1074
1075 -- set options in the interpreter.  Syntax is exactly the same as the
1076 -- ghc command line, except that certain options aren't available (-C,
1077 -- -E etc.)
1078 --
1079 -- This is pretty fragile: most options won't work as expected.  ToDo:
1080 -- figure out which ones & disallow them.
1081
1082 setCmd :: String -> GHCi ()
1083 setCmd ""
1084   = do st <- getGHCiState
1085        let opts = options st
1086        io $ putStrLn (showSDoc (
1087               text "options currently set: " <>
1088               if null opts
1089                    then text "none."
1090                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1091            ))
1092 setCmd str
1093   = case toArgs str of
1094         ("args":args) -> setArgs args
1095         ("prog":prog) -> setProg prog
1096         ("prompt":prompt) -> setPrompt (after 6)
1097         ("editor":cmd) -> setEditor (after 6)
1098         wds -> setOptions wds
1099    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1100
1101 setArgs args = do
1102   st <- getGHCiState
1103   setGHCiState st{ args = args }
1104
1105 setProg [prog] = do
1106   st <- getGHCiState
1107   setGHCiState st{ progname = prog }
1108 setProg _ = do
1109   io (hPutStrLn stderr "syntax: :set prog <progname>")
1110
1111 setEditor cmd = do
1112   st <- getGHCiState
1113   setGHCiState st{ editor = cmd }
1114
1115 setPrompt value = do
1116   st <- getGHCiState
1117   if null value
1118       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1119       else setGHCiState st{ prompt = remQuotes value }
1120   where
1121      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1122      remQuotes x = x
1123
1124 setOptions wds =
1125    do -- first, deal with the GHCi opts (+s, +t, etc.)
1126       let (plus_opts, minus_opts)  = partition isPlus wds
1127       mapM_ setOpt plus_opts
1128
1129       -- then, dynamic flags
1130       dflags <- getDynFlags
1131       let pkg_flags = packageFlags dflags
1132       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1133
1134       if (not (null leftovers))
1135                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1136                                                 unwords leftovers))
1137                 else return ()
1138
1139       new_pkgs <- setDynFlags dflags'
1140
1141       -- if the package flags changed, we should reset the context
1142       -- and link the new packages.
1143       dflags <- getDynFlags
1144       when (packageFlags dflags /= pkg_flags) $ do
1145         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1146         session <- getSession
1147         io (GHC.setTargets session [])
1148         io (GHC.load session LoadAllTargets)
1149         io (linkPackages dflags new_pkgs)
1150         setContextAfterLoad session []
1151       return ()
1152
1153
1154 unsetOptions :: String -> GHCi ()
1155 unsetOptions str
1156   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1157        let opts = words str
1158            (minus_opts, rest1) = partition isMinus opts
1159            (plus_opts, rest2)  = partition isPlus rest1
1160
1161        if (not (null rest2))
1162           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1163           else do
1164
1165        mapM_ unsetOpt plus_opts
1166
1167        -- can't do GHC flags for now
1168        if (not (null minus_opts))
1169           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1170           else return ()
1171
1172 isMinus ('-':s) = True
1173 isMinus _ = False
1174
1175 isPlus ('+':s) = True
1176 isPlus _ = False
1177
1178 setOpt ('+':str)
1179   = case strToGHCiOpt str of
1180         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1181         Just o  -> setOption o
1182
1183 unsetOpt ('+':str)
1184   = case strToGHCiOpt str of
1185         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1186         Just o  -> unsetOption o
1187
1188 strToGHCiOpt :: String -> (Maybe GHCiOption)
1189 strToGHCiOpt "s" = Just ShowTiming
1190 strToGHCiOpt "t" = Just ShowType
1191 strToGHCiOpt "r" = Just RevertCAFs
1192 strToGHCiOpt _   = Nothing
1193
1194 optToStr :: GHCiOption -> String
1195 optToStr ShowTiming = "s"
1196 optToStr ShowType   = "t"
1197 optToStr RevertCAFs = "r"
1198
1199 -- ---------------------------------------------------------------------------
1200 -- code for `:show'
1201
1202 showCmd str =
1203   case words str of
1204         ["modules" ] -> showModules
1205         ["bindings"] -> showBindings
1206         ["linker"]   -> io showLinkerState
1207         ["breakpoints"] -> showBkptTable
1208         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1209
1210 showModules = do
1211   session <- getSession
1212   let show_one ms = do m <- io (GHC.showModule session ms)
1213                        io (putStrLn m)
1214   graph <- io (GHC.getModuleGraph session)
1215   mapM_ show_one graph
1216
1217 showBindings = do
1218   s <- getSession
1219   unqual <- io (GHC.getPrintUnqual s)
1220   bindings <- io (GHC.getBindings s)
1221   mapM_ showTyThing bindings
1222   return ()
1223
1224 showTyThing (AnId id) = do
1225   ty' <- cleanType (GHC.idType id)
1226   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1227   io (putStrLn str)
1228 showTyThing _  = return ()
1229
1230 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1231 cleanType :: Type -> GHCi Type
1232 cleanType ty = do
1233   dflags <- getDynFlags
1234   if dopt Opt_GlasgowExts dflags
1235         then return ty
1236         else return $! GHC.dropForAlls ty
1237
1238 showBkptTable :: GHCi ()
1239 showBkptTable = do
1240   bt     <- getBkptTable
1241   msg <- showForUser . vcat $
1242              [ ppr mod <> colon <+> fcat
1243                        [ parens(int row <> comma <> int col) | (row,col) <- sites]
1244                | (mod, sites) <-  sitesList bt ]
1245   io (putStrLn msg)
1246 -- -----------------------------------------------------------------------------
1247 -- Completion
1248
1249 completeNone :: String -> IO [String]
1250 completeNone w = return []
1251
1252 #ifdef USE_READLINE
1253 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1254 completeWord w start end = do
1255   line <- Readline.getLineBuffer
1256   case w of
1257      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1258      _other
1259         | Just c <- is_cmd line -> do
1260            maybe_cmd <- lookupCommand c
1261            let (n,w') = selectWord (words' 0 line)
1262            case maybe_cmd of
1263              Nothing -> return Nothing
1264              Just (_,_,False,complete) -> wrapCompleter complete w
1265              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1266                                                               return (map (drop n) rets)
1267                                          in wrapCompleter complete' w'
1268         | otherwise     -> do
1269                 --printf "complete %s, start = %d, end = %d\n" w start end
1270                 wrapCompleter completeIdentifier w
1271     where words' _ [] = []
1272           words' n str = let (w,r) = break isSpace str
1273                              (s,r') = span isSpace r
1274                          in (n,w):words' (n+length w+length s) r'
1275           -- In a Haskell expression we want to parse 'a-b' as three words
1276           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1277           -- only be a single word.
1278           selectWord [] = (0,w)
1279           selectWord ((offset,x):xs)
1280               | offset+length x >= start = (start-offset,take (end-offset) x)
1281               | otherwise = selectWord xs
1282
1283 is_cmd line
1284  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1285  | otherwise = Nothing
1286
1287 completeCmd w = do
1288   cmds <- readIORef commands
1289   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1290
1291 completeMacro w = do
1292   cmds <- readIORef commands
1293   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1294   return (filter (w `isPrefixOf`) cmds')
1295
1296 completeIdentifier w = do
1297   s <- restoreSession
1298   rdrs <- GHC.getRdrNamesInScope s
1299   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1300
1301 completeModule w = do
1302   s <- restoreSession
1303   dflags <- GHC.getSessionDynFlags s
1304   let pkg_mods = allExposedModules dflags
1305   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1306
1307 completeHomeModule w = do
1308   s <- restoreSession
1309   g <- GHC.getModuleGraph s
1310   let home_mods = map GHC.ms_mod_name g
1311   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1312
1313 completeSetOptions w = do
1314   return (filter (w `isPrefixOf`) options)
1315     where options = "args":"prog":allFlags
1316
1317 completeBkpt = unionComplete completeModule completeBkptCmds
1318
1319 completeBkptCmds w = do
1320   return (filter (w `isPrefixOf`) options)
1321     where options = ["add","del","list","stop"]
1322
1323 completeFilename = Readline.filenameCompletionFunction
1324
1325 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1326
1327 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1328 unionComplete f1 f2 w = do
1329   s1 <- f1 w
1330   s2 <- f2 w
1331   return (s1 ++ s2)
1332
1333 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1334 wrapCompleter fun w =  do
1335   strs <- fun w
1336   case strs of
1337     []  -> return Nothing
1338     [x] -> return (Just (x,[]))
1339     xs  -> case getCommonPrefix xs of
1340                 ""   -> return (Just ("",xs))
1341                 pref -> return (Just (pref,xs))
1342
1343 getCommonPrefix :: [String] -> String
1344 getCommonPrefix [] = ""
1345 getCommonPrefix (s:ss) = foldl common s ss
1346   where common s "" = s
1347         common "" s = ""
1348         common (c:cs) (d:ds)
1349            | c == d = c : common cs ds
1350            | otherwise = ""
1351
1352 allExposedModules :: DynFlags -> [ModuleName]
1353 allExposedModules dflags
1354  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1355  where
1356   pkg_db = pkgIdMap (pkgState dflags)
1357 #else
1358 completeCmd        = completeNone
1359 completeMacro      = completeNone
1360 completeIdentifier = completeNone
1361 completeModule     = completeNone
1362 completeHomeModule = completeNone
1363 completeSetOptions = completeNone
1364 completeFilename   = completeNone
1365 completeHomeModuleOrFile=completeNone
1366 completeBkpt       = completeNone
1367 #endif
1368
1369 -- ----------------------------------------------------------------------------
1370 -- Utils
1371
1372 expandPath :: String -> GHCi String
1373 expandPath path =
1374   case dropWhile isSpace path of
1375    ('~':d) -> do
1376         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1377         return (tilde ++ '/':d)
1378    other ->
1379         return other
1380
1381 -- ----------------------------------------------------------------------------
1382 -- Windows console setup
1383
1384 setUpConsole :: IO ()
1385 setUpConsole = do
1386 #ifdef mingw32_HOST_OS
1387         -- On Windows we need to set a known code page, otherwise the characters
1388         -- we read from the console will be be in some strange encoding, and
1389         -- similarly for characters we write to the console.
1390         --
1391         -- At the moment, GHCi pretends all input is Latin-1.  In the
1392         -- future we should support UTF-8, but for now we set the code pages
1393         -- to Latin-1.
1394         --
1395         -- It seems you have to set the font in the console window to
1396         -- a Unicode font in order for output to work properly,
1397         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1398         -- (see MSDN for SetConsoleOutputCP()).
1399         --
1400         setConsoleCP 28591       -- ISO Latin-1
1401         setConsoleOutputCP 28591 -- ISO Latin-1
1402 #endif
1403         return ()
1404
1405
1406 instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
1407 instrumentationBkptHandler ref_bkptTable = BkptHandler {
1408     isAutoBkptEnabled = \sess bkptLoc -> do
1409       bktpTable <- readIORef ref_bkptTable
1410       return$ isBkptEnabled bktpTable bkptLoc
1411
1412   , handleBreakpoint = doBreakpoint ref_bkptTable
1413   }
1414
1415 doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
1416 doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
1417          let (ids, hValues) = unzip values
1418              names = map idName ids
1419          ASSERT (length names == length hValues) return ()
1420          let global_ids = map globaliseAndTidy ids
1421          printScopeMsg locMsg global_ids
1422          typed_ids  <- mapM instantiateIdType global_ids
1423          hsc_env <- readIORef ref
1424          let ictxt = hsc_IC hsc_env
1425              rn_env   = ic_rn_local_env ictxt
1426              type_env = ic_type_env ictxt
1427              bound_names = map idName typed_ids
1428              new_rn_env  = extendLocalRdrEnv rn_env bound_names
1429                 -- Remove any shadowed bindings from the type_env;
1430                 -- they are inaccessible but might, I suppose, cause
1431                 -- a space leak if we leave them there
1432              shadowed = [ n | name <- bound_names,
1433                           let rdr_name = mkRdrUnqual (nameOccName name),
1434                           Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
1435              filtered_type_env = delListFromNameEnv type_env shadowed
1436              new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
1437              new_ic = ictxt { ic_rn_local_env = new_rn_env,
1438                               ic_type_env     = new_type_env }
1439          writeIORef ref (hsc_env { hsc_IC = new_ic })
1440          is_tty <- hIsTerminalDevice stdin
1441          prel_mod <- GHC.findModule s prel_name Nothing
1442          withExtendedLinkEnv (zip names hValues) $
1443            startGHCi (interactiveLoop is_tty True) GHCiState{
1444                               progname = "<interactive>",
1445                               args     = [],
1446                               prompt   = locMsg ++ "> ",
1447                               session  = s,
1448                               options  = [],
1449                               bkptTable= ref_bkptTable,
1450                               prelude  = prel_mod,
1451                               topLevel = False }
1452              `catchDyn` (
1453                  \StopChildSession -> evaluate$
1454                      throwDyn (ChildSessionStopped "You may need to reload your modules")
1455            ) `finally` do
1456              writeIORef ref hsc_env
1457              putStrLn $ "Returning to normal execution..."
1458          return b
1459   where
1460      printScopeMsg :: String -> [Id] -> IO ()
1461      printScopeMsg location ids = do
1462        unqual  <- GHC.getPrintUnqual s
1463        printForUser stdout unqual $
1464          text "Local bindings in scope:" $$
1465          nest 2 (pprWithCommas showId ids)
1466       where
1467            showId id =
1468                 ppr (idName id) <+> dcolon <+> ppr (idType id)
1469
1470 -- | Give the Id a Global Name, and tidy its type
1471      globaliseAndTidy :: Id -> Id
1472      globaliseAndTidy id
1473       = let tidied_type = tidyTopType$ idType id
1474         in setIdType (globaliseId VanillaGlobal id) tidied_type
1475
1476 -- | Instantiate the tyVars with GHC.Base.Unknown
1477      instantiateIdType :: Id -> IO Id
1478      instantiateIdType id = do
1479        instantiatedType <- instantiateTyVarsToUnknown s (idType id)
1480        return$ setIdType id instantiatedType
1481
1482