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 Nothing
 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   refreshBkptTable graph'
 783   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 784
 785 setContextAfterLoad session [] = do
 786   prel_mod <- getPrelude
 787   io (GHC.setContext session [] [prel_mod])
 788 setContextAfterLoad session ms = do
 789   -- load a target if one is available, otherwise load the topmost module.
 790   targets <- io (GHC.getTargets session)
 791   case [ m | Just m <- map (findTarget ms) targets ] of
 792         []    ->
 793           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 794           load_this (last graph')
 795         (m:_) ->
 796           load_this m
 797  where
 798    findTarget ms t
 799     = case filter (`matches` t) ms of
 800         []    -> Nothing
 801         (m:_) -> Just m
 802
 803    summary `matches` Target (TargetModule m) _
 804         = GHC.ms_mod_name summary == m
 805    summary `matches` Target (TargetFile f _) _
 806         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 807    summary `matches` target
 808         = False
 809
 810    load_this summary | m <- GHC.ms_mod summary = do
 811         b <- io (GHC.moduleIsInterpreted session m)
 812         if b then io (GHC.setContext session [m] [])
 813              else do
 814                    prel_mod <- getPrelude
 815                    io (GHC.setContext session []  [prel_mod,m])
 816
 817
 818 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 819 modulesLoadedMsg ok mods = do
 820   dflags <- getDynFlags
 821   when (verbosity dflags > 0) $ do
 822    let mod_commas
 823         | null mods = text "none."
 824         | otherwise = hsep (
 825             punctuate comma (map ppr mods)) <> text "."
 826    case ok of
 827     Failed ->
 828        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 829     Succeeded  ->
 830        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 831
 832
 833 typeOfExpr :: String -> GHCi ()
 834 typeOfExpr str
 835   = do cms <- getSession
 836        maybe_ty <- io (GHC.exprType cms str)
 837        case maybe_ty of
 838           Nothing -> return ()
 839           Just ty -> do ty' <- cleanType ty
 840                         tystr <- showForUser (ppr ty')
 841                         io (putStrLn (str ++ " :: " ++ tystr))
 842
 843 kindOfType :: String -> GHCi ()
 844 kindOfType str
 845   = do cms <- getSession
 846        maybe_ty <- io (GHC.typeKind cms str)
 847        case maybe_ty of
 848           Nothing    -> return ()
 849           Just ty    -> do tystr <- showForUser (ppr ty)
 850                            io (putStrLn (str ++ " :: " ++ tystr))
 851
 852 quit :: String -> GHCi Bool
 853 quit _ =  do in_inferior_session <- liftM not isTopLevel
 854              if in_inferior_session
 855                then throwDyn StopParentSession
 856                else return True
 857
 858
 859 shellEscape :: String -> GHCi Bool
 860 shellEscape str = io (system str >> return False)
 861
 862 -----------------------------------------------------------------------------
 863 -- create tags file for currently loaded modules.
 864
 865 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 866
 867 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 868 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 869
 870 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 871 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 872
 873 data TagsKind = ETags | CTags
 874
 875 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 876 ghciCreateTagsFile kind file = do
 877   session <- getSession
 878   io $ createTagsFile session kind file
 879
 880 -- ToDo:
 881 --      - remove restriction that all modules must be interpreted
 882 --        (problem: we don't know source locations for entities unless
 883 --        we compiled the module.
 884 --
 885 --      - extract createTagsFile so it can be used from the command-line
 886 --        (probably need to fix first problem before this is useful).
 887 --
 888 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 889 createTagsFile session tagskind tagFile = do
 890   graph <- GHC.getModuleGraph session
 891   let ms = map GHC.ms_mod graph
 892       tagModule m = do
 893         is_interpreted <- GHC.moduleIsInterpreted session m
 894         -- should we just skip these?
 895         when (not is_interpreted) $
 896           throwDyn (CmdLineError ("module '"
 897                                 ++ GHC.moduleNameString (GHC.moduleName m)
 898                                 ++ "' is not interpreted"))
 899         mbModInfo <- GHC.getModuleInfo session m
 900         let unqual
 901               | Just modinfo <- mbModInfo,
 902                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 903               | otherwise = GHC.alwaysQualify
 904
 905         case mbModInfo of
 906           Just modInfo -> return $! listTags unqual modInfo
 907           _            -> return []
 908
 909   mtags <- mapM tagModule ms
 910   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 911   case either_res of
 912     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 913     Right _ -> return ()
 914
 915 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 916 listTags unqual modInfo =
 917            [ tagInfo unqual name loc
 918            | name <- GHC.modInfoExports modInfo
 919            , let loc = nameSrcLoc name
 920            , isGoodSrcLoc loc
 921            ]
 922
 923 type TagInfo = (String -- tag name
 924                ,String -- file name
 925                ,Int    -- line number
 926                ,Int    -- column number
 927                )
 928
 929 -- get tag info, for later translation into Vim or Emacs style
 930 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 931 tagInfo unqual name loc
 932     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 933       , showSDocForUser unqual $ ftext (srcLocFile loc)
 934       , srcLocLine loc
 935       , srcLocCol loc
 936       )
 937
 938 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 939 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 940   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 941   IO.try (writeFile file tags)
 942 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 943   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 944       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 945   tagGroups <- mapM tagFileGroup groups
 946   IO.try (writeFile file $ concat tagGroups)
 947   where
 948     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
 949     tagFileGroup group@((_,fileName,_,_):_) = do
 950       file <- readFile fileName -- need to get additional info from sources..
 951       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 952           sortedGroup = sortLe byLine group
 953           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 954       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 955     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
 956       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 957     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
 958       showETag tagInfo line pos : perFile tags count pos lines
 959     perFile tags count pos lines = []
 960
 961 -- simple ctags format, for Vim et al
 962 showTag :: TagInfo -> String
 963 showTag (tag,file,lineNo,colNo)
 964     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 965
 966 -- etags format, for Emacs/XEmacs
 967 showETag :: TagInfo -> String -> Int -> String
 968 showETag (tag,file,lineNo,colNo) line charPos
 969     =  take colNo line ++ tag
 970     ++ "\x7f" ++ tag
 971     ++ "\x01" ++ show lineNo
 972     ++ "," ++ show charPos
 973
 974 -----------------------------------------------------------------------------
 975 -- Browsing a module's contents
 976
 977 browseCmd :: String -> GHCi ()
 978 browseCmd m =
 979   case words m of
 980     ['*':m] | looksLikeModuleName m -> browseModule m False
 981     [m]     | looksLikeModuleName m -> browseModule m True
 982     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 983
 984 browseModule m exports_only = do
 985   s <- getSession
 986   modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
 987   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
 988   when (not is_interpreted && not exports_only) $
 989         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 990
 991   -- Temporarily set the context to the module we're interested in,
 992   -- just so we can get an appropriate PrintUnqualified
 993   (as,bs) <- io (GHC.getContext s)
 994   prel_mod <- getPrelude
 995   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 996                       else GHC.setContext s [modl] [])
 997   unqual <- io (GHC.getPrintUnqual s)
 998   io (GHC.setContext s as bs)
 999
1000   mb_mod_info <- io $ GHC.getModuleInfo s modl
1001   case mb_mod_info of
1002     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1003     Just mod_info -> do
1004         let names
1005                | exports_only = GHC.modInfoExports mod_info
1006                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1007
1008             filtered = filterOutChildren names
1009
1010         things <- io $ mapM (GHC.lookupName s) filtered
1011
1012         dflags <- getDynFlags
1013         let exts = dopt Opt_GlasgowExts dflags
1014         io (putStrLn (showSDocForUser unqual (
1015                 vcat (map (pprTyThingInContext exts) (catMaybes things))
1016            )))
1017         -- ToDo: modInfoInstances currently throws an exception for
1018         -- package modules.  When it works, we can do this:
1019         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1020
1021 -----------------------------------------------------------------------------
1022 -- Setting the module context
1023
1024 setContext str
1025   | all sensible mods = fn mods
1026   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1027   where
1028     (fn, mods) = case str of
1029                         '+':stuff -> (addToContext,      words stuff)
1030                         '-':stuff -> (removeFromContext, words stuff)
1031                         stuff     -> (newContext,        words stuff)
1032
1033     sensible ('*':m) = looksLikeModuleName m
1034     sensible m       = looksLikeModuleName m
1035
1036 separate :: Session -> [String] -> [Module] -> [Module]
1037         -> GHCi ([Module],[Module])
1038 separate session []           as bs = return (as,bs)
1039 separate session (('*':str):ms) as bs = do
1040    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1041    b <- io $ GHC.moduleIsInterpreted session m
1042    if b then separate session ms (m:as) bs
1043         else throwDyn (CmdLineError ("module '"
1044                         ++ GHC.moduleNameString (GHC.moduleName m)
1045                         ++ "' is not interpreted"))
1046 separate session (str:ms) as bs = do
1047   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1048   separate session ms as (m:bs)
1049
1050 newContext :: [String] -> GHCi ()
1051 newContext strs = do
1052   s <- getSession
1053   (as,bs) <- separate s strs [] []
1054   prel_mod <- getPrelude
1055   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1056   io $ GHC.setContext s as bs'
1057
1058
1059 addToContext :: [String] -> GHCi ()
1060 addToContext strs = do
1061   s <- getSession
1062   (as,bs) <- io $ GHC.getContext s
1063
1064   (new_as,new_bs) <- separate s strs [] []
1065
1066   let as_to_add = new_as \\ (as ++ bs)
1067       bs_to_add = new_bs \\ (as ++ bs)
1068
1069   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1070
1071
1072 removeFromContext :: [String] -> GHCi ()
1073 removeFromContext strs = do
1074   s <- getSession
1075   (as,bs) <- io $ GHC.getContext s
1076
1077   (as_to_remove,bs_to_remove) <- separate s strs [] []
1078
1079   let as' = as \\ (as_to_remove ++ bs_to_remove)
1080       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1081
1082   io $ GHC.setContext s as' bs'
1083
1084 ----------------------------------------------------------------------------
1085 -- Code for `:set'
1086
1087 -- set options in the interpreter.  Syntax is exactly the same as the
1088 -- ghc command line, except that certain options aren't available (-C,
1089 -- -E etc.)
1090 --
1091 -- This is pretty fragile: most options won't work as expected.  ToDo:
1092 -- figure out which ones & disallow them.
1093
1094 setCmd :: String -> GHCi ()
1095 setCmd ""
1096   = do st <- getGHCiState
1097        let opts = options st
1098        io $ putStrLn (showSDoc (
1099               text "options currently set: " <>
1100               if null opts
1101                    then text "none."
1102                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1103            ))
1104 setCmd str
1105   = case toArgs str of
1106         ("args":args) -> setArgs args
1107         ("prog":prog) -> setProg prog
1108         ("prompt":prompt) -> setPrompt (after 6)
1109         ("editor":cmd) -> setEditor (after 6)
1110         wds -> setOptions wds
1111    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1112
1113 setArgs args = do
1114   st <- getGHCiState
1115   setGHCiState st{ args = args }
1116
1117 setProg [prog] = do
1118   st <- getGHCiState
1119   setGHCiState st{ progname = prog }
1120 setProg _ = do
1121   io (hPutStrLn stderr "syntax: :set prog <progname>")
1122
1123 setEditor cmd = do
1124   st <- getGHCiState
1125   setGHCiState st{ editor = cmd }
1126
1127 setPrompt value = do
1128   st <- getGHCiState
1129   if null value
1130       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1131       else setGHCiState st{ prompt = remQuotes value }
1132   where
1133      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1134      remQuotes x = x
1135
1136 setOptions wds =
1137    do -- first, deal with the GHCi opts (+s, +t, etc.)
1138       let (plus_opts, minus_opts)  = partition isPlus wds
1139       mapM_ setOpt plus_opts
1140
1141       -- then, dynamic flags
1142       dflags <- getDynFlags
1143       let pkg_flags = packageFlags dflags
1144       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1145
1146       if (not (null leftovers))
1147                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1148                                                 unwords leftovers))
1149                 else return ()
1150
1151       new_pkgs <- setDynFlags dflags'
1152
1153       -- if the package flags changed, we should reset the context
1154       -- and link the new packages.
1155       dflags <- getDynFlags
1156       when (packageFlags dflags /= pkg_flags) $ do
1157         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1158         session <- getSession
1159         io (GHC.setTargets session [])
1160         io (GHC.load session LoadAllTargets)
1161         io (linkPackages dflags new_pkgs)
1162         setContextAfterLoad session []
1163       return ()
1164
1165
1166 unsetOptions :: String -> GHCi ()
1167 unsetOptions str
1168   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1169        let opts = words str
1170            (minus_opts, rest1) = partition isMinus opts
1171            (plus_opts, rest2)  = partition isPlus rest1
1172
1173        if (not (null rest2))
1174           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1175           else do
1176
1177        mapM_ unsetOpt plus_opts
1178
1179        -- can't do GHC flags for now
1180        if (not (null minus_opts))
1181           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1182           else return ()
1183
1184 isMinus ('-':s) = True
1185 isMinus _ = False
1186
1187 isPlus ('+':s) = True
1188 isPlus _ = False
1189
1190 setOpt ('+':str)
1191   = case strToGHCiOpt str of
1192         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1193         Just o  -> setOption o
1194
1195 unsetOpt ('+':str)
1196   = case strToGHCiOpt str of
1197         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1198         Just o  -> unsetOption o
1199
1200 strToGHCiOpt :: String -> (Maybe GHCiOption)
1201 strToGHCiOpt "s" = Just ShowTiming
1202 strToGHCiOpt "t" = Just ShowType
1203 strToGHCiOpt "r" = Just RevertCAFs
1204 strToGHCiOpt _   = Nothing
1205
1206 optToStr :: GHCiOption -> String
1207 optToStr ShowTiming = "s"
1208 optToStr ShowType   = "t"
1209 optToStr RevertCAFs = "r"
1210
1211 -- ---------------------------------------------------------------------------
1212 -- code for `:show'
1213
1214 showCmd str =
1215   case words str of
1216         ["modules" ] -> showModules
1217         ["bindings"] -> showBindings
1218         ["linker"]   -> io showLinkerState
1219         ["breakpoints"] -> showBkptTable
1220         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1221
1222 showModules = do
1223   session <- getSession
1224   let show_one ms = do m <- io (GHC.showModule session ms)
1225                        io (putStrLn m)
1226   graph <- io (GHC.getModuleGraph session)
1227   mapM_ show_one graph
1228
1229 showBindings = do
1230   s <- getSession
1231   unqual <- io (GHC.getPrintUnqual s)
1232   bindings <- io (GHC.getBindings s)
1233   mapM_ showTyThing bindings
1234   return ()
1235
1236 showTyThing (AnId id) = do
1237   ty' <- cleanType (GHC.idType id)
1238   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1239   io (putStrLn str)
1240 showTyThing _  = return ()
1241
1242 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1243 cleanType :: Type -> GHCi Type
1244 cleanType ty = do
1245   dflags <- getDynFlags
1246   if dopt Opt_GlasgowExts dflags
1247         then return ty
1248         else return $! GHC.dropForAlls ty
1249
1250 showBkptTable :: GHCi ()
1251 showBkptTable = do
1252   bt     <- getBkptTable
1253   msg <- showForUser . vcat $
1254              [ ppr mod <> colon <+> fcat
1255                        [ parens(int row <> comma <> int col) | (row,col) <- sites]
1256                | (mod, sites) <-  sitesList bt ]
1257   io (putStrLn msg)
1258 -- -----------------------------------------------------------------------------
1259 -- Completion
1260
1261 completeNone :: String -> IO [String]
1262 completeNone w = return []
1263
1264 #ifdef USE_READLINE
1265 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1266 completeWord w start end = do
1267   line <- Readline.getLineBuffer
1268   case w of
1269      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1270      _other
1271         | Just c <- is_cmd line -> do
1272            maybe_cmd <- lookupCommand c
1273            let (n,w') = selectWord (words' 0 line)
1274            case maybe_cmd of
1275              Nothing -> return Nothing
1276              Just (_,_,False,complete) -> wrapCompleter complete w
1277              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1278                                                               return (map (drop n) rets)
1279                                          in wrapCompleter complete' w'
1280         | otherwise     -> do
1281                 --printf "complete %s, start = %d, end = %d\n" w start end
1282                 wrapCompleter completeIdentifier w
1283     where words' _ [] = []
1284           words' n str = let (w,r) = break isSpace str
1285                              (s,r') = span isSpace r
1286                          in (n,w):words' (n+length w+length s) r'
1287           -- In a Haskell expression we want to parse 'a-b' as three words
1288           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1289           -- only be a single word.
1290           selectWord [] = (0,w)
1291           selectWord ((offset,x):xs)
1292               | offset+length x >= start = (start-offset,take (end-offset) x)
1293               | otherwise = selectWord xs
1294
1295 is_cmd line
1296  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1297  | otherwise = Nothing
1298
1299 completeCmd w = do
1300   cmds <- readIORef commands
1301   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1302
1303 completeMacro w = do
1304   cmds <- readIORef commands
1305   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1306   return (filter (w `isPrefixOf`) cmds')
1307
1308 completeIdentifier w = do
1309   s <- restoreSession
1310   rdrs <- GHC.getRdrNamesInScope s
1311   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1312
1313 completeModule w = do
1314   s <- restoreSession
1315   dflags <- GHC.getSessionDynFlags s
1316   let pkg_mods = allExposedModules dflags
1317   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1318
1319 completeHomeModule w = do
1320   s <- restoreSession
1321   g <- GHC.getModuleGraph s
1322   let home_mods = map GHC.ms_mod_name g
1323   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1324
1325 completeSetOptions w = do
1326   return (filter (w `isPrefixOf`) options)
1327     where options = "args":"prog":allFlags
1328
1329 completeBkpt = unionComplete completeModule completeBkptCmds
1330
1331 completeBkptCmds w = do
1332   return (filter (w `isPrefixOf`) options)
1333     where options = ["add","del","list","stop"]
1334
1335 completeFilename = Readline.filenameCompletionFunction
1336
1337 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1338
1339 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1340 unionComplete f1 f2 w = do
1341   s1 <- f1 w
1342   s2 <- f2 w
1343   return (s1 ++ s2)
1344
1345 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1346 wrapCompleter fun w =  do
1347   strs <- fun w
1348   case strs of
1349     []  -> return Nothing
1350     [x] -> return (Just (x,[]))
1351     xs  -> case getCommonPrefix xs of
1352                 ""   -> return (Just ("",xs))
1353                 pref -> return (Just (pref,xs))
1354
1355 getCommonPrefix :: [String] -> String
1356 getCommonPrefix [] = ""
1357 getCommonPrefix (s:ss) = foldl common s ss
1358   where common s "" = s
1359         common "" s = ""
1360         common (c:cs) (d:ds)
1361            | c == d = c : common cs ds
1362            | otherwise = ""
1363
1364 allExposedModules :: DynFlags -> [ModuleName]
1365 allExposedModules dflags
1366  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1367  where
1368   pkg_db = pkgIdMap (pkgState dflags)
1369 #else
1370 completeCmd        = completeNone
1371 completeMacro      = completeNone
1372 completeIdentifier = completeNone
1373 completeModule     = completeNone
1374 completeHomeModule = completeNone
1375 completeSetOptions = completeNone
1376 completeFilename   = completeNone
1377 completeHomeModuleOrFile=completeNone
1378 completeBkpt       = completeNone
1379 #endif
1380
1381 -- ---------------------------------------------------------------------------
1382 -- User code exception handling
1383
1384 -- This is the exception handler for exceptions generated by the
1385 -- user's code and exceptions coming from children sessions;
1386 -- it normally just prints out the exception.  The
1387 -- handler must be recursive, in case showing the exception causes
1388 -- more exceptions to be raised.
1389 --
1390 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1391 -- raising another exception.  We therefore don't put the recursive
1392 -- handler arond the flushing operation, so if stderr is closed
1393 -- GHCi will just die gracefully rather than going into an infinite loop.
1394 handler :: Exception -> GHCi Bool
1395 handler (DynException dyn)
1396   | Just StopChildSession <- fromDynamic dyn
1397      -- propagate to the parent session
1398   = do ASSERTM (liftM not isTopLevel)
1399        throwDyn StopChildSession
1400
1401   | Just StopParentSession <- fromDynamic dyn
1402   = do at_topLevel <-  isTopLevel
1403        if at_topLevel then return True else throwDyn StopParentSession
1404
1405   | Just (ChildSessionStopped msg) <- fromDynamic dyn
1406   = io(putStrLn msg) >> return False
1407
1408 handler exception = do
1409   flushInterpBuffers
1410   io installSignalHandlers
1411   ghciHandle handler (showException exception >> return False)
1412
1413 showException (DynException dyn) =
1414   case fromDynamic dyn of
1415     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1416     Just Interrupted      -> io (putStrLn "Interrupted.")
1417     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1418     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1419     Just other_ghc_ex     -> io (print other_ghc_ex)
1420
1421 showException other_exception
1422   = io (putStrLn ("*** Exception: " ++ show other_exception))
1423
1424 -----------------------------------------------------------------------------
1425 -- recursive exception handlers
1426
1427 -- Don't forget to unblock async exceptions in the handler, or if we're
1428 -- in an exception loop (eg. let a = error a in a) the ^C exception
1429 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1430
1431 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1432 ghciHandle h (GHCi m) = GHCi $ \s ->
1433    Exception.catch (m s)
1434         (\e -> unGHCi (ghciUnblock (h e)) s)
1435
1436 ghciUnblock :: GHCi a -> GHCi a
1437 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1438
1439
1440 -- ----------------------------------------------------------------------------
1441 -- Utils
1442
1443 expandPath :: String -> GHCi String
1444 expandPath path =
1445   case dropWhile isSpace path of
1446    ('~':d) -> do
1447         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1448         return (tilde ++ '/':d)
1449    other ->
1450         return other
1451
1452 -- ----------------------------------------------------------------------------
1453 -- Windows console setup
1454
1455 setUpConsole :: IO ()
1456 setUpConsole = do
1457 #ifdef mingw32_HOST_OS
1458         -- On Windows we need to set a known code page, otherwise the characters
1459         -- we read from the console will be be in some strange encoding, and
1460         -- similarly for characters we write to the console.
1461         --
1462         -- At the moment, GHCi pretends all input is Latin-1.  In the
1463         -- future we should support UTF-8, but for now we set the code pages
1464         -- to Latin-1.
1465         --
1466         -- It seems you have to set the font in the console window to
1467         -- a Unicode font in order for output to work properly,
1468         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1469         -- (see MSDN for SetConsoleOutputCP()).
1470         --
1471         setConsoleCP 28591       -- ISO Latin-1
1472         setConsoleOutputCP 28591 -- ISO Latin-1
1473 #endif
1474         return ()
1475
1476
1477 instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
1478 instrumentationBkptHandler ref_bkptTable = BkptHandler {
1479     isAutoBkptEnabled = \sess bkptLoc -> do
1480       bktpTable <- readIORef ref_bkptTable
1481       return$ isBkptEnabled bktpTable bkptLoc
1482
1483   , handleBreakpoint = doBreakpoint ref_bkptTable
1484   }
1485
1486 doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
1487 doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
1488          let (ids, hValues) = unzip values
1489              names = map idName ids
1490          ASSERT (length names == length hValues) return ()
1491          let global_ids = map globaliseAndTidy ids
1492          printScopeMsg locMsg global_ids
1493          typed_ids  <- mapM instantiateIdType global_ids
1494          hsc_env <- readIORef ref
1495          let ictxt = hsc_IC hsc_env
1496              rn_env   = ic_rn_local_env ictxt
1497              type_env = ic_type_env ictxt
1498              bound_names = map idName typed_ids
1499              new_rn_env  = extendLocalRdrEnv rn_env bound_names
1500                 -- Remove any shadowed bindings from the type_env;
1501                 -- they are inaccessible but might, I suppose, cause
1502                 -- a space leak if we leave them there
1503              shadowed = [ n | name <- bound_names,
1504                           let rdr_name = mkRdrUnqual (nameOccName name),
1505                           Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
1506              filtered_type_env = delListFromNameEnv type_env shadowed
1507              new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
1508              new_ic = ictxt { ic_rn_local_env = new_rn_env,
1509                               ic_type_env     = new_type_env }
1510          writeIORef ref (hsc_env { hsc_IC = new_ic })
1511          is_tty <- hIsTerminalDevice stdin
1512          prel_mod <- GHC.findModule s prel_name Nothing
1513          withExtendedLinkEnv (zip names hValues) $
1514            startGHCi (interactiveLoop is_tty True) GHCiState{
1515                               progname = "<interactive>",
1516                               args     = [],
1517                               prompt   = locMsg ++ "> ",
1518                               session  = s,
1519                               options  = [],
1520                               bkptTable= ref_bkptTable,
1521                               prelude  = prel_mod,
1522                               topLevel = False }
1523              `catchDyn` (\e -> case e of
1524                            StopChildSession -> evaluate$
1525                                                throwDyn (ChildSessionStopped "")
1526                            StopParentSession -> throwDyn StopParentSession
1527            ) `finally` do
1528              writeIORef ref hsc_env
1529              putStrLn $ "Returning to normal execution..."
1530          return b
1531   where
1532      printScopeMsg :: String -> [Id] -> IO ()
1533      printScopeMsg location ids = do
1534        unqual  <- GHC.getPrintUnqual s
1535        printForUser stdout unqual $
1536          text "Stopped at a breakpoint in " <> text (stripColumn location) <>
1537          char '.' <+> text "Local bindings in scope:" $$
1538          nest 2 (pprWithCommas showId ids)
1539       where
1540            showId id =
1541                 ppr (idName id) <+> dcolon <+> ppr (idType id)
1542            stripColumn = reverse . tail . dropWhile (/= ':') . reverse
1543
1544 -- | Give the Id a Global Name, and tidy its type
1545      globaliseAndTidy :: Id -> Id
1546      globaliseAndTidy id
1547       = let tidied_type = tidyTopType$ idType id
1548         in setIdType (globaliseId VanillaGlobal id) tidied_type
1549
1550 -- | Instantiate the tyVars with GHC.Base.Unknown
1551      instantiateIdType :: Id -> IO Id
1552      instantiateIdType id = do
1553        instantiatedType <- instantiateTyVarsToUnknown s (idType id)
1554        return$ setIdType id instantiatedType
1555
1556