Parser support for assoc synonyms

Fri Jul 28 21:52:46 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Parser support for assoc synonyms

5 files changed, 155 insertions, 54 deletions

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 070079e6a6..f2bf9d3904 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -18,7 +18,7 @@ module HsDecls (
 	DeprecDecl(..),  LDeprecDecl,
 	HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
 	tcdName, tyClDeclNames, tyClDeclTyVars,
-	isClassDecl, isSynDecl, isDataDecl, 
+	isClassDecl, isTFunDecl, isSynDecl, isTEqnDecl, isDataDecl, 
 	countTyClDecls,
 	conDetailsTys,
 	instDeclATs,
@@ -359,8 +359,15 @@ data TyClDecl name
 			-- are non-empty for the newtype-deriving case
     }
 
+  | TyFunction {tcdLName  :: Located name,	        -- type constructor
+		tcdTyVars :: [LHsTyVarBndr name],	-- type variables
+		tcdIso    :: Bool,	                -- injective type?
+		tcdKindSig:: Maybe Kind			-- result kind
+    }
+
   | TySynonym {	tcdLName  :: Located name,	        -- type constructor
 		tcdTyVars :: [LHsTyVarBndr name],	-- type variables
+		tcdTyPats :: Maybe [LHsType name],	-- Type patterns
 		tcdSynRhs :: LHsType name	        -- synonym expansion
     }
 
@@ -384,10 +391,20 @@ data NewOrData
 Simple classifiers
 
 \begin{code}
-isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool
+isTFunDecl, isDataDecl, isSynDecl, isTEqnDecl, isClassDecl :: 
+  TyClDecl name -> Bool
+
+-- type function kind signature
+isTFunDecl (TyFunction {}) = True
+isTFunDecl other	   = False
+
+-- vanilla Haskell type synonym
+isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
+isSynDecl other		                    = False
 
-isSynDecl (TySynonym {}) = True
-isSynDecl other		 = False
+-- type equation (of a type function)
+isTEqnDecl (TySynonym {tcdTyPats = Just _}) = True
+isTEqnDecl other		            = False
 
 isDataDecl (TyData {}) = True
 isDataDecl other       = False
@@ -408,8 +425,11 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
 -- For record fields, the first one counts as the SrcLoc
 -- We use the equality to filter out duplicate field names
 
-tyClDeclNames (TySynonym   {tcdLName = name})  = [name]
-tyClDeclNames (ForeignType {tcdLName = name})  = [name]
+tyClDeclNames (TyFunction  {tcdLName = name})    = [name]
+tyClDeclNames (TySynonym   {tcdLName = name,
+			    tcdTyPats= Nothing}) = [name]
+tyClDeclNames (TySynonym   {}                  ) = []     -- type equation
+tyClDeclNames (ForeignType {tcdLName = name})    = [name]
 
 tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
   = cls_name : 
@@ -418,18 +438,22 @@ tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
 tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
   = tc_name : conDeclsNames (map unLoc cons)
 
-tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (TyData    {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (ForeignType {})		     = []
+tyClDeclTyVars (TyFunction  {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (TyData      {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ClassDecl   {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ForeignType {})		       = []
 \end{code}
 
 \begin{code}
-countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int)
-	-- class, data, newtype, synonym decls
+countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
+	-- class, synonym decls, type function signatures,
+	-- type function equations, data, newtype
 countTyClDecls decls 
  = (count isClassDecl     decls,
     count isSynDecl       decls,
+    count isTFunDecl      decls,
+    count isTEqnDecl      decls,
     count isDataTy        decls,
     count isNewTy         decls) 
  where
@@ -447,8 +471,22 @@ instance OutputableBndr name
     ppr (ForeignType {tcdLName = ltycon})
 	= hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon]
 
-    ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
-      = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars Nothing <+> equals)
+    ppr (TyFunction {tcdLName = ltycon, tcdTyVars = tyvars, tcdIso = iso, 
+		     tcdKindSig = mb_sig})
+      = typeMaybeIso <+> pp_decl_head [] ltycon tyvars Nothing <+> 
+	ppr_sig mb_sig
+        where
+	  typeMaybeIso = if iso 
+			 then ptext SLIT("type iso") 
+			 else ptext SLIT("type")
+
+	  ppr_sig Nothing     = empty
+	  ppr_sig (Just kind) = dcolon <+> pprKind kind
+
+    ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
+		    tcdSynRhs = mono_ty})
+      = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars typats <+> 
+	      equals)
 	     4 (ppr mono_ty)
 
     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index e4e8ac560c..a750ad84cc 100644
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -38,6 +38,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
 		("FixityDecls      ", fixity_sigs),
 		("DefaultDecls     ", default_ds),
 	      	("TypeDecls        ", type_ds),
