X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsDecls.lhs;h=572a8422d98eb46af52272028bb1e5c34dde34c6;hb=fa6c4bf01427a4191a595afecf90d96b27bad306;hp=bd2593f86f9b5538e8433aedc8e895b80224bcc1;hpb=87124ee17065dd3d549c5b7547266c377b689edf;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index bd2593f..572a842 100644
--- 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
@@ -399,8 +399,10 @@ data TyClDecl name
 			-- instance' decl with explicit kind sig
 
 		tcdCons	  :: [LConDecl name],	 	-- Data constructors
-			-- For data T a = T1 | T2 a          the LConDecls all have ResTyH98
-			-- For data T a where { T1 :: T a }  the LConDecls all have ResTyGADT
+			-- For data T a = T1 | T2 a          
+                        --   the LConDecls all have ResTyH98
+			-- For data T a where { T1 :: T a }  
+                        --   the LConDecls all have ResTyGADT
 
 		tcdDerivs :: Maybe [LHsType name]
 			-- Derivings; Nothing => not specified
@@ -427,9 +429,9 @@ data TyClDecl name
 		tcdSigs    :: [LSig name],		-- Methods' signatures
 		tcdMeths   :: LHsBinds name,		-- Default methods
 		tcdATs	   :: [LTyClDecl name],		-- Associated types; ie
-							--   only 'TyData',
-							--   'TyFunction',
-							--   and 'TySynonym'
+							--   only 'TyFamily' and
+							--   'TySynonym'; the
+                                                        --   latter for defaults
 		tcdDocs    :: [LDocDecl name]		-- Haddock docs
     }
 
@@ -440,7 +442,7 @@ data NewOrData
 
 data FamilyFlavour
   = TypeFamily			-- "type family ..."
-  | DataFamily NewOrData	-- "newtype family ..." or "data family ..."
+  | DataFamily	                -- "data family ..."
 \end{code}
 
 Simple classifiers
@@ -536,9 +538,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
@@ -651,13 +652,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,
@@ -665,7 +678,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
@@ -673,14 +686,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}
   
 
@@ -688,6 +700,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
@@ -704,7 +717,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}
 
 %************************************************************************
@@ -849,11 +866,11 @@ data FoType = DNType 		-- In due course we'll add subtype stuff
 
 instance OutputableBndr name => Outputable (ForeignDecl name) where
   ppr (ForeignImport n ty fimport) =
-    ptext SLIT("foreign import") <+> ppr fimport <+> 
-    ppr n <+> dcolon <+> ppr ty
+    hang (ptext SLIT("foreign import") <+> ppr fimport <+> ppr n)
+       2 (dcolon <+> ppr ty)
   ppr (ForeignExport n ty fexport) =
-    ptext SLIT("foreign export") <+> ppr fexport <+> 
-    ppr n <+> dcolon <+> ppr ty
+    hang (ptext SLIT("foreign export") <+> ppr fexport <+> ppr n)
+       2 (dcolon <+> ppr ty)
 
 instance Outputable ForeignImport where
   ppr (DNImport			        spec) =