New syntax for GADT-style record declarations, and associated refactoring

[ghc-hetmet.git] / compiler / hsSyn / HsTypes.lhs

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 25d6566..d5b674b 100644 (file)
--- 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
@@ -76,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
@@ -120,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)
 
@@ -161,8 +159,19 @@ data HsType name
 
   | HsDocTy             (LHsType name) (LHsDoc name) -- A documented type
 
+  | 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 (LHsDoc name) }
+
+
 -----------------------
 -- Combine adjacent for-alls. 
 -- The following awkward situation can happen otherwise:
@@ -284,7 +293,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]
 
@@ -303,15 +312,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}
@@ -354,6 +370,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
     sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
 
 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 ctxt_prec (HsFunTy ty1 ty2)   = ppr_fun_ty ctxt_prec ty1 ty2
 ppr_mono_ty _         (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
@@ -378,8 +395,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
@@ -388,11 +408,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}