X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsTypes.lhs;h=797a8f28eaec8d315ec74c8f51d05c356ef149ca;hb=fb6d198f498d4e325a540f28aaa6e1d1530839c3;hp=2b3fc09b1414a6437d48ed4a53482ae4dabe4f82;hpb=5204b7d8bbd3649b38035af9defcdbbc85d165d7;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 2b3fc09..797a8f2 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -15,6 +15,8 @@ module HsTypes ( LBangType, BangType, HsBang(..), getBangType, getBangStrictness, + + ConDeclField(..), pprConDeclFields, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, hsTyVarName, hsTyVarNames, replaceTyVarName, @@ -28,8 +30,6 @@ module HsTypes ( pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr ) where -#include "HsVersions.h" - import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import Type @@ -38,6 +38,7 @@ import BasicTypes import SrcLoc import StaticFlags import Outputable +import FastString \end{code} @@ -75,7 +76,7 @@ data HsBang = HsNoBang -- Only used as a return value for getBangStrictness, instance Outputable HsBang where ppr (HsNoBang) = empty ppr (HsStrict) = char '!' - ppr (HsUnbox) = ptext SLIT("!!") + ppr (HsUnbox) = ptext (sLit "!!") getBangType :: LHsType a -> LHsType a getBangType (L _ (HsBangTy _ ty)) = ty @@ -119,8 +120,6 @@ data HsType name | HsTyVar name -- Type variable or type constructor - | HsBangTy HsBang (LHsType name) -- Bang-style type annotations - | HsAppTy (LHsType name) (LHsType name) @@ -158,10 +157,24 @@ data HsType name | HsSpliceTy (HsSplice name) - | HsDocTy (LHsType name) (LHsDoc name) -- A documented type + | HsDocTy (LHsType name) LHsDocString -- A documented type + + | HsSpliceTyOut Kind -- Used just like KindedTyVar, just between + -- kcHsType and dsHsType + + | HsBangTy HsBang (LHsType name) -- Bang-style type annotations + | HsRecTy [ConDeclField name] -- Only in data type declarations data HsExplicitForAll = Explicit | Implicit + + +data ConDeclField name -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_name :: Located name, + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe LHsDocString } + + ----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: @@ -283,7 +296,7 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where instance OutputableBndr name => Outputable (HsPred name) where ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys) - ppr (HsEqualP t1 t2) = hsep [pprLHsType t1, ptext SLIT("~"), + ppr (HsEqualP t1 t2) = hsep [pprLHsType t1, ptext (sLit "~"), pprLHsType t2] ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] @@ -302,15 +315,22 @@ pprHsForAll exp tvs cxt show_forall = opt_PprStyle_Debug || (not (null tvs) && is_explicit) is_explicit = case exp of {Explicit -> True; Implicit -> False} - forall_part = ptext SLIT("forall") <+> interppSP tvs <> dot + forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc pprHsContext [] = empty -pprHsContext cxt = ppr_hs_context cxt <+> ptext SLIT("=>") +pprHsContext cxt = ppr_hs_context cxt <+> ptext (sLit "=>") ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc ppr_hs_context [] = empty ppr_hs_context cxt = parens (interpp'SP cxt) + +pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc +pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) + where + ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, + cd_fld_doc = doc }) + = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} \begin{code} @@ -352,16 +372,18 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) = maybeParen ctxt_prec pREC_FUN $ sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] -ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr ty -ppr_mono_ty _ (HsTyVar name) = ppr name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 -ppr_mono_ty _ (HsTupleTy con tys) = tupleParens con (interpp'SP tys) -ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) -ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsPredTy pred) = ppr pred -ppr_mono_ty _ (HsNumTy n) = integer n -- generics only -ppr_mono_ty _ (HsSpliceTy s) = pprSplice s +ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr ty +ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds +ppr_mono_ty _ (HsTyVar name) = ppr name +ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 +ppr_mono_ty _ (HsTupleTy con tys) = tupleParens con (interpp'SP tys) +ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) +ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty _ (HsPredTy pred) = ppr pred +ppr_mono_ty _ (HsNumTy n) = integer n -- generics only +ppr_mono_ty _ (HsSpliceTy s) = pprSplice s +ppr_mono_ty _ (HsSpliceTyOut k) = text "" <> dcolon <> ppr k ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ @@ -377,8 +399,11 @@ ppr_mono_ty _ (HsParTy ty) -- But we still use the precedence stuff to add parens because -- toHsType doesn't put in any HsParTys, so we may still need them -ppr_mono_ty _ (HsDocTy ty doc) - = ppr ty <+> ppr (unLoc doc) +ppr_mono_ty ctxt_prec (HsDocTy ty doc) + = maybeParen ctxt_prec pREC_OP $ + ppr_mono_lty pREC_OP ty <+> ppr (unLoc doc) + -- we pretty print Haddock comments on types as if they were + -- postfix operators -------------------------- ppr_fun_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc @@ -387,11 +412,11 @@ ppr_fun_ty ctxt_prec ty1 ty2 p2 = ppr_mono_lty pREC_TOP ty2 in maybeParen ctxt_prec pREC_FUN $ - sep [p1, ptext SLIT("->") <+> p2] + sep [p1, ptext (sLit "->") <+> p2] -------------------------- pabrackets :: SDoc -> SDoc -pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") +pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") \end{code}