X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Frename%2FParseIface.y;h=7fa4cd352e1c3a99127e1cbbc5b93599fadf3970;hb=10cbc75d37064b3ef76ca3ccd219d66e445ecb0f;hp=c1419389721449e30e6f6ac93146bcab901f8e98;hpb=2ffefc1bfca0c8924825cd15750e7ced457f3c81;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index c141938..7fa4cd3 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -28,13 +28,13 @@ Import declarations
 
 
 {
-module ParseIface ( parseIface, IfaceStuff(..) ) where
+module ParseIface ( parseIface, parseType, parseRules, parseIdInfo ) where
 
 #include "HsVersions.h"
 
 import HsSyn		-- quite a bit of stuff
 import RdrHsSyn		-- oodles of synonyms
-import HsTypes		( mkHsForAllTy, mkHsUsForAllTy, mkHsTupCon )
+import HsTypes		( mkHsForAllTy, mkHsTupCon )
 import HsCore
 import Demand		( mkStrictnessInfo )
 import Literal		( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 )
@@ -43,8 +43,8 @@ import BasicTypes	( Fixity(..), FixityDirection(..),
 			)
 import CostCentre       ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
 import CallConv         ( cCallConv )
-import Type		( Kind, mkArrowKind, boxedTypeKind, openTypeKind )
-import IdInfo           ( exactArity, InlinePragInfo(..) )
+import Type		( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
+import IdInfo           ( InlinePragInfo(..) )
 import PrimOp           ( CCall(..), CCallTarget(..) )
 import Lex		
 
@@ -56,21 +56,24 @@ import HscTypes         ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..),
 import RdrName          ( RdrName, mkRdrUnqual, mkIfaceOrig )
 import Name		( OccName )
 import OccName          ( mkSysOccFS,
-			  tcName, varName, ipName, dataName, clsName, tvName, uvName,
+			  tcName, varName, dataName, clsName, tvName,
 			  EncodedFS 
 			)
 import Module           ( ModuleName, PackageName, mkSysModuleNameFS, mkModule )
 import SrcLoc		( SrcLoc )
 import CmdLineOpts	( opt_InPackage, opt_IgnoreIfacePragmas )
 import Outputable
-import List		( insert )
 import Class            ( DefMeth (..) )
 
 import GlaExts
 import FastString	( tailFS )
 }
 
-%name	    parseIface
+%name	    parseIface      iface
+%name	    parseType       type
+%name	    parseIdInfo     id_info
+%name	    parseRules      rules_and_deprecs
+
 %tokentype  { Token }
 %monad	    { P }{ thenP }{ returnP }
 %lexer      { lexer } { ITeof }
@@ -136,7 +139,6 @@ import FastString	( tailFS )
  '__sccC'       { ITsccAllCafs }
 
  '__u'		{ ITusage }
- '__fuall'	{ ITfuall }
 
  '__A'		{ ITarity }
  '__P'		{ ITspecialise }
@@ -155,13 +157,10 @@ import FastString	( tailFS )
  '<-'		{ ITlarrow }
  '->'		{ ITrarrow }
  '@'		{ ITat }
- '~'		{ ITtilde }
  '=>'		{ ITdarrow }
  '-'		{ ITminus }
  '!'		{ ITbang }
 
- '/\\'		{ ITbiglam }			-- GHC-extension symbols
-
  '{'		{ ITocurly } 			-- special symbols
  '}'		{ ITccurly }
  '{|'		{ ITocurlybar } 			-- special symbols
@@ -174,6 +173,7 @@ import FastString	( tailFS )
  '#)'		{ ITcubxparen }
  ';'		{ ITsemi }
  ','		{ ITcomma }
+ '.'		{ ITdot }
 
  VARID   	{ ITvarid    $$ }		-- identifiers
  CONID   	{ ITconid    $$ }
@@ -197,17 +197,6 @@ import FastString	( tailFS )
  UNKNOWN	{ ITunknown  $$ }
 %%
 
--- iface_stuff is the main production.
--- It recognises (a) a whole interface file
---		 (b) a type (so that type sigs can be parsed lazily)
---		 (c) the IdInfo part of a signature (same reason)
-
-iface_stuff :: { IfaceStuff }
-iface_stuff : iface		{ PIface   $1 }
-      	    | type		{ PType    $1 }
-      	    | id_info		{ PIdInfo  $1 }
-	    | rules_and_deprecs	{ PRulesAndDeprecs $1 }
-
 iface		:: { ParsedIface }
 iface		: '__interface' package mod_name 
 			version sub_versions
