X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParserCore.y;h=6839fa2d45d0f12364378213f7a6fd9ccb82a10d;hp=225c164472ecc1e6efb8569b031f6a53da80cb64;hb=59300a7161f44b3a2afe381a6ccd914043a32c4f;hpb=de777ba42eb12b6a20e548a959b23b60179d9b57

diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 225c164..6839fa2 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -1,4 +1,11 @@
 {
+{-# OPTIONS -Wwarn -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module ParserCore ( parseCore ) where
 
 import IfaceSyn
@@ -13,7 +20,6 @@ import Type ( Kind,
             )
 import Name( Name, nameOccName, nameModule, mkExternalName )
 import Module
-import PackageConfig	( mainPackageId, stringToPackageId )
 import ParserCoreUtils
 import LexCore
 import Literal
@@ -23,7 +29,7 @@ import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
 import TyCon ( TyCon, tyConName )
 import FastString
 import Outputable
-import Char
+import Data.Char
 import Unique
 
 #include "../HsVersions.h"
@@ -31,6 +37,7 @@ import Unique
 }
 
 %name parseCore
+%expect 0
 %tokentype { Token }
 
 %token
@@ -117,18 +124,18 @@ tdefs	:: { [TyClDecl RdrName] }
 
 tdef	:: { TyClDecl RdrName }
 	: '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
-                { mkTyData DataType ( noLoc []
-				    , noLoc (ifaceExtRdrName $2)
-				    , map toHsTvBndr $3
-				    , Nothing
-				    ) Nothing $6 Nothing }
+	{ TyData { tcdND = DataType, tcdCtxt = noLoc [] 
+	         , tcdLName = noLoc (ifaceExtRdrName $2)
+	         , tcdTyVars = map toHsTvBndr $3
+	         , tcdTyPats = Nothing, tcdKindSig = Nothing
+	         , tcdCons = $6, tcdDerivs = Nothing } }
 	| '%newtype' q_tc_name tv_bndrs trep ';'
 		{ let tc_rdr = ifaceExtRdrName $2 in
-                  mkTyData NewType ( noLoc []
-				   , noLoc tc_rdr
-				   , map toHsTvBndr $3
-				   , Nothing
-				   ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
+		    TyData { tcdND = NewType, tcdCtxt = noLoc []
+			     , tcdLName = noLoc tc_rdr
+			     , tcdTyVars = map toHsTvBndr $3
+			     , tcdTyPats = Nothing, tcdKindSig = Nothing
+			     , tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = 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
@@ -136,8 +143,8 @@ trep    :: { OccName -> [LConDecl RdrName] }
         : {- empty -}   { (\ tc_occ -> []) }
         | '=' ty        { (\ tc_occ -> let { dc_name  = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
 			                     con_info = PrefixCon [toHsType $2] }
-			                in [noLoc $ ConDecl (noLoc dc_name) Explicit []
-					   (noLoc []) con_info ResTyH98 Nothing]) }
+			                in [noLoc $ mkSimpleConDecl (noLoc dc_name) []
+					               (noLoc []) con_info]) }
 
 cons	:: { [LConDecl RdrName] }
 	: {- empty -}	{ [] } -- 20060420 Empty data types allowed. jds
@@ -146,15 +153,8 @@ cons	:: { [LConDecl RdrName] }
 
 con	:: { LConDecl RdrName }
 	: d_pat_occ attv_bndrs hs_atys 
-		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98 Nothing }
-        | d_pat_occ '::' ty
-                -- 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.
-                -- 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) Nothing }
+		{ noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) }
+-- ToDo: parse record-style declarations
 
 attv_bndrs :: { [LHsTyVarBndr RdrName] }
 	: {- empty -} 	         { [] }
@@ -200,12 +200,12 @@ let_bind :: { IfaceBinding }
 	|  vdef                 { let (b,r) = $1
 				  in IfaceNonRec b r }
 
-vdefs1	:: { [(IfaceIdBndr, IfaceExpr)] }
+vdefs1	:: { [(IfaceLetBndr, IfaceExpr)] }
 	: vdef  	        { [$1] }
 	| vdef ';' vdefs1       { $1:$3 }
 
-vdef	:: { (IfaceIdBndr, IfaceExpr) }
-	: fs_var_occ '::' ty '=' exp { (($1, $3), $5) }
+vdef	:: { (IfaceLetBndr, IfaceExpr) }
+	: fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) }
         | '%local' vdef              { $2 }
 
   -- NB: qd_occ includes data constructors, because
@@ -269,11 +269,12 @@ exp	:: { IfaceExpr }
 	| '%case' '(' ty ')' aexp '%of' id_bndr
 	  '{' alts1 '}'		      { IfaceCase $5 (fst $7) $3 $9 }
         | '%cast' aexp aty { IfaceCast $2 $3 }
-	| '%note' STRING exp 	   
-	    { case $2 of
-	       --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
-	       "InlineMe"   -> IfaceNote IfaceInlineMe $3
-            }
+-- No InlineMe any more
+-- 	| '%note' STRING exp 	   
+--	    { case $2 of
+--	       --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
+--	       "InlineMe"   -> IfaceNote IfaceInlineMe $3
+--            }
         | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
                                                     (CCallSpec (StaticTarget (mkFastString $2)) 
                                                                CCallConv (PlaySafe False))) 
@@ -346,7 +347,7 @@ eqTc (IfaceTc name) tycon = name == tyConName tycon
 -- are very limited (see the productions for 'ty', so the translation
 -- isn't hard
 toHsType :: IfaceType -> LHsType RdrName
-toHsType (IfaceTyVar v)        		 = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOcc v))
+toHsType (IfaceTyVar v)        		 = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v))
 toHsType (IfaceAppTy t1 t2)    		 = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
 toHsType (IfaceFunTy t1 t2)    		 = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
@@ -378,7 +379,7 @@ ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2)
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k)
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toKind k)
 
 ifaceExtRdrName :: Name -> RdrName
 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)