X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsDecls.lhs;fp=ghc%2Fcompiler%2FhsSyn%2FHsDecls.lhs;h=ddd11a662d86e1a4c240898f440a86e9a648bdc6;hb=36436bc62a98f53e126ec02fe946337c4c766c3f;hp=1cf7c85860225b51c224ec18d9b70069617f5b63;hpb=8761b73561019d5514194fc8b0eee2b13f0e0ec9;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 1cf7c85..ddd11a6 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -14,7 +14,7 @@ module HsDecls (
 	DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
 	ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
 	CImportSpec(..), FoType(..),
-	ConDecl(..), LConDecl,	
+	ConDecl(..), ResType(..), LConDecl,	
 	DeprecDecl(..),  LDeprecDecl,
 	HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
 	tcdName, tyClDeclNames, tyClDeclTyVars,
@@ -48,7 +48,7 @@ import FunDeps		( pprFundeps )
 import Class		( FunDep )
 import Outputable	
 import Util		( count )
-import SrcLoc		( Located(..), unLoc )
+import SrcLoc		( Located(..), unLoc, noLoc )
 import FastString
 \end{code}
 
@@ -343,8 +343,8 @@ data TyClDecl name
 							-- (only for the 'where' form)
 
 		tcdCons	  :: [LConDecl name],	 	-- Data constructors
-			-- For data T a = T1 | T2 a          the LConDecls are all ConDecls
-			-- For data T a where { T1 :: T a }  the LConDecls are all GadtDecls
+			-- 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
@@ -472,8 +472,7 @@ pp_decl_head :: OutputableBndr name
    -> SDoc
 pp_decl_head context thing tyvars
   = hsep [pprHsContext context, ppr thing, interppSP tyvars]
-
-pp_condecls cs@(L _ (GadtDecl _ _) : _) -- In GADT syntax
+pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
   = hang (ptext SLIT("where")) 2 (vcat (map ppr cs))
 pp_condecls cs 			  -- In H98 syntax
   = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
@@ -502,18 +501,27 @@ instance Outputable NewOrData where
 type LConDecl name = Located (ConDecl name)
 
 data ConDecl name
-  = ConDecl 	(Located name)		-- Constructor name; this is used for the
-					-- DataCon itself, and for the user-callable wrapper Id
-
-		[LHsTyVarBndr name]	-- Existentially quantified type variables
-		(LHsContext name)	-- ...and context
-					-- If both are empty then there are no existentials
-		(HsConDetails name (LBangType name))
-
-  | GadtDecl    (Located name)          -- Constructor name; this is used for the
-					-- DataCon itself, and for the user-callable wrapper Id
-                (LHsType name)          -- Constructor type; it may have HsBangs on the 
-					-- argument types
+  = ConDecl
+    { con_name      :: Located name	    -- Constructor name; this is used for the
+                                            -- DataCon itself, and for the user-callable wrapper Id
+
+    , con_explicit  :: HsExplicitForAll     -- Is there an user-written forall? (cf. HStypes.HsForAllTy)
+
+    , con_qvars     :: [LHsTyVarBndr name]  -- ResTyH98: the constructor's existential type variables
+					    -- ResTyGADT:    all the constructor's quantified type variables
+
+    , 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_res       :: ResType name         -- Result type of the constructor
+    }
+
+data ResType name
+   = ResTyH98		-- Constructor was declared using Haskell 98 syntax
+   | ResTyGADT (LHsType name)	-- Constructor was declared using GADT-style syntax,
+				--	and here is its result type
 \end{code}
 
 \begin{code}
@@ -524,17 +532,13 @@ conDeclsNames :: Eq name => [ConDecl name] -> [Located name]
 conDeclsNames cons
   = snd (foldl do_one ([], []) cons)
   where
-    do_one (flds_seen, acc) (ConDecl lname _ _ (RecCon flds))
+    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)
 	where
 	  new_flds = [ f | (f,_) <- flds, not (unLoc f `elem` flds_seen) ]
 
-    do_one (flds_seen, acc) (ConDecl lname _ _ _)
-	= (flds_seen, lname:acc)
-
--- gaw 2004
-    do_one (flds_seen, acc) (GadtDecl lname _)
-	= (flds_seen, lname:acc)
+    do_one (flds_seen, acc) c
+	= (flds_seen, (con_name c):acc)
 
 conDetailsTys details = map getBangType (hsConArgs details)
 \end{code}
@@ -542,26 +546,26 @@ conDetailsTys details = map getBangType (hsConArgs details)
 
 \begin{code}
 instance (OutputableBndr name) => Outputable (ConDecl name) where
-    ppr (ConDecl con tvs cxt con_details)
-      = sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details]
-    ppr (GadtDecl con ty)
-      = ppr con <+> dcolon <+> ppr ty
-
-ppr_con_details con (InfixCon ty1 ty2)
-  = hsep [ppr ty1, pprHsVar con, ppr ty2]
-
--- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even
--- if the constructor is an infix one.  This is because in an interface file
--- we don't distinguish between the two.  Hence when printing these for the
--- user, we need to parenthesise infix constructor names.
-ppr_con_details con (PrefixCon tys)
-  = hsep (pprHsVar con : map ppr tys)
-
-ppr_con_details con (RecCon fields)
-  = ppr con <+> braces (sep (punctuate comma (map ppr_field fields)))
+    ppr = pprConDecl
+
+pprConDecl (ConDecl con expl tvs cxt details ResTyH98)
+  = sep [pprHsForAll expl tvs cxt, ppr_details con details]
   where
-    ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty
+    ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2]
+    ppr_details con (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
+    ppr_details con (RecCon fields)  = ppr con <+> ppr_fields fields
+
+pprConDecl (ConDecl con expl tvs cxt details (ResTyGADT res_ty))
+  = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_details details]
+  where
+    ppr_details (PrefixCon arg_tys) = dcolon <+> ppr (foldr mk_fun_ty res_ty arg_tys)
+    ppr_details (RecCon fields)     = ppr fields <+> dcolon <+> ppr res_ty
+    ppr_details (PrefixCon _)       = pprPanic "pprConDecl" (ppr con)
+
+    mk_fun_ty a b = noLoc (HsFunTy a b)
 
+ppr_fields fields = braces (sep (punctuate comma (map ppr_field fields)))
+ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty
 \end{code}
 
 %************************************************************************