X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=2e9a1a0661f1dde38caf370e4694a7f51bd5ab1e;hb=3fc8c5b200dc411c9b4d3aa1c2b5706de653c5f7;hp=c4b5aeb93426ac7c60224c9836f451304e907728;hpb=4307f28b4d201d71a11dd304796ce7319fbb3345;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index c4b5aeb..2e9a1a0 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.172 2004/08/12 13:10:35 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.177 2004/10/11 14:44:38 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -12,14 +12,14 @@ module InteractiveUI ( ghciWelcomeMsg ) where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" 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,8 +265,8 @@ interactiveLoop is_tty show_prompt = do _other -> return ()) $ do -- read commands from stdin -#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS - if (is_tty) +#ifdef USE_READLINE + if (True || is_tty) then readlineLoop else fileLoop stdin show_prompt #else @@ -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