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