[project @ 2005-10-14 11:22:41 by simonpj]

Add record syntax for GADTs
	~~~~~~~~~~~~~~~~~~~~~~~~~~~

Atrijus Tang wanted to add record syntax for GADTs and existential
types, so he and I worked on it a bit at ICFP.  This commit is the
result.  Now you can say

 data T a where
  T1 { x :: a }           	 :: T [a]
  T2 { x :: a, y :: Int } 	 :: T [a]
  forall b. Show b =>
 	T3 { naughty :: b, ok :: Int } :: T Int
  T4 :: Eq a => a -> b -> T (a,b)

Here the constructors are declared using record syntax.

Still to come after this commit:
  - User manual documentation
  - More regression tests
  - Some missing cases in the parser (e.g. T3 won't parse)
Autrijus is going to do these.


Here's a quick summary of the rules.  (Atrijus is going to write
proper documentation shortly.)

Defnition: a 'vanilla' constructor has a type of the form
	forall a1..an. t1 -> ... -> tm -> T a1 ... an
No existentials, no context, nothing.  A constructor declared with
Haskell-98 syntax is vanilla by construction.  A constructor declared
with GADT-style syntax is vanilla iff its type looks like the above.
(In the latter case, the order of the type variables does not matter.)

* You can mix record syntax and non-record syntax in a single decl

* All constructors that share a common field 'x' must have the
  same result type (T [a] in the example).

* You can use field names without restriction in record construction
  and record pattern matching.

* Record *update* only works for data types that only have 'vanilla'
  constructors.

* Consider the field 'naughty', which uses a type variable that does
  not appear in the result type ('b' in the example).  You can use the
  field 'naughty' in pattern matching and construction, but NO
  SELECTOR function is generated for 'naughty'.  [An attempt to use
  'naughty' as a selector function will elicit a helpful error
  message.]

* Data types declared in GADT syntax cannot have a context. So this
is illegal:
	data (Monad m) => T a where
		  ....

* Constructors in GADT syntax can have a context (t.g. T3, T4 above)
  and that context is stored in the constructor and made available
  when the constructor is pattern-matched on.  WARNING: not competely
  implemented yet, but that's the plan.



Implementation notes
~~~~~~~~~~~~~~~~~~~~
- Data constructors (even vanilla ones) no longer share the type
  variables of their parent type constructor.

- HsDecls.ConDecl has changed quite a bit

- TyCons don't record the field labels and type any more (doesn't
  make sense for existential fields)

- GlobalIdDetails records which selectors are 'naughty', and hence
  don't have real code.

3 files changed, 48 insertions, 24 deletions

diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 22f75ae2b2..6ce037970f 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -117,13 +117,17 @@ hsSigFVs (SpecSig v ty)     = extractHsTyNames ty
 hsSigFVs other		    = emptyFVs
 
 ----------------
-conDeclFVs (L _ (ConDecl _ tyvars context details))
+-- XXX - autrijus - handle return type for GADT
+conDeclFVs (L _ (ConDecl _ _ tyvars context details _))
   = delFVs (map hsLTyVarName tyvars) $
     extractHsCtxtTyNames context	  `plusFV`
     conDetailsFVs details
+
+{-
 -- gaw 2004
 conDeclFVs (L _ (GadtDecl _ ty)) 
   = extractHsTyNames ty
+-}
 
 conDetailsFVs (PrefixCon btys)     = plusFVs (map bangTyFVs btys)
 conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 337b3d20c0..c113af7236 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -16,7 +16,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr )
 
 import HsSyn
 import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv )
-import RdrHsSyn		( extractGenericPatTyVars )
+import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
 import RnBinds		( rnTopBinds, rnMethodBinds, renameSigs )
@@ -40,6 +40,7 @@ import SrcLoc		( Located(..), unLoc, getLoc, noLoc )
 import DynFlags	( DynFlag(..) )
 import Maybes		( seqMaybe )
 import Maybe            ( isNothing )