+	      	("TypeFunDecls     ", type_fun_ds),
+	      	("TypeEquations    ", type_equs),
 	      	("DataDecls        ", data_ds),
 	      	("NewTypeDecls     ", newt_ds),
 	      	("DataConstrs      ", data_constrs),
@@ -73,7 +75,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
 		-- in class decls.  ToDo
 
     tycl_decls  = [d | TyClD d <- decls]
-    (class_ds, type_ds, data_ds, newt_ds) = countTyClDecls tycl_decls
+    (class_ds, type_ds, type_fun_ds, type_equs, data_ds, newt_ds) = 
+      countTyClDecls tycl_decls
 
     inst_decls  = [d | InstD d <- decls]
     inst_ds     = length inst_decls
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 0b02f41a9b..aed9cfb965 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -376,6 +376,7 @@ data Token
   | ITccallconv
   | ITdotnet
   | ITmdo
+  | ITiso
 
 	-- Pragmas
   | ITinline_prag Bool		-- True <=> INLINE, False <=> NOINLINE
@@ -499,6 +500,7 @@ isSpecial ITunsafe    	= True
 isSpecial ITccallconv   = True
 isSpecial ITstdcallconv = True
 isSpecial ITmdo		= True
+isSpecial ITiso		= True
 isSpecial _             = False
 
 -- the bitmap provided as the third component indicates whether the
@@ -539,6 +541,7 @@ reservedWordsFM = listToUFM $
 
       	( "forall",	ITforall,	 bit tvBit),
 	( "mdo",	ITmdo,		 bit glaExtsBit),
+	( "iso",	ITiso,		 bit glaExtsBit),
 
 	( "foreign",	ITforeign,	 bit ffiBit),
 	( "export",	ITexport,	 bit ffiBit),
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index da0082567c..7b9786fa03 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -113,6 +113,7 @@ and LL.  Each of these macros can be thought of as having type
 They each add a SrcSpan to their argument.
 
    L0	adds 'noSrcSpan', used for empty productions
+     -- This doesn't seem to work anymore -=chak
 
    L1   for a production with a single token on the lhs.  Grabs the SrcSpan
 	from that token.
@@ -175,7 +176,7 @@ incorrect.
  'where' 	{ L _ ITwhere }
  '_scc_'	{ L _ ITscc }	      -- ToDo: remove
 
- 'forall'	{ L _ ITforall }			-- GHC extension keywords
+ 'forall'	{ L _ ITforall }		-- GHC extension keywords
  'foreign'	{ L _ ITforeign }
  'export'	{ L _ ITexport }
  'label'	{ L _ ITlabel } 
@@ -184,6 +185,7 @@ incorrect.
  'threadsafe'	{ L _ ITthreadsafe }
  'unsafe'	{ L _ ITunsafe }
  'mdo'		{ L _ ITmdo }
+ 'iso'		{ L _ ITiso }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
  'dotnet'       { L _ ITdotnet }
@@ -466,7 +468,7 @@ cl_decl :: { LTyClDecl RdrName }
 		{% do { let { (binds, sigs, ats)           = 
 			        cvBindsAndSigs (unLoc $4)
 		            ; (ctxt, tc, tvs, Just tparms) = unLoc $2}
-                      ; checkTyVars tparms
+                      ; checkTyVars tparms False  -- only type vars allowed
 		      ; return $ L (comb4 $1 $2 $3 $4) 
 				   (mkClassDecl (ctxt, tc, tvs) 
 					        (unLoc $3) sigs binds ats) } }
