X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=d8ead0bcaa24d4c03741f85b918b9ec4a6610fcb;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=aee025fa1e7bccaa89dd63256e682422b7a53796;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index aee025f..d8ead0b 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[MkIface]{Print an interface for a module} @@ -8,6 +8,7 @@ module MkIface ( startIface, endIface, + ifaceUsages, ifaceVersions, ifaceExportList, ifaceFixities, @@ -17,57 +18,53 @@ module MkIface ( ifacePragmas ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..))) -import Bag ( emptyBag, snocBag, bagToList ) +import Bag ( bagToList ) import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) ) import CmdLineOpts ( opt_ProduceHi ) import FieldLabel ( FieldLabel{-instance NamedThing-} ) +import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap ) import HsSyn -import Id ( idType, dataConSig, dataConFieldLabels, +import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon, dataConStrictMarks, StrictnessMark(..), GenId{-instance NamedThing/Outputable-} ) -import Name ( nameOrigName, origName, nameOf, +import Maybes ( maybeToBool ) +import Name ( origName, nameOf, moduleOf, exportFlagOn, nameExportFlag, ExportFlag(..), - ltLexical, isExported, getExportFlag, - isLexSym, isLocallyDefined, + isLexSym, isLexCon, isLocallyDefined, isWiredInName, RdrName(..){-instance Outputable-}, + OrigName(..){-instance Ord-}, Name{-instance NamedThing-} ) +import ParseUtils ( UsagesMap(..), VersionsMap(..) ) import PprEnv -- not sure how much... import PprStyle ( PprStyle(..) ) import PprType -- most of it (??) -import Pretty -- quite a bit -import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} ) -import RnIfaces ( VersionInfo(..) ) -import TcModule ( TcIfaceInfo(..) ) +--import PrelMods ( modulesWithBuiltins ) +import PrelInfo ( builtinValNamesMap, builtinTcNamesMap ) +import Pretty ( prettyToUn ) +import Unpretty -- ditto +import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) ) +import RnUtils ( SYN_IE(RnEnv) {-, pprRnEnv ToDo:rm-} ) +import TcModule ( SYN_IE(TcIfaceInfo) ) import TcInstUtil ( InstInfo(..) ) import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) ) -import Type ( mkSigmaTy, mkDictTy, getAppTyCon ) -import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} ) +import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy ) +import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}{-, pprTrace ToDo:rm-} ) -ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util -ppr_ty ty = pprType PprInterface ty -ppr_tyvar tv = ppr PprInterface tv +uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util +ppr_ty ty = prettyToUn (pprType PprInterface ty) +ppr_tyvar tv = prettyToUn (ppr PprInterface tv) ppr_name n - = let - on = origName n - s = nameOf on - pp = ppr PprInterface on - in - (if isLexSym s then ppParens else id) pp -ppr_unq_name n - = let - on = origName n - s = nameOf on - pp = ppPStr s - in - (if isLexSym s then ppParens else id) pp + = case (origName "ppr_name" n) of { OrigName m s -> + uppBesides [uppPStr m, uppChar '.', uppPStr s] } \end{code} We have a function @startIface@ to open the output file and put -(something like) ``interface Foo N'' in it. It gives back a handle +(something like) ``interface Foo'' in it. It gives back a handle for subsequent additions to the interface file. We then have one-function-per-block-of-interface-stuff, e.g., @@ -78,13 +75,18 @@ to the handle provided by @startIface@. startIface :: Module -> IO (Maybe Handle) -- Nothing <=> don't do an interface endIface :: Maybe Handle -> IO () +ifaceUsages + :: Maybe Handle + -> UsagesMap + -> IO () ifaceVersions :: Maybe Handle - -> VersionInfo + -> VersionsMap -> IO () ifaceExportList :: Maybe Handle - -> RenamedHsModule + -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)])) + -> RnEnv -> IO () ifaceFixities :: Maybe Handle @@ -113,7 +115,7 @@ startIface mod Nothing -> return Nothing -- not producing any .hi file Just fn -> openFile fn WriteMode >>= \ if_hdl -> - hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >> + hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\ninterface "++ _UNPK_ mod) >> return (Just if_hdl) endIface Nothing = return () @@ -121,10 +123,48 @@ endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl \end{code} \begin{code} +ifaceUsages Nothing{-no iface handle-} _ = return () + +ifaceUsages (Just if_hdl) usages + | null usages_list + = return () + | otherwise + = hPutStr if_hdl "\n__usages__\n" >> + hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list))) + where + usages_list = fmToList usages -- NO: filter has_no_builtins (...) + +-- has_no_builtins (m, _) +-- = m `notElem` modulesWithBuiltins +-- -- Don't *have* to do this; save gratuitous spillage in +-- -- every interface. Could be flag-controlled... + + upp_uses (m, (mv, versions)) + = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "), + upp_versions (fmToList versions), uppSemi] + + upp_versions nvs + = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ] +\end{code} + +\begin{code} ifaceVersions Nothing{-no iface handle-} _ = return () ifaceVersions (Just if_hdl) version_info - = hPutStr if_hdl "__versions__\nFoo(1)" -- a stub, obviously + | null version_list + = return () + | otherwise + = hPutStr if_hdl "\n__versions__\n" >> + hPutStr if_hdl (uppShow 0 (upp_versions version_list)) + -- NB: when compiling Prelude.hs, this will spew out + -- stuff for [], (), (,), etc. [i.e., builtins], which + -- we'd rather it didn't. The version-mangling in + -- the driver will ignore them. + where + version_list = fmToList version_info + + upp_versions nvs + = uppAboves [ uppPStr n | (n,v) <- nvs ] \end{code} \begin{code} @@ -133,69 +173,96 @@ ifaceInstanceModules (Just _) [] = return () ifaceInstanceModules (Just if_hdl) imods = hPutStr if_hdl "\n__instance_modules__\n" >> - hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods))) + hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) \end{code} Export list: grab the Names of things that are marked Exported, sort (so the interface file doesn't ``wobble'' from one compilation to the -next...), and print. Note that the ``module'' now contains all the -imported things that we are dealing with, thus including any entities -that we are re-exporting from somewhere else. +next...), and print. We work from the renamer's final ``RnEnv'', +which has all the names we might possibly be interested in. +(Note that the ``module X'' export items can cause a lot of grief.) \begin{code} -ifaceExportList Nothing{-no iface handle-} _ = return () +ifaceExportList Nothing{-no iface handle-} _ _ = return () ifaceExportList (Just if_hdl) - (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _) + (export_fn, (dotdot_vals, dotdot_tcs)) + rn_env@((qual, unqual, tc_qual, tc_unqual), _) = let - name_flag_pairs :: Bag (Name, ExportFlag) + name_flag_pairs :: FiniteMap OrigName ExportFlag name_flag_pairs - = foldr from_ty - (foldr from_cls - (foldr from_sig - (from_binds binds emptyBag{-init accum-}) - sigs) - classdecls) - typedecls - - sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs) + = foldr (from_wired True{-val-ish-}) + (foldr (from_wired False{-tycon-ish-}) + (foldr (from_dotdot True{-val-ish-}) + (foldr (from_dotdot False{-tycon-ish-}) + (foldr from_val + (foldr from_val + (foldr from_tc + (foldr from_tc emptyFM{-init accum-} + (eltsFM tc_unqual)) + (eltsFM tc_qual)) + (eltsFM unqual)) + (eltsFM qual)) + dotdot_tcs) + dotdot_vals) + (eltsFM builtinTcNamesMap)) + (eltsFM builtinValNamesMap) + + sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs) in + --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $ hPutStr if_hdl "\n__exports__\n" >> - hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs))) + hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs))) where - from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n - from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n - from_ty (TySynonym n _ _ _) acc = maybe_add acc n - - from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n + from_val rn acc + | fun_looking rn && exportFlagOn ef = addToFM acc on ef + | otherwise = acc + where + ef = export_fn n -- NB: using the export fn! + n = getName rn + on = origName "from_val" n - from_sig (Sig n _ _ _) acc = maybe_add acc n + -- fun_looking: must avoid class ops and data constructors + -- and record fieldnames + fun_looking (RnName _) = True + fun_looking (WiredInId i) = not (isDataCon i) + fun_looking _ = False - from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs) + from_tc rn acc + | exportFlagOn ef = addToFM acc on ef + | otherwise = acc + where + ef = export_fn n -- NB: using the export fn! + n = getName rn + on = origName "from_tc" n - -------------- - maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag) + from_dotdot is_valish (n,ef) acc + | is_valish && isLexCon str = acc + | exportFlagOn ef = addToFM acc on ef + | otherwise = acc + where + on = origName "from_dotdot" n + (OrigName _ str) = on - maybe_add acc rn - | exportFlagOn ef = acc `snocBag` (n, ef) + from_wired is_val_ish rn acc + | is_val_ish && not (fun_looking rn) + = acc -- these things don't cause export-ery + | exportFlagOn ef = addToFM acc on ef | otherwise = acc where n = getName rn - ef = nameExportFlag n + ef = export_fn n + on = origName "from_wired" n -------------- - maybe_add_list acc [] = acc - maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n + lexical_lt (n1,_) (n2,_) = n1 < n2 -------------- - lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2 - - -------------- - pp_pair (n, ef) - = ppBeside (ppr_name n) (pp_export ef) + upp_pair (OrigName m n, ef) + = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef] where - pp_export ExportAll = ppPStr SLIT("(..)") - pp_export ExportAbs = ppNil + upp_export ExportAll = uppPStr SLIT("(..)") + upp_export ExportAbs = uppNil \end{code} \begin{code} @@ -203,39 +270,51 @@ ifaceFixities Nothing{-no iface handle-} _ = return () ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) = let - local_fixities = filter from_here fixities + pp_fixities = foldr go [] fixities in - if null local_fixities then + if null pp_fixities then return () else hPutStr if_hdl "\n__fixities__\n" >> - hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid local_fixities))) + hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities)) where - from_here (InfixL v _) = isLocallyDefined v - from_here (InfixR v _) = isLocallyDefined v - from_here (InfixN v _) = isLocallyDefined v + go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc + go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc + go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix "" i v) else id) acc + + print_fix suff prec var + = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi] \end{code} \begin{code} +non_wired x = not (isWiredInName (getName x)) --ToDo:move? + ifaceDecls Nothing{-no iface handle-} _ = return () ifaceDecls (Just if_hdl) (vals, tycons, classes, _) - = let - exported_classes = filter isExported classes - exported_tycons = filter isExported tycons - exported_vals = filter isExported vals - - sorted_classes = sortLt ltLexical exported_classes - sorted_tycons = sortLt ltLexical exported_tycons - sorted_vals = sortLt ltLexical exported_vals + = ASSERT(all isLocallyDefined vals) + ASSERT(all isLocallyDefined tycons) + ASSERT(all isLocallyDefined classes) + let + nonwired_classes = filter non_wired classes + nonwired_tycons = filter non_wired tycons + nonwired_vals = filter non_wired vals + + lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b + + sorted_classes = sortLt lt_lexical nonwired_classes + sorted_tycons = sortLt lt_lexical nonwired_tycons + sorted_vals = sortLt lt_lexical nonwired_vals in - ASSERT(not (null exported_classes && null exported_tycons && null exported_vals)) - + if (null sorted_classes && null sorted_tycons && null sorted_vals) then + -- You could have a module with just (re-)exports/instances in it + return () + else hPutStr if_hdl "\n__declarations__\n" >> - hPutStr if_hdl (ppShow 100 (ppAboves [ - ppAboves (map ppr_class sorted_classes), - ppAboves (map ppr_tycon sorted_tycons), - ppAboves [ppr_val v (idType v) | v <- sorted_vals]])) + hPutStr if_hdl (uppShow 0 (uppAboves [ + uppAboves (map ppr_class sorted_classes), + uppAboves (map ppr_tycon sorted_tycons), + uppAboves [ppr_val v (idType v) | v <- sorted_vals]])) \end{code} \begin{code} @@ -243,17 +322,17 @@ ifaceInstances Nothing{-no iface handle-} _ = return () ifaceInstances (Just if_hdl) (_, _, _, insts) = let - exported_insts = filter is_exported_inst (bagToList insts) + togo_insts = filter is_togo_inst (bagToList insts) - sorted_insts = sortLt lt_inst exported_insts + sorted_insts = sortLt lt_inst togo_insts in - if null exported_insts then + if null togo_insts then return () else hPutStr if_hdl "\n__instances__\n" >> - hPutStr if_hdl (ppShow 100 (ppAboves (map pp_inst sorted_insts))) + hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts))) where - is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _) + is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _) = from_here -- && ... ------- @@ -263,10 +342,10 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) tycon1 = fst (getAppTyCon ty1) tycon2 = fst (getAppTyCon ty2) in - case (origName clas1 `cmp` origName clas2) of + case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of LT_ -> True GT_ -> False - EQ_ -> origName tycon1 < origName tycon2 + EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2 ------- pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _) @@ -274,7 +353,8 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) renumbered_ty = initNmbr (nmbrType forall_ty) in - ppBesides [ppPStr SLIT("instance "), ppr_ty renumbered_ty, ppSemi] + case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) -> + uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] } \end{code} %************************************************************************ @@ -284,35 +364,34 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) %************************************************************************ \begin{code} -ppr_class :: Class -> Pretty +ppr_class :: Class -> Unpretty ppr_class c = --pprTrace "ppr_class:" (ppr PprDebug c) $ case (initNmbr (nmbrClass c)) of { -- renumber it! Class _ n tyvar super_classes sdsels ops sels defms insts links -> - ppAbove (ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes, - ppr_name n, ppr_tyvar tyvar, - if null ops then ppSemi else ppStr "where {"]) - (if (null ops) - then ppNil - else ppAbove (ppNest 2 (ppAboves (map ppr_op ops))) - (ppStr "};") - ) + uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes, + ppr_name n, ppr_tyvar tyvar, + if null ops + then uppSemi + else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]] } where - ppr_theta :: TyVar -> [Class] -> Pretty + ppr_context :: TyVar -> [Class] -> Unpretty - ppr_theta tv [] = ppNil - ppr_theta tv [sc] = ppBeside (ppr_assert tv sc) (ppStr " =>") - ppr_theta tv super_classes - = ppBesides [ppLparen, - ppIntersperse pp'SP{-'-} (map (ppr_assert tv) super_classes), - ppStr ") =>"] + ppr_context tv [] = uppNil +-- ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>")) + ppr_context tv super_classes + = uppBesides [uppStr "{{", + uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes), + uppStr "}} =>"] - ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr_name n, ppr_tyvar tv] + ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv] - ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty + clas_mod = moduleOf (origName "ppr_class" c) + + ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty \end{code} \begin{code} @@ -321,7 +400,11 @@ ppr_val v ty -- renumber the type first! pp_sig v (initNmbr (nmbrType ty)) pp_sig op ty - = ppBesides [ppr_name op, ppPStr SLIT(" :: "), ppr_ty ty, ppSemi] + = case (splitForAllTy ty) of { (tvs, rho_ty) -> + uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] } + +ppr_forall [] = uppNil +ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ] \end{code} \begin{code} @@ -330,82 +413,72 @@ ppr_tycon tycon ppr_tc (initNmbr (nmbrTyCon tycon)) ------------------------ -ppr_tc (PrimTyCon _ n _) - = ppCat [ ppStr "{- data", ppr_name n, ppStr " *built-in* -}" ] +ppr_tc (PrimTyCon _ n _ _) + = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ] ppr_tc FunTyCon - = ppCat [ ppStr "{- data", ppr_name FunTyCon, ppStr " *built-in* -}" ] + = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ] ppr_tc (TupleTyCon _ n _) - = ppCat [ ppStr "{- ", ppr_name n, ppStr "-}" ] + = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ] ppr_tc (SynTyCon _ n _ _ tvs expand) = let pp_tyvars = map ppr_tyvar tvs in - ppBesides [ppPStr SLIT("type "), ppr_name n, ppSP, ppIntersperse ppSP pp_tyvars, - ppPStr SLIT(" = "), ppr_ty expand, ppSemi] + uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars, + uppPStr SLIT(" = "), ppr_ty expand, uppSemi] ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) - = ppHang (ppCat [pp_data_or_new, - ppr_context ctxt, - ppr_name n, - ppIntersperse ppSP (map ppr_tyvar tvs)]) - 2 - (ppBeside pp_unabstract_condecls ppSemi) + = uppCat [pp_data_or_new, + ppr_context ctxt, + ppr_name n, + uppIntersperse uppSP (map ppr_tyvar tvs), + uppEquals, pp_condecls, + uppSemi] -- NB: we do not print deriving info in interfaces where pp_data_or_new = case data_or_new of - DataType -> ppPStr SLIT("data") - NewType -> ppPStr SLIT("newtype") + DataType -> uppPStr SLIT("data") + NewType -> uppPStr SLIT("newtype") - ppr_context [] = ppNil - ppr_context [(c,t)] = ppCat [ppr_name c, ppr_ty t, ppStr "=>"] + ppr_context [] = uppNil +-- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")] ppr_context cs - = ppBesides[ppLparen, - ppInterleave ppComma [ppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], - ppRparen, ppStr " =>"] - - yes_we_print_condecls - = case (getExportFlag n) of - ExportAbs -> False - other -> True - - pp_unabstract_condecls - = if yes_we_print_condecls - then ppCat [ppEquals, pp_condecls] - else ppNil + = uppBesides[uppStr "{{", + uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], + uppStr "}}", uppPStr SLIT(" =>")] pp_condecls = let (c:cs) = cons in - ppSep ((ppr_con c) : (map ppr_next_con cs)) + uppCat ((ppr_con c) : (map ppr_next_con cs)) - ppr_next_con con = ppCat [ppChar '|', ppr_con con] + ppr_next_con con = uppCat [uppChar '|', ppr_con con] ppr_con con = let - (_, _, con_arg_tys, _) = dataConSig con + con_arg_tys = dataConRawArgTys con labels = dataConFieldLabels con -- none if not a record strict_marks = dataConStrictMarks con in - ppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys] + uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys] ppr_fields labels strict_marks con_arg_tys = if null labels then -- not a record thingy - ppIntersperse ppSP (zipWithEqual ppr_bang_ty strict_marks con_arg_tys) + uppIntersperse uppSP (zipWithEqual "ppr_fields" ppr_bang_ty strict_marks con_arg_tys) else - ppCat [ ppChar '{', - ppInterleave ppComma (zipWith3Equal ppr_field labels strict_marks con_arg_tys), - ppChar '}' ] + uppCat [ uppChar '{', + uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys), + uppChar '}' ] ppr_bang_ty b t - = ppBeside (case b of { MarkedStrict -> ppChar '!'; _ -> ppNil }) - (pprParendType PprInterface t) + = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }) + (prettyToUn (pprParendType PprInterface t)) ppr_field l b t - = ppBesides [ppr_unq_name l, ppPStr SLIT(" :: "), - case b of { MarkedStrict -> ppChar '!'; _ -> ppNil }, + = uppBesides [ppr_name l, uppPStr SLIT(" :: "), + case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }, ppr_ty t] \end{code}