Migrate cvs diff from fptools-assoc branch

Wed Jul 26 17:46:55 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Migrate cvs diff from fptools-assoc branch
  - Syntactic support for associated types
  - Renamer support for associated types
  - ATs are only allowed with -fglasgow-exts
  - Handle ATs in the type and class declaration kinding knot-tying exercise

3 files changed, 189 insertions, 50 deletions

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 4e98c24df9..da0082567c 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -45,6 +45,17 @@ import GLAEXTS
 
 {-
 -----------------------------------------------------------------------------
+26 July 2006
+
+Conflicts: 37 shift/reduce
+           1 reduce/reduce
+
+The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
+would think the two should never occur in the same context.
+
+  -=chak
+
+-----------------------------------------------------------------------------
 Conflicts: 36 shift/reduce (1.25)
 
 10 for abiguity in 'if x then y else z + 1'		[State 178]
@@ -430,10 +441,12 @@ topdecls :: { OrdList (LHsDecl RdrName) }
 	| topdecl			{ $1 }
 
 topdecl :: { OrdList (LHsDecl RdrName) }
-  	: tycl_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
+  	: cl_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
+  	| ty_decl			{% checkTopTyClD $1 >>= return.unitOL.L1 }
 	| 'instance' inst_type where
-		{ let (binds,sigs) = cvBindsAndSigs (unLoc $3)
-		  in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
+		{ let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
+		  in unitOL (L (comb3 $1 $2 $3) 
+			    (InstD (InstDecl $2 binds sigs ats))) }
 	| 'default' '(' comma_types0 ')'	{ unitOL (LL $ DefD (DefaultDecl $3)) }
 	| 'foreign' fdecl			{ unitOL (LL (unLoc $2)) }
 	| '{-# DEPRECATED' deprecations '#-}'	{ $2 }
@@ -446,7 +459,21 @@ topdecl :: { OrdList (LHsDecl RdrName) }
 							L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
 						  )) }
 
-tycl_decl :: { LTyClDecl RdrName }
+-- Type classes
+--
+cl_decl :: { LTyClDecl RdrName }
+	: 'class' tycl_hdr fds where
+		{% do { let { (binds, sigs, ats)           = 
+			        cvBindsAndSigs (unLoc $4)
+		            ; (ctxt, tc, tvs, Just tparms) = unLoc $2}
+                      ; checkTyVars tparms
+		      ; return $ L (comb4 $1 $2 $3 $4) 
+				   (mkClassDecl (ctxt, tc, tvs) 
+					        (unLoc $3) sigs binds ats) } }
+
+-- Type declarations
+--
+ty_decl :: { LTyClDecl RdrName }
  	: 'type' type '=' ctype	
 		-- Note type on the left of the '='; this allows
 		-- infix type constructors to be declared
