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(..),
  19                           mkModule, pprModule, Type, Module, SuccessFlag(..),
  20                           TyThing(..), Name, LoadHowMuch(..),
  21                           GhcException(..), showGhcException )
  22 import Outputable
  23
  24 -- following all needed for :info... ToDo: remove
  25 import IfaceSyn         ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
  26                           IfaceConDecl(..), IfaceType,
  27                           pprIfaceDeclHead, pprParendIfaceType,
  28                           pprIfaceForAllPart, pprIfaceType )
  29 import FunDeps          ( pprFundeps )
  30 import SrcLoc           ( SrcLoc, pprDefnLoc )
  31 import OccName          ( OccName, parenSymOcc, occNameUserString )
  32 import BasicTypes       ( StrictnessMark(..), defaultFixity )
  33
  34 -- Other random utilities
  35 import Panic            ( panic, installSignalHandlers )
  36 import Config
  37 import StaticFlags      ( opt_IgnoreDotGhci )
  38 import Linker           ( showLinkerState )
  39 import Util             ( removeSpaces, handle, global, toArgs,
  40                           looksLikeModuleName, prefixMatch )
  41
  42 #ifndef mingw32_HOST_OS
  43 import Util             ( handle )
  44 import System.Posix
  45 #if __GLASGOW_HASKELL__ > 504
  46         hiding (getEnv)
  47 #endif
  48 #else
  49 import GHC.ConsoleHandler ( flushConsole )
  50 #endif
  51
  52 #ifdef USE_READLINE
  53 import Control.Concurrent       ( yield )       -- Used in readline loop
  54 import System.Console.Readline as Readline
  55 #endif
  56
  57 --import SystemExts
  58
  59 import Control.Exception as Exception
  60 import Data.Dynamic
  61 -- import Control.Concurrent
  62
  63 import Numeric
  64 import Data.List
  65 import Data.Int         ( Int64 )
  66 import System.Cmd
  67 import System.CPUTime
  68 import System.Environment
  69 import System.Exit      ( exitWith, ExitCode(..) )
  70 import System.Directory
  71 import System.IO
  72 import System.IO.Error as IO
  73 import Data.Char
  74 import Control.Monad as Monad
  75 import Foreign.StablePtr        ( newStablePtr )
  76
  77 import GHC.Exts         ( unsafeCoerce# )
  78 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  79
  80 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  81
  82 import System.Posix.Internals ( setNonBlockingFD )
  83
  84 -----------------------------------------------------------------------------
  85
  86 ghciWelcomeMsg =
  87  "   ___         ___ _\n"++
  88  "  / _ \\ /\\  /\\/ __(_)\n"++
  89  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
  90  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
  91  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  92
  93 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  94
  95 builtin_commands :: [(String, String -> GHCi Bool)]
  96 builtin_commands = [
  97   ("add",       keepGoingPaths addModule),
  98   ("browse",    keepGoing browseCmd),
  99   ("cd",        keepGoing changeDirectory),
 100   ("def",       keepGoing defineMacro),
 101   ("help",      keepGoing help),
 102   ("?",         keepGoing help),
 103   ("info",      keepGoing info),
 104   ("load",      keepGoingPaths loadModule),
 105   ("module",    keepGoing setContext),
 106   ("reload",    keepGoing reloadModule),
 107   ("set",       keepGoing setCmd),
 108   ("show",      keepGoing showCmd),
 109   ("type",      keepGoing typeOfExpr),
 110   ("kind",      keepGoing kindOfType),
 111   ("unset",     keepGoing unsetOptions),
 112   ("undef",     keepGoing undefineMacro),
 113   ("quit",      quit)
 114   ]
 115
 116 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 117 keepGoing a str = a str >> return False
 118
 119 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 120 keepGoingPaths a str = a (toArgs str) >> return False
 121
 122 shortHelpText = "use :? for help.\n"
 123
 124 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 125 helpText =
 126  " Commands available from the prompt:\n" ++
 127  "\n" ++
 128  "   <stmt>                      evaluate/run <stmt>\n" ++
 129  "   :add <filename> ...         add module(s) to the current target set\n" ++
 130  "   :browse [*]<module>         display the names defined by <module>\n" ++
 131  "   :cd <dir>                   change directory to <dir>\n" ++
 132  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 133  "   :help, :?                   display this list of commands\n" ++
 134  "   :info [<name> ...]          display information about the given names\n" ++
 135  "   :load <filename> ...        load module(s) and their dependents\n" ++
 136  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 137  "   :reload                     reload the current module set\n" ++
 138  "\n" ++
 139  "   :set <option> ...           set options\n" ++
 140  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 141  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 142  "\n" ++
 143  "   :show modules               show the currently loaded modules\n" ++
 144  "   :show bindings              show the current bindings made at the prompt\n" ++
 145  "\n" ++
 146  "   :type <expr>                show the type of <expr>\n" ++
 147  "   :kind <type>                show the kind of <type>\n" ++
 148  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 149  "   :unset <option> ...         unset options\n" ++
 150  "   :quit                       exit GHCi\n" ++
 151  "   :!<command>                 run the shell command <command>\n" ++
 152  "\n" ++
 153  " Options for ':set' and ':unset':\n" ++
 154  "\n" ++
 155  "    +r            revert top-level expressions after each evaluation\n" ++
 156  "    +s            print timing/memory stats after each evaluation\n" ++
 157  "    +t            print type after evaluation\n" ++
 158  "    -<flags>      most GHC command line flags can also be set here\n" ++
 159  "                         (eg. -v2, -fglasgow-exts, etc.)\n"
 160
 161
 162 interactiveUI :: Session -> [FilePath] -> Maybe String -> IO ()
 163 interactiveUI session srcs maybe_expr = do
 164
 165    -- HACK! If we happen to get into an infinite loop (eg the user
 166    -- types 'let x=x in x' at the prompt), then the thread will block
 167    -- on a blackhole, and become unreachable during GC.  The GC will
 168    -- detect that it is unreachable and send it the NonTermination
 169    -- exception.  However, since the thread is unreachable, everything
 170    -- it refers to might be finalized, including the standard Handles.
 171    -- This sounds like a bug, but we don't have a good solution right
 172    -- now.
 173    newStablePtr stdin
 174    newStablePtr stdout
 175    newStablePtr stderr
 176
 177    hFlush stdout
 178    hSetBuffering stdout NoBuffering
 179
 180         -- Initialise buffering for the *interpreted* I/O system
 181    initInterpBuffering session
 182
 183         -- We don't want the cmd line to buffer any input that might be
 184         -- intended for the program, so unbuffer stdin.
 185    hSetBuffering stdin NoBuffering
 186
 187         -- initial context is just the Prelude
 188    GHC.setContext session [] [prelude_mod]
 189
 190 #ifdef USE_READLINE
 191    Readline.initialize
 192 #endif
 193
 194 #if defined(mingw32_HOST_OS)
 195     -- The win32 Console API mutates the first character of
 196     -- type-ahead when reading from it in a non-buffered manner. Work
 197     -- around this by flushing the input buffer of type-ahead characters.
 198     --
 199    GHC.ConsoleHandler.flushConsole stdin
 200 #endif
 201    startGHCi (runGHCi srcs maybe_expr)
 202         GHCiState{ progname = "<interactive>",
 203                    args = [],
 204                    session = session,
 205                    options = [] }
 206
 207 #ifdef USE_READLINE
 208    Readline.resetTerminal Nothing
 209 #endif
 210
 211    return ()
 212
 213 runGHCi :: [FilePath] -> Maybe String -> GHCi ()
 214 runGHCi paths maybe_expr = do
 215   let read_dot_files = not opt_IgnoreDotGhci
 216
 217   when (read_dot_files) $ do
 218     -- Read in ./.ghci.
 219     let file = "./.ghci"
 220     exists <- io (doesFileExist file)
 221     when exists $ do
 222        dir_ok  <- io (checkPerms ".")
 223        file_ok <- io (checkPerms file)
 224        when (dir_ok && file_ok) $ do
 225           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 226           case either_hdl of
 227              Left e    -> return ()
 228              Right hdl -> fileLoop hdl False
 229
 230   when (read_dot_files) $ do
 231     -- Read in $HOME/.ghci
 232     either_dir <- io (IO.try (getEnv "HOME"))
 233     case either_dir of
 234        Left e -> return ()
 235        Right dir -> do
 236           cwd <- io (getCurrentDirectory)
 237           when (dir /= cwd) $ do
 238              let file = dir ++ "/.ghci"
 239              ok <- io (checkPerms file)
 240              when ok $ do
 241                either_hdl <- io (IO.try (openFile file ReadMode))
 242                case either_hdl of
 243                   Left e    -> return ()
 244                   Right hdl -> fileLoop hdl False
 245
 246   -- Perform a :load for files given on the GHCi command line
 247   when (not (null paths)) $
 248      ghciHandle showException $
 249         loadModule paths
 250
 251   -- if verbosity is greater than 0, or we are connected to a
 252   -- terminal, display the prompt in the interactive loop.
 253   is_tty <- io (hIsTerminalDevice stdin)
 254   dflags <- getDynFlags
 255   let show_prompt = verbosity dflags > 0 || is_tty
 256
 257   case maybe_expr of
 258         Nothing ->
 259             -- enter the interactive loop
 260             interactiveLoop is_tty show_prompt
 261         Just expr -> do
 262             -- just evaluate the expression we were given
 263             runCommandEval expr
 264             return ()
 265
 266   -- and finally, exit
 267   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 268
 269
 270 interactiveLoop is_tty show_prompt = do
 271   -- Ignore ^C exceptions caught here
 272   ghciHandleDyn (\e -> case e of
 273                         Interrupted -> ghciUnblock (
 274 #if defined(mingw32_HOST_OS)
 275                                                 io (putStrLn "") >>
 276 #endif
 277                                                 interactiveLoop is_tty show_prompt)
 278                         _other      -> return ()) $ do
 279
 280   -- read commands from stdin
 281 #ifdef USE_READLINE
 282   if (is_tty)
 283         then readlineLoop
 284         else fileLoop stdin show_prompt
 285 #else
 286   fileLoop stdin show_prompt
 287 #endif
 288
 289
 290 -- NOTE: We only read .ghci files if they are owned by the current user,
 291 -- and aren't world writable.  Otherwise, we could be accidentally
 292 -- running code planted by a malicious third party.
 293
 294 -- Furthermore, We only read ./.ghci if . is owned by the current user
 295 -- and isn't writable by anyone else.  I think this is sufficient: we
 296 -- don't need to check .. and ../.. etc. because "."  always refers to
 297 -- the same directory while a process is running.
 298
 299 checkPerms :: String -> IO Bool
 300 checkPerms name =
 301 #ifdef mingw32_HOST_OS
 302   return True
 303 #else
 304   Util.handle (\_ -> return False) $ do
 305      st <- getFileStatus name
 306      me <- getRealUserID
 307      if fileOwner st /= me then do
 308         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 309         return False
 310       else do
 311         let mode =  fileMode st
 312         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 313            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 314            then do
 315                putStrLn $ "*** WARNING: " ++ name ++
 316                           " is writable by someone else, IGNORING!"
 317                return False
 318           else return True
 319 #endif
 320
 321 fileLoop :: Handle -> Bool -> GHCi ()
 322 fileLoop hdl prompt = do
 323    session <- getSession
 324    (mod,imports) <- io (GHC.getContext session)
 325    when prompt (io (putStr (mkPrompt mod imports)))
 326    l <- io (IO.try (hGetLine hdl))
 327    case l of
 328         Left e | isEOFError e              -> return ()
 329                | InvalidArgument <- etype  -> return ()
 330                | otherwise                 -> io (ioError e)
 331                 where etype = ioeGetErrorType e
 332                 -- treat InvalidArgument in the same way as EOF:
 333                 -- this can happen if the user closed stdin, or
 334                 -- perhaps did getContents which closes stdin at
 335                 -- EOF.
 336         Right l ->
 337           case removeSpaces l of
 338             "" -> fileLoop hdl prompt
 339             l  -> do quit <- runCommand l
 340                      if quit then return () else fileLoop hdl prompt
 341
 342 stringLoop :: [String] -> GHCi ()
 343 stringLoop [] = return ()
 344 stringLoop (s:ss) = do
 345    case removeSpaces s of
 346         "" -> stringLoop ss
 347         l  -> do quit <- runCommand l
 348                  if quit then return () else stringLoop ss
 349
 350 mkPrompt toplevs exports
 351   = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs)
 352              <+> hsep (map pprModule exports)
 353              <> text "> ")
 354
 355 #ifdef USE_READLINE
 356 readlineLoop :: GHCi ()
 357 readlineLoop = do
 358    session <- getSession
 359    (mod,imports) <- io (GHC.getContext session)
 360    io yield
 361    l <- io (readline (mkPrompt mod imports)
 362                 `finally` setNonBlockingFD 0)
 363                 -- readline sometimes puts stdin into blocking mode,
 364                 -- so we need to put it back for the IO library
 365    case l of
 366         Nothing -> return ()
 367         Just l  ->
 368           case removeSpaces l of
 369             "" -> readlineLoop
 370             l  -> do
 371                   io (addHistory l)
 372                   quit <- runCommand l
 373                   if quit then return () else readlineLoop
 374 #endif
 375
 376 runCommand :: String -> GHCi Bool
 377 runCommand c = ghciHandle handler (doCommand c)
 378
 379 -- This version is for the GHC command-line option -e.  The only difference
 380 -- from runCommand is that it catches the ExitException exception and
 381 -- exits, rather than printing out the exception.
 382 runCommandEval c = ghciHandle handleEval (doCommand c)
 383   where
 384     handleEval (ExitException code) = io (exitWith code)
 385     handleEval e                    = do showException e
 386                                          io (exitWith (ExitFailure 1))
 387
 388 -- This is the exception handler for exceptions generated by the
 389 -- user's code; it normally just prints out the exception.  The
 390 -- handler must be recursive, in case showing the exception causes
 391 -- more exceptions to be raised.
 392 --
 393 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
 394 -- raising another exception.  We therefore don't put the recursive
 395 -- handler arond the flushing operation, so if stderr is closed
 396 -- GHCi will just die gracefully rather than going into an infinite loop.
 397 handler :: Exception -> GHCi Bool
 398 handler exception = do
 399   flushInterpBuffers
 400   io installSignalHandlers
 401   ghciHandle handler (showException exception >> return False)
 402
 403 showException (DynException dyn) =
 404   case fromDynamic dyn of
 405     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 406     Just Interrupted      -> io (putStrLn "Interrupted.")
 407     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 408     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 409     Just other_ghc_ex     -> io (print other_ghc_ex)
 410
 411 showException other_exception
 412   = io (putStrLn ("*** Exception: " ++ show other_exception))
 413
 414 doCommand (':' : command) = specialCommand command
 415 doCommand stmt
 416    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 417         return False
 418
 419 runStmt :: String -> GHCi [Name]
 420 runStmt stmt
 421  | null (filter (not.isSpace) stmt) = return []
 422  | otherwise
 423  = do st <- getGHCiState
 424       session <- getSession
 425       result <- io $ withProgName (progname st) $ withArgs (args st) $
 426                      GHC.runStmt session stmt
 427       case result of
 428         GHC.RunFailed      -> return []
 429         GHC.RunException e -> throw e  -- this is caught by runCommand(Eval)
 430         GHC.RunOk names    -> return names
 431
 432 -- possibly print the type and revert CAFs after evaluating an expression
 433 finishEvalExpr names
 434  = do b <- isOptionSet ShowType
 435       session <- getSession
 436       when b (mapM_ (showTypeOfName session) names)
 437
 438       flushInterpBuffers
 439       io installSignalHandlers
 440       b <- isOptionSet RevertCAFs
 441       io (when b revertCAFs)
 442       return True
 443
 444 showTypeOfName :: Session -> Name -> GHCi ()
 445 showTypeOfName session n
 446    = do maybe_tything <- io (GHC.lookupName session n)
 447         case maybe_tything of
 448           Nothing    -> return ()
 449           Just thing -> showTyThing thing
 450
 451 showForUser :: SDoc -> GHCi String
 452 showForUser doc = do
 453   session <- getSession
 454   unqual <- io (GHC.getPrintUnqual session)
 455   return $! showSDocForUser unqual doc
 456
 457 specialCommand :: String -> GHCi Bool
 458 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 459 specialCommand str = do
 460   let (cmd,rest) = break isSpace str
 461   cmds <- io (readIORef commands)
 462   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 463      []      -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 464                                     ++ shortHelpText) >> return False)
 465      [(_,f)] -> f (dropWhile isSpace rest)
 466      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 467                                       " matches multiple commands (" ++
 468                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 469                                          ++ ")") >> return False)
 470
 471 noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
 472
 473
 474 -----------------------------------------------------------------------------
 475 -- To flush buffers for the *interpreted* computation we need
 476 -- to refer to *its* stdout/stderr handles
 477
 478 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 479 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 480
 481 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
 482              " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
 483 flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
 484
 485 initInterpBuffering :: Session -> IO ()
 486 initInterpBuffering session
 487  = do maybe_hval <- GHC.compileExpr session no_buf_cmd
 488
 489       case maybe_hval of
 490         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 491         other     -> panic "interactiveUI:setBuffering"
 492
 493       maybe_hval <- GHC.compileExpr session flush_cmd
 494       case maybe_hval of
 495         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 496         _         -> panic "interactiveUI:flush"
 497
 498       turnOffBuffering  -- Turn it off right now
 499
 500       return ()
 501
 502
 503 flushInterpBuffers :: GHCi ()
 504 flushInterpBuffers
 505  = io $ do Monad.join (readIORef flush_interp)
 506            return ()
 507
 508 turnOffBuffering :: IO ()
 509 turnOffBuffering
 510  = do Monad.join (readIORef turn_off_buffering)
 511       return ()
 512
 513 -----------------------------------------------------------------------------
 514 -- Commands
 515
 516 help :: String -> GHCi ()
 517 help _ = io (putStr helpText)
 518
 519 info :: String -> GHCi ()
 520 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 521 info s  = do { let names = words s
 522              ; session <- getSession
 523              ; dflags <- getDynFlags
 524              ; let exts = dopt Opt_GlasgowExts dflags
 525              ; mapM_ (infoThing exts session) names }
 526   where
 527     infoThing exts session name
 528         = do { stuff <- io (GHC.getInfo session name)
 529              ; unqual <- io (GHC.getPrintUnqual session)
 530              ; io (putStrLn (showSDocForUser unqual $
 531                    vcat (intersperse (text "") (map (showThing exts) stuff)))) }
 532
 533 showThing :: Bool -> GHC.GetInfoResult -> SDoc
 534 showThing exts (wanted_str, thing, fixity, src_loc, insts)
 535     = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
 536              show_fixity fixity,
 537              vcat (map show_inst insts)]
 538   where
 539     want_name occ = wanted_str == occNameUserString occ
 540
 541     show_fixity fix
 542         | fix == defaultFixity = empty
 543         | otherwise            = ppr fix <+> text wanted_str
 544
 545     show_inst (inst_ty, loc)
 546         = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
 547
 548 showWithLoc :: SrcLoc -> SDoc -> SDoc
 549 showWithLoc loc doc
 550     = hang doc 2 (char '\t' <> comment <+> pprDefnLoc loc)
 551                 -- The tab tries to make them line up a bit
 552   where
 553     comment = ptext SLIT("--")
 554
 555
 556 -- Now there is rather a lot of goop just to print declarations in a
 557 -- civilised way with "..." for the parts we are less interested in.
 558
 559 showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
 560 showDecl exts want_name (IfaceForeign {ifName = tc})
 561   = ppr tc <+> ptext SLIT("is a foreign type")
 562
 563 showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
 564   = ppr var <+> dcolon <+> showIfaceType exts ty
 565
 566 showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
 567   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
 568        2 (equals <+> ppr mono_ty)
 569
 570 showDecl exts want_name (IfaceData {ifName = tycon,
 571                      ifTyVars = tyvars, ifCons = condecls, ifCtxt = context})
 572   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 573        2 (add_bars (ppr_trim show_con cs))
 574   where
 575     show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
 576                              ifConStricts = strs, ifConFields = flds})
 577         | want_name tycon || want_name con_name || any want_name flds
 578         = Just (show_guts con_name is_infix tys_w_strs flds)
 579         | otherwise = Nothing
 580         where
 581           tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
 582     show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
 583                           ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
 584         | want_name tycon || want_name con_name
 585         = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
 586         | otherwise = Nothing
 587         where
 588           tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
 589           pp_tau = foldr add pp_res_ty tys_w_strs
 590           pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
 591           add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
 592
 593     show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
 594     show_guts con _ tys []   = ppr_bndr con <+> sep (map ppr_bangty tys)
 595     show_guts con _ tys flds
 596         = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
 597         where
 598           show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
 599                               = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
 600                               | otherwise = Nothing
 601
 602     (pp_nd, cs) = case condecls of
 603                     IfAbstractTyCon        -> (ptext SLIT("data"),   [])
 604                     IfDataTyCon cs         -> (ptext SLIT("data"),   cs)
 605                     IfNewTyCon c           -> (ptext SLIT("newtype"),[c])
 606
 607     add_bars []      = empty
 608     add_bars [c]     = equals <+> c
 609     add_bars (c:cs)  = equals <+> sep (c : map (char '|' <+>) cs)
 610
 611     ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
 612     ppr_str MarkedStrict    = char '!'
 613     ppr_str MarkedUnboxed   = ptext SLIT("!!")
 614     ppr_str NotMarkedStrict = empty
 615
 616 showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 617                       ifFDs = fds, ifSigs = sigs})
 618   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
 619                 <+> pprFundeps fds <+> opt_where)
 620        2 (vcat (ppr_trim show_op sigs))
 621   where
 622     opt_where | null sigs = empty
 623               | otherwise = ptext SLIT("where")
 624     show_op (IfaceClassOp op dm ty)
 625         | want_name clas || want_name op
 626         = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
 627         | otherwise
 628         = Nothing
 629
 630 showIfaceType :: Bool -> IfaceType -> SDoc
 631 showIfaceType True  ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
 632 showIfaceType False ty = ppr ty     -- otherwise, print without the foralls
 633
 634 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
 635 ppr_trim show xs
 636   = snd (foldr go (False, []) xs)
 637   where
 638     go x (eliding, so_far)
 639         | Just doc <- show x = (False, doc : so_far)
 640         | otherwise = if eliding then (True, so_far)
 641                                  else (True, ptext SLIT("...") : so_far)
 642
 643 ppr_bndr :: OccName -> SDoc
 644 -- Wrap operators in ()
 645 ppr_bndr occ = parenSymOcc occ (ppr occ)
 646
 647
 648 -----------------------------------------------------------------------------
 649 -- Commands
 650
 651 addModule :: [FilePath] -> GHCi ()
 652 addModule files = do
 653   io (revertCAFs)                       -- always revert CAFs on load/add.
 654   files <- mapM expandPath files
 655   targets <- mapM (io . GHC.guessTarget) files
 656   session <- getSession
 657   io (mapM_ (GHC.addTarget session) targets)
 658   ok <- io (GHC.load session LoadAllTargets)
 659   afterLoad ok session
 660
 661 changeDirectory :: String -> GHCi ()
 662 changeDirectory dir = do
 663   session <- getSession
 664   graph <- io (GHC.getModuleGraph session)
 665   when (not (null graph)) $
 666         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 667   io (GHC.setTargets session [])
 668   io (GHC.load session LoadAllTargets)
 669   setContextAfterLoad []
 670   io (GHC.workingDirectoryChanged session)
 671   dir <- expandPath dir
 672   io (setCurrentDirectory dir)
 673
 674 defineMacro :: String -> GHCi ()
 675 defineMacro s = do
 676   let (macro_name, definition) = break isSpace s
 677   cmds <- io (readIORef commands)
 678   if (null macro_name)
 679         then throwDyn (CmdLineError "invalid macro name")
 680         else do
 681   if (macro_name `elem` map fst cmds)
 682         then throwDyn (CmdLineError
 683                 ("command '" ++ macro_name ++ "' is already defined"))
 684         else do
 685
 686   -- give the expression a type signature, so we can be sure we're getting
 687   -- something of the right type.
 688   let new_expr = '(' : definition ++ ") :: String -> IO String"
 689
 690   -- compile the expression
 691   cms <- getSession
 692   maybe_hv <- io (GHC.compileExpr cms new_expr)
 693   case maybe_hv of
 694      Nothing -> return ()
 695      Just hv -> io (writeIORef commands --
 696                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 697
 698 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
 699 runMacro fun s = do
 700   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 701   stringLoop (lines str)
 702
 703 undefineMacro :: String -> GHCi ()
 704 undefineMacro macro_name = do
 705   cmds <- io (readIORef commands)
 706   if (macro_name `elem` map fst builtin_commands)
 707         then throwDyn (CmdLineError
 708                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 709         else do
 710   if (macro_name `notElem` map fst cmds)
 711         then throwDyn (CmdLineError
 712                 ("command '" ++ macro_name ++ "' not defined"))
 713         else do
 714   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 715
 716
 717 loadModule :: [FilePath] -> GHCi ()
 718 loadModule fs = timeIt (loadModule' fs)
 719
 720 loadModule' :: [FilePath] -> GHCi ()
 721 loadModule' files = do
 722   session <- getSession
 723
 724   -- unload first
 725   io (GHC.setTargets session [])
 726   io (GHC.load session LoadAllTargets)
 727
 728   -- expand tildes
 729   files <- mapM expandPath files
 730   targets <- io (mapM GHC.guessTarget files)
 731
 732   -- NOTE: we used to do the dependency anal first, so that if it
 733   -- fails we didn't throw away the current set of modules.  This would
 734   -- require some re-working of the GHC interface, so we'll leave it
 735   -- as a ToDo for now.
 736
 737   io (GHC.setTargets session targets)
 738   ok <- io (GHC.load session LoadAllTargets)
 739   afterLoad ok session
 740
 741
 742 reloadModule :: String -> GHCi ()
 743 reloadModule "" = do
 744   io (revertCAFs)               -- always revert CAFs on reload.
 745   session <- getSession
 746   ok <- io (GHC.load session LoadAllTargets)
 747   afterLoad ok session
 748 reloadModule m = do
 749   io (revertCAFs)               -- always revert CAFs on reload.
 750   session <- getSession
 751   ok <- io (GHC.load session (LoadUpTo (mkModule m)))
 752   afterLoad ok session
 753
 754 afterLoad ok session = do
 755   io (revertCAFs)  -- always revert CAFs on load.
 756   graph <- io (GHC.getModuleGraph session)
 757   let mods = map GHC.ms_mod graph
 758   mods' <- filterM (io . GHC.isLoaded session) mods
 759   setContextAfterLoad mods'
 760   modulesLoadedMsg ok mods'
 761
 762 setContextAfterLoad [] = do
 763   session <- getSession
 764   io (GHC.setContext session [] [prelude_mod])
 765 setContextAfterLoad (m:_) = do
 766   session <- getSession
 767   b <- io (GHC.moduleIsInterpreted session m)
 768   if b then io (GHC.setContext session [m] [])
 769        else io (GHC.setContext session []  [m])
 770
 771 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
 772 modulesLoadedMsg ok mods = do
 773   dflags <- getDynFlags
 774   when (verbosity dflags > 0) $ do
 775    let mod_commas
 776         | null mods = text "none."
 777         | otherwise = hsep (
 778             punctuate comma (map pprModule mods)) <> text "."
 779    case ok of
 780     Failed ->
 781        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 782     Succeeded  ->
 783        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 784
 785
 786 typeOfExpr :: String -> GHCi ()
 787 typeOfExpr str
 788   = do cms <- getSession
 789        maybe_ty <- io (GHC.exprType cms str)
 790        case maybe_ty of
 791           Nothing -> return ()
 792           Just ty -> do ty' <- cleanType ty
 793                         tystr <- showForUser (ppr ty')
 794                         io (putStrLn (str ++ " :: " ++ tystr))
 795
 796 kindOfType :: String -> GHCi ()
 797 kindOfType str
 798   = do cms <- getSession
 799        maybe_ty <- io (GHC.typeKind cms str)
 800        case maybe_ty of
 801           Nothing    -> return ()
 802           Just ty    -> do tystr <- showForUser (ppr ty)
 803                            io (putStrLn (str ++ " :: " ++ tystr))
 804
 805 quit :: String -> GHCi Bool
 806 quit _ = return True
 807
 808 shellEscape :: String -> GHCi Bool
 809 shellEscape str = io (system str >> return False)
 810
 811 -----------------------------------------------------------------------------
 812 -- Browsing a module's contents
 813
 814 browseCmd :: String -> GHCi ()
 815 browseCmd m =
 816   case words m of
 817     ['*':m] | looksLikeModuleName m -> browseModule m False
 818     [m]     | looksLikeModuleName m -> browseModule m True
 819     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 820
 821 browseModule m exports_only = do
 822   s <- getSession
 823
 824   let modl = mkModule m
 825   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
 826   when (not is_interpreted && not exports_only) $
 827         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 828
 829   -- Temporarily set the context to the module we're interested in,
 830   -- just so we can get an appropriate PrintUnqualified
 831   (as,bs) <- io (GHC.getContext s)
 832   io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
 833                       else GHC.setContext s [modl] [])
 834   io (GHC.setContext s as bs)
 835
 836   things <- io (GHC.browseModule s modl exports_only)
 837   unqual <- io (GHC.getPrintUnqual s)
 838
 839   dflags <- getDynFlags
 840   let exts = dopt Opt_GlasgowExts dflags
 841   io (putStrLn (showSDocForUser unqual (
 842          vcat (map (showDecl exts (const True)) things)
 843       )))
 844
 845 -----------------------------------------------------------------------------
 846 -- Setting the module context
 847
 848 setContext str
 849   | all sensible mods = fn mods
 850   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 851   where
 852     (fn, mods) = case str of
 853                         '+':stuff -> (addToContext,      words stuff)
 854                         '-':stuff -> (removeFromContext, words stuff)
 855                         stuff     -> (newContext,        words stuff)
 856
 857     sensible ('*':m) = looksLikeModuleName m
 858     sensible m       = looksLikeModuleName m
 859
 860 newContext mods = do
 861   session <- getSession
 862   (as,bs) <- separate session mods [] []
 863   let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
 864   io (GHC.setContext session as bs')
 865
 866 separate :: Session -> [String] -> [Module] -> [Module]
 867   -> GHCi ([Module],[Module])
 868 separate session []           as bs = return (as,bs)
 869 separate session (('*':m):ms) as bs = do
 870    let modl = mkModule m
 871    b <- io (GHC.moduleIsInterpreted session modl)
 872    if b then separate session ms (modl:as) bs
 873         else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 874 separate session (m:ms)       as bs = separate session ms as (mkModule m:bs)
 875
 876 prelude_mod = mkModule "Prelude"
 877
 878
 879 addToContext mods = do
 880   cms <- getSession
 881   (as,bs) <- io (GHC.getContext cms)
 882
 883   (as',bs') <- separate cms mods [] []
 884
 885   let as_to_add = as' \\ (as ++ bs)
 886       bs_to_add = bs' \\ (as ++ bs)
 887
 888   io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
 889
 890
 891 removeFromContext mods = do
 892   cms <- getSession
 893   (as,bs) <- io (GHC.getContext cms)
 894
 895   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 896
 897   let as' = as \\ (as_to_remove ++ bs_to_remove)
 898       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 899
 900   io (GHC.setContext cms as' bs')
 901
 902 ----------------------------------------------------------------------------
 903 -- Code for `:set'
 904
 905 -- set options in the interpreter.  Syntax is exactly the same as the
 906 -- ghc command line, except that certain options aren't available (-C,
 907 -- -E etc.)
 908 --
 909 -- This is pretty fragile: most options won't work as expected.  ToDo:
 910 -- figure out which ones & disallow them.
 911
 912 setCmd :: String -> GHCi ()
 913 setCmd ""
 914   = do st <- getGHCiState
 915        let opts = options st
 916        io $ putStrLn (showSDoc (
 917               text "options currently set: " <>
 918               if null opts
 919                    then text "none."
 920                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 921            ))
 922 setCmd str
 923   = case words str of
 924         ("args":args) -> setArgs args
 925         ("prog":prog) -> setProg prog
 926         wds -> setOptions wds
 927
 928 setArgs args = do
 929   st <- getGHCiState
 930   setGHCiState st{ args = args }
 931
 932 setProg [prog] = do
 933   st <- getGHCiState
 934   setGHCiState st{ progname = prog }
 935 setProg _ = do
 936   io (hPutStrLn stderr "syntax: :set prog <progname>")
 937
 938 setOptions wds =
 939    do -- first, deal with the GHCi opts (+s, +t, etc.)
 940       let (plus_opts, minus_opts)  = partition isPlus wds
 941       mapM_ setOpt plus_opts
 942
 943       -- then, dynamic flags
 944       dflags <- getDynFlags
 945       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
 946       setDynFlags dflags'
 947
 948         -- update things if the users wants more packages
 949 {- TODO:
 950         let new_packages = pkgs_after \\ pkgs_before
 951         when (not (null new_packages)) $
 952            newPackages new_packages
 953 -}
 954
 955       if (not (null leftovers))
 956                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 957                                                 unwords leftovers))
 958                 else return ()
 959
 960
 961 unsetOptions :: String -> GHCi ()
 962 unsetOptions str
 963   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 964        let opts = words str
 965            (minus_opts, rest1) = partition isMinus opts
 966            (plus_opts, rest2)  = partition isPlus rest1
 967
 968        if (not (null rest2))
 969           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
 970           else do
 971
 972        mapM_ unsetOpt plus_opts
 973
 974        -- can't do GHC flags for now
 975        if (not (null minus_opts))
 976           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 977           else return ()
 978
 979 isMinus ('-':s) = True
 980 isMinus _ = False
 981
 982 isPlus ('+':s) = True
 983 isPlus _ = False
 984
 985 setOpt ('+':str)
 986   = case strToGHCiOpt str of
 987         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 988         Just o  -> setOption o
 989
 990 unsetOpt ('+':str)
 991   = case strToGHCiOpt str of
 992         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 993         Just o  -> unsetOption o
 994
 995 strToGHCiOpt :: String -> (Maybe GHCiOption)
 996 strToGHCiOpt "s" = Just ShowTiming
 997 strToGHCiOpt "t" = Just ShowType
 998 strToGHCiOpt "r" = Just RevertCAFs
 999 strToGHCiOpt _   = Nothing
1000
1001 optToStr :: GHCiOption -> String
1002 optToStr ShowTiming = "s"
1003 optToStr ShowType   = "t"
1004 optToStr RevertCAFs = "r"
1005
1006 {- ToDo
1007 newPackages new_pkgs = do       -- The new packages are already in v_Packages
1008   session <- getSession
1009   io (GHC.setTargets session [])
1010   io (GHC.load session Nothing)
1011   dflags   <- getDynFlags
1012   io (linkPackages dflags new_pkgs)
1013   setContextAfterLoad []
1014 -}
1015
1016 -- ---------------------------------------------------------------------------
1017 -- code for `:show'
1018
1019 showCmd str =
1020   case words str of
1021         ["modules" ] -> showModules
1022         ["bindings"] -> showBindings
1023         ["linker"]   -> io showLinkerState
1024         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1025
1026 showModules = do
1027   session <- getSession
1028   let show_one ms = do m <- io (GHC.showModule session ms)
1029                        io (putStrLn m)
1030   graph <- io (GHC.getModuleGraph session)
1031   mapM_ show_one graph
1032
1033 showBindings = do
1034   s <- getSession
1035   unqual <- io (GHC.getPrintUnqual s)
1036   bindings <- io (GHC.getBindings s)
1037   mapM_ showTyThing bindings
1038   return ()
1039
1040 showTyThing (AnId id) = do
1041   ty' <- cleanType (GHC.idType id)
1042   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1043   io (putStrLn str)
1044 showTyThing _  = return ()
1045
1046 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1047 cleanType :: Type -> GHCi Type
1048 cleanType ty = do
1049   dflags <- getDynFlags
1050   if dopt Opt_GlasgowExts dflags
1051         then return ty
1052         else return $! GHC.dropForAlls ty
1053
1054 -----------------------------------------------------------------------------
1055 -- GHCi monad
1056
1057 data GHCiState = GHCiState
1058      {
1059         progname       :: String,
1060         args           :: [String],
1061         session        :: GHC.Session,
1062         options        :: [GHCiOption]
1063      }
1064
1065 data GHCiOption
1066         = ShowTiming            -- show time/allocs after evaluation
1067         | ShowType              -- show the type of expressions
1068         | RevertCAFs            -- revert CAFs after every evaluation
1069         deriving Eq
1070
1071 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1072
1073 startGHCi :: GHCi a -> GHCiState -> IO a
1074 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1075
1076 instance Monad GHCi where
1077   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1078   return a  = GHCi $ \s -> return a
1079
1080 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1081 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1082    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1083
1084 getGHCiState   = GHCi $ \r -> readIORef r
1085 setGHCiState s = GHCi $ \r -> writeIORef r s
1086
1087 -- for convenience...
1088 getSession = getGHCiState >>= return . session
1089
1090 getDynFlags = do
1091   s <- getSession
1092   io (GHC.getSessionDynFlags s)
1093 setDynFlags dflags = do
1094   s <- getSession
1095   io (GHC.setSessionDynFlags s dflags)
1096
1097 isOptionSet :: GHCiOption -> GHCi Bool
1098 isOptionSet opt
1099  = do st <- getGHCiState
1100       return (opt `elem` options st)
1101
1102 setOption :: GHCiOption -> GHCi ()
1103 setOption opt
1104  = do st <- getGHCiState
1105       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1106
1107 unsetOption :: GHCiOption -> GHCi ()
1108 unsetOption opt
1109  = do st <- getGHCiState
1110       setGHCiState (st{ options = filter (/= opt) (options st) })
1111
1112 io :: IO a -> GHCi a
1113 io m = GHCi { unGHCi = \s -> m >>= return }
1114
1115 -----------------------------------------------------------------------------
1116 -- recursive exception handlers
1117
1118 -- Don't forget to unblock async exceptions in the handler, or if we're
1119 -- in an exception loop (eg. let a = error a in a) the ^C exception
1120 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1121
1122 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1123 ghciHandle h (GHCi m) = GHCi $ \s ->
1124    Exception.catch (m s)
1125         (\e -> unGHCi (ghciUnblock (h e)) s)
1126
1127 ghciUnblock :: GHCi a -> GHCi a
1128 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1129
1130 -----------------------------------------------------------------------------
1131 -- timing & statistics
1132
1133 timeIt :: GHCi a -> GHCi a
1134 timeIt action
1135   = do b <- isOptionSet ShowTiming
1136        if not b
1137           then action
1138           else do allocs1 <- io $ getAllocations
1139                   time1   <- io $ getCPUTime
1140                   a <- action
1141                   allocs2 <- io $ getAllocations
1142                   time2   <- io $ getCPUTime
1143                   io $ printTimes (fromIntegral (allocs2 - allocs1))
1144                                   (time2 - time1)
1145                   return a
1146
1147 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1148         -- defined in ghc/rts/Stats.c
1149
1150 printTimes :: Integer -> Integer -> IO ()
1151 printTimes allocs psecs
1152    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1153             secs_str = showFFloat (Just 2) secs
1154         putStrLn (showSDoc (
1155                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1156                          text (show allocs) <+> text "bytes")))
1157
1158 -----------------------------------------------------------------------------
1159 -- reverting CAFs
1160
1161 revertCAFs :: IO ()
1162 revertCAFs = do
1163   rts_revertCAFs
1164   turnOffBuffering
1165         -- Have to turn off buffering again, because we just
1166         -- reverted stdout, stderr & stdin to their defaults.
1167
1168 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1169         -- Make it "safe", just in case
1170
1171 -- -----------------------------------------------------------------------------
1172 -- Utils
1173
1174 expandPath :: String -> GHCi String
1175 expandPath path =
1176   case dropWhile isSpace path of
1177    ('~':d) -> do
1178         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1179         return (tilde ++ '/':d)
1180    other ->
1181         return other