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