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