@@ -258,6 +247,7 @@ whats_imported      :: { WhatsImported OccName }
 whats_imported      :                                           	{ NothingAtAll }
 		    | '::' version					{ Everything $2 }
                     | '::' version version version name_version_pairs   { Specifically $2 (Just $3) $5 $4 }
+                    | '::' version version name_version_pairs		{ Specifically $2 Nothing $4 $3 }
 
 name_version_pairs  ::	{ [(OccName, Version)] }
 name_version_pairs  :  						{ [] }
@@ -330,10 +320,9 @@ csigs1		: 				{ [] }
 		| csig ';' csigs1		{ $1 : $3 }
 
 csig		:: { RdrNameSig }
-csig		:  src_loc qvar_name '::' type		{ mkClassOpSig NoDefMeth $2 $4 $1 }
-	        |  src_loc qvar_name '=' '::' type	{ mkClassOpSig (DefMeth (error "DefMeth") )
-								$2 $5 $1 }
-	        |  src_loc qvar_name ';' '::' type	{ mkClassOpSig GenDefMeth  $2 $5 $1 }		
+csig		:  src_loc qvar_name '::' type		{ ClassOpSig $2 NoDefMeth $4 $1 }
+	        |  src_loc qvar_name ';' '::' type	{ ClassOpSig $2 GenDefMeth $5 $1 }		
+	        |  src_loc qvar_name '=' '::' type	{ mkClassOpSigDM $2 $5 $1 }
 
 --------------------------------------------------------------------------
 
@@ -367,13 +356,13 @@ decl    : src_loc qvar_name '::' type maybe_idinfo
 	| src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr
 			{ mkTyData NewType $3 $4 $5 $6 1 Nothing $1 }
 	| src_loc 'class' opt_decl_context qtc_name tv_bndrs fds csigs
-			{ mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1 }
+			{ mkClassDecl $3 $4 $5 $6 $7 Nothing $1 }
 
 maybe_idinfo  :: { RdrName -> [HsIdInfo RdrName] }
 maybe_idinfo  : {- empty -} 	{ \_ -> [] }
 	      | pragma		{ \x -> if opt_IgnoreIfacePragmas then [] 
 					else case $1 of
-						POk _ (PIdInfo id_info) -> id_info
+						POk _ id_info -> id_info
 						PFailed err -> pprPanic "IdInfo parse failed" 
 								        (vcat [ppr x, err])
 				}
@@ -394,8 +383,8 @@ maybe_idinfo  : {- empty -} 	{ \_ -> [] }
        dates from a time where we picked up a .hi file first if it existed.]
     -}
 