+import BasicTypes       ( Boxity(..) )
 \end{code}
 
 @rnSourceDecl@ `renames' declarations.
@@ -445,9 +446,9 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
 	     	   deriv_fvs) }
 
   | otherwise	-- GADT
-  = ASSERT( null (unLoc context) )
-    do	{ tycon' <- lookupLocatedTopBndrRn tycon
-	; tyvars' <- bindTyVarsRn data_doc tyvars 
+  = do	{ tycon' <- lookupLocatedTopBndrRn tycon
+	; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
+    	; tyvars' <- bindTyVarsRn data_doc tyvars 
 				  (\ tyvars' -> return tyvars')
 		-- For GADTs, the type variables in the declaration 
 		-- do not scope over the constructor signatures
@@ -463,14 +464,13 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
   where
     is_vanilla = case condecls of	-- Yuk
 		     [] 		   -> True
-		     L _ (ConDecl {}) : _  -> True
+		     L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 		     other		   -> False
 
     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
     con_names = map con_names_helper condecls
 
-    con_names_helper (L _ (ConDecl n _ _ _)) = n
-    con_names_helper (L _ (GadtDecl n _)) = n
+    con_names_helper (L _ c) = con_name c
 
     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
     rn_derivs (Just ds) = rnLHsTypes data_doc ds	`thenM` \ ds' -> 
@@ -542,6 +542,10 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
     meth_doc = text "In the default-methods for class"	<+> ppr cname
     cls_doc  = text "In the declaration for class" 	<+> ppr cname
     sig_doc  = text "In the signatures for class"  	<+> ppr cname
+
+badGadtStupidTheta tycon
+  = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
+	  ptext SLIT("(You can put a context on each contructor, though.)")]
 \end{code}
 
 %*********************************************************
@@ -556,24 +560,40 @@ rnConDecls tycon condecls
   = mappM (wrapLocM rnConDecl) condecls
 
 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (ConDecl name tvs cxt details)
-  = addLocM checkConName name		`thenM_` 
-    lookupLocatedTopBndrRn name		`thenM` \ new_name ->
-
-    bindTyVarsRn doc tvs 		$ \ new_tyvars ->
-    rnContext doc cxt			`thenM` \ new_context ->
-    rnConDetails doc details		`thenM` \ new_details -> 
-    returnM (ConDecl new_name new_tyvars new_context new_details)
-  where
-    doc = text "In the definition of data constructor" <+> quotes (ppr name)
+rnConDecl (ConDecl name expl tvs cxt details res_ty)
+  = do	{ addLocM checkConName name
 
-rnConDecl (GadtDecl name ty) 
-  = addLocM checkConName name		`thenM_` 
-    lookupLocatedTopBndrRn name		`thenM` \ new_name ->
-    rnHsSigType doc ty                  `thenM` \ new_ty ->
-    returnM (GadtDecl new_name new_ty)
+	; new_name <- lookupLocatedTopBndrRn name
+	; name_env <- getLocalRdrEnv
+	
+	-- For H98 syntax, the tvs are the existential ones
+	-- For GADT syntax, the tvs are all the quantified tyvars
+	-- Hence the 'filter' in the ResTyH98 case only
+	; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
+	      arg_tys       = hsConArgs details
+	      implicit_tvs  = case res_ty of
+	      	    		ResTyH98 -> filter not_in_scope $
+						get_rdr_tvs arg_tys
+	      	    		ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+	      tvs' = case expl of
+	        	Explicit -> tvs
+		    	Implicit -> userHsTyVarBndrs implicit_tvs
+
+	; bindTyVarsRn doc tvs' $ \new_tyvars -> do
+	{ new_context <- rnContext doc cxt
+        ; new_details <- rnConDetails doc details
+        ; new_res_ty  <- rnConResult doc res_ty
+        ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
+        ; traceRn (text "****** - autrijus" <> ppr rv)
+        ; return rv } }
   where
     doc = text "In the definition of data constructor" <+> quotes (ppr name)
+    get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
+
+rnConResult _ ResTyH98 = return ResTyH98
+rnConResult doc (ResTyGADT ty) = do
+    ty' <- rnHsSigType doc ty
+    return $ ResTyGADT ty'
 
 rnConDetails doc (PrefixCon tys)
   = mappM (rnLHsType doc) tys	`thenM` \ new_tys  ->
diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs
index 31279ff1ec..c30f1b72b5 100644
--- a/ghc/compiler/rename/RnTypes.lhs
+++ b/ghc/compiler/rename/RnTypes.lhs
@@ -99,7 +99,7 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty)
 	-- class signatures:
 	--	class C a where { op :: a -> a }
 	forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
-	tyvar_bndrs = [ L loc (UserTyVar v) | (L loc v) <- forall_tyvars ]
+	tyvar_bndrs   = userHsTyVarBndrs forall_tyvars
     in
     rnForAll doc Implicit tyvar_bndrs ctxt ty