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