ghc/compiler/ghci/InteractiveUI.hs

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