-pragma	:: { ParseResult IfaceStuff }
-pragma	: src_loc PRAGMA	{ parseIface $2 PState{ bol = 0#, atbol = 1#,
+pragma	:: { ParseResult [HsIdInfo RdrName] }
+pragma	: src_loc PRAGMA	{ parseIdInfo $2 PState{ bol = 0#, atbol = 1#,
 							context = [],
 							glasgow_exts = 1#,
 							loc = $1 }
@@ -405,11 +394,18 @@ pragma	: src_loc PRAGMA	{ parseIface $2 PState{ bol = 0#, atbol = 1#,
 
 rules_and_deprecs_part :: { ([RdrNameRuleDecl], IfaceDeprecs) }
 rules_and_deprecs_part : {- empty -}	{ ([], Nothing) }
-		       | pragma		{ case $1 of
-					     POk _ (PRulesAndDeprecs rds) -> rds
+		       | rules_prag	{ case $1 of
+					     POk _ rds -> rds
 					     PFailed err -> pprPanic "Rules/Deprecations parse failed" err
 					}
 
+rules_prag :: { ParseResult ([RdrNameRuleDecl], IfaceDeprecs) }
+rules_prag : src_loc PRAGMA	{ parseRules $2 PState{ bol = 0#, atbol = 1#,
+							context = [],
+							glasgow_exts = 1#,
+							loc = $1 }
+				}
+
 rules_and_deprecs :: { ([RdrNameRuleDecl], IfaceDeprecs) }
 rules_and_deprecs : rule_prag deprec_prag	{ ($1, $2) }
 
@@ -494,30 +490,27 @@ batypes		:  					{ [] }
 		|  batype batypes			{ $1 : $2 }
 
 batype		:: { RdrNameBangType }
-batype		:  atype				{ Unbanged $1 }
-		|  '!' atype				{ Banged   $2 }
-		|  '!' '!' atype			{ Unpacked $3 }
+batype		:  tatype				{ Unbanged $1 }
+		|  '!' tatype				{ Banged   $2 }
+		|  '!' '!' tatype			{ Unpacked $3 }
 
 fields1		:: { [([RdrName], RdrNameBangType)] }
 fields1		: field					{ [$1] }
 		| field ',' fields1			{ $1 : $3 }
 
 field		:: { ([RdrName], RdrNameBangType) }
-field		:  qvar_names1 '::' type		{ ($1, Unbanged $3) }
-		|  qvar_names1 '::' '!' type    	{ ($1, Banged   $4) }
-		|  qvar_names1 '::' '!' '!' type	{ ($1, Unpacked $5) }
+field		:  qvar_names1 '::' ttype		{ ($1, Unbanged $3) }
+		|  qvar_names1 '::' '!' ttype    	{ ($1, Banged   $4) }
+		|  qvar_names1 '::' '!' '!' ttype	{ ($1, Unpacked $5) }
+
 --------------------------------------------------------------------------
 
 type		:: { RdrNameHsType }
-type		: '__fuall'  fuall '=>' type    { mkHsUsForAllTy $2 $4 }
-                | '__forall' tv_bndrs 
+type 		: '__forall' tv_bndrs 
 			opt_context '=>' type	{ mkHsForAllTy (Just $2) $3 $5 }
 		| btype '->' type		{ HsFunTy $1 $3 }
 		| btype				{ $1 }
 
-fuall		:: { [RdrName] }
-fuall		: '[' uv_bndrs ']'		        { $2 }
-
 opt_context	:: { RdrNameContext }
 opt_context	:  					{ [] }
 		| context 			        { $1 }
@@ -546,16 +539,13 @@ types2		:  type ',' type			{ [$1,$3] }
 btype		:: { RdrNameHsType }
 btype		:  atype				{ $1 }
 		|  btype atype				{ HsAppTy $1 $2 }
-                |  '__u' usage atype			{ HsUsgTy $2 $3 }
-
-usage		:: { HsUsageAnn RdrName }
-usage		: '-' 					{ HsUsOnce }
-		| '!' 					{ HsUsMany }
-		| uv_name 				{ HsUsVar $1 }
+		|  '__u' atype atype			{ HsUsageTy $2 $3 }
 
 atype		:: { RdrNameHsType }
 atype		:  qtc_name 			  	{ HsTyVar $1 }
 		|  tv_name			  	{ HsTyVar $1 }
+		|  '.'					{ hsUsOnce }
+		|  '!'					{ hsUsMany }
 	  	|  '(' ')' 				{ HsTupleTy (mkHsTupCon tcName Boxed   []) [] }
 		|  '(' types2 ')'	  		{ HsTupleTy (mkHsTupCon tcName Boxed   $2) $2 }
 		|  '(#' types0 '#)'			{ HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 }
@@ -567,7 +557,34 @@ atype		:  qtc_name 			  	{ HsTyVar $1 }
 atypes		:: { [RdrNameHsType] 	{-  Zero or more -} }
 atypes		:  					{ [] }
 		|  atype atypes				{ $1 : $2 }
+--------------------------------------------------------------------------
+
+-- versions of type/btype/atype that cant begin with '!' (or '.')
+-- for use where the kind is definitely known NOT to be '$'
+
+ttype		:: { RdrNameHsType }
+ttype 		: '__forall' tv_bndrs 
+			opt_context '=>' type		{ mkHsForAllTy (Just $2) $3 $5 }
+		| tbtype '->' type			{ HsFunTy $1 $3 }
+		| tbtype				{ $1 }
+
+tbtype		:: { RdrNameHsType }
+tbtype		:  tatype				{ $1 }
+		|  tbtype atype				{ HsAppTy $1 $2 }
+		|  '__u' atype atype			{ HsUsageTy $2 $3 }
+
+tatype		:: { RdrNameHsType }
+tatype		:  qtc_name 			  	{ HsTyVar $1 }
+		|  tv_name			  	{ HsTyVar $1 }
+	  	|  '(' ')' 				{ HsTupleTy (mkHsTupCon tcName Boxed   []) [] }
+		|  '(' types2 ')'	  		{ HsTupleTy (mkHsTupCon tcName Boxed   $2) $2 }
+		|  '(#' types0 '#)'			{ HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 }
+		|  '[' type ']'		  		{ HsListTy  $2 }
+		|  '{' qcls_name atypes '}'		{ mkHsDictTy $2 $3 }
+		|  '{' ipvar_name '::' type '}'		{ mkHsIParamTy $2 $4 }
+		|  '(' type ')'		  		{ $2 }
 ---------------------------------------------------------------------
+
 package		:: { PackageName }
 		:  STRING		{ $1 }
 		| {- empty -}		{ opt_InPackage }	-- Useful for .hi-boot files,
@@ -610,7 +627,7 @@ qvar_name	:  var_name		{ $1 }
 		|  qvar_fs      	{ mkIfaceOrig varName $1 }
 
 ipvar_name	:: { RdrName }
-		:  IPVARID		{ mkRdrUnqual (mkSysOccFS ipName (tailFS $1)) }
+		:  IPVARID		{ mkRdrUnqual (mkSysOccFS varName (tailFS $1)) }
 
 qvar_names1	:: { [RdrName] }
 qvar_names1	: qvar_name		{ [$1] }
@@ -671,27 +688,15 @@ qcls_name	:: { RdrName }
 		| qdata_fs		{ mkIfaceOrig clsName $1 }
 
 ---------------------------------------------------
-uv_name		:: { RdrName }
-		:  VARID 		{ mkRdrUnqual (mkSysOccFS uvName $1) }
-
-uv_bndr		:: { RdrName }
-		:  uv_name		{ $1 }
-
-uv_bndrs	:: { [RdrName] }
-		:  			{ [] }
-		| uv_bndr uv_bndrs	{ $1 : $2 }
-
----------------------------------------------------
 tv_name		:: { RdrName }
 		:  VARID 		{ mkRdrUnqual (mkSysOccFS tvName $1) }
-		|  VARSYM		{ mkRdrUnqual (mkSysOccFS tvName $1) {- Allow t2 as a tyvar -} }
 
 tv_bndr		:: { HsTyVarBndr RdrName }
 		:  tv_name '::' akind	{ IfaceTyVar $1 $3 }
-		|  tv_name		{ IfaceTyVar $1 boxedTypeKind }
+		|  tv_name		{ IfaceTyVar $1 liftedTypeKind }
 
 tv_bndrs	:: { [HsTyVarBndr RdrName] }
-tv_bndrs	: tv_bndrs1		{ $1 }
+		: tv_bndrs1		{ $1 }
 		| '[' tv_bndrs1 ']'	{ $2 } 	-- Backward compatibility
 
 tv_bndrs1	:: { [HsTyVarBndr RdrName] }
@@ -721,10 +726,12 @@ kind		:: { Kind }
 
 akind		:: { Kind }
 		: VARSYM		{ if $1 == SLIT("*") then
-						boxedTypeKind
+						liftedTypeKind
 					  else if $1 == SLIT("?") then
 						openTypeKind
-					  else panic "ParseInterface: akind"
+					  else if $1 == SLIT("\36") then
+                                                usageTypeKind  -- dollar
+                                          else panic "ParseInterface: akind"
 					}
 		| '(' kind ')'	{ $2 }
 
@@ -735,12 +742,12 @@ id_info		:: { [HsIdInfo RdrName] }
 		| id_info_item id_info		{ $1 : $2 }
 
 id_info_item	:: { HsIdInfo RdrName }
-		: '__A' INTEGER			{ HsArity (exactArity (fromInteger $2)) }
+		: '__A' INTEGER			{ HsArity (fromInteger $2) }
 		| '__U' inline_prag core_expr	{ HsUnfold $2 $3 }
 		| '__M'				{ HsCprInfo }
 		| '__S'				{ HsStrictness (mkStrictnessInfo $1) }
 		| '__C'                         { HsNoCafRefs }
-		| '__P' qvar_name 		{ HsWorker $2 }
+		| '__P' qvar_name INTEGER	{ HsWorker $2 (fromInteger $3) }
 
 inline_prag     :: { InlinePragInfo }
                 :  {- empty -}                  { NoInlinePragInfo }
@@ -888,7 +895,7 @@ core_val_bndr	: var_name '::' atype				{ UfValBinder $1 $3 }
 
 core_tv_bndr	:: { UfBinder RdrName }
 core_tv_bndr	:  '@' tv_name '::' akind		{ UfTyBinder $2 $4 }
-		|  '@' tv_name			        { UfTyBinder $2 boxedTypeKind }
+		|  '@' tv_name			        { UfTyBinder $2 liftedTypeKind }
 
 ccall_string	:: { FAST_STRING }
 		: STRING					{ $1 }
@@ -934,10 +941,5 @@ checkVersion :: { () }
 happyError :: P a
 happyError buf PState{ loc = loc } = PFailed (ifaceParseErr buf loc)
 
-data IfaceStuff = PIface 	   ParsedIface
-		| PIdInfo	   [HsIdInfo RdrName]
-		| PType		   RdrNameHsType
-		| PRulesAndDeprecs ([RdrNameRuleDecl], IfaceDeprecs)
-
 mk_con_decl name (ex_tvs, ex_ctxt) details loc = mkConDecl name ex_tvs ex_ctxt details loc
 }