X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=b31e0250852368133f4f0655eb21c38a4625ef21;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hp=abfc2582d36893b2d7b92a0a0f04b6d05e31bda2;hpb=d52ec21d7ef5dc077f406cd17e57116b9f83fa18;p=ghc-hetmet.git diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index abfc258..b31e025 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -361,10 +361,10 @@ module :: { Located (HsModule RdrName) } {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) -> return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 opt info doc) )}} - | missing_module_keyword top close + | body2 {% fileSrcSpan >>= \ loc -> return (L loc (HsModule Nothing Nothing - (fst $2) (snd $2) Nothing Nothing emptyHaddockModInfo + (fst $1) (snd $1) Nothing Nothing emptyHaddockModInfo Nothing)) } optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) } @@ -385,6 +385,10 @@ body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } : '{' top '}' { $2 } | vocurly top close { $2 } +body2 :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } + : '{' top '}' { $2 } + | missing_module_keyword top close { $2 } + top :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } : importdecls { (reverse $1,[]) } | importdecls ';' cvtopdecls { (reverse $1,$3) } @@ -614,7 +618,7 @@ ty_decl :: { LTyClDecl RdrName } (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } } -- data/newtype family - | data_or_newtype 'family' tycl_hdr opt_kind_sig + | 'data' 'family' tycl_hdr opt_kind_sig {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3} ; checkTyVars tparms -- no type pattern ; unless (null (unLoc ctxt)) $ -- and no context @@ -622,8 +626,7 @@ ty_decl :: { LTyClDecl RdrName } "A family declaration cannot have a context" ; return $ L (comb3 $1 $2 $4) - (TyFamily (DataFamily (unLoc $1)) tc tvs - (unLoc $4)) } } + (TyFamily DataFamily tc tvs (unLoc $4)) } } -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving @@ -678,7 +681,7 @@ at_decl_cls :: { LTyClDecl RdrName } } } -- data/newtype family declaration - | data_or_newtype tycl_hdr opt_kind_sig + | 'data' tycl_hdr opt_kind_sig {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms -- no type pattern ; unless (null (unLoc ctxt)) $ -- and no context @@ -686,8 +689,7 @@ at_decl_cls :: { LTyClDecl RdrName } "A family declaration cannot have a context" ; return $ L (comb3 $1 $2 $3) - (TyFamily (DataFamily (unLoc $1)) tc tvs - (unLoc $3)) + (TyFamily DataFamily tc tvs (unLoc $3)) } } -- Associate type instances @@ -1134,7 +1136,7 @@ forall :: { Located [LHsTyVarBndr RdrName] } : 'forall' tv_bndrs '.' { LL $2 } | {- empty -} { noLoc [] } -constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } +constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } -- We parse the constructor declaration -- C t1 t2 -- as a btype (treating C as a type constructor) and then convert C to be @@ -1147,7 +1149,7 @@ constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrN | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL } | btype conop btype { LL ($2, InfixCon $1 $3) } -constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } +constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) } : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) } | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) } @@ -1268,7 +1270,7 @@ exp10 :: { LHsExpr RdrName } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } - | '-' fexp { LL $ mkHsNegApp $2 } + | '-' fexp { LL $ NegApp $2 noSyntaxExpr } | 'do' stmtlist {% let loc = comb2 $1 $2 in checkDo loc (unLoc $2) >>= \ (stmts,body) -> @@ -1319,9 +1321,8 @@ aexp :: { LHsExpr RdrName } | aexp1 { $1 } aexp1 :: { LHsExpr RdrName } - : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) - $3; - return (LL r) }} + : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3 + ; return (LL r) }} | aexp2 { $1 } -- Here was the syntax for type applications that I was planning @@ -1493,7 +1494,7 @@ gdpat :: { LGRHS RdrName } -- Bangs inside are parsed as infix operator applications, so that -- we parse them right when bang-patterns are off pat :: { LPat RdrName } -pat : infixexp {% checkPattern $1 } +pat : exp {% checkPattern $1 } | '!' aexp {% checkPattern (LL (SectionR (L1 (HsVar bang_RDR)) $2)) } apat :: { LPat RdrName } @@ -1546,16 +1547,21 @@ qual :: { LStmt RdrName } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { HsRecordBinds RdrName } - : fbinds1 { HsRecordBinds (reverse $1) } - | {- empty -} { HsRecordBinds [] } +fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } + : fbinds1 { $1 } + | {- empty -} { ([], False) } -fbinds1 :: { [(Located id, LHsExpr id)] } - : fbinds1 ',' fbind { $3 : $1 } - | fbind { [$1] } +fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } + : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } + | fbind { ([$1], False) } + | '..' { ([], True) } -fbind :: { (Located RdrName, LHsExpr RdrName) } - : qvar '=' exp { ($1,$3) } +fbind :: { HsRecField RdrName (LHsExpr RdrName) } + : qvar '=' exp { HsRecField $1 $3 False } + | qvar { HsRecField $1 (L (getLoc $1) (HsVar (unLoc $1))) True } + -- Here's where we say that plain 'x' + -- means exactly 'x = x'. The pun-flag boolean is + -- there so we can still print it right ----------------------------------------------------------------------------- -- Implicit Parameter Bindings