X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y.pp;h=156cedcab385b437cbea945dcdfd6caa09d709d2;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=4a1519a47fbaa1027c873e1f229782f9b9f66975;hpb=9c30856ddafb6de78811cf5e8f1b9a8c773ddd5d;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 4a1519a..156cedc 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -25,7 +25,7 @@ import Type ( funTyCon ) import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, CCallConv(..), CCallTarget(..), defaultCCallConv ) -import OccName ( UserFS, varName, dataName, tcClsName, tvName ) +import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, SrcSpan, combineLocs, srcLocFile, @@ -34,9 +34,8 @@ import Module import StaticFlags ( opt_SccProfilingOn ) import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), InlineSpec(..), defaultInlineSpec ) + Activation(..), defaultInlineSpec ) import OrdList -import Panic import FastString import Maybes ( orElse ) @@ -455,20 +454,16 @@ tycl_decl :: { LTyClDecl RdrName } {% do { (tc,tvs) <- checkSynHdr $2 ; return (LL (TySynonym tc tvs $4)) } } - | 'data' tycl_hdr constrs deriving + | data_or_newtype tycl_hdr constrs deriving { L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr -- in case constrs and deriving are both empty - (mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) } + (mkTyData (unLoc $1) (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) } - | 'data' tycl_hdr opt_kind_sig + | data_or_newtype tycl_hdr opt_kind_sig 'where' gadt_constrlist deriving { L (comb4 $1 $2 $4 $5) - (mkTyData DataType $2 $3 (reverse (unLoc $5)) (unLoc $6)) } - - | 'newtype' tycl_hdr '=' newconstr deriving - { L (comb3 $1 $4 $5) - (mkTyData NewType $2 Nothing [$4] (unLoc $5)) } + (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) } | 'class' tycl_hdr fds where { let @@ -477,6 +472,10 @@ tycl_decl :: { LTyClDecl RdrName } L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs binds) } +data_or_newtype :: { Located NewOrData } + : 'data' { L1 DataType } + | 'newtype' { L1 NewType } + opt_kind_sig :: { Maybe Kind } : { Nothing } | '::' kind { Just $2 } @@ -775,7 +774,7 @@ gentype :: { LHsType RdrName } : btype { $1 } | btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 } - | btype '->' gentype { LL $ HsFunTy $1 $3 } + | btype '->' ctype { LL $ HsFunTy $1 $3 } btype :: { LHsType RdrName } : btype atype { LL $ HsAppTy $1 $2 } @@ -785,10 +784,10 @@ atype :: { LHsType RdrName } : gtycon { L1 (HsTyVar (unLoc $1)) } | tyvar { L1 (HsTyVar (unLoc $1)) } | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } - | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } + | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } - | '[' type ']' { LL $ HsListTy $2 } - | '[:' type ':]' { LL $ HsPArrTy $2 } + | '[' ctype ']' { LL $ HsListTy $2 } + | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } -- Generics @@ -810,8 +809,8 @@ comma_types0 :: { [LHsType RdrName] } | {- empty -} { [] } comma_types1 :: { [LHsType RdrName] } - : type { [$1] } - | type ',' comma_types1 { $1 : $3 } + : ctype { [$1] } + | ctype ',' comma_types1 { $1 : $3 } tv_bndrs :: { [LHsTyVarBndr RdrName] } : tv_bndr tv_bndrs { $1 : $2 } @@ -852,11 +851,6 @@ akind :: { Kind } ----------------------------------------------------------------------------- -- Datatype declarations -newconstr :: { LConDecl RdrName } - : conid atype { LL $ ConDecl $1 Explicit [] (noLoc []) (PrefixCon [$2]) ResTyH98 } - | conid '{' var '::' ctype '}' - { LL $ ConDecl $1 Explicit [] (noLoc []) (RecCon [($3, $5)]) ResTyH98 } - gadt_constrlist :: { Located [LConDecl RdrName] } : '{' gadt_constrs '}' { LL (unLoc $2) } | vocurly gadt_constrs close { $2 } @@ -974,6 +968,10 @@ deriving :: { Located (Maybe [LHsType RdrName]) } decl :: { Located (OrdList (LHsDecl RdrName)) } : sigdecl { $1 } + | '!' infixexp 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; return (LL $ unitOL (LL $ ValD r)) } } @@ -1069,6 +1067,7 @@ aexps :: { [LHsExpr RdrName] } aexp :: { LHsExpr RdrName } : qvar '@' aexp { LL $ EAsPat $1 $3 } | '~' aexp { LL $ ELazyPat $2 } +-- | '!' aexp { LL $ EBangPat $2 } | aexp1 { $1 } aexp1 :: { LHsExpr RdrName } @@ -1092,7 +1091,7 @@ aexp2 :: { LHsExpr RdrName } | INTEGER { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) } | RATIONAL { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) } | '(' exp ')' { LL (HsPar $2) } - | '(' exp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed } + | '(' texp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed } | '(#' texps '#)' { LL $ ExplicitTuple (reverse $2) Unboxed } | '[' list ']' { LL (unLoc $2) } | '[:' parr ':]' { LL (unLoc $2) } @@ -1134,9 +1133,15 @@ cvtopdecls0 :: { [LHsDecl RdrName] } : {- empty -} { [] } | cvtopdecls { $1 } +texp :: { LHsExpr RdrName } + : exp { $1 } + | qopm infixexp { LL $ SectionR $1 $2 } + -- The second production is really here only for bang patterns + -- but + texps :: { [LHsExpr RdrName] } - : texps ',' exp { $3 : $1 } - | exp { [$1] } + : texps ',' texp { $3 : $1 } + | texp { [$1] } ----------------------------------------------------------------------------- @@ -1146,17 +1151,17 @@ texps :: { [LHsExpr RdrName] } -- avoiding another shift/reduce-conflict. list :: { LHsExpr RdrName } - : exp { L1 $ ExplicitList placeHolderType [$1] } + : texp { L1 $ ExplicitList placeHolderType [$1] } | lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) } - | exp '..' { LL $ ArithSeq noPostTcExpr (From $1) } - | exp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } - | exp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } - | exp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | exp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 } + | texp '..' { LL $ ArithSeq noPostTcExpr (From $1) } + | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } + | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } + | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } + | texp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 } lexps :: { Located [LHsExpr RdrName] } - : lexps ',' exp { LL ($3 : unLoc $1) } - | exp ',' exp { LL [$3,$1] } + : lexps ',' texp { LL ($3 : unLoc $1) } + | texp ',' texp { LL [$3,$1] } ----------------------------------------------------------------------------- -- List Comprehensions @@ -1266,7 +1271,7 @@ stmt :: { LStmt RdrName } | 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) } qual :: { LStmt RdrName } - : infixexp '<-' exp {% checkPattern $1 >>= \p -> + : exp '<-' exp {% checkPattern $1 >>= \p -> return (LL $ mkBindStmt p $3) } | exp { L1 $ mkExprStmt $1 } | 'let' binds { LL $ LetStmt (unLoc $2) } @@ -1475,7 +1480,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' -- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these -- except 'unsafe' and 'forall' whose treatment differs depending on context -special_id :: { Located UserFS } +special_id :: { Located FastString } special_id : 'as' { L1 FSLIT("as") } | 'qualified' { L1 FSLIT("qualified") } @@ -1486,7 +1491,7 @@ special_id | 'stdcall' { L1 FSLIT("stdcall") } | 'ccall' { L1 FSLIT("ccall") } -special_sym :: { Located UserFS } +special_sym :: { Located FastString } special_sym : '!' { L1 FSLIT("!") } | '.' { L1 FSLIT(".") } | '*' { L1 FSLIT("*") }