ghc/compiler/ghci/InteractiveUI.hs

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