Initial checkin of HetMet / -XModalTypes modifications

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

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a0cc964..3958b9c 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          ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
                          SrcSpan, combineLocs, srcLocFile, 
@@ -304,6 +304,11 @@ incorrect.
  '#)'          { L _ ITcubxparen }
  '(|'          { L _ IToparenbar }
  '|)'          { L _ ITcparenbar }
+ '<['          { L _ ITopenBrak }
+ ']>'          { L _ ITcloseBrak }
+ '~~'          { L _ ITescape }
+ '~~$'         { L _ ITescapeDollar }
+ '%%'          { L _ ITdoublePercent }
  ';'           { L _ ITsemi }
  ','           { L _ ITcomma }
  '`'           { L _ ITbackquote }
@@ -1011,6 +1016,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) }
@@ -1214,6 +1220,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) }
@@ -1231,6 +1238,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
        : infixexp '::' sigtypedoc      {% do s <- checkValSig $1 $3 
                                         ; return (LL $ unitOL (LL $ SigD s)) }
                -- See Note [Declaration/signature overlap] for why we need infixexp here
+
        | var ',' sig_vars '::' sigtypedoc
                                { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
        | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
@@ -1255,6 +1263,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 }
@@ -1262,6 +1274,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 }
@@ -1392,6 +1405,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 -}                   { [] }
@@ -1823,7 +1841,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") }
@@ -1848,9 +1866,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