@@ -474,27 +476,61 @@ cl_decl :: { LTyClDecl RdrName }
 -- Type declarations
 --
 ty_decl :: { LTyClDecl RdrName }
- 	: 'type' type '=' ctype	
-		-- Note type on the left of the '='; this allows
-		-- infix type constructors to be declared
+        -- type function signature and equations (w/ type synonyms as special
+        -- case); we need to handle all this in one rule to avoid a large
+        -- number of shift/reduce conflicts (due to the generality of `type')
+        : 'type' opt_iso type kind_or_ctype
+	        --
+		-- Note the use of type for the head; this allows
+		-- infix type constructors to be declared and type
+		-- patterns for type function equations
 		-- 
-		-- Note ctype, not sigtype, on the right
-		-- We allow an explicit for-all but we don't insert one
-		-- in 	type Foo a = (b,b)
-		-- Instead we just say b is out of scope
- 		{% do { (tc,tvs) <- checkSynHdr $2
-		      ; return (LL (TySynonym tc tvs $4)) } }
-
+		-- We have that `typats :: Maybe [LHsType name]' is `Nothing'
+		-- (in the second case alternative) when all arguments are
+		-- variables (and we thus have a vanilla type synonym
+		-- declaration); otherwise, it contains all arguments as type
+		-- patterns.
+		--
+ 		{% case $4 of 
+		     Left kind -> 
+		       do { (tc, tvs, _) <- checkSynHdr $3 False
+		          ; return (L (comb3 $1 $3 kind) 
+				      (TyFunction tc tvs $2 (unLoc kind)))
+		          } 
+		     Right ty  -> 
+		       do { (tc, tvs, typats) <- checkSynHdr $3 True
+		          ; return (L (comb2 $1 ty) 
+				      (TySynonym tc tvs typats ty)) }
+                }
+
+        -- data type or newtype declaration
 	| data_or_newtype tycl_hdr constrs deriving
 		{ L (comb4 $1 $2 $3 $4)	-- We need the location on tycl_hdr 
-					-- in case constrs and deriving are both empty
-		    (mkTyData (unLoc $1) (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) }
+					-- in case constrs and deriving are
+					-- both empty
+		    (mkTyData (unLoc $1) (unLoc $2) Nothing 
+		       (reverse (unLoc $3)) (unLoc $4)) }
 
+        -- GADT declaration
         | data_or_newtype tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
 		{ L (comb4 $1 $2 $4 $5)
-		    (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
+		    (mkTyData (unLoc $1) (unLoc $2) $3
+		       (reverse (unLoc $5)) (unLoc $6)) }
+
+opt_iso :: { Bool }
+	:       { False }
+	| 'iso'	{ True  }
+
+kind_or_ctype :: { Either (Located (Maybe Kind)) (LHsType RdrName) }
+	: 		{ Left  (noLoc Nothing)           }
+        | '::' kind	{ Left  (LL    (Just (unLoc $2))) }
+	| '=' ctype	{ Right (LL    (unLoc $2))        }
+		-- Note ctype, not sigtype, on the right of '='
+		-- We allow an explicit for-all but we don't insert one
+		-- in 	type Foo a = (b,b)
+		-- Instead we just say b is out of scope
 
 data_or_newtype :: { Located NewOrData }
 	: 'data'	{ L1 DataType }
@@ -502,7 +538,7 @@ data_or_newtype :: { Located NewOrData }
 
 opt_kind_sig :: { Maybe Kind }
 	: 				{ Nothing }
-	| '::' kind			{ Just $2 }
+	| '::' kind			{ Just (unLoc $2) }
 
 -- tycl_hdr parses the header of a type decl,
 -- which takes the form
@@ -719,7 +755,7 @@ atype :: { LHsType RdrName }
 	| '[' ctype ']'			{ LL $ HsListTy  $2 }
 	| '[:' ctype ':]'		{ LL $ HsPArrTy  $2 }
 	| '(' ctype ')'		        { LL $ HsParTy   $2 }
-	| '(' ctype '::' kind ')'	{ LL $ HsKindSig $2 $4 }
+	| '(' ctype '::' kind ')'	{ LL $ HsKindSig $2 (unLoc $4) }
 -- Generics
         | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
 
@@ -748,7 +784,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
 	: tyvar				{ L1 (UserTyVar (unLoc $1)) }
-	| '(' tyvar '::' kind ')'	{ LL (KindedTyVar (unLoc $2) $4) }
+	| '(' tyvar '::' kind ')'	{ LL (KindedTyVar (unLoc $2) 
+							  (unLoc $4)) }
 
 fds :: { Located [Located ([RdrName], [RdrName])] }
 	: {- empty -}			{ noLoc [] }
@@ -769,14 +806,14 @@ varids0	:: { Located [RdrName] }
 -----------------------------------------------------------------------------
 -- Kinds
 
-kind	:: { Kind }
+kind	:: { Located Kind }
 	: akind			{ $1 }
-	| akind '->' kind	{ mkArrowKind $1 $3 }
+	| akind '->' kind	{ LL (mkArrowKind (unLoc $1) (unLoc $3)) }
 
-akind	:: { Kind }
-	: '*'			{ liftedTypeKind }
-	| '!'			{ unliftedTypeKind }
-	| '(' kind ')'		{ $2 }
+akind	:: { Located Kind }
+	: '*'			{ L1 liftedTypeKind }
+	| '!'			{ L1 unliftedTypeKind }
+	| '(' kind ')'		{ LL (unLoc $2) }
 
 
 -----------------------------------------------------------------------------
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 59651a46d8..b0cf2cf8cc 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -36,8 +36,8 @@ 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])
+	checkTyVars,          -- [LHsType RdrName] -> Bool -> P ()
+	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
 	checkTopTyClD,	      -- LTyClDecl RdrName -> P (HsDecl RdrName)
 	checkInstType,	      -- HsType -> P HsType
 	checkPattern,	      -- HsExp -> P HsPat
