X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=3958b9cf9a74d878db0885dc6ca8e7d40dcb3bb1;hp=a45ad87f0f0b6075cef117bd33d5adef10ea1136;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=83d563cb9ede0ba792836e529b1e2929db926355 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index a45ad87..3958b9c 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -8,15 +8,8 @@ -- --------------------------------------------------------------------------- { -{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} --- The NoMonomorphismRestriction deals with a Happy infelicity --- With OutsideIn's more conservativ monomorphism restriction --- we aren't generalising --- notHappyAtAll = error "urk" --- which is terrible. Switching off the restriction allows --- the generalisation. Better would be to make Happy generate --- an appropriate signature. - +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -46,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, @@ -311,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 } @@ -1018,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) } @@ -1208,15 +1207,21 @@ docdecld :: { LDocDecl } | docsection { L1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } decl :: { Located (OrdList (LHsDecl RdrName)) } - : sigdecl { $1 } - | '!' aexp rhs {% do { pat <- checkPattern $2; - return (LL $ unitOL $ LL $ ValD ( - PatBind (LL $ BangPat pat) (unLoc $3) - placeHolderType placeHolderNames)) } } - | 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 } + : sigdecl { $1 } + + | '!' aexp rhs {% do { let { e = LL (SectionR (LL (HsVar bang_RDR)) $2) }; + pat <- checkPattern e; + return $ LL $ unitOL $ LL $ ValD $ + PatBind pat (unLoc $3) + placeHolderType placeHolderNames } } + -- Turn it all into an expression so that + -- checkPattern can check that bangs are enabled + + | 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) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } @@ -1233,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)))) @@ -1257,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 } @@ -1264,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 } @@ -1277,7 +1288,7 @@ exp10 :: { LHsExpr RdrName } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp optSemi 'then' exp optSemi 'else' exp {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> - return (LL $ HsIf $2 $5 $8) } + return (LL $ mkHsIf $2 $5 $8) } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } @@ -1286,7 +1297,9 @@ exp10 :: { LHsExpr RdrName } return (L loc (mkHsDo DoExpr stmts body)) } | 'mdo' stmtlist {% let loc = comb2 $1 $2 in checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)) } + return (L loc (mkHsDo MDoExpr + [L loc (mkRecStmt stmts)] + body)) } | scc_annot exp { LL $ if opt_SccProfilingOn then HsSCC (unLoc $1) $2 else HsPar $2 } @@ -1358,8 +1371,8 @@ aexp2 :: { LHsExpr RdrName } | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) } -- N.B.: sections get parsed by these next two productions. - -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't correct Haskell98 - -- (you'd have to write '((+ 3), (4 -))') + -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't + -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. | '(' texp ')' { LL (HsPar $2) } | '(' tup_exprs ')' { LL (ExplicitTuple $2 Boxed) } @@ -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 -} { [] } @@ -1419,8 +1437,8 @@ texp :: { LHsExpr RdrName } -- Note [Parsing sections] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- We include left and right sections here, which isn't - -- technically right according to Haskell 98. For example - -- (3 +, True) isn't legal + -- technically right according to the Haskell standard. + -- For example (3 +, True) isn't legal. -- However, we want to parse bang patterns like -- (!x, !y) -- and it's convenient to do so here as a section @@ -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