X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=f72c8b9d83f46b2085b40957b5662ba61a73ce8f;hb=3ded6e65b730c2b5eb9a9519448bbcd905c5d7fa;hp=f349f30770e1d40b71542645e19c9f8638cf1aaa;hpb=e343a6ca48114f26ac8bb90af543c6ec5bd5a2d4;p=ghc-hetmet.git

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index f349f30..f72c8b9 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -31,7 +31,7 @@ import SrcLoc		( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
 			  SrcSpan, combineLocs, srcLocFile, 
 			  mkSrcLoc, mkSrcSpan )
 import Module
-import StaticFlags	( opt_SccProfilingOn )
+import StaticFlags	( opt_SccProfilingOn, opt_Hpc )
 import Type		( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
 import BasicTypes	( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
 			  Activation(..), defaultInlineSpec )
@@ -223,6 +223,7 @@ incorrect.
  '{-# RULES'	   { L _ ITrules_prag }
  '{-# CORE'        { L _ ITcore_prag }              -- hdaume: annotated core
  '{-# SCC'	   { L _ ITscc_prag }
+ '{-# GENERATED'   { L _ ITgenerated_prag }
  '{-# DEPRECATED'  { L _ ITdeprecated_prag }
  '{-# UNPACK'      { L _ ITunpack_prag }
  '#-}'		   { L _ ITclose_prag }
@@ -970,8 +971,13 @@ ctype	:: { LHsType RdrName }
 -- errors in ctype.  The basic problem is that
 --	(Eq a, Ord a)
 -- looks so much like a tuple type.  We can't tell until we find the =>
+--
+-- We have the t1 ~ t2 form here and in gentype, to permit an individual
+-- equational constraint without parenthesis.
 context :: { LHsContext RdrName }
-	: btype 			{% checkContext $1 }
+        : btype '~'      btype  	{% checkContext
+					     (LL $ HsPredTy (HsEqualP $1 $3)) }
+	| btype 			{% checkContext $1 }
 
 type :: { LHsType RdrName }
 	: ipvar '::' gentype		{ LL (HsPredTy (HsIParam (unLoc $1) $3)) }
@@ -981,7 +987,8 @@ gentype :: { LHsType RdrName }
         : btype                         { $1 }
         | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  gentype  	{ LL $ HsOpTy $1 $2 $3 }
- 	| btype '->' ctype		{ LL $ HsFunTy $1 $3 }
+ 	| btype '->'     ctype		{ LL $ HsFunTy $1 $3 }
+        | btype '~'      btype  	{ LL $ HsPredTy (HsEqualP $1 $3) }
 
 btype :: { LHsType RdrName }
 	: btype atype			{ LL $ HsAppTy $1 $2 }
@@ -1263,6 +1270,9 @@ exp10 :: { LHsExpr RdrName }
         | scc_annot exp		    		{ LL $ if opt_SccProfilingOn
 							then HsSCC (unLoc $1) $2
 							else HsPar $2 }
+        | hpc_annot exp		    		{ LL $ if opt_Hpc
+							then HsTickPragma (unLoc $1) $2
+							else HsPar $2 }
 
 	| 'proc' aexp '->' exp	
 			{% checkPattern $2 >>= \ p -> 
@@ -1278,6 +1288,18 @@ scc_annot :: { Located FastString }
 	: '_scc_' STRING			{ LL $ getSTRING $2 }
 	| '{-# SCC' STRING '#-}'		{ LL $ getSTRING $2 }
 
+hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
+	: '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+						{ LL $ (getSTRING $2
+						       ,( fromInteger $ getINTEGER $3
+ 							, fromInteger $ getINTEGER $5
+							)
+                         			       ,( fromInteger $ getINTEGER $7
+ 							, fromInteger $ getINTEGER $9
+							)
+						       )
+					         }
+
 fexp 	:: { LHsExpr RdrName }
 	: fexp aexp				{ LL $ HsApp $1 $2 }
   	| aexp					{ $1 }