X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y.pp;h=b4acb890eb4228c97364c4abddbb26c23ae71e9d;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;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..b4acb89 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) } - -activation :: { Activation } -- Omitted means AlwaysActive - : {- empty -} { AlwaysActive } - | explicit_activation { $1 } + { LL $ RuleD (HsRule (getSTRING $1) + ($2 `orElse` AlwaysActive) + $3 $4 $6) } -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)) } @@ -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 } @@ -996,16 +988,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)) } @@ -1476,7 +1469,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 +1480,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 +1566,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