compiler/ghci/InteractiveUI.hs

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