compiler/ghci/InteractiveUI.hs

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