X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParserCore.y;h=a6ee5ddc89864f9330232b902068c64ca69c055f;hp=a9669b23ec4619608b42aa0d47267c6a93584aa0;hb=afef39736dcde6f4947a6f362f9e6b3586933db4;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc

diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index a9669b2..a6ee5dd 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -7,7 +7,10 @@ import RdrHsSyn
 import HsSyn
 import RdrName
 import OccName
-import Kind( Kind(..) )
+import Type ( Kind,
+              liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+              argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp
+            )
 import Name( nameOccName, nameModule )
 import Module
 import PackageConfig	( mainPackageId )
@@ -39,7 +42,7 @@ import Char
  '%in'		{ TKin }
  '%case'	{ TKcase }
  '%of'		{ TKof }
- '%coerce'	{ TKcoerce }
+ '%cast'	{ TKcast }
  '%note'	{ TKnote }
  '%external'	{ TKexternal }
  '%_'		{ TKwild }
@@ -85,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
@@ -107,7 +118,7 @@ con	:: { LConDecl RdrName }
 	: d_pat_occ attv_bndrs hs_atys 
 		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
         | d_pat_occ '::' ty
-                -- XXX - autrijus - $3 needs to be split into argument and return types!
+                -- XXX - audreyt - $3 needs to be split into argument and return types!
                 -- also not sure whether the [] below (quantified vars) appears.
                 -- also the "PrefixCon []" is wrong.
                 -- also we want to munge $3 somehow.
@@ -192,7 +203,7 @@ id_bndrs :: { [IfaceIdBndr] }
 	| id_bndr id_bndrs	{ $1:$2 }
 
 tv_bndr	:: { IfaceTvBndr }
-	:  tv_occ                    { ($1, LiftedTypeKind) }
+	:  tv_occ                    { ($1, ifaceLiftedTypeKind) }
 	|  '(' tv_occ '::' akind ')' { ($2, $4) }
 
 tv_bndrs 	:: { [IfaceTvBndr] }
@@ -200,14 +211,14 @@ tv_bndrs 	:: { [IfaceTvBndr] }
 	| tv_bndr tv_bndrs	{ $1:$2 }
 
 akind	:: { IfaceKind }
-	: '*' 		   { LiftedTypeKind   }	
-	| '#'		   { UnliftedTypeKind }
-	| '?'		   { OpenTypeKind     }
+	: '*' 		   { ifaceLiftedTypeKind }	
+	| '#'		   { ifaceUnliftedTypeKind }
+	| '?'		   { ifaceOpenTypeKind }
         | '(' kind ')'	   { $2 }
 
 kind 	:: { IfaceKind }
 	: akind 	   { $1 }
-	| akind '->' kind  { FunKind $1 $3 }
+	| akind '->' kind  { ifaceArrow $1 $3 }
 
 -----------------------------------------
 --             Expressions
@@ -230,7 +241,7 @@ exp	:: { IfaceExpr }
 -- gaw 2004
 	| '%case' '(' ty ')' aexp '%of' id_bndr
 	  '{' alts1 '}'		      { IfaceCase $5 (fst $7) $3 $9 }
-	| '%coerce' aty exp   	      { IfaceNote (IfaceCoerce $2) $3 }
+        | '%cast' exp aty { IfaceCast $2 $3 }
 	| '%note' STRING exp 	   
 	    { case $2 of
 	       --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
@@ -285,6 +296,8 @@ d_occ :: { FastString }
 
 {
 
+ifaceKind kc = IfaceTyConApp kc []
+
 ifaceBndrName (IfaceIdBndr (n,_)) = n
 ifaceBndrName (IfaceTvBndr (n,_)) = n
 
@@ -322,8 +335,31 @@ toHsType (IfaceFunTy t1 t2)    		 = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
 toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)
 
+-- We also need to convert IfaceKinds to Kinds (now that they are different).
+-- Only a limited form of kind will be encountered... hopefully
+toKind :: IfaceKind -> Kind
+toKind (IfaceFunTy ifK1 ifK2)  = mkArrowKind (toKind ifK1) (toKind ifK2)
+toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
+toKind other                   = pprPanic "toKind" (ppr other)
+
+toKindTc :: IfaceTyCon -> TyCon
+toKindTc IfaceLiftedTypeKindTc   = liftedTypeKindTyCon
+toKindTc IfaceOpenTypeKindTc     = openTypeKindTyCon
+toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon
+toKindTc IfaceUbxTupleKindTc     = ubxTupleKindTyCon
+toKindTc IfaceArgTypeKindTc      = argTypeKindTyCon
+toKindTc other                   = pprPanic "toKindTc" (ppr other)
+
+ifaceTcType ifTc = IfaceTyConApp ifTc []
+
+ifaceLiftedTypeKind   = ifaceTcType IfaceLiftedTypeKindTc
+ifaceOpenTypeKind     = ifaceTcType IfaceOpenTypeKindTc
+ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
+
+ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
+
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) k
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k)
 
 ifaceExtRdrName :: IfaceExtName -> RdrName
 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