merge upstream

[ghc-hetmet.git] / compiler / parser / Parser.y.pp

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index b663ac2..1a847ec 100644 (file)
--- 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
 import Module
@@ -305,6 +305,11 @@ incorrect.
  '#)'          { L _ ITcubxparen }
  '(|'          { L _ IToparenbar }
  '|)'          { L _ ITcparenbar }
+ '<['          { L _ ITopenBrak }
+ ']>'          { L _ ITcloseBrak }
+ '~~'          { L _ ITescape }
+ '~~$'         { L _ ITescapeDollar }
+ '%%'          { L _ ITdoublePercent }
  ';'           { L _ ITsemi }
  ','           { L _ ITcomma }
  '`'           { L _ ITbackquote }
@@ -470,7 +475,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 (RealSrcSpan 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