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