add support for <{..}> and ~~> syntax as well as typing for Kappa-calculus

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

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 1a847ec..bd93101 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -60,8 +60,10 @@ import Control.Monad    ( unless )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )
+
 }
 
+
 {-
 -----------------------------------------------------------------------------
 24 Februar 2006
@@ -277,6 +279,7 @@ incorrect.
  '|'           { L _ ITvbar }
  '<-'          { L _ ITlarrow }
  '->'          { L _ ITrarrow }
+ '~~>'         { L _ ITkappa }
  '@'           { L _ ITat }
  '~'           { L _ ITtilde }
  '=>'          { L _ ITdarrow }
@@ -307,6 +310,8 @@ incorrect.
  '|)'          { L _ ITcparenbar }
  '<['          { L _ ITopenBrak }
  ']>'          { L _ ITcloseBrak }
+ '<{'          { L _ ITopenBrak1 }
+ '}>'          { L _ ITcloseBrak1 }
  '~~'          { L _ ITescape }
  '~~$'         { L _ ITescapeDollar }
  '%%'          { L _ ITdoublePercent }
@@ -475,7 +480,8 @@ 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 }
+        | '<[' incdepth  export decdepth ']>' { $3 }
+        | '<{' incdepth1 export decdepth '}>' { $3 }
 qcnames :: { [RdrName] }
        :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
        |  qcname_ext                   { [unLoc $1]  }
@@ -1000,6 +1006,7 @@ type :: { LHsType RdrName }
         | btype qtyconop type           { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  type          { LL $ HsOpTy $1 $2 $3 }
        | btype '->'     ctype          { LL $ HsFunTy $1 $3 }
+       | btype '~~>'    ctype          { LL $ HsKappaTy $1 $3 }
         | btype '~'      btype         { LL $ HsPredTy (HsEqualP $1 $3) }
 
 typedoc :: { LHsType RdrName }
@@ -1025,7 +1032,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 ']>' '@' tyvar     { LL $ HsModalBoxType  (unLoc $5) $2 }
        | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
        | '(' ctype ')'                 { LL $ HsParTy   $2 }
        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 (unLoc $4) }
@@ -1271,8 +1278,11 @@ 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 () } }
+incdepth   :: { Located () } :  {% do { incrBracketDepth  ; return $ noLoc () } }
+incdepth1  :: { Located () } :  {% do { incrBracketDepth1 ; return $ noLoc () } }
+decdepth   :: { Located () } :  {% do { decrBracketDepth  ; return $ noLoc () } }
+pushdepth  :: { Located () } :  {% do { pushBracketDepth  ; return $ noLoc () } }
+popdepth   :: { Located () } :  {% do { popBracketDepth   ; return $ noLoc () } }
 
 
 exp   :: { LHsExpr RdrName }
@@ -1282,7 +1292,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) }
+       | '~~$' pushdepth exp popdepth  {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }
 
 infixexp :: { LHsExpr RdrName }
        : exp10                         { $1 }
@@ -1290,9 +1300,12 @@ infixexp :: { LHsExpr RdrName }
 
 exp10 :: { LHsExpr RdrName }
        : '\\' apat apats opt_asig '->' exp     
-                       { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4
-                                                               (unguardedGRHSs $6)
-                                                           ]) }
+                       {% do { x <- getParserBrakDepth
+                              ; return
+                                  $ case x of
+                                   KappaFlavor:_ -> LL $ HsKappa (mkMatchGroup[LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ])
+                                   _             -> LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ])
+                              } }
        | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
        | 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
@@ -1342,7 +1355,12 @@ hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
                                                 }
 
 fexp   :: { LHsExpr RdrName }
-       : fexp aexp                             { LL $ HsApp $1 $2 }
+       : fexp aexp                             {% do { x <- getParserBrakDepth
+                                                      ; return $ case x of 
+                                                                   []             -> LL $ HsApp $1 $2
+                                                                   LambdaFlavor:_ -> LL $ HsApp $1 $2
+                                                                   KappaFlavor:_  -> LL $ HsKappaApp $1 $2
+                                                      } }
        | aexp                                  { $1 }
 
 aexp   :: { LHsExpr RdrName }
@@ -1409,9 +1427,10 @@ aexp2    :: { LHsExpr RdrName }
        | '(|' 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) }
+       | '<[' incdepth  exp  decdepth ']>'     { sL (comb2 $3 $>) (HsHetMetBrak  placeHolderType                 $3) }
+       | '<{' incdepth1 exp  decdepth '}>'     { sL (comb2 $3 $>) (HsHetMetBrak  placeHolderType                 $3) }
+       | '~~' pushdepth aexp popdepth          {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }
+       | '%%' pushdepth aexp popdepth          { sL (comb2 $3 $>) (HsHetMetCSP   placeHolderType                 $3) }
 
 cmdargs        :: { [LHsCmdTop RdrName] }
        : cmdargs acmd                  { $2 : $1 }
@@ -1846,7 +1865,7 @@ qvarid :: { Located RdrName }
         | PREFIXQVARSYM         { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
 
 varid :: { Located RdrName }
-       : VARID                 {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } }
+       : VARID                 {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARID $1)) } }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual varName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual varName (fsLit "safe") }
@@ -1872,9 +1891,9 @@ varsym :: { Located RdrName }
 
 varsym_no_minus :: { Located RdrName } -- varsym not including '-'
        : VARSYM                {% do { depth <- getParserBrakDepth
-                                      ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } }
+                                      ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARSYM $1)) } }
        | special_sym           {% do { depth <- getParserBrakDepth
-                                      ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } }
+                                      ; return (L1 $! mkUnqual (varNameDepth $ length depth) (unLoc $1)) } }
 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these
@@ -2055,4 +2074,12 @@ fileSrcSpan = do
   l <- getSrcLoc; 
   let loc = mkSrcLoc (srcLocFile l) 1 1;
   return (mkSrcSpan loc loc)
+
+mkHsHetMetEsc a b c = do { depth <- getParserBrakDepth
+                         ; return $ case head depth of
+                                    { LambdaFlavor -> HsHetMetEsc  a b c
+                                    ; KappaFlavor  -> HsHetMetEsc  a b c
+                                    }
+                         }
+
 }