%
-% (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}
module MkIface (
startIface, endIface,
+ ifaceUsages,
ifaceVersions,
ifaceExportList,
ifaceFixities,
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.,
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
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 ()
\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}
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}
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}
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 -- && ...
-------
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 _ _ _ _ _ _ _ _)
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}
%************************************************************************
%************************************************************************
\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}
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}
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}
projects / ghc-hetmet.git / blobdiff