@@ -377,25 +377,45 @@ checkInstType (L l t)
 	ty ->   do dict_ty <- checkDictTy (L l ty)
 	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
--- Check that the given list of type parameters are all type variables
--- (possibly with a kind signature).
+-- Check whether the given list of type parameters are all type variables
+-- (possibly with a kind signature).  If the second argument is `False', we
+-- only type variables are allowed and we raise an error on encountering a
+-- non-variable; otherwise, we return the entire list parameters iff at least
+-- one is not a variable.
 --
-checkTyVars :: [LHsType RdrName] -> P ()
-checkTyVars tvs = mapM_ chk tvs
+checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName])
+checkTyVars tparms nonVarsOk = 
+  do
+    areVars <- mapM chk tparms
+    return $ if and areVars then Nothing else Just tparms
   where
 	-- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-	| isRdrTyVar tv = return ()
+	| isRdrTyVar tv    = return True
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv = return ()
+        | isRdrTyVar tv    = return True
     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, Just tparms) <- checkTyClHdr (noLoc []) ty
-		    ; checkTyVars tparms
-		    ; return (tc, tvs) }
+        | nonVarsOk        = return False
+        | otherwise        = 
+	  parseError l "Type found where type variable expected"
 
+-- Check whether the type arguments in a type synonym head are simply
+-- variables.  If not, we have a type equation of a type function and return
+-- all patterns.
+--
+checkSynHdr :: LHsType RdrName 
+	    -> Bool                             -- non-variables admitted?
+	    -> P (Located RdrName,		-- head symbol
+	          [LHsTyVarBndr RdrName],	-- parameters
+		  Maybe [LHsType RdrName])	-- type patterns
+checkSynHdr ty nonVarsOk = 
+  do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+     ; typats <- checkTyVars tparms nonVarsOk
+     ; return (tc, tvs, typats) }
+
+
+-- Well-formedness check and decomposition of type and class heads.
+--
 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
   -> P (LHsContext RdrName,	     -- the type context
         Located RdrName,	     -- the head symbol (type or class name)
@@ -493,7 +513,7 @@ extractTyVars tvs = collects [] tvs
 checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
 checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = 
   do
-    checkTyVars typats
+    checkTyVars typats False
     return $ TyClD d {tcdTyPats = Nothing}
 checkTopTyClD (L _ d)                             = return $ TyClD d