{-# 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
--
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
#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
import System.IO as IO
import Data.Char
import Control.Monad as Monad
+import Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
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
-- initial context is just the Prelude
cmstate <- cmSetContext cmstate [] ["Prelude"]
-#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
+#ifdef USE_READLINE
Readline.initialize
#endif
cmstate = cmstate,
options = [] }
-#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
+#ifdef USE_READLINE
Readline.resetTerminal Nothing
#endif
_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
mkPrompt toplevs exports
= concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
-#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
+#ifdef USE_READLINE
readlineLoop :: GHCi ()
readlineLoop = do
cmstate <- getCmState
; 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.
= 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)
= 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
projects / ghc-hetmet.git / blobdiff