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