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, ifCtxt = context})
 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, cs) = case condecls of
 597                     IfAbstractTyCon        -> (ptext SLIT("data"),   [])
 598                     IfDataTyCon cs         -> (ptext SLIT("data"),   cs)
 599                     IfNewTyCon c           -> (ptext SLIT("newtype"),[c])
 600
 601     add_bars []      = empty
 602     add_bars [c]     = equals <+> c
 603     add_bars (c:cs)  = equals <+> sep (c : map (char '|' <+>) cs)
 604
 605     ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
 606     ppr_str MarkedStrict    = char '!'
 607     ppr_str MarkedUnboxed   = ptext SLIT("!!")
 608     ppr_str NotMarkedStrict = empty
 609
 610 showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 611                       ifFDs = fds, ifSigs = sigs})
 612   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
 613                 <+> pprFundeps fds <+> opt_where)
 614        2 (vcat (ppr_trim show_op sigs))
 615   where
 616     opt_where | null sigs = empty
 617               | otherwise = ptext SLIT("where")
 618     show_op (IfaceClassOp op dm ty)
 619         | want_name clas || want_name op
 620         = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
 621         | otherwise
 622         = Nothing
 623
 624 showIfaceType :: Bool -> IfaceType -> SDoc
 625 showIfaceType True  ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
 626 showIfaceType False ty = ppr ty     -- otherwise, print without the foralls
 627
 628 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
 629 ppr_trim show xs
 630   = snd (foldr go (False, []) xs)
 631   where
 632     go x (eliding, so_far)
 633         | Just doc <- show x = (False, doc : so_far)
 634         | otherwise = if eliding then (True, so_far)
 635                                  else (True, ptext SLIT("...") : so_far)
 636
 637 ppr_bndr :: OccName -> SDoc
 638 -- Wrap operators in ()
 639 ppr_bndr occ = parenSymOcc occ (ppr occ)
 640
 641
 642 -----------------------------------------------------------------------------
 643 -- Commands
 644
 645 addModule :: [FilePath] -> GHCi ()
 646 addModule files = do
 647   io (revertCAFs)                       -- always revert CAFs on load/add.
 648   files <- mapM expandPath files
 649   targets <- mapM (io . GHC.guessTarget) files
 650   session <- getSession
 651   io (mapM_ (GHC.addTarget session) targets)
 652   ok <- io (GHC.load session LoadAllTargets)
 653   afterLoad ok session
 654
 655 changeDirectory :: String -> GHCi ()
 656 changeDirectory dir = do
 657   session <- getSession
 658   graph <- io (GHC.getModuleGraph session)
 659   when (not (null graph)) $
 660         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 661   io (GHC.setTargets session [])
 662   io (GHC.load session LoadAllTargets)
 663   setContextAfterLoad []
 664   io (GHC.workingDirectoryChanged session)
 665   dir <- expandPath dir
 666   io (setCurrentDirectory dir)
 667
 668 defineMacro :: String -> GHCi ()
 669 defineMacro s = do
 670   let (macro_name, definition) = break isSpace s
 671   cmds <- io (readIORef commands)
 672   if (null macro_name)
 673         then throwDyn (CmdLineError "invalid macro name")
 674         else do
 675   if (macro_name `elem` map fst cmds)
 676         then throwDyn (CmdLineError
 677                 ("command '" ++ macro_name ++ "' is already defined"))
 678         else do
 679
 680   -- give the expression a type signature, so we can be sure we're getting
 681   -- something of the right type.
 682   let new_expr = '(' : definition ++ ") :: String -> IO String"
 683
 684   -- compile the expression
 685   cms <- getSession
 686   maybe_hv <- io (GHC.compileExpr cms new_expr)
 687   case maybe_hv of
 688      Nothing -> return ()
 689      Just hv -> io (writeIORef commands --
 690                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 691
 692 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
 693 runMacro fun s = do
 694   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 695   stringLoop (lines str)
 696
 697 undefineMacro :: String -> GHCi ()
 698 undefineMacro macro_name = do
 699   cmds <- io (readIORef commands)
 700   if (macro_name `elem` map fst builtin_commands)
 701         then throwDyn (CmdLineError
 702                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 703         else do
 704   if (macro_name `notElem` map fst cmds)
 705         then throwDyn (CmdLineError
 706                 ("command '" ++ macro_name ++ "' not defined"))
 707         else do
 708   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 709
 710
 711 loadModule :: [FilePath] -> GHCi ()
 712 loadModule fs = timeIt (loadModule' fs)
 713
 714 loadModule' :: [FilePath] -> GHCi ()
 715 loadModule' files = do
 716   session <- getSession
 717
 718   -- unload first
 719   io (GHC.setTargets session [])
 720   io (GHC.load session LoadAllTargets)
 721
 722   -- expand tildes
 723   files <- mapM expandPath files
 724   targets <- io (mapM GHC.guessTarget files)
 725
 726   -- NOTE: we used to do the dependency anal first, so that if it
 727   -- fails we didn't throw away the current set of modules.  This would
 728   -- require some re-working of the GHC interface, so we'll leave it
 729   -- as a ToDo for now.
 730
 731   io (GHC.setTargets session targets)
 732   ok <- io (GHC.load session LoadAllTargets)
 733   afterLoad ok session
 734
 735
 736 reloadModule :: String -> GHCi ()
 737 reloadModule "" = do
 738   io (revertCAFs)               -- always revert CAFs on reload.
 739   session <- getSession
 740   ok <- io (GHC.load session LoadAllTargets)
 741   afterLoad ok session
 742 reloadModule m = do
 743   io (revertCAFs)               -- always revert CAFs on reload.
 744   session <- getSession
 745   ok <- io (GHC.load session (LoadUpTo (mkModule m)))
 746   afterLoad ok session
 747
 748 afterLoad ok session = do
 749   io (revertCAFs)  -- always revert CAFs on load.
 750   graph <- io (GHC.getModuleGraph session)
 751   let mods = map GHC.ms_mod graph
 752   mods' <- filterM (io . GHC.isLoaded session) mods
 753   setContextAfterLoad mods'
 754   modulesLoadedMsg ok mods'
 755
 756 setContextAfterLoad [] = do
 757   session <- getSession
 758   io (GHC.setContext session [] [prelude_mod])
 759 setContextAfterLoad (m:_) = do
 760   session <- getSession
 761   b <- io (GHC.moduleIsInterpreted session m)
 762   if b then io (GHC.setContext session [m] [])
 763        else io (GHC.setContext session []  [m])
 764
 765 modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
 766 modulesLoadedMsg ok mods = do
 767   dflags <- getDynFlags
 768   when (verbosity dflags > 0) $ do
 769    let mod_commas
 770         | null mods = text "none."
 771         | otherwise = hsep (
 772             punctuate comma (map pprModule mods)) <> text "."
 773    case ok of
 774     Failed ->
 775        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 776     Succeeded  ->
 777        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 778
 779
 780 typeOfExpr :: String -> GHCi ()
 781 typeOfExpr str
 782   = do cms <- getSession
 783        maybe_ty <- io (GHC.exprType cms str)
 784        case maybe_ty of
 785           Nothing -> return ()
 786           Just ty -> do ty' <- cleanType ty
 787                         tystr <- showForUser (ppr ty')
 788                         io (putStrLn (str ++ " :: " ++ tystr))
 789
 790 kindOfType :: String -> GHCi ()
 791 kindOfType str
 792   = do cms <- getSession
 793        maybe_ty <- io (GHC.typeKind cms str)
 794        case maybe_ty of
 795           Nothing    -> return ()
 796           Just ty    -> do tystr <- showForUser (ppr ty)
 797                            io (putStrLn (str ++ " :: " ++ tystr))
 798
 799 quit :: String -> GHCi Bool
 800 quit _ = return True
 801
 802 shellEscape :: String -> GHCi Bool
 803 shellEscape str = io (system str >> return False)
 804
 805 -----------------------------------------------------------------------------
 806 -- Browsing a module's contents
 807
 808 browseCmd :: String -> GHCi ()
 809 browseCmd m =
 810   case words m of
 811     ['*':m] | looksLikeModuleName m -> browseModule m False
 812     [m]     | looksLikeModuleName m -> browseModule m True
 813     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 814
 815 browseModule m exports_only = do
 816   s <- getSession
 817
 818   let modl = mkModule m
 819   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
 820   when (not is_interpreted && not exports_only) $
 821         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 822
 823   -- Temporarily set the context to the module we're interested in,
 824   -- just so we can get an appropriate PrintUnqualified
 825   (as,bs) <- io (GHC.getContext s)
 826   io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
 827                       else GHC.setContext s [modl] [])
 828   io (GHC.setContext s as bs)
 829
 830   things <- io (GHC.browseModule s modl exports_only)
 831   unqual <- io (GHC.getPrintUnqual s)
 832
 833   dflags <- getDynFlags
 834   let exts = dopt Opt_GlasgowExts dflags
 835   io (putStrLn (showSDocForUser unqual (
 836          vcat (map (showDecl exts (const True)) things)
 837       )))
 838
 839 -----------------------------------------------------------------------------
 840 -- Setting the module context
 841
 842 setContext str
 843   | all sensible mods = fn mods
 844   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 845   where
 846     (fn, mods) = case str of
 847                         '+':stuff -> (addToContext,      words stuff)
 848                         '-':stuff -> (removeFromContext, words stuff)
 849                         stuff     -> (newContext,        words stuff)
 850
 851     sensible ('*':m) = looksLikeModuleName m
 852     sensible m       = looksLikeModuleName m
 853
 854 newContext mods = do
 855   session <- getSession
 856   (as,bs) <- separate session mods [] []
 857   let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
 858   io (GHC.setContext session as bs')
 859
 860 separate :: Session -> [String] -> [Module] -> [Module]
 861   -> GHCi ([Module],[Module])
 862 separate session []           as bs = return (as,bs)
 863 separate session (('*':m):ms) as bs = do
 864    let modl = mkModule m
 865    b <- io (GHC.moduleIsInterpreted session modl)
 866    if b then separate session ms (modl:as) bs
 867         else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 868 separate session (m:ms)       as bs = separate session ms as (mkModule m:bs)
 869
 870 prelude_mod = mkModule "Prelude"
 871
 872
 873 addToContext mods = do
 874   cms <- getSession
 875   (as,bs) <- io (GHC.getContext cms)
 876
 877   (as',bs') <- separate cms mods [] []
 878
 879   let as_to_add = as' \\ (as ++ bs)
 880       bs_to_add = bs' \\ (as ++ bs)
 881
 882   io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
 883
 884
 885 removeFromContext mods = do
 886   cms <- getSession
 887   (as,bs) <- io (GHC.getContext cms)
 888
 889   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 890
 891   let as' = as \\ (as_to_remove ++ bs_to_remove)
 892       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 893
 894   io (GHC.setContext cms as' bs')
 895
 896 ----------------------------------------------------------------------------
 897 -- Code for `:set'
 898
 899 -- set options in the interpreter.  Syntax is exactly the same as the
 900 -- ghc command line, except that certain options aren't available (-C,
 901 -- -E etc.)
 902 --
 903 -- This is pretty fragile: most options won't work as expected.  ToDo:
 904 -- figure out which ones & disallow them.
 905
 906 setCmd :: String -> GHCi ()
 907 setCmd ""
 908   = do st <- getGHCiState
 909        let opts = options st
 910        io $ putStrLn (showSDoc (
 911               text "options currently set: " <>
 912               if null opts
 913                    then text "none."
 914                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 915            ))
 916 setCmd str
 917   = case words str of
 918         ("args":args) -> setArgs args
 919         ("prog":prog) -> setProg prog
 920         wds -> setOptions wds
 921
 922 setArgs args = do
 923   st <- getGHCiState
 924   setGHCiState st{ args = args }
 925
 926 setProg [prog] = do
 927   st <- getGHCiState
 928   setGHCiState st{ progname = prog }
 929 setProg _ = do
 930   io (hPutStrLn stderr "syntax: :set prog <progname>")
 931
 932 setOptions wds =
 933    do -- first, deal with the GHCi opts (+s, +t, etc.)
 934       let (plus_opts, minus_opts)  = partition isPlus wds
 935       mapM_ setOpt plus_opts
 936
 937       -- then, dynamic flags
 938       dflags <- getDynFlags
 939       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
 940       setDynFlags dflags'
 941
 942         -- update things if the users wants more packages
 943 {- TODO:
 944         let new_packages = pkgs_after \\ pkgs_before
 945         when (not (null new_packages)) $
 946            newPackages new_packages
 947 -}
 948
 949       if (not (null leftovers))
 950                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 951                                                 unwords leftovers))
 952                 else return ()
 953
 954
 955 unsetOptions :: String -> GHCi ()
 956 unsetOptions str
 957   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 958        let opts = words str
 959            (minus_opts, rest1) = partition isMinus opts
 960            (plus_opts, rest2)  = partition isPlus rest1
 961
 962        if (not (null rest2))
 963           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
 964           else do
 965
 966        mapM_ unsetOpt plus_opts
 967
 968        -- can't do GHC flags for now
 969        if (not (null minus_opts))
 970           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 971           else return ()
 972
 973 isMinus ('-':s) = True
 974 isMinus _ = False
 975
 976 isPlus ('+':s) = True
 977 isPlus _ = False
 978
 979 setOpt ('+':str)
 980   = case strToGHCiOpt str of
 981         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 982         Just o  -> setOption o
 983
 984 unsetOpt ('+':str)
 985   = case strToGHCiOpt str of
 986         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
 987         Just o  -> unsetOption o
 988
 989 strToGHCiOpt :: String -> (Maybe GHCiOption)
 990 strToGHCiOpt "s" = Just ShowTiming
 991 strToGHCiOpt "t" = Just ShowType
 992 strToGHCiOpt "r" = Just RevertCAFs
 993 strToGHCiOpt _   = Nothing
 994
 995 optToStr :: GHCiOption -> String
 996 optToStr ShowTiming = "s"
 997 optToStr ShowType   = "t"
 998 optToStr RevertCAFs = "r"
 999
1000 {- ToDo
1001 newPackages new_pkgs = do       -- The new packages are already in v_Packages
1002   session <- getSession
1003   io (GHC.setTargets session [])
1004   io (GHC.load session Nothing)
1005   dflags   <- getDynFlags
1006   io (linkPackages dflags new_pkgs)
1007   setContextAfterLoad []
1008 -}
1009
1010 -- ---------------------------------------------------------------------------
1011 -- code for `:show'
1012
1013 showCmd str =
1014   case words str of
1015         ["modules" ] -> showModules
1016         ["bindings"] -> showBindings
1017         ["linker"]   -> io showLinkerState
1018         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1019
1020 showModules = do
1021   session <- getSession
1022   let show_one ms = do m <- io (GHC.showModule session ms)
1023                        io (putStrLn m)
1024   graph <- io (GHC.getModuleGraph session)
1025   mapM_ show_one graph
1026
1027 showBindings = do
1028   s <- getSession
1029   unqual <- io (GHC.getPrintUnqual s)
1030   bindings <- io (GHC.getBindings s)
1031   mapM_ showTyThing bindings
1032   return ()
1033
1034 showTyThing (AnId id) = do
1035   ty' <- cleanType (GHC.idType id)
1036   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1037   io (putStrLn str)
1038 showTyThing _  = return ()
1039
1040 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1041 cleanType :: Type -> GHCi Type
1042 cleanType ty = do
1043   dflags <- getDynFlags
1044   if dopt Opt_GlasgowExts dflags
1045         then return ty
1046         else return $! GHC.dropForAlls ty
1047
1048 -----------------------------------------------------------------------------
1049 -- GHCi monad
1050
1051 data GHCiState = GHCiState
1052      {
1053         progname       :: String,
1054         args           :: [String],
1055         session        :: GHC.Session,
1056         options        :: [GHCiOption]
1057      }
1058
1059 data GHCiOption
1060         = ShowTiming            -- show time/allocs after evaluation
1061         | ShowType              -- show the type of expressions
1062         | RevertCAFs            -- revert CAFs after every evaluation
1063         deriving Eq
1064
1065 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1066
1067 startGHCi :: GHCi a -> GHCiState -> IO a
1068 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1069
1070 instance Monad GHCi where
1071   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1072   return a  = GHCi $ \s -> return a
1073
1074 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1075 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1076    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1077
1078 getGHCiState   = GHCi $ \r -> readIORef r
1079 setGHCiState s = GHCi $ \r -> writeIORef r s
1080
1081 -- for convenience...
1082 getSession = getGHCiState >>= return . session
1083
1084 getDynFlags = do
1085   s <- getSession
1086   io (GHC.getSessionDynFlags s)
1087 setDynFlags dflags = do
1088   s <- getSession
1089   io (GHC.setSessionDynFlags s dflags)
1090
1091 isOptionSet :: GHCiOption -> GHCi Bool
1092 isOptionSet opt
1093  = do st <- getGHCiState
1094       return (opt `elem` options st)
1095
1096 setOption :: GHCiOption -> GHCi ()
1097 setOption opt
1098  = do st <- getGHCiState
1099       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1100
1101 unsetOption :: GHCiOption -> GHCi ()
1102 unsetOption opt
1103  = do st <- getGHCiState
1104       setGHCiState (st{ options = filter (/= opt) (options st) })
1105
1106 io :: IO a -> GHCi a
1107 io m = GHCi { unGHCi = \s -> m >>= return }
1108
1109 -----------------------------------------------------------------------------
1110 -- recursive exception handlers
1111
1112 -- Don't forget to unblock async exceptions in the handler, or if we're
1113 -- in an exception loop (eg. let a = error a in a) the ^C exception
1114 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1115
1116 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1117 ghciHandle h (GHCi m) = GHCi $ \s ->
1118    Exception.catch (m s)
1119         (\e -> unGHCi (ghciUnblock (h e)) s)
1120
1121 ghciUnblock :: GHCi a -> GHCi a
1122 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1123
1124 -----------------------------------------------------------------------------
1125 -- timing & statistics
1126
1127 timeIt :: GHCi a -> GHCi a
1128 timeIt action
1129   = do b <- isOptionSet ShowTiming
1130        if not b
1131           then action
1132           else do allocs1 <- io $ getAllocations
1133                   time1   <- io $ getCPUTime
1134                   a <- action
1135                   allocs2 <- io $ getAllocations
1136                   time2   <- io $ getCPUTime
1137                   io $ printTimes (fromIntegral (allocs2 - allocs1))
1138                                   (time2 - time1)
1139                   return a
1140
1141 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1142         -- defined in ghc/rts/Stats.c
1143
1144 printTimes :: Integer -> Integer -> IO ()
1145 printTimes allocs psecs
1146    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1147             secs_str = showFFloat (Just 2) secs
1148         putStrLn (showSDoc (
1149                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1150                          text (show allocs) <+> text "bytes")))
1151
1152 -----------------------------------------------------------------------------
1153 -- reverting CAFs
1154
1155 revertCAFs :: IO ()
1156 revertCAFs = do
1157   rts_revertCAFs
1158   turnOffBuffering
1159         -- Have to turn off buffering again, because we just
1160         -- reverted stdout, stderr & stdin to their defaults.
1161
1162 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1163         -- Make it "safe", just in case
1164
1165 -- -----------------------------------------------------------------------------
1166 -- Utils
1167
1168 expandPath :: String -> GHCi String
1169 expandPath path =
1170   case dropWhile isSpace path of
1171    ('~':d) -> do
1172         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1173         return (tilde ++ '/':d)
1174    other ->
1175         return other