X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParserCore.y;h=3210583f9651cfa70247dadca7adafb2fa17fd42;hb=e6218fe7eff4e34e1a3c823cd4b7aebe09d2d4fb;hp=95abaf43a185637a92de79d7409391f7a428c8f7;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y
index 95abaf4..3210583 100644
--- a/ghc/compiler/parser/ParserCore.y
+++ b/ghc/compiler/parser/ParserCore.y
@@ -4,16 +4,15 @@ module ParserCore ( parseCore ) where
 import IfaceSyn
 import ForeignCall
 import RdrHsSyn
-import TcIface ( tcIfaceKind )
 import HsSyn
 import RdrName
 import OccName
-import Name( nameOccName, nameModuleName )
+import Kind( Kind(..) )
+import Name( nameOccName, nameModule )
 import Module
 import ParserCoreUtils
 import LexCore
 import Literal
-import BasicTypes
 import SrcLoc
 import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, 
 		floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
@@ -70,11 +69,10 @@ import Char
 %%
 
 module	:: { HsExtCore RdrName }
-         : '%module' modid tdefs vdefgs
-		{ HsExtCore (mkHomeModule $2) $3 $4 }
+         : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 }
 
-modid	:: { ModuleName }
-	: CNAME	                 { mkSysModuleNameFS (mkFastString $1) }
+modid	:: { Module }
+	: CNAME	                 { mkModuleFS (mkFastString $1) }
 
 -------------------------------------------------------------
 --     Type and newtype declarations are in HsSyn syntax
@@ -85,19 +83,19 @@ tdefs	:: { [TyClDecl RdrName] }
 
 tdef	:: { TyClDecl RdrName }
 	: '%data' q_tc_name tv_bndrs '=' '{' cons1 '}'
-                { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) $6 Nothing }
+                { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) 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) ($4 (rdrNameOcc tc_rdr)) Nothing }
+                  mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) 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
 trep    :: { OccName -> [LConDecl RdrName] }
         : {- empty -}   { (\ tc_occ -> []) }
         | '=' ty        { (\ tc_occ -> let { dc_name  = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
-			                      con_info = PrefixCon [unbangedType (toHsType $2)] }
-			                in [noLoc $ ConDecl (noLoc dc_name) []
-					   (noLoc []) con_info]) }
+			                     con_info = PrefixCon [toHsType $2] }
+			                in [noLoc $ ConDecl (noLoc dc_name) Explicit []
+					   (noLoc []) con_info ResTyH98]) }
 
 cons1	:: { [LConDecl RdrName] }
 	: con		{ [$1] }
@@ -105,7 +103,15 @@ cons1	:: { [LConDecl RdrName] }
 
 con	:: { LConDecl RdrName }
 	: d_pat_occ attv_bndrs hs_atys 
-		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon (map unbangedType $3))}
+		{ 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!
+                -- also not sure whether the [] below (quantified vars) appears.
+                -- also the "PrefixCon []" is wrong.
+                -- also we want to munge $3 somehow.
+                -- extractWhatEver to unpack ty into the parts to ConDecl
+                -- XXX - define it somewhere in RdrHsSyn
+		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) }
 
 attv_bndrs :: { [LHsTyVarBndr RdrName] }
 	: {- empty -} 	         { [] }
@@ -131,6 +137,7 @@ aty	:: { IfaceType }
 bty	:: { IfaceType }
 	: tv_occ atys    { foldl IfaceAppTy (IfaceTyVar $1) $2 }
         | q_tc_name atys  { IfaceTyConApp (IfaceTc $1) $2 }
+        | '(' ty ')' { $2 }
 
 ty	:: { IfaceType }
 	: bty	                     { $1 }
@@ -183,7 +190,7 @@ id_bndrs :: { [IfaceIdBndr] }
 	| id_bndr id_bndrs	{ $1:$2 }
 
 tv_bndr	:: { IfaceTvBndr }
-	:  tv_occ                    { ($1, IfaceLiftedTypeKind) }
+	:  tv_occ                    { ($1, LiftedTypeKind) }
 	|  '(' tv_occ '::' akind ')' { ($2, $4) }
 
 tv_bndrs 	:: { [IfaceTvBndr] }
@@ -191,14 +198,14 @@ tv_bndrs 	:: { [IfaceTvBndr] }
 	| tv_bndr tv_bndrs	{ $1:$2 }
 
 akind	:: { IfaceKind }
-	: '*' 		   { IfaceLiftedTypeKind   }	
-	| '#'		   { IfaceUnliftedTypeKind }
-	| '?'		   { IfaceOpenTypeKind     }
+	: '*' 		   { LiftedTypeKind   }	
+	| '#'		   { UnliftedTypeKind }
+	| '?'		   { OpenTypeKind     }
         | '(' kind ')'	   { $2 }
 
 kind 	:: { IfaceKind }
 	: akind 	   { $1 }
-	| akind '->' kind  { IfaceFunKind $1 $3 }
+	| akind '->' kind  { FunKind $1 $3 }
 
 -----------------------------------------
 --             Expressions
@@ -218,8 +225,9 @@ exp	:: { IfaceExpr }
 	: fexp		              { $1 }
 	| '\\' bndrs '->' exp 	      { foldr IfaceLam $4 $2 }
 	| '%let' let_bind '%in' exp   { IfaceLet $2 $4 }
-	| '%case' aexp '%of' id_bndr
-	  '{' alts1 '}'		      { IfaceCase $2 (fst $4) $6 }
+-- gaw 2004
+	| '%case' '(' ty ')' aexp '%of' id_bndr
+	  '{' alts1 '}'		      { IfaceCase $5 (fst $7) $3 $9 }
 	| '%coerce' aty exp   	      { IfaceNote (IfaceCoerce $2) $3 }
 	| '%note' STRING exp 	   
 	    { case $2 of
@@ -254,25 +262,25 @@ lit	:: { Literal }
 	| '(' STRING '::' aty ')'	{ MachStr (mkFastString $2) }
 
 tv_occ	:: { OccName }
-	: NAME	{ mkSysOcc tvName $1 }
+	: NAME	{ mkOccName tvName $1 }
 
 var_occ	:: { OccName }
-	: NAME	{ mkSysOcc varName $1 }
+	: NAME	{ mkVarOcc $1 }
 
 
 -- Type constructor
 q_tc_name	:: { IfaceExtName }
-        : modid '.' CNAME	{ ExtPkg $1 (mkSysOcc tcName $3) }
+        : modid '.' CNAME	{ ExtPkg $1 (mkOccName tcName $3) }
 
 -- Data constructor in a pattern or data type declaration; use the dataName, 
 -- because that's what we expect in Core case patterns
 d_pat_occ :: { OccName }
-        : CNAME      { mkSysOcc dataName $1 }
+        : CNAME      { mkOccName dataName $1 }
 
 -- Data constructor occurrence in an expression;
 -- use the varName because that's the worker Id
 d_occ :: { OccName }
-       : CNAME { mkSysOcc varName $1 }
+       : CNAME { mkVarOcc $1 }
 
 {
 
@@ -297,7 +305,7 @@ convRatLit i aty
 
 eqTc :: IfaceTyCon -> TyCon -> Bool   -- Ugh!
 eqTc (IfaceTc (ExtPkg mod occ)) tycon
-  = mod == nameModuleName nm && occ == nameOccName nm
+  = mod == nameModule nm && occ == nameOccName nm
   where
     nm = tyConName tycon
 
@@ -314,7 +322,7 @@ toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifa
 toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k)
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) k
 
 ifaceExtRdrName :: IfaceExtName -> RdrName
 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