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