X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=5b3d1e31d0ff108d2998386d404bd286cf6531f7;hb=dfec17bf9c379ff1f899deb2cb39692d3cd5c418;hp=38b24854cf67149a9b94593ac27a95aa351ce76c;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 38b2485..5b3d1e3 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.173 2004/08/13 13:06:42 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.178 2004/10/13 08:48:47 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -19,7 +19,7 @@ import CompManager import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, isObjectLinkable, GhciMode(..) ) import IfaceSyn ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), - pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart ) + IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart ) import FunDeps ( pprFundeps ) import DriverFlags import DriverState @@ -47,7 +47,7 @@ import System.Posix #endif #endif -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE import Control.Concurrent ( yield ) -- Used in readline loop import System.Console.Readline as Readline #endif @@ -68,6 +68,7 @@ import System.Directory import System.IO as IO import Data.Char import Control.Monad as Monad +import Foreign.StablePtr ( newStablePtr ) import GHC.Exts ( unsafeCoerce# ) @@ -159,6 +160,18 @@ interactiveUI srcs maybe_expr = do cmstate <- cmInit Interactive dflags; + -- HACK! If we happen to get into an infinite loop (eg the user + -- types 'let x=x in x' at the prompt), then the thread will block + -- on a blackhole, and become unreachable during GC. The GC will + -- detect that it is unreachable and send it the NonTermination + -- exception. However, since the thread is unreachable, everything + -- it refers to might be finalized, including the standard Handles. + -- This sounds like a bug, but we don't have a good solution right + -- now. + newStablePtr stdin + newStablePtr stdout + newStablePtr stderr + hFlush stdout hSetBuffering stdout NoBuffering @@ -172,7 +185,7 @@ interactiveUI srcs maybe_expr = do -- initial context is just the Prelude cmstate <- cmSetContext cmstate [] ["Prelude"] -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE Readline.initialize #endif @@ -183,7 +196,7 @@ interactiveUI srcs maybe_expr = do cmstate = cmstate, options = [] } -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE Readline.resetTerminal Nothing #endif @@ -252,7 +265,7 @@ interactiveLoop is_tty show_prompt = do _other -> return ()) $ do -- read commands from stdin -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE if (is_tty) then readlineLoop else fileLoop stdin show_prompt @@ -318,7 +331,7 @@ stringLoop (s:ss) = do mkPrompt toplevs exports = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> " -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +#ifdef USE_READLINE readlineLoop :: GHCi () readlineLoop = do cmstate <- getCmState @@ -478,23 +491,32 @@ info s = do { let names = words s ; mapM_ (infoThing init_cms) names } where infoThing cms name - = do { stuff <- io (cmInfoThing cms name) + = do { stuff <- io (cmGetInfo cms name) ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $ - vcat (intersperse (text "") (map (showThing name) stuff)))) } - -showThing :: String -> (IfaceDecl, Fixity, SrcLoc) -> SDoc -showThing name (thing, fixity, src_loc) - = vcat [ showDecl (\occ -> name == occNameUserString occ) thing, - showFixity fixity, - text "-- " <> showLoc src_loc] + vcat (intersperse (text "") (map showThing stuff)))) } + +showThing :: GetInfoResult -> SDoc +showThing (wanted_str, (thing, fixity, src_loc, insts)) + = vcat [ showDecl want_name thing, + show_fixity fixity, + show_loc src_loc, + vcat (map show_inst insts)] where - showFixity fix + want_name occ = wanted_str == occNameUserString occ + + show_fixity fix | fix == defaultFixity = empty - | otherwise = ppr fix <+> text name + | otherwise = ppr fix <+> text wanted_str - showLoc loc -- The ppr function for SrcLocs is a bit wonky - | isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc - | otherwise = ppr loc + 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. @@ -510,17 +532,28 @@ showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 2 (equals <+> ppr mono_ty) -showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon, +showDecl want_name (IfaceData {ifName = tycon, ifTyVars = tyvars, ifCons = condecls}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 2 (add_bars (ppr_trim show_con cs)) where - show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds) + show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys, + ifConStricts = strs, ifConFields = flds}) | want_name tycon || want_name con_name || any want_name flds - = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds)) + = Just (show_guts con_name is_infix tys_w_strs flds) | otherwise = Nothing where tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict) + show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta, + ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs }) + | want_name tycon || want_name con_name + = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau) + | otherwise = Nothing + where + tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict) + pp_tau = foldr add pp_res_ty tys_w_strs + pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys) + add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2] show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys) @@ -531,10 +564,11 @@ showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon, = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty) | otherwise = Nothing - (pp_nd, cs) = case condecls of - IfAbstractTyCon -> (ptext SLIT("data"), []) - IfDataTyCon cs -> (ptext SLIT("data"), cs) - IfNewTyCon c -> (ptext SLIT("newtype"), [c]) + (pp_nd, context, cs) = case condecls of + IfAbstractTyCon -> (ptext SLIT("data"), [], []) + IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs) + IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs) + IfNewTyCon c -> (ptext SLIT("newtype"), [], [c]) add_bars [] = empty add_bars [c] = equals <+> c