X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=8806a3d4ef9c8ab3dc05b884283abae0217dad71;hb=c0778bd3da61e80948e5813255ee82cdfebe0fdf;hp=2f1166d420c7e3c24c626dd28c6ae9700857c3a4;hpb=abc32aba7135136c89e089296e296fbb380bda39;p=ghc-hetmet.git diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 2f1166d..8806a3d 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -47,7 +47,7 @@ import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), defaultInlineSpec ) + Activation(..), RuleMatchInfo(..), defaultInlineSpec ) import DynFlags import OrdList import HaddockParse @@ -254,6 +254,7 @@ incorrect. 'using' { L _ ITusing } -- for list transform extension '{-# INLINE' { L _ (ITinline_prag _) } + '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_prag _) } '{-# SPECIALISE' { L _ ITspec_prag } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } '{-# SOURCE' { L _ ITsource_prag } @@ -264,6 +265,7 @@ incorrect. '{-# DEPRECATED' { L _ ITdeprecated_prag } '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } + '{-# ANN' { L _ ITann_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -561,6 +563,7 @@ topdecl :: { OrdList (LHsDecl RdrName) } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | annotation { unitOL $1 } | decl { unLoc $1 } -- Template Haskell Extension @@ -586,7 +589,7 @@ cl_decl :: { LTyClDecl RdrName } -- ty_decl :: { LTyClDecl RdrName } -- ordinary type synonyms - : 'type' type '=' ctype + : 'type' type '=' ctypedoc -- Note ctype, not sigtype, on the right of '=' -- We allow an explicit for-all but we don't insert one -- in type Foo a = (b,b) @@ -926,6 +929,13 @@ deprecation :: { OrdList (LHsDecl RdrName) } { toOL [ LL $ WarningD (Warning n (DeprecatedTxt (getSTRING $2))) | n <- unLoc $1 ] } +----------------------------------------------------------------------------- +-- Annotations +annotation :: { LHsDecl RdrName } + : '{-# ANN' name_var aexp '#-}' { LL (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) } + | '{-# ANN' 'type' tycon aexp '#-}' { LL (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) } + | '{-# ANN' 'module' aexp '#-}' { LL (AnnD $ HsAnnotation ModuleAnnProvenance $3) } + ----------------------------------------------------------------------------- -- Foreign import and export declarations @@ -990,23 +1000,6 @@ infixtype :: { LHsType RdrName } : btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 } -infixtypedoc :: { LHsType RdrName } - : infixtype { $1 } - | infixtype docprev { LL $ HsDocTy $1 $2 } - -gentypedoc :: { LHsType RdrName } - : btype { $1 } - | btypedoc { $1 } - | infixtypedoc { $1 } - | btype '->' ctypedoc { LL $ HsFunTy $1 $3 } - | btypedoc '->' ctypedoc { LL $ HsFunTy $1 $3 } - -ctypedoc :: { LHsType RdrName } - : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } - | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 } - -- A type of form (context => type) is an *implicit* HsForAllTy - | gentypedoc { $1 } - strict_mark :: { Located HsBang } : '!' { L1 HsStrict } | '{-# UNPACK' '#-}' '!' { LL HsUnbox } @@ -1018,6 +1011,12 @@ ctype :: { LHsType RdrName } -- A type of form (context => type) is an *implicit* HsForAllTy | type { $1 } +ctypedoc :: { LHsType RdrName } + : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } + | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 } + -- A type of form (context => type) is an *implicit* HsForAllTy + | typedoc { $1 } + -- We parse a context as a btype so that we don't get reduce/reduce -- errors in ctype. The basic problem is that -- (Eq a, Ord a) @@ -1034,6 +1033,10 @@ type :: { LHsType RdrName } : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) } | gentype { $1 } +typedoc :: { LHsType RdrName } + : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) } + | gentypedoc { $1 } + gentype :: { LHsType RdrName } : btype { $1 } | btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } @@ -1041,14 +1044,21 @@ gentype :: { LHsType RdrName } | btype '->' ctype { LL $ HsFunTy $1 $3 } | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } +gentypedoc :: { LHsType RdrName } + : btype { $1 } + | btype docprev { LL $ HsDocTy $1 $2 } + | btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } + | btype qtyconop gentype docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 } + | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 } + | btype tyvarop gentype docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 } + | btype '->' ctypedoc { LL $ HsFunTy $1 $3 } + | btype docprev '->' ctypedoc { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 } + | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } + btype :: { LHsType RdrName } : btype atype { LL $ HsAppTy $1 $2 } | atype { $1 } -btypedoc :: { LHsType RdrName } - : btype atype docprev { LL $ HsDocTy (L (comb2 $1 $2) (HsAppTy $1 $2)) $3 } - | atype docprev { LL $ HsDocTy $1 $2 } - atype :: { LHsType RdrName } : gtycon { L1 (HsTyVar (unLoc $1)) } | tyvar { L1 (HsTyVar (unLoc $1)) } @@ -1278,12 +1288,14 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | 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 $3 (mkInlineSpec $2 (getINLINE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) } + | '{-# INLINE_CONLIKE' activation qvar '#-}' + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' { 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))) + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1))) | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } @@ -2004,6 +2016,7 @@ getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getTH_ID_SPLICE (L _ (ITidEscape x)) = x getINLINE (L _ (ITinline_prag b)) = b +getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b getDOCNEXT (L _ (ITdocCommentNext x)) = x