X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=f0fc523feee824bed3e55414da88ff937b43ad21;hb=6c06fdc7ad20682f0f52b5a78e5e3487a2ed047b;hp=2f1166d420c7e3c24c626dd28c6ae9700857c3a4;hpb=abc32aba7135136c89e089296e296fbb380bda39;p=ghc-hetmet.git diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 2f1166d..f0fc523 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,27 +1000,21 @@ 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 } +---------------------- +-- Notes for 'ctype' +-- We should probably use 'gentype' rather than 'type' in the LHS of type declarations +-- That would leave the only use of 'type' in 'ctype'; and only one of its occurrences +-- makes sense there too! So it might make sense to inline type there: +-- ctype : 'forall' tv_bndrs '.' ctype +-- | context '=>' ctype +-- | ipvar '::' gentype +-- | gentype +-- Which in turn would let us rename gentype to type + -- A ctype is a for-all type ctype :: { LHsType RdrName } : 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } @@ -1018,22 +1022,47 @@ ctype :: { LHsType RdrName } -- A type of form (context => type) is an *implicit* HsForAllTy | type { $1 } +type :: { LHsType RdrName } + : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) } + | gentype { $1 } + +---------------------- +-- Notes for 'ctypedoc' +-- It would have been nice to simplify the grammar by unifying `ctype` and +-- ctypedoc` into one production, allowing comments on types everywhere (and +-- rejecting them after parsing, where necessary). This is however not possible +-- since it leads to ambiguity. The reason is the support for comments on record +-- fields: +-- data R = R { field :: Int -- ^ comment on the field } +-- If we allow comments on types here, it's not clear if the comment applies +-- to 'field' or to 'Int'. So we must use `ctype` to describe the type. + +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 } + +typedoc :: { LHsType RdrName } + : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) } + | gentypedoc { $1 } + +---------------------- +-- Notes for 'context' -- 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) -- looks so much like a tuple type. We can't tell until we find the => --- --- We have the t1 ~ t2 form here and in gentype, to permit an individual --- equational constraint without parenthesis. + +-- We have the t1 ~ t2 form both in 'context' and in gentype, +-- to permit an individual equational constraint without parenthesis. +-- Thus for some reason we allow f :: a~b => blah +-- but not f :: ?x::Int => blah context :: { LHsContext RdrName } : btype '~' btype {% checkContext (LL $ HsPredTy (HsEqualP $1 $3)) } | btype {% checkContext $1 } -type :: { LHsType RdrName } - : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) } - | gentype { $1 } - gentype :: { LHsType RdrName } : btype { $1 } | btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } @@ -1041,14 +1070,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 +1314,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)) } @@ -1791,6 +1829,11 @@ tyvar : tyvarid { $1 } tyvarop :: { Located RdrName } tyvarop : '`' tyvarid '`' { LL (unLoc $2) } | tyvarsym { $1 } + | '.' {% parseErrorSDoc (getLoc $1) + (vcat [ptext (sLit "Illegal symbol '.' in type"), + ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"), + ptext (sLit "to enable explicit-forall syntax: forall . ")]) + } tyvarid :: { Located RdrName } : VARID { L1 $! mkUnqual tvName (getVARID $1) } @@ -2004,6 +2047,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