-
-========================================================
- INTERFACE STUFF; move it out
-
-
-\begin{pseudocode}
-pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs
- = ASSERT (null specs)
- let
- lookup_fn = mk_lookup_tyvar_fn sty vs
- pp_tyvars = map lookup_fn vs
- in
- ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
- ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
-
-pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings data_or_new) specs
- = ppHang (ppCat [pp_data_or_new,
- pprContext sty ctxt,
- ppr sty n,
- ppIntersperse ppSP (map lookup_fn vs)])
- 4
- (ppCat [pp_unabstract_condecls,
- pp_pragma])
- -- NB: we do not print deriving info in interfaces
- where
- lookup_fn = mk_lookup_tyvar_fn sty vs
-
- pp_data_or_new = case data_or_new of
- DataType -> ppPStr SLIT("data")
- NewType -> ppPStr SLIT("newtype")
-
- yes_we_print_condecls
- = unabstract
- && not (null cons) -- we know what they are
- && (case (getExportFlag n) of
- ExportAbs -> False
- other -> True)
-
- yes_we_print_pragma_condecls
- = not yes_we_print_condecls
- && not opt_OmitInterfacePragmas
- && not (null cons)
- && not (maybeToBool (maybePurelyLocalTyCon this_tycon))
- {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
-
- yes_we_print_pragma_specs
- = not (null specs)
-
- pp_unabstract_condecls
- = if yes_we_print_condecls
- then ppCat [ppSP, ppEquals, pp_condecls]
- else ppNil
-
- pp_pragma_condecls
- = if yes_we_print_pragma_condecls
- then pp_condecls
- else ppNil
-
- pp_pragma_specs
- = if yes_we_print_pragma_specs
- then pp_specs
- else ppNil
-
- pp_pragma
- = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs)
- then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"]
- else ppNil
-
- pp_condecls
- = let
- (c:cs) = cons
- in
- ppCat ((ppr_con c) : (map ppr_next_con cs))
- where
- ppr_con con
- = let
- (_, _, con_arg_tys, _) = dataConSig con
- in
- ppCat [pprNonSym PprForUser con, -- the data con's name...
- ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
-
- ppr_next_con con = ppCat [ppChar '|', ppr_con con]
-
- pp_specs
- = ppBesides [ppPStr SLIT("_SPECIALIZE_ "), pp_the_list [
- ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
- | ty_maybes <- specs ]]
-
- pp_the_list [p] = p
- pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
-
- pp_maybe Nothing = pp_NONE
- pp_maybe (Just ty) = pprParendGenType sty ty
-
- pp_NONE = ppPStr SLIT("_N_")
-
-pprTyCon PprInterface (TupleTyCon _ name _) specs
- = ASSERT (null specs)
- ppCat [ ppStr "{- ", ppr PprForUser name, ppStr "-}" ]
-
-pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs
- = ASSERT (null specs)
- ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
-
-
-
-
-
-pprIfaceClass :: (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
-
-pprIfaceClass better_id_fn inline_env
- (Class k n tyvar super_classes sdsels ops sels defms insts links)
- = let
- sdsel_infos = map (getIdInfo . better_id_fn) sdsels
- in
- ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
- ppr sty n, lookup_fn tyvar,
- if null sdsel_infos
- || opt_OmitInterfacePragmas
- || (any boringIdInfo sdsel_infos)
- -- ToDo: really should be "all bor..."
- -- but then parsing is more tedious,
- -- and this is really as good in practice.
- then ppNil
- else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
- if (null ops)
- then ppNil
- else ppPStr SLIT("where")],
- ppNest 8 (ppAboves
- [ ppr_op op (better_id_fn sel) (better_id_fn defm)
- | (op,sel,defm) <- zip3 ops sels defms]) ]
- where
- lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
-
- ppr_theta :: TyVar -> [Class] -> Pretty
- ppr_theta tv [] = ppNil
- ppr_theta tv super_classes
- = ppBesides [ppLparen,
- ppIntersperse pp'SP{-'-} (map ppr_assert super_classes),
- ppStr ") =>"]
- where
- ppr_assert (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
-
- pp_sdsel_pragmas sdsels_and_infos
- = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}",
- ppIntersperse pp'SP{-'-}
- [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info
- | (sdsel, info) <- sdsels_and_infos ],
- ppStr "#-}"]
-
- ppr_op op opsel_id defm_id
- = let
- stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
- in
- if opt_OmitInterfacePragmas
- then stuff
- else ppAbove stuff
- (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
- where
- pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)]
- pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)]
-\end{pseudocode}