X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=a827ee4c5e52b360568c6bc40f0e505f6e5d4076;hp=b663ac2aba699b9ce3f383e1739aa1b86d80dbf0;hb=HEAD;hpb=609940166562b6a5f2ff05fc9d00cf26d531c6dd diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index b663ac2..a827ee4 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 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 + } + } + }