@@ -469,13 +496,6 @@ tycl_decl :: { LTyClDecl RdrName }
 		{ L (comb4 $1 $2 $4 $5)
 		    (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
 
-	| 'class' tycl_hdr fds where
-		{ let 
-			(binds,sigs) = cvBindsAndSigs (unLoc $4)
-		  in
-	 	  L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs 
-					  binds) }
-
 data_or_newtype :: { Located NewOrData }
 	: 'data'	{ L1 DataType }
 	| 'newtype'	{ L1 NewType }
@@ -484,19 +504,49 @@ opt_kind_sig :: { Maybe Kind }
 	: 				{ Nothing }
 	| '::' kind			{ Just $2 }
 
--- tycl_hdr parses the header of a type or class decl,
+-- tycl_hdr parses the header of a type decl,
 -- which takes the form
 --	T a b
 -- 	Eq a => T a
 --	(Eq a, Ord b) => T a b
+--      T Int [a]			-- for associated types
 -- Rather a lot of inlining here, else we get reduce/reduce errors
-tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) }
+tycl_hdr :: { Located (LHsContext RdrName, 
+		       Located RdrName, 
+		       [LHsTyVarBndr RdrName],
+		       Maybe [LHsType RdrName]) }
 	: context '=>' type		{% checkTyClHdr $1         $3 >>= return.LL }
 	| type				{% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
 -----------------------------------------------------------------------------
 -- Nested declarations
 
+-- Type declaration or value declaration
+--
+tydecl  :: { Located (OrdList (LHsDecl RdrName)) }
+tydecl  : ty_decl		        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+	| decl                          { $1 }
+
+tydecls	:: { Located (OrdList (LHsDecl RdrName)) }	-- Reversed
+	: tydecls ';' tydecl		{ LL (unLoc $1 `appOL` unLoc $3) }
+	| tydecls ';'			{ LL (unLoc $1) }
+	| tydecl			{ $1 }
+	| {- empty -}			{ noLoc nilOL }
+
+
+tydecllist 
+        :: { Located (OrdList (LHsDecl RdrName)) }	-- Reversed
+	: '{'            tydecls '}'	{ LL (unLoc $2) }
+	|     vocurly    tydecls close	{ $2 }
+
+-- Form of the body of class and instance declarations
+--
+where 	:: { Located (OrdList (LHsDecl RdrName)) }	-- Reversed
+				-- No implicit parameters
+				-- May have type declarations
+	: 'where' tydecllist		{ LL (unLoc $2) }
+	| {- empty -}			{ noLoc nilOL }
+
 decls 	:: { Located (OrdList (LHsDecl RdrName)) }	
 	: decls ';' decl		{ LL (unLoc $1 `appOL` unLoc $3) }
 	| decls ';'			{ LL (unLoc $1) }
@@ -508,17 +558,16 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
 	: '{'            decls '}'	{ LL (unLoc $2) }
 	|     vocurly    decls close	{ $2 }
 
-where 	:: { Located (OrdList (LHsDecl RdrName)) }
-				-- No implicit parameters
-	: 'where' decllist		{ LL (unLoc $2) }
-	| {- empty -}			{ noLoc nilOL }
-
+-- Binding groups other than those of class and instance declarations
+--
 binds 	::  { Located (HsLocalBinds RdrName) } 		-- May have implicit parameters
+						-- No type declarations
 	: decllist			{ L1 (HsValBinds (cvBindGroup (unLoc $1))) }
 	| '{'            dbinds '}'	{ LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
 	|     vocurly    dbinds close	{ L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
 
 wherebinds :: { Located (HsLocalBinds RdrName) }	-- May have implicit parameters
+						-- No type declarations
 	: 'where' binds			{ LL (unLoc $2) }
 	| {- empty -}			{ noLoc emptyLocalBinds }
 
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index b24ec2e9d7..a6ee5ddc89 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -88,10 +88,18 @@ tdefs	:: { [TyClDecl RdrName] }
 
 tdef	:: { TyClDecl RdrName }
 	: '%data' q_tc_name tv_bndrs '=' '{' cons '}'
-                { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing }
+                { mkTyData DataType ( noLoc []
+				    , noLoc (ifaceExtRdrName $2)
+				    , map toHsTvBndr $3
+				    , Nothing
+				    ) Nothing $6 Nothing }
 	| '%newtype' q_tc_name tv_bndrs trep 
 		{ let tc_rdr = ifaceExtRdrName $2 in
-                  mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
+                  mkTyData NewType ( noLoc []
+				   , noLoc tc_rdr
+				   , map toHsTvBndr $3
+				   , Nothing
+				   ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
 
 -- For a newtype we have to invent a fake data constructor name
 -- It doesn't matter what it is, because it won't be used
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ca24070a04..777ff64d8c 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -8,7 +8,7 @@ module RdrHsSyn (
 	extractHsTyRdrTyVars, 
 	extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
-	mkHsOpApp, mkClassDecl, 
+	mkHsOpApp, mkClassDecl,
 	mkHsNegApp, mkHsIntegral, mkHsFractional,
 	mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,	
@@ -36,7 +36,9 @@ module RdrHsSyn (
 	checkContext,	      -- HsType -> P HsContext
 	checkPred,	      -- HsType -> P HsPred
 	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+	checkTyVars,          -- [LHsType RdrName] -> P ()
 	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
+	checkTopTyClD,	      -- LTyClDecl RdrName -> P (HsDecl RdrName)
 	checkInstType,	      -- HsType -> P HsType
 	checkPattern,	      -- HsExp -> P HsPat
 	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -155,12 +157,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
 		tcdFDs = fds,  
 		tcdSigs = sigs,
-		tcdMeths = mbinds
+		tcdMeths = mbinds,
+		tcdATs   = ats
 		}
 
-mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
+mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
-	     tcdTyVars = tyvars,  tcdCons = data_cons, 
+	     tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, 
 	     tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 \end{code}
 
@@ -198,23 +201,29 @@ cvTopDecls decls = go (fromOL decls)
 			    where (L l' b', ds') = getMonoBind (L l b) ds
     go (d : ds)   	    = d : go ds
 
+-- Declaration list may only contain value bindings and signatures
+--
 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 cvBindGroup binding
-  = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
-    ValBindsIn mbs sigs
-    }
+  = case cvBindsAndSigs binding of
+      (mbs, sigs, []) ->                 -- list of type decls *always* empty
+        ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (Bag (LHsBind RdrName), [LSig RdrName])
+  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
 -- Input decls contain just value bindings and signatures
+-- and in case of class or instance declarations also
+-- associated data or synonym definitions
 cvBindsAndSigs  fb = go (fromOL fb)
   where
-    go [] 		   = (emptyBag, [])
-    go (L l (SigD s) : ds) = (bs, L l s : ss)
-			    where (bs,ss) = go ds
-    go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
-			    where (b',ds') = getMonoBind (L l b) ds
-				  (bs,ss)  = go ds'
+    go [] 		   = (emptyBag, [], [])
+    go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
+			    where (bs, ss, ts) = go ds
+    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+			    where (b', ds')    = getMonoBind (L l b) ds
+				  (bs, ss, ts) = go ds'
+    go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
+			    where (bs, ss, ts) = go ds
 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
@@ -368,44 +377,61 @@ checkInstType (L l t)
 	ty ->   do dict_ty <- checkDictTy (L l ty)
 	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
-checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-checkTyVars tvs 
-  = mapM chk tvs
+-- Check that the given list of type parameters are all type variables
+-- (possibly with a kind signature).
+--
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tvs = mapM_ chk tvs
   where
-	--  Check that the name space is correct!
+	-- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-	| isRdrTyVar tv = return (L l (KindedTyVar tv k))
+	| isRdrTyVar tv = return ()
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv = return (L l (UserTyVar tv))
+        | isRdrTyVar tv = return ()
     chk (L l other)
 	= parseError l "Type found where type variable expected"
 
 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
-checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
+checkSynHdr ty = do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+		    ; checkTyVars tparms
 		    ; return (tc, tvs) }
 
 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
-  -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+  -> P (LHsContext RdrName,	     -- the type context
+        Located RdrName,	     -- the head symbol (type or class name)
+	[LHsTyVarBndr RdrName],	     -- free variables of the non-context part
+	Maybe [LHsType RdrName])     -- parameters of head symbol; wrapped into
+				     -- 'Maybe' for 'mkTyData'
 -- The header of a type or class decl should look like
 --	(C a, D b) => T a b
 -- or	T a b
 -- or	a + b
 -- etc
+-- With associated types, we can also have non-variable parameters; ie,
+--      T Int [a]
+-- The unaltered parameter list is returned in the fourth component of the
+-- result.  Eg, for
+--      T Int [a]
+-- we return
+--      ('()', 'T', ['a'], Just ['Int', '[a]'])
 checkTyClHdr (L l cxt) ty
-  = do (tc, tvs) <- gol ty []
+  = do (tc, tvs, parms) <- gol ty []
        mapM_ chk_pred cxt
-       return (L l cxt, tc, tvs)
+       return (L l cxt, tc, tvs, Just parms)
   where
     gol (L l ty) acc = go l ty acc
 
     go l (HsTyVar tc)    acc 
-	| not (isRdrTyVar tc)   = checkTyVars acc		>>= \ tvs ->
-				  return (L l tc, tvs)
-    go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)	>>= \ tvs ->
-				  return (tc, tvs)
+	| not (isRdrTyVar tc)   = do
+				    tvs <- extractTyVars acc
+				    return (L l tc, tvs, acc)
+    go l (HsOpTy t1 tc t2) acc  = do
+				    tvs <- extractTyVars (t1:t2:acc)
+				    return (tc, tvs, acc)
     go l (HsParTy ty)    acc    = gol ty acc
     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
-    go l other	         acc    = parseError l "Malformed LHS to type of class declaration"
+    go l other	         acc    = 
+      parseError l "Malformed head of type or class declaration"
 
 	-- The predicates in a type or class decl must all
 	-- be HsClassPs.  They need not all be type variables,
@@ -414,7 +440,63 @@ checkTyClHdr (L l cxt) ty
     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 
-  
+-- Extract the type variables of a list of type parameters.
+--
+-- * Type arguments can be complex type terms (needed for associated type
+--   declarations).
+--
+extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+extractTyVars tvs = collects [] tvs
+  where
+        -- Collect all variables (1st arg serves as an accumulator)
+    collect tvs (L l (HsForAllTy _ _ _ _)) =
+      parseError l "Forall type not allowed as type parameter"
+    collect tvs (L l (HsTyVar tv))
+      | isRdrTyVar tv			   = return $ L l (UserTyVar tv) : tvs
+      | otherwise			   = return tvs
+    collect tvs (L l (HsBangTy _ _      )) =
+      parseError l "Bang-style type annotations not allowed as type parameter"
+    collect tvs (L l (HsAppTy t1 t2     )) = do
+					       tvs' <- collect tvs t2
+					       collect tvs' t1
+    collect tvs (L l (HsFunTy t1 t2     )) = do
+					       tvs' <- collect tvs t2
+					       collect tvs' t1
+    collect tvs (L l (HsListTy t        )) = collect tvs t
+    collect tvs (L l (HsPArrTy t        )) = collect tvs t
+    collect tvs (L l (HsTupleTy _ ts    )) = collects tvs ts
+    collect tvs (L l (HsOpTy t1 _ t2    )) = do
+					       tvs' <- collect tvs t2
+					       collect tvs' t1
+    collect tvs (L l (HsParTy t         )) = collect tvs t
+    collect tvs (L l (HsNumTy t         )) = return tvs
+    collect tvs (L l (HsPredTy t        )) = 
+      parseError l "Predicate not allowed as type parameter"
+    collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
+	| isRdrTyVar tv                    = 
+	  return $ L l (KindedTyVar tv k) : tvs
+	| otherwise                        =
+	  parseError l "Kind signature only allowed for type variables"
+    collect tvs (L l (HsSpliceTy t      )) = 
+      parseError l "Splice not allowed as type parameter"
+
+        -- Collect all variables of a list of types
+    collects tvs []     = return tvs
+    collects tvs (t:ts) = do
+			    tvs' <- collects tvs ts
+			    collect tvs' t
+
+-- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring
+-- that all type parameters are variables only (which is in contrast to
+-- associated type declarations).
+--
+checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
+checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = 
+  do
+    checkTyVars typats
+    return $ TyClD d {tcdTyPats = Nothing}
+checkTopTyClD (L _ d)                             = return $ TyClD d
+
 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 checkContext (L l t)
   = check t