fix haddock submodule pointer

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

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index b663ac2..a827ee4 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
@@ -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 }
@@ -305,6 +308,13 @@ incorrect.
  '#)'          { L _ ITcubxparen }
  '(|'          { L _ IToparenbar }
  '|)'          { L _ ITcparenbar }
+ '<['          { L _ ITopenBrak }
+ ']>'          { L _ ITcloseBrak }
+ '<{'          { L _ ITopenBrak1 }
+ '}>'          { L _ ITcloseBrak1 }
+ '~~'          { L _ ITescape }
+ '~~$'         { L _ ITescapeDollar }
+ '%%'          { L _ ITdoublePercent }
  ';'           { L _ ITsemi }
  ','           { L _ ITcomma }
  '`'           { L _ ITbackquote }
@@ -470,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 }
+        | '<{' incdepth1 export decdepth '}>' { $3 }
 qcnames :: { [RdrName] }
        :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
        |  qcname_ext                   { [unLoc $1]  }
@@ -995,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 }
@@ -1020,6 +1032,8 @@ 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) }
@@ -1221,6 +1235,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 +1279,13 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
                                 ; quoterId = mkUnqual varName quoter }
                             in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
+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 }
        : infixexp '::' sigtype         { LL $ ExprWithTySig $1 $3 }
        | infixexp '-<' exp             { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
@@ -1271,6 +1293,7 @@ exp   :: { LHsExpr RdrName }
        | infixexp '-<<' exp            { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
        | infixexp '>>-' exp            { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
        | infixexp                      { $1 }
+       | '~~$' pushdepth exp popdepth  {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }
 
 infixexp :: { LHsExpr RdrName }
        : exp10                         { $1 }
@@ -1278,9 +1301,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 >>
@@ -1330,7 +1356,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 }
@@ -1396,6 +1427,12 @@ 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) }
+       | '<{' 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 }
        | {- empty -}                   { [] }
@@ -1829,7 +1866,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 $ length depth) (getVARID $1)) } }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual varName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual varName (fsLit "safe") }
@@ -1854,9 +1891,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 $ length depth) (getVARSYM $1)) } }
+       | special_sym           {% do { depth <- getParserBrakDepth
+                                      ; 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
@@ -2037,4 +2075,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
+                                    }
+                         }
+
 }