- | otherwise = ppr fix <+>
- (if isSymOcc (nameOccName name)
- then ppr name
- else char '`' <> ppr name <> char '`')
-
- showTyThing (AClass cl)
- = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
- 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
- | isRecordSelector id =
- case tyConClass_maybe (fieldLabelTyCon (
- recordSelectorFieldLabel id)) of
- Nothing -> text "record selector"
- Just c -> text "method in class " <> ppr c
- | isDataConWrapId id = text "data constructor"
- | otherwise = text "variable"
-
- -- also print out the source location for home things
- showSrcLoc name
- | isHomePackageName name && isGoodSrcLoc loc
- = hsep [ text ", defined at", ppr loc ]
- | otherwise
- = empty
- where loc = nameSrcLoc name
-
- cms <- infoThings init_cms names
- setCmState cms
- return ()
+ | 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("--")
+
+
+-- 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})
+ = ppr tc <+> ptext SLIT("is a foreign type")
+
+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 {ifName = tycon,
+ ifTyVars = tyvars, ifCons = condecls})
+ = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
+ 2 (add_bars (ppr_trim show_con cs))
+ where
+ 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 (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)
+ 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, 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
+ 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
+
+
+-----------------------------------------------------------------------------
+-- Commands
projects / ghc-hetmet.git / blobdiff