X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y.pp;h=156cedcab385b437cbea945dcdfd6caa09d709d2;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=6ad9f6bef66c6dbf8b8aee2c418a01c68594a2d0;hpb=36436bc62a98f53e126ec02fe946337c4c766c3f;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 6ad9f6b..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(..) ) + Activation(..), defaultInlineSpec ) import OrdList -import Panic import FastString import Maybes ( orElse ) @@ -184,10 +183,10 @@ incorrect. 'proc' { L _ ITproc } -- for arrow notation extension 'rec' { L _ ITrec } -- for arrow notation extension - '{-# SPECIALISE' { L _ ITspecialise_prag } + '{-# INLINE' { L _ (ITinline_prag _) } + '{-# SPECIALISE' { L _ ITspec_prag } + '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } '{-# SOURCE' { L _ ITsource_prag } - '{-# INLINE' { L _ ITinline_prag } - '{-# NOINLINE' { L _ ITnoinline_prag } '{-# RULES' { L _ ITrules_prag } '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core '{-# SCC' { L _ ITscc_prag } @@ -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 } @@ -531,15 +530,13 @@ rules :: { OrdList (LHsDecl RdrName) } -- Reversed rule :: { LHsDecl RdrName } : STRING activation rule_forall infixexp '=' exp - { LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6) } + { LL $ RuleD (HsRule (getSTRING $1) + ($2 `orElse` AlwaysActive) + $3 $4 $6) } -activation :: { Activation } -- Omitted means AlwaysActive - : {- empty -} { AlwaysActive } - | explicit_activation { $1 } - -inverse_activation :: { Activation } -- Omitted means NeverActive - : {- empty -} { NeverActive } - | explicit_activation { $1 } +activation :: { Maybe Activation } + : {- empty -} { Nothing } + | explicit_activation { Just $1 } explicit_activation :: { Activation } -- In brackets : '[' INTEGER ']' { ActiveAfter (fromInteger (getINTEGER $2)) } @@ -777,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 } @@ -787,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 @@ -812,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 } @@ -854,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 } @@ -976,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)) } } @@ -996,16 +992,17 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } return (LL $ unitOL (LL $ SigD s)) } -- See the above notes for why we need infixexp here | var ',' sig_vars '::' sigtype - { LL $ toOL [ LL $ SigD (Sig n $5) | n <- $1 : unLoc $3 ] } + { 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)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig True $3 $2)) } - | '{-# NOINLINE' inverse_activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $2 t) + { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) | t <- $4] } + | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1))) + | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } @@ -1070,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 } @@ -1093,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) } @@ -1135,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] } ----------------------------------------------------------------------------- @@ -1147,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 @@ -1267,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) } @@ -1476,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") } @@ -1487,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("*") } @@ -1573,6 +1577,8 @@ getPRIMINTEGER (L _ (ITprimint x)) = x getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getTH_ID_SPLICE (L _ (ITidEscape x)) = x +getINLINE (L _ (ITinline_prag b)) = b +getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b -- Utilities for combining source spans comb2 :: Located a -> Located b -> SrcSpan