diff options
Diffstat (limited to 'compiler/parser/Parser.y')
| -rw-r--r-- | compiler/parser/Parser.y | 924 |
1 files changed, 502 insertions, 422 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 672b6f74ab..dd9beadc4d 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -48,7 +48,7 @@ import PackageConfig import OrdList import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) import FastString -import Maybes ( orElse ) +import Maybes ( isJust, orElse ) import Outputable -- compiler/basicTypes @@ -76,21 +76,20 @@ import TcEvidence ( emptyTcEvBinds ) -- compiler/prelude import ForeignCall import TysPrim ( eqPrimTyCon ) -import PrelNames ( eqTyCon_RDR ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) + listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) -- compiler/utils import Util ( looksLikePackageName ) -import Prelude +import GhcPrelude import qualified GHC.LanguageExtensions as LangExt } -%expect 36 -- shift/reduce conflicts +%expect 235 -- shift/reduce conflicts -{- Last updated: 3 Aug 2016 +{- Last updated: 04 June 2018 If you modify this parser and add a conflict, please update this comment. You can learn more about the conflicts by passing 'happy' the -i flag: @@ -121,7 +120,7 @@ follows. Shift parses as if the 'module' keyword follows. ------------------------------------------------------------------------------- -state 48 contains 2 shift/reduce conflicts. +state 57 contains 2 shift/reduce conflicts. *** strict_mark -> unpackedness . strict_mark -> unpackedness . strictness @@ -130,7 +129,7 @@ state 48 contains 2 shift/reduce conflicts. ------------------------------------------------------------------------------- -state 52 contains 1 shift/reduce conflict. +state 61 contains 1 shift/reduce conflict. context -> btype . *** type -> btype . @@ -140,16 +139,25 @@ state 52 contains 1 shift/reduce conflict. ------------------------------------------------------------------------------- -state 53 contains 9 shift/reduce conflicts. +state 62 contains 46 shift/reduce conflicts. *** btype -> tyapps . tyapps -> tyapps . tyapp - Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM + Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' SIMPLEQUOTE + VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM + STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE + and all the special ids. + +Example ambiguity: + 'if x then y else z :: F a' + +Shift parses as (per longest-parse rule): + 'if x then y else z :: (F a)' ------------------------------------------------------------------------------- -state 134 contains 14 shift/reduce conflicts. +state 144 contains 15 shift/reduce conflicts. exp -> infixexp . '::' sigtype exp -> infixexp . '-<' exp @@ -160,7 +168,7 @@ state 134 contains 14 shift/reduce conflicts. infixexp -> infixexp . qop exp10 Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-' - '.' '`' VARSYM CONSYM QVARSYM QCONSYM + '.' '`' '*' VARSYM CONSYM QVARSYM QCONSYM Examples of ambiguity: 'if x then y else z -< e' @@ -174,7 +182,44 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 299 contains 1 shift/reduce conflicts. +state 149 contains 67 shift/reduce conflicts. + + *** exp10 -> fexp . + fexp -> fexp . aexp + fexp -> fexp . TYPEAPP atype + + Conflicts: TYPEAPP and all the tokens that can start an aexp + +Examples of ambiguity: + 'if x then y else f z' + 'if x then y else f @ z' + +Shift parses as (per longest-parse rule): + 'if x then y else (f z)' + 'if x then y else (f @ z)' + +------------------------------------------------------------------------------- + +state 204 contains 27 shift/reduce conflicts. + + aexp2 -> TH_TY_QUOTE . tyvar + aexp2 -> TH_TY_QUOTE . gtycon + *** aexp2 -> TH_TY_QUOTE . + + Conflicts: two single quotes is error syntax with specific error message. + +Example of ambiguity: + 'x = ''' + 'x = ''a' + 'x = ''T' + +Shift parses as (per longest-parse rule): + 'x = ''a' + 'x = ''T' + +------------------------------------------------------------------------------- + +state 300 contains 1 shift/reduce conflicts. rule -> STRING . rule_activation rule_forall infixexp '=' exp @@ -192,18 +237,18 @@ a rule instructing how to rewrite the expression '[0] f'. ------------------------------------------------------------------------------- -state 309 contains 1 shift/reduce conflict. +state 310 contains 1 shift/reduce conflict. *** type -> btype . type -> btype . '->' ctype Conflict: '->' -Same as state 50 but without contexts. +Same as state 61 but without contexts. ------------------------------------------------------------------------------- -state 348 contains 1 shift/reduce conflicts. +state 354 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail sysdcon_nolist -> '(' commas . ')' @@ -218,7 +263,7 @@ if -XTupleSections is not specified. ------------------------------------------------------------------------------- -state 402 contains 1 shift/reduce conflicts. +state 409 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail sysdcon_nolist -> '(#' commas . '#)' @@ -226,22 +271,35 @@ state 402 contains 1 shift/reduce conflicts. Conflict: '#)' (empty tup_tail reduces) -Same as State 324 for unboxed tuples. +Same as State 354 for unboxed tuples. + +------------------------------------------------------------------------------- + +state 417 contains 67 shift/reduce conflicts. + + *** exp10 -> '-' fexp . + fexp -> fexp . aexp + fexp -> fexp . TYPEAPP atype + +Same as 149 but with a unary minus. ------------------------------------------------------------------------------- -state 477 contains 1 shift/reduce conflict. +state 481 contains 1 shift/reduce conflict. oqtycon -> '(' qtyconsym . ')' *** qtyconop -> qtyconsym . Conflict: ')' -TODO: Why? +Example ambiguity: 'foo :: (:%)' + +Shift means '(:%)' gets parsed as a type constructor, rather than than a +parenthesized infix type expression of length 1. ------------------------------------------------------------------------------- -state 658 contains 1 shift/reduce conflicts. +state 675 contains 1 shift/reduce conflicts. *** aexp2 -> ipvar . dbind -> ipvar . '=' exp @@ -256,7 +314,7 @@ sensible meaning, namely the lhs of an implicit binding. ------------------------------------------------------------------------------- -state 731 contains 1 shift/reduce conflicts. +state 752 contains 1 shift/reduce conflicts. rule -> STRING rule_activation . rule_forall infixexp '=' exp @@ -273,7 +331,7 @@ doesn't include 'forall'. ------------------------------------------------------------------------------- -state 963 contains 1 shift/reduce conflicts. +state 986 contains 1 shift/reduce conflicts. transformqual -> 'then' 'group' . 'using' exp transformqual -> 'then' 'group' . 'by' exp 'using' exp @@ -283,14 +341,25 @@ state 963 contains 1 shift/reduce conflicts. ------------------------------------------------------------------------------- -state 1303 contains 1 shift/reduce conflict. +state 1367 contains 1 shift/reduce conflict. *** atype -> tyvar . tv_bndr -> '(' tyvar . '::' kind ')' Conflict: '::' -TODO: Why? +Example ambiguity: 'class C a where type D a = ( a :: * ...' + +Here the parser cannot tell whether this is specifying a default for the +associated type like: + +'class C a where type D a = ( a :: * ); type D a' + +or it is an injectivity signature like: + +'class C a where type D a = ( r :: * ) | r -> a' + +Shift means the parser only allows the latter. ------------------------------------------------------------------------------- -- API Annotations @@ -414,6 +483,7 @@ are the most common patterns, rewritten as regular expressions for clarity: 'static' { L _ ITstatic } -- for static pointers extension 'stock' { L _ ITstock } -- for DerivingStrategies extension 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension + 'via' { L _ ITvia } -- for DerivingStrategies extension 'unit' { L _ ITunit } 'signature' { L _ ITsignature } @@ -432,9 +502,6 @@ are the most common patterns, rewritten as regular expressions for clarity: '{-# UNPACK' { L _ (ITunpack_prag _) } '{-# NOUNPACK' { L _ (ITnounpack_prag _) } '{-# ANN' { L _ (ITann_prag _) } - '{-# VECTORISE' { L _ (ITvect_prag _) } - '{-# VECTORISE_SCALAR' { L _ (ITvect_scalar_prag _) } - '{-# NOVECTORISE' { L _ (ITnovect_prag _) } '{-# MINIMAL' { L _ (ITminimal_prag _) } '{-# CTYPE' { L _ (ITctype _) } '{-# OVERLAPPING' { L _ (IToverlapping_prag _) } @@ -455,10 +522,10 @@ are the most common patterns, rewritten as regular expressions for clarity: '->' { L _ (ITrarrow _) } '@' { L _ ITat } '~' { L _ ITtilde } - '~#' { L _ ITtildehsh } '=>' { L _ (ITdarrow _) } '-' { L _ ITminus } '!' { L _ ITbang } + '*' { L _ (ITstar _) } '-<' { L _ (ITlarrowtail _) } -- for arrow notation '>-' { L _ (ITrarrowtail _) } -- for arrow notation '-<<' { L _ (ITLarrowtail _) } -- for arrow notation @@ -558,7 +625,9 @@ identifier :: { Located RdrName } | qvarop { $1 } | qconop { $1 } | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) - [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] } + [mop $1,mu AnnRarrow $2,mcp $3] } + | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) + [mop $1,mj AnnTilde $2,mcp $3] } ----------------------------------------------------------------------------- -- Backpack stuff @@ -781,9 +850,9 @@ expdoclist :: { OrdList (LIE GhcPs) } | {- empty -} { nilOL } exp_doc :: { OrdList (LIE GhcPs) } - : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) } - | docnamed { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) } - | docnext { unitOL (sL1 $1 (IEDoc (unLoc $1))) } + : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup noExt n doc)) } + | docnamed { unitOL (sL1 $1 (IEDocNamed noExt ((fst . unLoc) $1))) } + | docnext { unitOL (sL1 $1 (IEDoc noExt (unLoc $1))) } -- No longer allow things like [] and (,,,) to be exported @@ -791,9 +860,9 @@ exp_doc :: { OrdList (LIE GhcPs) } export :: { OrdList (LIE GhcPs) } : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2) >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } - | 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2)) + | 'module' modid {% amsu (sLL $1 $> (IEModuleContents noExt $2)) [mj AnnModule $1] } - | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2)))) + | 'pattern' qcon {% amsu (sLL $1 $> (IEVar noExt (sLL $1 $> (IEPattern $2)))) [mj AnnPattern $1] } export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } @@ -870,7 +939,8 @@ importdecls_semi importdecl :: { LImportDecl GhcPs } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec {% ams (L (comb4 $1 $6 (snd $7) $8) $ - ImportDecl { ideclSourceSrc = snd $ fst $2 + ImportDecl { ideclExt = noExt + , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 , ideclSource = snd $2, ideclSafe = snd $3 , ideclQualified = snd $4, ideclImplicit = False @@ -953,49 +1023,22 @@ topdecls_semi :: { OrdList (LHsDecl GhcPs) } | {- empty -} { nilOL } topdecl :: { LHsDecl GhcPs } - : cl_decl { sL1 $1 (TyClD (unLoc $1)) } - | ty_decl { sL1 $1 (TyClD (unLoc $1)) } - | inst_decl { sL1 $1 (InstD (unLoc $1)) } - | stand_alone_deriving { sLL $1 $> (DerivD (unLoc $1)) } - | role_annot { sL1 $1 (RoleAnnotD (unLoc $1)) } - | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD (DefaultDecl $3))) + : cl_decl { sL1 $1 (TyClD noExt (unLoc $1)) } + | ty_decl { sL1 $1 (TyClD noExt (unLoc $1)) } + | inst_decl { sL1 $1 (InstD noExt (unLoc $1)) } + | stand_alone_deriving { sLL $1 $> (DerivD noExt (unLoc $1)) } + | role_annot { sL1 $1 (RoleAnnotD noExt (unLoc $1)) } + | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD noExt (DefaultDecl noExt $3))) [mj AnnDefault $1 ,mop $2,mcp $4] } | 'foreign' fdecl {% ams (sLL $1 $> (snd $ unLoc $2)) (mj AnnForeign $1:(fst $ unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2))) + | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD noExt (Warnings noExt (getDEPRECATED_PRAGs $1) (fromOL $2))) [mo $1,mc $3] } - | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2))) + | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD noExt (Warnings noExt (getWARNING_PRAGs $1) (fromOL $2))) [mo $1,mc $3] } - | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2))) + | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD noExt (HsRules noExt (getRULES_PRAGs $1) (fromOL $2))) [mo $1,mc $3] } - | '{-# VECTORISE' qvar '=' exp '#-}' {% ams (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4)) - [mo $1,mj AnnEqual $3 - ,mc $5] } - | '{-# NOVECTORISE' qvar '#-}' {% ams (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2)) - [mo $1,mc $3] } - | '{-# VECTORISE' 'type' gtycon '#-}' - {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing)) - [mo $1,mj AnnType $2,mc $4] } - - | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' - {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing)) - [mo $1,mj AnnType $2,mc $4] } - - | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' - {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5))) - [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } - | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' - {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5))) - [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } - - | '{-# VECTORISE' 'class' gtycon '#-}' - {% ams (sLL $1 $> $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3)) - [mo $1,mj AnnClass $2,mc $4] } | annotation { $1 } | decl_no_th { $1 } @@ -1066,12 +1109,13 @@ ty_decl :: { LTyClDecl GhcPs } inst_decl :: { LInstDecl GhcPs } : 'instance' overlap_pragma inst_type where_inst {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) - ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds + ; let cid = ClsInstDecl { cid_ext = noExt + , cid_poly_ty = $3, cid_binds = binds , cid_sigs = mkClassOpSigs sigs , cid_tyfam_insts = ats , cid_overlap_mode = $2 , cid_datafam_insts = adts } - ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid })) + ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid })) (mj AnnInstance $1 : (fst $ unLoc $4)) } } -- type instance declarations @@ -1109,13 +1153,26 @@ overlap_pragma :: { Maybe (Located OverlapMode) } [mo $1,mc $2] } | {- empty -} { Nothing } -deriv_strategy :: { Maybe (Located DerivStrategy) } +deriv_strategy_no_via :: { LDerivStrategy GhcPs } + : 'stock' {% ams (sL1 $1 StockStrategy) + [mj AnnStock $1] } + | 'anyclass' {% ams (sL1 $1 AnyclassStrategy) + [mj AnnAnyclass $1] } + | 'newtype' {% ams (sL1 $1 NewtypeStrategy) + [mj AnnNewtype $1] } + +deriv_strategy_via :: { LDerivStrategy GhcPs } + : 'via' type {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2))) + [mj AnnVia $1] } + +deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } : 'stock' {% ajs (Just (sL1 $1 StockStrategy)) [mj AnnStock $1] } | 'anyclass' {% ajs (Just (sL1 $1 AnyclassStrategy)) [mj AnnAnyclass $1] } | 'newtype' {% ajs (Just (sL1 $1 NewtypeStrategy)) [mj AnnNewtype $1] } + | deriv_strategy_via { Just $1 } | {- empty -} { Nothing } -- Injective type families @@ -1154,21 +1211,23 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) } ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% asl (unLoc $1) $2 (snd $ unLoc $3) - >> ams $3 (fst $ unLoc $3) - >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) } + {% let L loc (anns, eqn) = $3 in + asl (unLoc $1) $2 (L loc eqn) + >> ams $3 anns + >> return (sLL $1 $> (L loc eqn : unLoc $1)) } | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn {% ams $1 (fst $ unLoc $1) - >> return (sLL $1 $> [snd $ unLoc $1]) } + | ty_fam_inst_eqn {% let L loc (anns, eqn) = $1 in + ams $1 anns + >> return (sLL $1 $> [L loc eqn]) } | {- empty -} { noLoc [] } -ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn GhcPs) } +ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } : type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3 - ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn)) } } + ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } } -- Associated type family declarations -- @@ -1273,22 +1332,22 @@ opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) } | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) } opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } - : { noLoc ([] , noLoc NoSig )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))} + : { noLoc ([] , noLoc (NoSig noExt) )} + | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExt $2))} opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } - : { noLoc ([] , noLoc NoSig )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))} - | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))} + : { noLoc ([] , noLoc (NoSig noExt) )} + | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExt $2))} + | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExt $2))} opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs , Maybe (LInjectivityAnn GhcPs)))} - : { noLoc ([], (noLoc NoSig, Nothing)) } + : { noLoc ([], (noLoc (NoSig noExt), Nothing)) } | '::' kind { sLL $1 $> ( [mu AnnDcolon $1] - , (sLL $2 $> (KindSig $2), Nothing)) } + , (sLL $2 $> (KindSig noExt $2), Nothing)) } | '=' tv_bndr '|' injectivity_cond { sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] - , (sLL $1 $2 (TyVarSig $2), Just $4))} + , (sLL $1 $2 (TyVarSig noExt $2), Just $4))} -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -1320,10 +1379,11 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl GhcPs } - : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type + : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type {% do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr $5) } - ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4)) + ; ams (sLL $1 (hsSigType $>) + (DerivDecl noExt (mkHsWildCardBndrs $5) $2 $4)) [mj AnnDeriving $1, mj AnnInstance $3] } } ----------------------------------------------------------------------------- @@ -1354,28 +1414,28 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 } pattern_synonym_decl :: { LHsDecl GhcPs } : 'pattern' pattern_synonym_lhs '=' pat {% let (name, args,as ) = $2 in - ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 + ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4 ImplicitBidirectional) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) } | 'pattern' pattern_synonym_lhs '<-' pat {% let (name, args, as) = $2 in - ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional) + ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4 Unidirectional) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) } | 'pattern' pattern_synonym_lhs '<-' pat where_decls {% do { let (name, args, as) = $2 ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) - ; ams (sLL $1 $> . ValD $ + ; ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4 (ExplicitBidirectional mg)) (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) ) }} pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) } - : con vars0 { ($1, PrefixPatSyn $2, []) } - | varid conop varid { ($2, InfixPatSyn $1 $3, []) } - | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) } + : con vars0 { ($1, PrefixCon $2, []) } + | varid conop varid { ($2, InfixCon $1 $3, []) } + | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) } vars0 :: { [Located RdrName] } : {- empty -} { [] } @@ -1395,7 +1455,7 @@ where_decls :: { Located ([AddAnn] pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtypedoc - {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4)) + {% ams (sLL $1 $> $ PatSynSig noExt (unLoc $2) (mkLHsSigType $4)) [mj AnnPattern $1, mu AnnDcolon $3] } ----------------------------------------------------------------------------- @@ -1412,7 +1472,7 @@ decl_cls : at_decl_cls { $1 } {% do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> quotes (ppr $2) - ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4) + ; ams (sLL $1 $> $ SigD noExt $ ClassOpSig noExt True [v] $ mkLHsSigType $4) [mj AnnDefault $1,mu AnnDcolon $3] } } decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed @@ -1450,7 +1510,7 @@ where_cls :: { Located ([AddAnn] -- Declarations in instance bodies -- decl_inst :: { Located (OrdList (LHsDecl GhcPs)) } -decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) } +decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD noExt (unLoc $1)))) } | decl { sLL $1 $> (unitOL $1) } decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed @@ -1518,15 +1578,13 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } -- No type declarations : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) ; return (sL1 $1 (fst $ unLoc $1 - ,sL1 $1 $ HsValBinds val_binds)) } } + ,sL1 $1 $ HsValBinds noExt val_binds)) } } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) - emptyTcEvBinds)) } + ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } | vocurly dbinds close { L (getLoc $2) ([] - ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) - emptyTcEvBinds)) } + ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } @@ -1550,10 +1608,9 @@ rules :: { OrdList (LRuleDecl GhcPs) } rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_forall infixexp '=' exp - {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1)) + {%ams (sLL $1 $> $ (HsRule noExt (L (gl $1) (getSTRINGs $1,getSTRING $1)) ((snd $2) `orElse` AlwaysActive) - (snd $3) $4 placeHolderNames $6 - placeHolderNames)) + (snd $3) $4 $6)) (mj AnnEqual $5 : (fst $2) ++ (fst $3)) } -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas @@ -1579,8 +1636,8 @@ rule_var_list :: { [LRuleBndr GhcPs] } | rule_var rule_var_list { $1 : $2 } rule_var :: { LRuleBndr GhcPs } - : varid { sLL $1 $> (RuleBndr $1) } - | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2 + : varid { sLL $1 $> (RuleBndr noExt $1) } + | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig noExt $2 (mkLHsSigWcType $4))) [mop $1,mu AnnDcolon $3,mcp $5] } @@ -1598,7 +1655,7 @@ warnings :: { OrdList (LWarnDecl GhcPs) } -- SUP: TEMPORARY HACK, not checking for `module Foo' warning :: { OrdList (LWarnDecl GhcPs) } : namelist strings - {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) + {% amsu (sLL $1 $> (Warning noExt (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) (fst $ unLoc $2) } deprecations :: { OrdList (LWarnDecl GhcPs) } @@ -1613,7 +1670,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LWarnDecl GhcPs) } : namelist strings - {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) + {% amsu (sLL $1 $> $ (Warning noExt (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) (fst $ unLoc $2) } strings :: { Located ([AddAnn],[Located StringLiteral]) } @@ -1630,17 +1687,17 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } ----------------------------------------------------------------------------- -- Annotations annotation :: { LHsDecl GhcPs } - : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) (ValueAnnProvenance $2) $3)) [mo $1,mc $4] } - | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) (TypeAnnProvenance $3) $4)) [mo $1,mj AnnType $2,mc $5] } - | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) ModuleAnnProvenance $3)) [mo $1,mj AnnModule $2,mc $4] } @@ -1690,10 +1747,6 @@ opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) } : {- empty -} { ([],Nothing) } | '::' sigtype { ([mu AnnDcolon $1],Just $2) } -opt_asig :: { ([AddAnn],Maybe (LHsType GhcPs)) } - : {- empty -} { ([],Nothing) } - | '::' atype { ([mu AnnDcolon $1],Just $2) } - opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } : {- empty -} { ([], Nothing) } | '::' gtycon { ([mu AnnDcolon $1], Just $2) } @@ -1741,13 +1794,15 @@ ctype :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> ams (sLL $1 $> $ HsForAllTy { hst_bndrs = $2 + , hst_xforall = noExt , hst_body = $4 }) [mu AnnForall $1, mj AnnDot $3] } | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ HsQualTy { hst_ctxt = $1 + , hst_xqual = noExt , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3)) + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3)) [mu AnnDcolon $2] } | type { $1 } @@ -1766,13 +1821,15 @@ ctypedoc :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> ams (sLL $1 $> $ HsForAllTy { hst_bndrs = $2 + , hst_xforall = noExt , hst_body = $4 }) [mu AnnForall $1,mj AnnDot $3] } | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ HsQualTy { hst_ctxt = $1 + , hst_xqual = noExt , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3)) + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3)) [mu AnnDcolon $2] } | typedoc { $1 } @@ -1797,7 +1854,7 @@ context :: { LHsContext GhcPs } } } context_no_ops :: { LHsContext GhcPs } - : btype_no_ops {% do { ty <- splitTilde $1 + : btype_no_ops {% do { ty <- splitTilde (reverse (unLoc $1)) ; (anns,ctx) <- checkContext ty ; if null (unLoc ctx) then addAnnotation (gl ty) AnnUnit (gl ty) @@ -1809,9 +1866,10 @@ context_no_ops :: { LHsContext GhcPs } ~~~~~~~~~~~~~~~~~~~~~ The type production for - btype `->` btype + btype `->` ctypedoc + btype docprev `->` ctypedoc -adds the AnnRarrow annotation twice, in different places. +add the AnnRarrow annotation twice, in different places. This is because if the type is processed as usual, it belongs on the annotations for the type as a whole. @@ -1824,91 +1882,106 @@ is connected to the first type too. type :: { LHsType GhcPs } : btype { $1 } | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy $1 $3) + >> ams (sLL $1 $> $ HsFunTy noExt $1 $3) [mu AnnRarrow $2] } typedoc :: { LHsType GhcPs } : btype { $1 } - | btype docprev { sLL $1 $> $ HsDocTy $1 $2 } - | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3) + | btype docprev { sLL $1 $> $ HsDocTy noExt $1 $2 } + | docnext btype { sLL $1 $> $ HsDocTy noExt $2 $1 } + | btype '->' ctypedoc {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] + >> ams (sLL $1 $> $ HsFunTy noExt $1 $3) [mu AnnRarrow $2] } - | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ - HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) + | btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] + >> ams (sLL $1 $> $ + HsFunTy noExt (L (comb2 $1 $2) + (HsDocTy noExt $1 $2)) + $4) + [mu AnnRarrow $3] } + | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] + >> ams (sLL $1 $> $ + HsFunTy noExt (L (comb2 $1 $2) + (HsDocTy noExt $2 $1)) $4) [mu AnnRarrow $3] } + + -- See Note [Parsing ~] btype :: { LHsType GhcPs } - : tyapps {% splitTildeApps (reverse (unLoc $1)) >>= - \ts -> return $ sL1 $1 $ HsAppsTy ts } + : tyapps {% mergeOps (unLoc $1) } -- Used for parsing Haskell98-style data constructors, -- in order to forbid the blasphemous -- > data Foo = Int :+ Char :* Bool -- See also Note [Parsing data constructors is hard] in RdrHsSyn -btype_no_ops :: { LHsType GhcPs } - : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 } - | atype { $1 } +btype_no_ops :: { Located [LHsType GhcPs] } -- NB: This list is reversed + : atype_docs { sL1 $1 [$1] } + | btype_no_ops atype_docs { sLL $1 $> $ $2 : (unLoc $1) } -tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed +tyapps :: { Located [Located TyEl] } -- NB: This list is reversed : tyapp { sL1 $1 [$1] } | tyapps tyapp { sLL $1 $> $ $2 : (unLoc $1) } --- See Note [HsAppsTy] in HsTypes -tyapp :: { LHsAppType GhcPs } - : atype { sL1 $1 $ HsAppPrefix $1 } - | qtyconop { sL1 $1 $ HsAppInfix $1 } - | tyvarop { sL1 $1 $ HsAppInfix $1 } - | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix $2) - [mj AnnSimpleQuote $1] } - | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2) - [mj AnnSimpleQuote $1] } +tyapp :: { Located TyEl } + : atype { sL1 $1 $ TyElOpd (unLoc $1) } + | qtyconop { sL1 $1 $ TyElOpr (unLoc $1) } + | tyvarop { sL1 $1 $ TyElOpr (unLoc $1) } + | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) + [mj AnnSimpleQuote $1,mj AnnVal $2] } + | SIMPLEQUOTE varop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) + [mj AnnSimpleQuote $1,mj AnnVal $2] } + +atype_docs :: { LHsType GhcPs } + : atype docprev { sLL $1 $> $ HsDocTy noExt $1 $2 } + | atype { $1 } atype :: { LHsType GhcPs } - : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples - | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples]) - | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2)) + : ntgtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- Not including unit tuples + | tyvar { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- (See Note [Unit tuples]) + | '*' {% do { warnStarIsType (getLoc $1) + ; return $ sL1 $1 (HsStarTy noExt (isUnicode $1)) } } + | strict_mark atype {% ams (sLL $1 $> (HsBangTy noExt (snd $ unLoc $1) $2)) (fst $ unLoc $1) } -- Constructor sigs only | '{' fielddecls '}' {% amms (checkRecordSyntax - (sLL $1 $> $ HsRecTy $2)) + (sLL $1 $> $ HsRecTy noExt $2)) -- Constructor sigs only [moc $1,mcc $3] } - | '(' ')' {% ams (sLL $1 $> $ HsTupleTy + | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExt HsBoxedOrConstraintTuple []) [mop $1,mcp $2] } | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma (gl $3) >> - ams (sLL $1 $> $ HsTupleTy + ams (sLL $1 $> $ HsTupleTy noExt + HsBoxedOrConstraintTuple ($2 : $4)) [mop $1,mcp $5] } - | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple []) + | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple []) [mo $1,mc $2] } - | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2) + | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple $2) [mo $1,mc $3] } - | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy $2) + | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExt $2) [mo $1,mc $3] } - | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] } - | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] } - | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] } - | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4) + | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy noExt $2) [mos $1,mcs $3] } + | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy noExt $2) [mop $1,mcp $3] } + | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig noExt $2 $4) [mop $1,mu AnnDcolon $3,mcp $5] } - | quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) } + | quasiquote { sL1 $1 (HsSpliceTy noExt (unLoc $1) ) } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } - | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar $ + | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar noExt $ (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1)))) [mj AnnThIdSplice $1] } -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $3) AnnComma (gl $4) >> - ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) + ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5)) [mj AnnSimpleQuote $1,mop $2,mcp $6] } - | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy Promoted - placeHolderKind $3) + | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExt Promoted $3) [mj AnnSimpleQuote $1,mos $2,mcs $4] } - | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2) + | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } -- Two or more [ty, ty, ty] must be a promoted list type, just as @@ -1917,13 +1990,12 @@ atype :: { LHsType GhcPs } -- so you have to quote those.) | '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma (gl $3) >> - ams (sLL $1 $> $ HsExplicitListTy NotPromoted - placeHolderKind ($2 : $4)) + ams (sLL $1 $> $ HsExplicitListTy noExt NotPromoted ($2 : $4)) [mos $1,mcs $5] } - | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1) - (il_value (getINTEGER $1)) } - | STRING { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1) - (getSTRING $1) } + | INTEGER { sLL $1 $> $ HsTyLit noExt $ HsNumTy (getINTEGERs $1) + (il_value (getINTEGER $1)) } + | STRING { sLL $1 $> $ HsTyLit noExt $ HsStrTy (getSTRINGs $1) + (getSTRING $1) } | '_' { sL1 $1 $ mkAnonWildCardTy } -- An inst_type is what occurs in the head of an instance decl @@ -1958,8 +2030,8 @@ tv_bndrs :: { [LHsTyVarBndr GhcPs] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr GhcPs } - : tyvar { sL1 $1 (UserTyVar $1) } - | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4)) + : tyvar { sL1 $1 (UserTyVar noExt $1) } + | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExt $2 $4)) [mop $1,mu AnnDcolon $3 ,mcp $5] } @@ -1988,13 +2060,13 @@ Note [Parsing ~] Due to parsing conflicts between laziness annotations in data type declarations (see strict_mark) and equality types ~'s are always -parsed as laziness annotations, and turned into HsEqTy's in the +parsed as laziness annotations, and turned into HsOpTy's in the correct places using RdrHsSyn.splitTilde. Since strict_mark is parsed as part of atype which is part of type, typedoc and context (where HsEqTy previously appeared) it made most sense and was simplest to parse ~ as part of strict_mark and later -turn them into HsEqTy's. +turn them into HsOpTy's. -} @@ -2032,14 +2104,17 @@ both become a HsTyVar ("Zero", DataName) after the renamer. gadt_constrlist :: { Located ([AddAnn] ,[LConDecl GhcPs]) } -- Returned in order - : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) - ([mj AnnWhere $1 - ,moc $2 - ,mcc $4] - , unLoc $3) } - | 'where' vocurly gadt_constrs close { L (comb2 $1 $3) - ([mj AnnWhere $1] - , unLoc $3) } + + : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $ + L (comb2 $1 $3) + ([mj AnnWhere $1 + ,moc $2 + ,mcc $4] + , unLoc $3) } + | 'where' vocurly gadt_constrs close {% checkEmptyGADTs $ + L (comb2 $1 $3) + ([mj AnnWhere $1] + , unLoc $3) } | {- empty -} { noLoc ([],[]) } gadt_constrs :: { Located [LConDecl GhcPs] } @@ -2065,9 +2140,10 @@ gadt_constr_with_doc gadt_constr :: { LConDecl GhcPs } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty - : con_list '::' sigtype - {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3))) - [mu AnnDcolon $2] } + : con_list '::' sigtypedoc + {% let (gadt,anns) = mkGadtDecl (unLoc $1) $3 + in ams (sLL $1 $> gadt) + (mu AnnDcolon $2:anns) } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2092,29 +2168,39 @@ constrs1 :: { Located [LConDecl GhcPs] } | constr { sL1 $1 [$1] } constr :: { LConDecl GhcPs } - : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev - {% ams (let (con,details) = unLoc $5 in + : maybe_docnext forall context_no_ops '=>' constr_stuff + {% ams (let (con,details,doc_prev) = unLoc $5 in addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con - (snd $ unLoc $2) $3 details)) - ($1 `mplus` $6)) + (snd $ unLoc $2) + (Just $3) + details)) + ($1 `mplus` doc_prev)) (mu AnnDarrow $4:(fst $ unLoc $2)) } - | maybe_docnext forall constr_stuff maybe_docprev - {% ams ( let (con,details) = unLoc $3 in + | maybe_docnext forall constr_stuff + {% ams ( let (con,details,doc_prev) = unLoc $3 in addConDoc (L (comb2 $2 $3) (mkConDeclH98 con - (snd $ unLoc $2) (noLoc []) details)) - ($1 `mplus` $4)) + (snd $ unLoc $2) + Nothing -- No context + details)) + ($1 `mplus` doc_prev)) (fst $ unLoc $2) } forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) } : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } | {- empty -} { noLoc ([], Nothing) } -constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) } +constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString) } -- See Note [Parsing data constructors is hard] in RdrHsSyn - : btype_no_ops {% do { c <- splitCon $1 - ; return $ sLL $1 $> c } } - | btype_no_ops conop btype_no_ops {% do { ty <- splitTilde $1 - ; return $ sLL $1 $> ($2, InfixCon ty $3) } } + : btype_no_ops {% do { c <- splitCon (unLoc $1) + ; return $ sL1 $1 c } } + | btype_no_ops conop maybe_docprev btype_no_ops + {% do { lhs <- splitTilde (reverse (unLoc $1)) + ; (_, ds_l) <- checkInfixConstr lhs + ; let rhs1 = foldl1 mkHsAppTy (reverse (unLoc $4)) + ; (rhs, ds_r) <- checkInfixConstr rhs1 + ; return $ if isJust (ds_l `mplus` $3) + then sLL $1 $> ($2, InfixCon lhs rhs1, $3) + else sLL $1 $> ($2, InfixCon lhs rhs, ds_r) } } fielddecls :: { [LConDeclField GhcPs] } : {- empty -} { [] } @@ -2130,7 +2216,7 @@ fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev {% ams (L (comb2 $2 $4) - (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5))) + (ConDeclField noExt (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } -- Reversed! @@ -2146,21 +2232,27 @@ derivings :: { HsDeriving GhcPs } -- The outer Located is just to allow the caller to -- know the rightmost extremity of the 'deriving' clause deriving :: { LHsDerivingClause GhcPs } - : 'deriving' deriv_strategy qtycondoc + : 'deriving' deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc - [mkLHsSigType $3]) + in ams (L full_loc $ HsDerivingClause noExt Nothing $2) [mj AnnDeriving $1] } - | 'deriving' deriv_strategy '(' ')' + | 'deriving' deriv_strategy_no_via deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc []) - [mj AnnDeriving $1,mop $3,mcp $4] } + in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3) + [mj AnnDeriving $1] } - | 'deriving' deriv_strategy '(' deriv_types ')' + | 'deriving' deriv_clause_types deriv_strategy_via {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc $4) - [mj AnnDeriving $1,mop $3,mcp $5] } + in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2) + [mj AnnDeriving $1] } + +deriv_clause_types :: { Located [LHsSigType GhcPs] } + : qtycondoc { sL1 $1 [mkLHsSigType $1] } + | '(' ')' {% ams (sLL $1 $> []) + [mop $1,mcp $2] } + | '(' deriv_types ')' {% ams (sLL $1 $> $2) + [mop $1,mcp $3] } -- Glasgow extension: allow partial -- applications in derivings @@ -2190,7 +2282,7 @@ There's an awkward overlap with a type signature. Consider -} docdecl :: { LHsDecl GhcPs } - : docdecld { sL1 $1 (DocD (unLoc $1)) } + : docdecld { sL1 $1 (DocD noExt (unLoc $1)) } docdecld :: { LDocDecl } : docnext { sL1 $1 (DocCommentNext (unLoc $1)) } @@ -2201,35 +2293,34 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } - | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) - -- Turn it all into an expression so that - -- checkPattern can check that bangs are enabled + | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2) ; l = comb2 $1 $> }; (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ; + hintBangPat (comb2 $1 $2) (unLoc e) ; -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note - -- [Varieties of binding pattern matches] + -- [FunBind vs PatBind] case r of { - (FunBind n _ _ _ _) -> + (FunBind _ n _ _ _) -> ams (L l ()) [mj AnnFunId n] >> return () ; - (PatBind (L lh _lhs) _rhs _ _ _) -> + (PatBind _ (L lh _lhs) _rhs _) -> ams (L lh ()) [] >> return () } ; _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; - return $! (sL l $ ValD r) } } + return $! (sL l $ ValD noExt r) } } | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3; let { l = comb2 $1 $> }; -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note - -- [Varieties of binding pattern matches] + -- [FunBind vs PatBind] case r of { - (FunBind n _ _ _ _) -> + (FunBind _ n _ _ _) -> ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind (L lh _lhs) _rhs _ _ _) -> + (PatBind _ (L lh _lhs) _rhs _) -> ams (L lh ()) (fst $2) >> return () } ; _ <- ams (L l ()) (ann ++ (fst $ unLoc $3)); - return $! (sL l $ ValD r) } } + return $! (sL l $ ValD noExt r) } } | pattern_synonym_decl { $1 } | docdecl { $1 } @@ -2244,10 +2335,10 @@ decl :: { LHsDecl GhcPs } rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) ((mj AnnEqual $1 : (fst $ unLoc $3)) - ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2) + ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2) (snd $ unLoc $3)) } | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2 - ,GRHSs (reverse (unLoc $1)) + ,GRHSs noExt (reverse (unLoc $1)) (snd $ unLoc $2)) } gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } @@ -2255,7 +2346,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } | gdrh { sL1 $1 [$1] } gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } - : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) + : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) [mj AnnVbar $1,mj AnnEqual $3] } sigdecl :: { LHsDecl GhcPs } @@ -2264,69 +2355,69 @@ sigdecl :: { LHsDecl GhcPs } infixexp_top '::' sigtypedoc {% do v <- checkValSigLhs $1 ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2] - ; return (sLL $1 $> $ SigD $ - TypeSig [v] (mkLHsSigWcType $3)) } + ; return (sLL $1 $> $ SigD noExt $ + TypeSig noExt [v] (mkLHsSigWcType $3)) } | var ',' sig_vars '::' sigtypedoc - {% do { let sig = TypeSig ($1 : reverse (unLoc $3)) + {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3)) (mkLHsSigWcType $5) ; addAnnotation (gl $1) AnnComma (gl $2) - ; ams ( sLL $1 $> $ SigD sig ) + ; ams ( sLL $1 $> $ SigD noExt sig ) [mu AnnDcolon $4] } } | infix prec ops - {% ams (sLL $1 $> $ SigD - (FixSig (FixitySig (fromOL $ unLoc $3) + {% ams (sLL $1 $> $ SigD noExt + (FixSig noExt (FixitySig noExt (fromOL $ unLoc $3) (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) [mj AnnInfix $1,mj AnnVal $2] } - | pattern_synonym_sig { sLL $1 $> . SigD . unLoc $ $1 } + | pattern_synonym_sig { sLL $1 $> . SigD noExt . unLoc $ $1 } | '{-# COMPLETE' con_list opt_tyconsig '#-}' {% let (dcolon, tc) = $3 in ams (sLL $1 $> - (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc))) + (SigD noExt (CompleteMatchSig noExt (getCOMPLETE_PRAGs $1) $2 tc))) ([ mo $1 ] ++ dcolon ++ [mc $4]) } -- This rule is for both INLINE and INLINABLE pragmas | '{-# INLINE' activation qvar '#-}' - {% ams ((sLL $1 $> $ SigD (InlineSig $3 + {% ams ((sLL $1 $> $ SigD noExt (InlineSig noExt $3 (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) (snd $2))))) ((mo $1:fst $2) ++ [mc $4]) } | '{-# SCC' qvar '#-}' - {% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing))) + {% ams (sLL $1 $> (SigD noExt (SCCFunSig noExt (getSCC_PRAGs $1) $2 Nothing))) [mo $1, mc $3] } | '{-# SCC' qvar STRING '#-}' {% do { scc <- getSCC $3 ; let str_lit = StringLiteral (getSTRINGs $3) scc - ; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) + ; ams (sLL $1 $> (SigD noExt (SCCFunSig noExt (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) [mo $1, mc $4] } } | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' {% ams ( let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) - (EmptyInlineSpec, FunLike) (snd $2) - in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag)) + (NoUserInline, FunLike) (snd $2) + in sLL $1 $> $ SigD noExt (SpecSig noExt $3 (fromOL $5) inl_prag)) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - {% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) + {% ams (sLL $1 $> $ SigD noExt (SpecSig noExt $3 (fromOL $5) (mkInlinePragma (getSPEC_INLINE_PRAGs $1) (getSPEC_INLINE $1) (snd $2)))) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } | '{-# SPECIALISE' 'instance' inst_type '#-}' {% ams (sLL $1 $> - $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3)) + $ SigD noExt (SpecInstSig noExt (getSPEC_PRAGs $1) $3)) [mo $1,mj AnnInstance $2,mc $4] } -- A minimal complete definition | '{-# MINIMAL' name_boolformula_opt '#-}' - {% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2)) + {% ams (sLL $1 $> $ SigD noExt (MinimalSig noExt (getMINIMAL_PRAGs $1) $2)) [mo $1,mc $3] } activation :: { ([AddAnn],Maybe Activation) } @@ -2354,89 +2445,45 @@ quasiquote :: { Located (HsSplice GhcPs) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr GhcPs } - : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3)) + : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig (mkLHsSigWcType $3) $1) [mu AnnDcolon $2] } - | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType + | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3 HsFirstOrderApp True) [mu Annlarrowtail $2] } - | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType + | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1 HsFirstOrderApp False) [mu Annrarrowtail $2] } - | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType + | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3 HsHigherOrderApp True) [mu AnnLarrowtail $2] } - | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType + | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1 HsHigherOrderApp False) [mu AnnRarrowtail $2] } | infixexp { $1 } infixexp :: { LHsExpr GhcPs } : exp10 { $1 } - | infixexp qop exp10 {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) + | infixexp qop exp10 {% ams (sLL $1 $> (OpApp noExt $1 $2 $3)) [mj AnnVal $2] } -- AnnVal annotation for NPlusKPat, which discards the operator infixexp_top :: { LHsExpr GhcPs } : exp10_top { $1 } | infixexp_top qop exp10_top - {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) + {% ams (sLL $1 $> (OpApp noExt $1 $2 $3)) [mj AnnVal $2] } -exp10_top :: { LHsExpr GhcPs } - : '\\' apat apats opt_asig '->' exp - {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource - [sLL $1 $> $ Match { m_ctxt = LambdaExpr - , m_pats = $2:$3 - , m_type = snd $4 - , m_grhss = unguardedGRHSs $6 }])) - (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) } - | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) - (mj AnnLet $1:mj AnnIn $3 - :(fst $ unLoc $2)) } - | '\\' 'lcase' altslist - {% ams (sLL $1 $> $ HsLamCase - (mkMatchGroup FromSource (snd $ unLoc $3))) - (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } - | 'if' exp optSemi 'then' exp optSemi 'else' exp - {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> - ams (sLL $1 $> $ mkHsIf $2 $5 $8) - (mj AnnIf $1:mj AnnThen $4 - :mj AnnElse $7 - :(map (\l -> mj AnnSemi l) (fst $3)) - ++(map (\l -> mj AnnSemi l) (fst $6))) } - | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> - ams (sLL $1 $> $ HsMultiIf - placeHolderType - (reverse $ snd $ unLoc $2)) - (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup - FromSource (snd $ unLoc $4))) - (mj AnnCase $1:mj AnnOf $3 - :(fst $ unLoc $4)) } - | '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr) +exp10_top :: { LHsExpr GhcPs } + : '-' fexp {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr) [mj AnnMinus $1] } - | 'do' stmtlist {% ams (L (comb2 $1 $2) - (mkHsDo DoExpr (snd $ unLoc $2))) - (mj AnnDo $1:(fst $ unLoc $2)) } - | 'mdo' stmtlist {% ams (L (comb2 $1 $2) - (mkHsDo MDoExpr (snd $ unLoc $2))) - (mj AnnMdo $1:(fst $ unLoc $2)) } - | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1) + | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1) (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ fst $ unLoc $1) } - | 'proc' aexp '->' exp - {% checkPattern empty $2 >>= \ p -> - checkCommand $4 >>= \ cmd -> - ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType - placeHolderType [])) - -- TODO: is LL right here? - [mj AnnProc $1,mu AnnRarrow $3] } - - | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4) + | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } -- hdaume: core annotation @@ -2444,7 +2491,7 @@ exp10_top :: { LHsExpr GhcPs } exp10 :: { LHsExpr GhcPs } : exp10_top { $1 } - | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + | scc_annot exp {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ unLoc $1) } optSemi :: { ([Located a],Bool) } @@ -2487,19 +2534,65 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In } fexp :: { LHsExpr GhcPs } - : fexp aexp { sLL $1 $> $ HsApp $1 $2 } - | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3)) + : fexp aexp {% checkBlockArguments $1 >> checkBlockArguments $2 >> + return (sLL $1 $> $ (HsApp noExt $1 $2)) } + | fexp TYPEAPP atype {% checkBlockArguments $1 >> + ams (sLL $1 $> $ HsAppType (mkHsWildCardBndrs $3) $1) [mj AnnAt $2] } - | 'static' aexp {% ams (sLL $1 $> $ HsStatic placeHolderNames $2) + | 'static' aexp {% ams (sLL $1 $> $ HsStatic noExt $2) [mj AnnStatic $1] } | aexp { $1 } aexp :: { LHsExpr GhcPs } - : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] } + : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] } -- If you change the parsing, make sure to understand -- Note [Lexing type applications] in Lexer.x - | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] } + | '~' aexp {% ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] } + + | '\\' apat apats '->' exp + {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource + [sLL $1 $> $ Match { m_ext = noExt + , m_ctxt = LambdaExpr + , m_pats = $2:$3 + , m_grhss = unguardedGRHSs $5 }])) + [mj AnnLam $1, mu AnnRarrow $4] } + | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4) + (mj AnnLet $1:mj AnnIn $3 + :(fst $ unLoc $2)) } + | '\\' 'lcase' altslist + {% ams (sLL $1 $> $ HsLamCase noExt + (mkMatchGroup FromSource (snd $ unLoc $3))) + (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } + | 'if' exp optSemi 'then' exp optSemi 'else' exp + {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> + ams (sLL $1 $> $ mkHsIf $2 $5 $8) + (mj AnnIf $1:mj AnnThen $4 + :mj AnnElse $7 + :(map (\l -> mj AnnSemi l) (fst $3)) + ++(map (\l -> mj AnnSemi l) (fst $6))) } + | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> + ams (sLL $1 $> $ HsMultiIf noExt + (reverse $ snd $ unLoc $2)) + (mj AnnIf $1:(fst $ unLoc $2)) } + | 'case' exp 'of' altslist {% ams (L (comb3 $1 $3 $4) $ + HsCase noExt $2 (mkMatchGroup + FromSource (snd $ unLoc $4))) + (mj AnnCase $1:mj AnnOf $3 + :(fst $ unLoc $4)) } + | 'do' stmtlist {% ams (L (comb2 $1 $2) + (mkHsDo DoExpr (snd $ unLoc $2))) + (mj AnnDo $1:(fst $ unLoc $2)) } + | 'mdo' stmtlist {% ams (L (comb2 $1 $2) + (mkHsDo MDoExpr (snd $ unLoc $2))) + (mj AnnMdo $1:(fst $ unLoc $2)) } + | 'proc' aexp '->' exp + {% checkPattern empty $2 >>= \ p -> + checkCommand $4 >>= \ cmd -> + ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd)) + -- TODO: is LL right here? + [mj AnnProc $1,mu AnnRarrow $3] } + | aexp1 { $1 } aexp1 :: { LHsExpr GhcPs } @@ -2510,72 +2603,70 @@ aexp1 :: { LHsExpr GhcPs } | aexp2 { $1 } aexp2 :: { LHsExpr GhcPs } - : qvar { sL1 $1 (HsVar $! $1) } - | qcon { sL1 $1 (HsVar $! $1) } - | ipvar { sL1 $1 (HsIPVar $! unLoc $1) } - | overloaded_label { sL1 $1 (HsOverLabel Nothing $! unLoc $1) } - | literal { sL1 $1 (HsLit $! unLoc $1) } + : qvar { sL1 $1 (HsVar noExt $! $1) } + | qcon { sL1 $1 (HsVar noExt $! $1) } + | ipvar { sL1 $1 (HsIPVar noExt $! unLoc $1) } + | overloaded_label { sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) } + | literal { sL1 $1 (HsLit noExt $! unLoc $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. -- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) --- (getSTRING $1) placeHolderType) } - | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral - (getINTEGER $1) placeHolderType) } - | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional - (getRATIONAL $1) placeHolderType) } +-- (getSTRING $1) noExt) } + | INTEGER { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) } + | RATIONAL { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. - | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] } + | '(' texp ')' {% ams (sLL $1 $> (HsPar noExt $2)) [mop $1,mcp $3] } | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2) - (Present $2)] Unboxed)) + | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2) + (Present noExt $2)] Unboxed)) [mo $1,mc $3] } | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } } | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } - | '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) } - | '_' { sL1 $1 EWildPat } + | '_' { sL1 $1 $ EWildPat noExt } -- Template Haskell Extension | splice_exp { $1 } - | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) + | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) } + | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) + | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] } + | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> - ams (sLL $1 $> $ HsBracket (PatBr p)) + ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p)) [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2))) + | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2))) (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { sL1 $1 (HsSpliceE (unLoc $1)) } + | quasiquote { sL1 $1 (HsSpliceE noExt (unLoc $1)) } -- arrow notation extension - | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm $2 + | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm noExt $2 Nothing (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } splice_exp :: { LHsExpr GhcPs } : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE HasDollar - (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName + (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE HasDollar - (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName + (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2) @@ -2587,8 +2678,7 @@ cmdargs :: { [LHsCmdTop GhcPs] } acmd :: { LHsCmdTop GhcPs } : aexp2 {% checkCommand $1 >>= \ cmd -> - return (sL1 $1 $ HsCmdTop cmd - placeHolderType placeHolderType []) } + return (sL1 $1 $ HsCmdTop noExt cmd) } cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 @@ -2619,17 +2709,17 @@ texp :: { LHsExpr GhcPs } -- Then when converting expr to pattern we unravel it again -- Meanwhile, the renamer checks that real sections appear -- inside parens. - | infixexp qop { sLL $1 $> $ SectionL $1 $2 } - | qopm infixexp { sLL $1 $> $ SectionR $1 $2 } + | infixexp qop { sLL $1 $> $ SectionL noExt $1 $2 } + | qopm infixexp { sLL $1 $> $ SectionR noExt $1 $2 } -- View patterns get parenthesized above - | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] } + | exp '->' texp {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] } -- Always at least one comma or bar. tup_exprs :: { ([AddAnn],SumOrTuple) } : texp commas_tup_tail {% do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } } + ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } } | texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } @@ -2652,8 +2742,8 @@ commas_tup_tail : commas tup_tail -- Always follows a comma tup_tail :: { [LHsTupArg GhcPs] } : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> - return ((L (gl $1) (Present $1)) : snd $2) } - | texp { [L (gl $1) (Present $1)] } + return ((L (gl $1) (Present noExt $1)) : snd $2) } + | texp { [L (gl $1) (Present noExt $1)] } | {- empty -} { [noLoc missingTupArg] } ----------------------------------------------------------------------------- @@ -2662,19 +2752,18 @@ tup_tail :: { [LHsTupArg GhcPs] } -- The rules below are little bit contorted to keep lexps left-recursive while -- avoiding another shift/reduce-conflict. list :: { ([AddAnn],HsExpr GhcPs) } - : texp { ([],ExplicitList placeHolderType Nothing [$1]) } - | lexps { ([],ExplicitList placeHolderType Nothing - (reverse (unLoc $1))) } + : texp { ([],ExplicitList noExt Nothing [$1]) } + | lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) } | texp '..' { ([mj AnnDotdot $2], - ArithSeq noPostTcExpr Nothing (From $1)) } + ArithSeq noExt Nothing (From $1)) } | texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noPostTcExpr Nothing + ArithSeq noExt Nothing (FromThen $1 $3)) } | texp '..' exp { ([mj AnnDotdot $2], - ArithSeq noPostTcExpr Nothing + ArithSeq noExt Nothing (FromTo $1 $3)) } | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noPostTcExpr Nothing + ArithSeq noExt Nothing (FromThenTo $1 $3 $5)) } | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> @@ -2697,9 +2786,9 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | + qss -> sL1 $1 [sL1 $1 $ ParStmt noExt [ParStmtBlock noExt qs [] noSyntaxExpr | qs <- qss] - noExpr noSyntaxExpr placeHolderType] + noExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } @@ -2746,29 +2835,6 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs -- in by choosing the "group by" variant, which is what we want. ----------------------------------------------------------------------------- --- Parallel array expressions - --- The rules below are little bit contorted; see the list case for details. --- Note that, in contrast to lists, we only have finite arithmetic sequences. --- Moreover, we allow explicit arrays with no element (represented by the nil --- constructor in the list case). - -parr :: { ([AddAnn],HsExpr GhcPs) } - : { ([],ExplicitPArr placeHolderType []) } - | texp { ([],ExplicitPArr placeHolderType [$1]) } - | lexps { ([],ExplicitPArr placeHolderType - (reverse (unLoc $1))) } - | texp '..' exp { ([mj AnnDotdot $2] - ,PArrSeq noPostTcExpr (FromTo $1 $3)) } - | texp ',' exp '..' exp - { ([mj AnnComma $2,mj AnnDotdot $4] - ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) } - | texp '|' flattenedpquals - { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) } - --- We are reusing `lexps' and `flattenedpquals' from the list case. - ------------------------------------------------------------------------------ -- Guards guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } @@ -2788,7 +2854,7 @@ altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } ,(reverse (snd $ unLoc $2))) } | vocurly alts close { L (getLoc $2) (fst $ unLoc $2 ,(reverse (snd $ unLoc $2))) } - | '{' '}' { noLoc ([moc $1,mcc $2],[]) } + | '{' '}' { sLL $1 $> ([moc $1,mcc $2],[]) } | vocurly close { noLoc ([],[]) } alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } @@ -2812,15 +2878,15 @@ alts1 :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } | alt { sL1 $1 ([],[$1]) } alt :: { LMatch GhcPs (LHsExpr GhcPs) } - : pat opt_asig alt_rhs {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt - , m_pats = [$1] - , m_type = snd $2 - , m_grhss = snd $ unLoc $3 })) - (fst $2 ++ (fst $ unLoc $3))} + : pat alt_rhs {%ams (sLL $1 $> (Match { m_ext = noExt + , m_ctxt = CaseAlt + , m_pats = [$1] + , m_grhss = snd $ unLoc $2 })) + (fst $ unLoc $2)} alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } : ralt wherebinds { sLL $1 $> (fst $ unLoc $2, - GRHSs (unLoc $1) (snd $ unLoc $2)) } + GRHSs noExt (unLoc $1) (snd $ unLoc $2)) } ralt :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } : '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) @@ -2840,7 +2906,7 @@ ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) } : '|' guardquals '->' exp - {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) + {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) [mj AnnVbar $1,mu AnnRarrow $3] } -- 'pat' recognises a pattern, including one with a bang at the top @@ -2849,8 +2915,8 @@ gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) } -- we parse them right when bang-patterns are off pat :: { LPat GhcPs } pat : exp {% checkPattern empty $1 } - | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR - (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR noExt + (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } bindpat :: { LPat GhcPs } @@ -2858,14 +2924,14 @@ bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% amms (checkPattern (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } apat :: { LPat GhcPs } apat : aexp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty - (sLL $1 $> (SectionR - (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (SectionR noExt + (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } apats :: { [LPat GhcPs] } @@ -2920,7 +2986,7 @@ qual :: { LStmt GhcPs (LHsExpr GhcPs) } : bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3) [mu AnnLarrow $2] } | exp { sL1 $1 $ mkBodyStmt $1 } - | 'let' binds {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2)) + | 'let' binds {% ams (sLL $1 $>$ LetStmt noExt (snd $ unLoc $2)) (mj AnnLet $1:(fst $ unLoc $2)) } ----------------------------------------------------------------------------- @@ -2962,7 +3028,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- | {- empty -} { [] } dbind :: { LIPBind GhcPs } -dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3)) +dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind noExt (Left $1) $3)) [mj AnnEqual $2] } ipvar :: { Located HsIPName } @@ -3027,8 +3093,6 @@ gen_qcon :: { Located RdrName } | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) [mop $1,mj AnnVal $2,mcp $3] } --- The case of '[:' ':]' is part of the production `parr' - con :: { Located RdrName } : conid { $1 } | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) @@ -3088,9 +3152,6 @@ ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) [mop $1,mu AnnRarrow $2,mcp $3] } | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } - | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } - | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) - [mop $1,mj AnnTildehsh $2,mcp $3] } oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; -- These can appear in export lists @@ -3143,8 +3204,8 @@ qtycon :: { Located RdrName } -- Qualified or unqualified | tycon { $1 } qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified - : qtycon { sL1 $1 (HsTyVar NotPromoted $1) } - | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) } + : qtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } + | qtycon docprev { sLL $1 $> (HsDocTy noExt (sL1 $1 (HsTyVar noExt NotPromoted $1)) $2) } tycon :: { Located RdrName } -- Unqualified : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } @@ -3177,15 +3238,19 @@ varop :: { Located RdrName } ,mj AnnBackquote $3] } qop :: { LHsExpr GhcPs } -- used in sections - : qvarop { sL1 $1 $ HsVar $1 } - | qconop { sL1 $1 $ HsVar $1 } - | '`' '_' '`' {% ams (sLL $1 $> EWildPat) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } + : qvarop { sL1 $1 $ HsVar noExt $1 } + | qconop { sL1 $1 $ HsVar noExt $1 } + | hole_op { $1 } qopm :: { LHsExpr GhcPs } -- used in sections - : qvaropm { sL1 $1 $ HsVar $1 } - | qconop { sL1 $1 $ HsVar $1 } + : qvaropm { sL1 $1 $ HsVar noExt $1 } + | qconop { sL1 $1 $ HsVar noExt $1 } + | hole_op { $1 } + +hole_op :: { LHsExpr GhcPs } -- used in sections +hole_op : '`' '_' '`' {% ams (sLL $1 $> $ EWildPat noExt) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } qvarop :: { Located RdrName } : qvarsym { $1 } @@ -3298,6 +3363,7 @@ special_id | 'group' { sL1 $1 (fsLit "group") } | 'stock' { sL1 $1 (fsLit "stock") } | 'anyclass' { sL1 $1 (fsLit "anyclass") } + | 'via' { sL1 $1 (fsLit "via") } | 'unit' { sL1 $1 (fsLit "unit") } | 'dependency' { sL1 $1 (fsLit "dependency") } | 'signature' { sL1 $1 (fsLit "signature") } @@ -3305,6 +3371,7 @@ special_id special_sym :: { Located FastString } special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } | '.' { sL1 $1 (fsLit ".") } + | '*' { sL1 $1 (fsLit (if isUnicode $1 then "\x2605" else "*")) } ----------------------------------------------------------------------------- -- Data constructors @@ -3331,19 +3398,19 @@ consym :: { Located RdrName } -- Literals literal :: { Located (HsLit GhcPs) } - : CHAR { sL1 $1 $ HsChar (sst $ getCHARs $1) $ getCHAR $1 } - | STRING { sL1 $1 $ HsString (sst $ getSTRINGs $1) - $ getSTRING $1 } - | PRIMINTEGER { sL1 $1 $ HsIntPrim (sst $ getPRIMINTEGERs $1) - $ getPRIMINTEGER $1 } - | PRIMWORD { sL1 $1 $ HsWordPrim (sst $ getPRIMWORDs $1) - $ getPRIMWORD $1 } - | PRIMCHAR { sL1 $1 $ HsCharPrim (sst $ getPRIMCHARs $1) - $ getPRIMCHAR $1 } - | PRIMSTRING { sL1 $1 $ HsStringPrim (sst $ getPRIMSTRINGs $1) - $ getPRIMSTRING $1 } - | PRIMFLOAT { sL1 $1 $ HsFloatPrim def $ getPRIMFLOAT $1 } - | PRIMDOUBLE { sL1 $1 $ HsDoublePrim def $ getPRIMDOUBLE $1 } + : CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 } + | STRING { sL1 $1 $ HsString (getSTRINGs $1) + $ getSTRING $1 } + | PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1) + $ getPRIMINTEGER $1 } + | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1) + $ getPRIMWORD $1 } + | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1) + $ getPRIMCHAR $1 } + | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1) + $ getPRIMSTRING $1 } + | PRIMFLOAT { sL1 $1 $ HsFloatPrim noExt $ getPRIMFLOAT $1 } + | PRIMDOUBLE { sL1 $1 $ HsDoublePrim noExt $ getPRIMDOUBLE $1 } ----------------------------------------------------------------------------- -- Layout @@ -3379,24 +3446,24 @@ bars :: { ([SrcSpan],Int) } -- One or more bars -- Documentation comments docnext :: { LHsDocString } - : DOCNEXT {% return (sL1 $1 (HsDocString (mkFastString (getDOCNEXT $1)))) } + : DOCNEXT {% return (sL1 $1 (mkHsDocString (getDOCNEXT $1))) } docprev :: { LHsDocString } - : DOCPREV {% return (sL1 $1 (HsDocString (mkFastString (getDOCPREV $1)))) } + : DOCPREV {% return (sL1 $1 (mkHsDocString (getDOCPREV $1))) } docnamed :: { Located (String, HsDocString) } : DOCNAMED {% let string = getDOCNAMED $1 (name, rest) = break isSpace string - in return (sL1 $1 (name, HsDocString (mkFastString rest))) } + in return (sL1 $1 (name, mkHsDocString rest)) } docsection :: { Located (Int, HsDocString) } : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in - return (sL1 $1 (n, HsDocString (mkFastString doc))) } + return (sL1 $1 (n, mkHsDocString doc)) } moduleheader :: { Maybe LHsDocString } : DOCNEXT {% let string = getDOCNEXT $1 in - return (Just (sL1 $1 (HsDocString (mkFastString string)))) } + return (Just (sL1 $1 (mkHsDocString string))) } maybe_docprev :: { Maybe LHsDocString } : docprev { Just $1 } @@ -3464,9 +3531,6 @@ getCORE_PRAGs (L _ (ITcore_prag src)) = src getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src getANN_PRAGs (L _ (ITann_prag src)) = src -getVECT_PRAGs (L _ (ITvect_prag src)) = src -getVECT_SCALAR_PRAGs (L _ (ITvect_scalar_prag src)) = src -getNOVECT_PRAGs (L _ (ITnovect_prag src)) = src getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src @@ -3490,6 +3554,7 @@ isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax isUnicode _ = False hasE :: Located Token -> Bool @@ -3625,6 +3690,24 @@ hintExplicitForall' span = do , text "extension to enable explicit-forall syntax: forall <tvs>. <type>" ] +-- When two single quotes don't followed by tyvar or gtycon, we report the +-- error as empty character literal, or TH quote that missing proper type +-- variable or constructor. See Trac #13450. +reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs)) +reportEmptyDoubleQuotes span = do + thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState + if thEnabled + then parseErrorSDoc span $ vcat + [ text "Parser error on `''`" + , text "Character literals may not be empty" + , text "Or perhaps you intended to use quotation syntax of TemplateHaskell," + , text "but the type variable or constructor is missing" + ] + else parseErrorSDoc span $ vcat + [ text "Parser error on `''`" + , text "Character literals may not be empty" + ] + {- %************************************************************************ %* * @@ -3740,7 +3823,4 @@ oll l = asl :: [Located a] -> Located b -> Located a -> P() asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls - -sst ::HasSourceText a => SourceText -> a -sst = setSourceText } |