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