X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=a686e436904ce1dd6ae5b62ca9d3a578f3ae849e;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=ec59f0b4e179a3189bae67266423c3efdd84c47e;hpb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index ec59f0b..a686e43 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.185 2005/01/28 12:55:23 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.191 2005/02/25 13:07:10 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -15,10 +15,11 @@ module InteractiveUI ( #include "HsVersions.h" import CompManager -import HscTypes ( HomeModInfo(hm_linkable), HomePackageTable, - isObjectLinkable, GhciMode(..) ) -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), - IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart ) +import HscTypes ( GhciMode(..) ) +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), + IfaceConDecl(..), IfaceType, + IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, + pprIfaceForAllPart, pprIfaceType ) import FunDeps ( pprFundeps ) import DriverFlags import DriverState @@ -26,10 +27,10 @@ import DriverUtil ( remove_spaces ) import Linker ( showLinkerState, linkPackages ) import Util import Name ( Name, NamedThing(..) ) -import OccName ( OccName, isSymOcc, occNameUserString ) +import OccName ( OccName, parenSymOcc, occNameUserString ) import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) ) import Outputable -import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset ) +import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) import Panic hiding ( showException ) import Config import SrcLoc ( SrcLoc, isGoodSrcLoc ) @@ -51,7 +52,7 @@ import System.Console.Readline as Readline import Control.Exception as Exception import Data.Dynamic -import Control.Concurrent +-- import Control.Concurrent import Numeric import Data.List @@ -59,6 +60,7 @@ import Data.Int ( Int64 ) import System.Cmd import System.CPUTime import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO @@ -247,7 +249,7 @@ runGHCi paths dflags maybe_expr = do interactiveLoop is_tty show_prompt Just expr -> do -- just evaluate the expression we were given - runCommand expr + runCommandEval expr return () -- and finally, exit @@ -357,6 +359,15 @@ readlineLoop = do runCommand :: String -> GHCi Bool runCommand c = ghciHandle handler (doCommand c) +-- This version is for the GHC command-line option -e. The only difference +-- from runCommand is that it catches the ExitException exception and +-- exits, rather than printing out the exception. +runCommandEval c = ghciHandle handleEval (doCommand c) + where + handleEval (ExitException code) = io (exitWith code) + handleEval e = do showException e + io (exitWith (ExitFailure 1)) + -- This is the exception handler for exceptions generated by the -- user's code; it normally just prints out the exception. The -- handler must be recursive, in case showing the exception causes @@ -400,7 +411,7 @@ runStmt stmt setGHCiState st{cmstate = new_cmstate} case result of CmRunFailed -> return [] - CmRunException e -> showException e >> return [] + CmRunException e -> throw e -- this is caught by runCommand(Eval) CmRunOk names -> return names -- possibly print the type and revert CAFs after evaluating an expression @@ -446,9 +457,9 @@ noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments")) GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) -no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++ - " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" -flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr" +no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++ + " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering" +flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr" initInterpBuffering :: CmState -> IO () initInterpBuffering cmstate @@ -488,18 +499,19 @@ info :: String -> GHCi () info "" = throwDyn (CmdLineError "syntax: ':i '") info s = do { let names = words s ; init_cms <- getCmState - ; mapM_ (infoThing init_cms) names } + ; dflags <- getDynFlags + ; let exts = dopt Opt_GlasgowExts dflags + ; mapM_ (infoThing exts init_cms) names } where - infoThing cms name + infoThing exts cms name = do { stuff <- io (cmGetInfo cms name) ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $ - vcat (intersperse (text "") (map showThing stuff)))) } + vcat (intersperse (text "") (map (showThing exts) stuff)))) } -showThing :: GetInfoResult -> SDoc -showThing (wanted_str, (thing, fixity, src_loc, insts)) - = vcat [ showDecl want_name thing, +showThing :: Bool -> GetInfoResult -> SDoc +showThing exts (wanted_str, (thing, fixity, src_loc, insts)) + = vcat [ showWithLoc src_loc (showDecl exts want_name thing), show_fixity fixity, - show_loc src_loc, vcat (map show_inst insts)] where want_name occ = wanted_str == occNameUserString occ @@ -508,31 +520,35 @@ showThing (wanted_str, (thing, fixity, src_loc, insts)) | fix == defaultFixity = empty | otherwise = ppr fix <+> text wanted_str + show_inst (iface_inst, loc) + = showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst)) + +showWithLoc :: SrcLoc -> SDoc -> SDoc +showWithLoc loc doc + = hang doc 2 (char '\t' <> show_loc loc) + -- The tab tries to make them line up a bit + where show_loc loc -- The ppr function for SrcLocs is a bit wonky | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc | otherwise = comment <+> ppr loc comment = ptext SLIT("--") - show_inst (iface_inst, loc) - = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst)) - 2 (char '\t' <> show_loc loc) - -- The tab tries to make them line up a bit -- Now there is rather a lot of goop just to print declarations in a -- civilised way with "..." for the parts we are less interested in. -showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc -showDecl want_name (IfaceForeign {ifName = tc}) +showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc +showDecl exts want_name (IfaceForeign {ifName = tc}) = ppr tc <+> ptext SLIT("is a foreign type") -showDecl want_name (IfaceId {ifName = var, ifType = ty}) - = ppr var <+> dcolon <+> ppr ty +showDecl exts want_name (IfaceId {ifName = var, ifType = ty}) + = ppr var <+> dcolon <+> showType exts ty -showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) +showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 2 (equals <+> ppr mono_ty) -showDecl want_name (IfaceData {ifName = tycon, +showDecl exts want_name (IfaceData {ifName = tycon, ifTyVars = tyvars, ifCons = condecls}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 2 (add_bars (ppr_trim show_con cs)) @@ -579,15 +595,21 @@ showDecl want_name (IfaceData {ifName = tycon, ppr_str MarkedUnboxed = ptext SLIT("!!") ppr_str NotMarkedStrict = empty -showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, +showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs}) = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds <+> ptext SLIT("where")) 2 (vcat (ppr_trim show_op sigs)) where show_op (IfaceClassOp op dm ty) - | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty) - | otherwise = Nothing + | want_name clas || want_name op + = Just (ppr_bndr op <+> dcolon <+> showType exts ty) + | otherwise + = Nothing + +showType :: Bool -> IfaceType -> SDoc +showType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls +showType False ty = ppr ty -- otherwise, print without the foralls ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] ppr_trim show xs @@ -600,8 +622,7 @@ ppr_trim show xs ppr_bndr :: OccName -> SDoc -- Wrap operators in () -ppr_bndr occ | isSymOcc occ = parens (ppr occ) - | otherwise = ppr occ +ppr_bndr occ = parenSymOcc occ (ppr occ) ----------------------------------------------------------------------------- @@ -790,8 +811,10 @@ browseModule m exports_only = do let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context + dflags <- getDynFlags + let exts = dopt Opt_GlasgowExts dflags io (putStrLn (showSDocForUser unqual ( - vcat (map (showDecl (const True)) things) + vcat (map (showDecl exts (const True)) things) ))) -----------------------------------------------------------------------------