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