X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=a71323fe6dfbb5381af5f4ebc62abcc9c3a750ef;hp=102f989332b711894647d84678e7e44fa7cb13a1;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=18691d440f90a3dff4ef538091c886af505e5cf5

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 102f989..a71323f 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -39,7 +39,7 @@ import Type		( funTyCon )
 import ForeignCall	( Safety(..), CExportSpec(..), CLabelString,
 			  CCallConv(..), CCallTarget(..), defaultCCallConv
 			)
-import OccName		( varName, dataName, tcClsName, tvName )
+import OccName		( varName, varNameDepth, dataName, tcClsName, tvName )
 import DataCon		( DataCon, dataConName )
 import SrcLoc		( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
 			  SrcSpan, combineLocs, srcLocFile, 
@@ -306,6 +306,11 @@ incorrect.
  '#)'		{ L _ ITcubxparen }
  '(|'		{ L _ IToparenbar }
  '|)'		{ L _ ITcparenbar }
+ '<['		{ L _ ITopenBrak }
+ ']>'		{ L _ ITcloseBrak }
+ '~~'		{ L _ ITescape }
+ '~~$'		{ L _ ITescapeDollar }
+ '%%'		{ L _ ITdoublePercent }
  ';'		{ L _ ITsemi }
  ','		{ L _ ITcomma }
  '`'		{ L _ ITbackquote }
@@ -471,7 +476,7 @@ export 	:: { LIE RdrName }
 	|  oqtycon '(' ')'		{ LL (IEThingWith (unLoc $1) []) }
 	|  oqtycon '(' qcnames ')'	{ LL (IEThingWith (unLoc $1) (reverse $3)) }
 	|  'module' modid		{ LL (IEModuleContents (unLoc $2)) }
-
+        | '<[' incdepth export decdepth ']>' { $3 }
 qcnames :: { [RdrName] }
 	:  qcnames ',' qcname_ext	{ unLoc $3 : $1 }
 	|  qcname_ext			{ [unLoc $1]  }
@@ -1020,6 +1025,7 @@ atype :: { LHsType RdrName }
 	| '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy Boxed  ($2:$4) }
 	| '(#' comma_types1 '#)'	{ LL $ HsTupleTy Unboxed $2     }
 	| '[' ctype ']'			{ LL $ HsListTy  $2 }
+	| '<[' ctype ']>' '@' tyvar     { LL $ HsModalBoxType (unLoc $5) $2 }
 	| '[:' ctype ':]'		{ LL $ HsPArrTy  $2 }
 	| '(' ctype ')'		        { LL $ HsParTy   $2 }
 	| '(' ctype '::' kind ')'	{ LL $ HsKindSig $2 (unLoc $4) }
@@ -1221,6 +1227,7 @@ decl 	:: { Located (OrdList (LHsDecl RdrName)) }
         | infixexp opt_sig rhs  {% do { r <- checkValDef $1 $2 $3;
                                         let { l = comb2 $1 $> };
                                         return $! (sL l (unitOL $! (sL l $ ValD r))) } }
+
         | docdecl               { LL $ unitOL $1 }
 
 rhs	:: { Located (GRHSs RdrName) }
@@ -1264,6 +1271,10 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
                                 ; quoterId = mkUnqual varName quoter }
                             in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
 
+incdepth :: { Located () } :  {% do { incrBracketDepth ; return $ noLoc () } }
+decdepth :: { Located () } :  {% do { decrBracketDepth ; return $ noLoc () } }
+
+
 exp   :: { LHsExpr RdrName }
 	: infixexp '::' sigtype		{ LL $ ExprWithTySig $1 $3 }
 	| infixexp '-<' exp		{ LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
@@ -1271,6 +1282,7 @@ exp   :: { LHsExpr RdrName }
 	| infixexp '-<<' exp		{ LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
 	| infixexp '>>-' exp		{ LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
 	| infixexp			{ $1 }
+	| '~~$' decdepth exp incdepth	{ sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) }
 
 infixexp :: { LHsExpr RdrName }
 	: exp10				{ $1 }
@@ -1396,6 +1408,11 @@ aexp2	:: { LHsExpr RdrName }
 	-- arrow notation extension
 	| '(|' aexp2 cmdargs '|)'	{ LL $ HsArrForm $2 Nothing (reverse $3) }
 
+ 	-- code type notation extension
+	| '<[' incdepth exp  decdepth ']>'	{ sL (comb2 $3 $>) (HsHetMetBrak placeHolderType                 $3) }
+	| '~~' decdepth aexp incdepth 		{ sL (comb2 $3 $>) (HsHetMetEsc  placeHolderType placeHolderType $3) }
+	| '%%' decdepth aexp incdepth		{ sL (comb2 $3 $>) (HsHetMetCSP  placeHolderType                 $3) }
+
 cmdargs	:: { [LHsCmdTop RdrName] }
 	: cmdargs acmd			{ $2 : $1 }
   	| {- empty -}			{ [] }
@@ -1829,7 +1846,7 @@ qvarid :: { Located RdrName }
         | PREFIXQVARSYM         { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
 
 varid :: { Located RdrName }
-	: VARID			{ L1 $! mkUnqual varName (getVARID $1) }
+	: VARID			{% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } }
 	| special_id		{ L1 $! mkUnqual varName (unLoc $1) }
 	| 'unsafe'		{ L1 $! mkUnqual varName (fsLit "unsafe") }
 	| 'safe'		{ L1 $! mkUnqual varName (fsLit "safe") }
@@ -1854,9 +1871,10 @@ varsym :: { Located RdrName }
 	| '-'			{ L1 $ mkUnqual varName (fsLit "-") }
 
 varsym_no_minus :: { Located RdrName } -- varsym not including '-'
-	: VARSYM		{ L1 $ mkUnqual varName (getVARSYM $1) }
-	| special_sym		{ L1 $ mkUnqual varName (unLoc $1) }
-
+	: VARSYM		{% do { depth <- getParserBrakDepth
+                                      ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } }
+	| special_sym		{% do { depth <- getParserBrakDepth
+                                      ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } }
 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these