{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.166 2004/05/27 09:29:29 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.167 2004/07/21 09:25:42 simonpj Exp $
--
-- GHC Interactive User Interface
--
import CompManager
import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
isObjectLinkable, GhciMode(..) )
-import IfaceSyn ( IfaceDecl( ifName ) )
+import IfaceSyn ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
+ pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
+import FunDeps ( pprFundeps )
import DriverFlags
import DriverState
import DriverUtil ( remove_spaces )
import Module ( showModMsg, lookupModuleEnv )
import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
NamedThing(..) )
-import OccName ( isSymOcc )
-import BasicTypes ( defaultFixity, SuccessFlag(..) )
+import OccName ( OccName, isSymOcc, occNameUserString )
+import BasicTypes ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) )
import Packages
import Outputable
import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
info :: String -> GHCi ()
info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
-info s = do
- let names = words s
- init_cms <- getCmState
- let
- infoThings cms [] = return cms
- infoThings cms (name:names) = do
- stuff <- io (cmInfoThing cms name)
- io (putStrLn (showSDocForUser unqual (
- vcat (intersperse (text "") (map showThing stuff))))
- )
- infoThings cms names
-
- unqual = cmGetPrintUnqual init_cms
-
- showThing (decl, fixity)
- = vcat [ text "-- " <> showTyThing decl,
- showFixity fixity (ifName decl),
- showTyThing decl ]
-
- showFixity fix name
+info s = do { let names = words s
+ ; init_cms <- getCmState
+ ; mapM_ (infoThing init_cms) names }
+ where
+ infoThing cms name
+ = do { stuff <- io (cmInfoThing cms name)
+ ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
+ vcat (intersperse (text "") (map (showThing name) stuff)))) }
+
+showThing :: String -> (IfaceDecl, Fixity) -> SDoc
+showThing name (thing, fixity)
+ = vcat [ showDecl (\occ -> name == occNameUserString occ) thing,
+ showFixity fixity ]
+ where
+ showFixity fix
| fix == defaultFixity = empty
- | otherwise = ppr fix <+>
- (if isSymOcc name
- then ppr name
- else char '`' <> ppr name <> char '`')
+ | otherwise = ppr fix <+> text name
- showTyThing decl = ppr decl
+-- 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.
-{-
- showTyThing (AClass cl)
- = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
- showTyThing (ADataCon dc)
- = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
- showTyThing (ATyCon ty)
- | isPrimTyCon ty
- = hcat [ppr ty, text " is a primitive type constructor"]
- | otherwise
- = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
- showTyThing (AnId id)
- = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
-
- idDescr id
- = case globalIdDetails id of
- RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
- ClassOpId cls -> text "method in class" <+> ppr cls
- otherwise -> text "variable"
+showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
+showDecl want_name (IfaceId {ifName = var, ifType = ty})
+ = ppr var <+> dcolon <+> ppr ty
+
+showDecl 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 {ifCtxt = context, 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)
+ | 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))
+ | otherwise = Nothing
+ where
+ tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
+
+ 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)
+ show_guts con _ tys flds
+ = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
+ where
+ show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
+ = 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])
+
+ add_bars [] = empty
+ add_bars [c] = equals <+> c
+ add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
+
+ ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
+ ppr_str MarkedStrict = char '!'
+ ppr_str MarkedUnboxed = ptext SLIT("!!")
+ ppr_str NotMarkedStrict = empty
+
+showDecl 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
+
+ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
+ppr_trim show xs
+ = snd (foldr go (False, []) xs)
+ where
+ go x (eliding, so_far)
+ | Just doc <- show x = (False, doc : so_far)
+ | otherwise = if eliding then (True, so_far)
+ else (True, ptext SLIT("...") : so_far)
+
+ppr_bndr :: OccName -> SDoc
+-- Wrap operators in ()
+ppr_bndr occ | isSymOcc occ = parens (ppr occ)
+ | otherwise = ppr occ
+
+{-
-- also print out the source location for home things
showSrcLoc name
| isHomePackageName name && isGoodSrcLoc loc
where loc = nameSrcLoc name
-}
- infoThings init_cms names
- return ()
+
+-----------------------------------------------------------------------------
+-- Commands
addModule :: [FilePath] -> GHCi ()
addModule files = do
let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
io (putStrLn (showSDocForUser unqual (
- vcat (map ppr things)
+ vcat (map (showDecl (const True)) things)
)))
-----------------------------------------------------------------------------
eqIfDecl, eqIfInst, eqIfRule,
-- Pretty printing
- pprIfaceExpr, pprIfaceDecl
+ pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
) where
#include "HsVersions.h"
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
- = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars)
+ = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty,
pprVrcs vrcs])
pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen,
ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs})
- = hang (pp_nd <+> pp_decl_head context tycon tyvars)
+ = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls])
where
pp_nd = case condecls of
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
- = hang (ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds)
+ = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
4 (vcat [pprVrcs vrcs,
pprRec isrec,
sep (map ppr sigs)])
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
-pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
-pp_decl_head context thing tyvars
+pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
+pprIfaceDeclHead context thing tyvars
= hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}")
field_labels = dataConFieldLabels data_con
strict_marks = dataConStrictMarks data_con
- -- This case only happens in the call to ifaceThing in InteractiveUI
- -- Otherwise DataCons are filtered out in ifaceThing_acc
-tyThingToIfaceDecl _ _ ext (ADataCon dc)
- = IfaceId { ifName = getOccName dc,
- ifType = toIfaceType ext full_ty,
- ifIdInfo = NoInfo }
- where
- (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc
-
- -- The "stupid context" isn't part of the wrapper-Id type
- -- (for better or worse -- see note in DataCon.lhs), so we
- -- have to make it up here
- full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta)
- (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
+tyThingToIfaceDecl dis abstr ext (ADataCon dc)
+ = pprPanic "toIfaceDecl" (ppr dc)
+
--------------------------
dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst
IfaceExtName(..), IfaceConDecls(..),
tyThingToIfaceDecl )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
-import Id ( Id, isImplicitId )
+import Id ( Id, isImplicitId, globalIdDetails )
+import FieldLabel ( fieldLabelTyCon )
import MkId ( unsafeCoerceId )
+import DataCon ( dataConTyCon )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
import SrcLoc ( interactiveSrcLoc, unLoc )
ModIface(..), ModDetails(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
+import ListSetOps ( removeDups )
import Panic ( ghcError, GhcException(..) )
#endif
else -- Add deprecation warnings
mapM_ addMessages warns_s ;
- -- And lookup up the entities
- mapM do_one good_names
+ -- And lookup up the entities, avoiding duplicates, which arise
+ -- because constructors and record selectors are represented by
+ -- their parent declaration
+ let { do_one name = do { thing <- tcLookupGlobal name
+ ; let decl = toIfaceDecl ictxt thing
+ ; fixity <- lookupFixityRn name
+ ; return (decl, fixity) } ;
+ cmp (d1,_) (d2,_) = ifName d1 `compare` ifName d2 } ;
+ results <- mapM do_one good_names ;
+ return (fst (removeDups cmp results))
}
- where
- do_one name = do { thing <- tcLookupGlobal name
- ; fixity <- lookupFixityRn name
- ; return (toIfaceDecl ictxt thing, fixity) }
toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
toIfaceDecl ictxt thing
- = tyThingToIfaceDecl True {- Discard IdInfo -} emptyNameSet {- Show data cons -}
- ext_nm thing
+ = tyThingToIfaceDecl True -- Discard IdInfo
+ emptyNameSet -- Show data cons
+ ext_nm (munge thing)
where
unqual = icPrintUnqual ictxt
ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack
| otherwise = ExtPkg (nameModuleName n) (nameOccName n)
+
+ -- munge transforms a thing to it's "parent" thing
+ munge (ADataCon dc) = ATyCon (dataConTyCon dc)
+ munge (AnId id) = case globalIdDetails id of
+ RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
+ ClassOpId cls -> AClass cls
+ other -> AnId id
+ munge other_thing = other_thing
\end{code}
= initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
where
get_mod_contents exports_only
- | not exports_only -- We want the whole top-level type env
+ | not exports_only -- We want the whole top-level type env
-- so it had better be a home module
= do { hpt <- getHpt
; case lookupModuleEnvByName hpt mod of
projects / ghc-hetmet.git / commitdiff