Add several new record features

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

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 1822b58..4f0fc03 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -17,7 +17,8 @@ module HsDecls (
        DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
        ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
        CImportSpec(..), FoType(..),
-       ConDecl(..), ResType(..), LConDecl,     
+       ConDecl(..), ResType(..), ConDeclField(..), LConDecl,   
+       HsConDeclDetails, hsConDeclArgTys,
        DocDecl(..), LDocDecl, docDeclDoc,
        DeprecDecl(..),  LDeprecDecl,
        HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
@@ -25,7 +26,6 @@ module HsDecls (
        isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
        isFamInstDecl, 
        countTyClDecls,
-       conDetailsTys,
        instDeclATs,
        collectRuleBndrSigTys, 
     ) where
@@ -358,7 +358,7 @@ Interface file code:
 --
 --   * If it is 'Just pats', we have the definition of an indexed type.  Then,
 --     'pats' are type patterns for the type-indexes of the type constructor
---     and 'tcdVars' are the variables in those patterns.  Hence, the arity of
+--     and 'tcdTyVars' are the variables in those patterns.  Hence, the arity of
 --     the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
 --     *not* 'length tcdVars'.
 --
@@ -373,12 +373,16 @@ data TyClDecl name
                tcdFoType   :: FoType
     }
 
+       -- type/data/newtype family T :: *->*
   | TyFamily {  tcdFlavour:: FamilyFlavour,            -- type, new, or data
                tcdLName  :: Located name,              -- type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- type variables
                tcdKind   :: Maybe Kind                 -- result kind
     }
 
+       -- Declares a data type or newtype, giving its construcors
+       --      data/newtype T a = <constrs>
+       --      data/newtype instance T [a] = <constrs>
   | TyData {   tcdND     :: NewOrData,
                tcdCtxt   :: LHsContext name,           -- Context
                tcdLName  :: Located name,              -- Type constructor
@@ -406,9 +410,6 @@ data TyClDecl name
                        -- Typically the foralls and ty args are empty, but they
                        -- are non-empty for the newtype-deriving case
     }
-       -- data instance: tcdPats = Just tys
-       --
-       -- data:          tcdPats = Nothing, 
 
   | TySynonym {        tcdLName  :: Located name,              -- type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- type variables
@@ -439,7 +440,7 @@ data NewOrData
 
 data FamilyFlavour
   = TypeFamily                 -- "type family ..."
-  | DataFamily NewOrData       -- "newtype family ..." or "data family ..."
+  | DataFamily                 -- "data family ..."
 \end{code}
 
 Simple classifiers
@@ -535,9 +536,8 @@ instance OutputableBndr name
       = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
         where
          pp_flavour = case flavour of
-                        TypeFamily          -> ptext SLIT("type family")
-                        DataFamily NewType  -> ptext SLIT("newtype family")
-                        DataFamily DataType -> ptext SLIT("data family")
+                        TypeFamily -> ptext SLIT("type family")
+                        DataFamily -> ptext SLIT("data family")
 
           pp_kind = case mb_kind of
                      Nothing   -> empty
@@ -650,13 +650,25 @@ data ConDecl name
     , con_cxt       :: LHsContext name      -- The context.  This *does not* include the
                                            -- "stupid theta" which lives only in the TyData decl
 
-    , con_details   :: HsConDetails name (LBangType name)      -- The main payload
+    , con_details   :: HsConDeclDetails name   -- The main payload
 
     , con_res       :: ResType name         -- Result type of the constructor
 
     , con_doc       :: Maybe (LHsDoc name)  -- A possible Haddock comment
     }
 
+type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
+
+hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
+hsConDeclArgTys (PrefixCon tys)    = tys
+hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
+hsConDeclArgTys (RecCon flds)      = map cd_fld_type flds
+
+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) }
+
 data ResType name
    = ResTyH98          -- Constructor was declared using Haskell 98 syntax
    | ResTyGADT (LHsType name)  -- Constructor was declared using GADT-style syntax,
@@ -664,7 +676,7 @@ data ResType name
 \end{code}
 
 \begin{code}
-conDeclsNames :: Eq name => [ConDecl name] -> [Located name]
+conDeclsNames :: forall name. Eq name => [ConDecl name] -> [Located name]
   -- See tyClDeclNames for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
@@ -672,14 +684,13 @@ conDeclsNames cons
   = snd (foldl do_one ([], []) cons)
   where
     do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds })
-       = (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc)
+       = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
        where
-         new_flds = [ f | (HsRecField f _ _) <- flds, not (unLoc f `elem` flds_seen) ]
+         new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
+                              (map cd_fld_name flds)
 
     do_one (flds_seen, acc) c
        = (flds_seen, (con_name c):acc)
-
-conDetailsTys details = map getBangType (hsConArgs details)
 \end{code}
   
 
@@ -687,6 +698,7 @@ conDetailsTys details = map getBangType (hsConArgs details)
 instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
+pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
 pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
   where
@@ -703,7 +715,11 @@ pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _)
 pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
   = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty]
 
-ppr_fields fields = braces (sep (punctuate comma (map ppr fields)))
+ppr_fields 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}
 
 %************************************************************************