summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/ApiAnnotation.hs1
-rw-r--r--compiler/parser/Parser.y220
-rw-r--r--compiler/parser/RdrHsSyn.hs92
3 files changed, 160 insertions, 153 deletions
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index b20f23f066..9d289d0d25 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -242,7 +242,6 @@ data AnnKeywordId
| AnnMinus -- ^ '-'
| AnnModule
| AnnNewtype
- | AnnName -- ^ where a name loses its location in the AST, this carries it
| AnnOf
| AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc
| AnnOpenC -- ^ '{'
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 175cfbbdfc..82c696156f 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -552,12 +552,12 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) }
-----------------------------------------------------------------------------
-- Identifiers; one of the entry points
-identifier :: { Located RdrName }
+identifier :: { Located (Embellished RdrName) }
: qvar { $1 }
| qcon { $1 }
| qvarop { $1 }
| qconop { $1 }
- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon)
+ | '(' '->' ')' {% ams (sLL $1 $> $ EName $ getRdrName funTyCon)
[mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] }
-----------------------------------------------------------------------------
@@ -793,7 +793,7 @@ export :: { OrdList (LIE RdrName) }
>>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
| 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2))
[mj AnnModule $1] }
- | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2))))
+ | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $ unLEmb $2))))
[mj AnnPattern $1] }
export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
@@ -827,12 +827,12 @@ qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) }
| '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) }
qcname_ext :: { Located ImpExpQcSpec }
- : qcname { sL1 $1 (ImpExpQcName $1) }
- | 'type' oqtycon {% do { n <- mkTypeImpExp $2
+ : qcname { sL1 $1 (ImpExpQcName (unLEmb $1)) }
+ | 'type' oqtycon {% do { n <- mkTypeImpExp (unLEmb $2)
; ams (sLL $1 $> (ImpExpQcType n))
[mj AnnType $1] } }
-qcname :: { Located RdrName } -- Variable or type constructor
+qcname :: { Located (Embellished RdrName) } -- Variable or type constructor
: qvar { $1 } -- Things which look like functions
-- Note: This includes record selectors but
-- also (-.->), see #11432
@@ -935,7 +935,7 @@ infix :: { Located FixityDirection }
| 'infixl' { sL1 $1 InfixL }
| 'infixr' { sL1 $1 InfixR }
-ops :: { Located (OrdList (Located RdrName)) }
+ops :: { Located (OrdList (Located (Embellished RdrName))) }
: ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))}
| op { sL1 $1 (unitOL $1) }
@@ -1352,7 +1352,7 @@ pattern_synonym_decl :: { LHsDecl RdrName }
(as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )
}}
-pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }
+pattern_synonym_lhs :: { (Located (Embellished 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] ) }
@@ -1656,9 +1656,9 @@ fspec :: { Located ([AddAnn]
,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) }
: STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3]
,(L (getLoc $1)
- (getStringLiteral $1), $2, mkLHsSigType $4)) }
+ (getStringLiteral $1), unLEmb $2, mkLHsSigType $4)) }
| var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2]
- ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
+ ,(noLoc (StringLiteral NoSourceText nilFS), unLEmb $1, mkLHsSigType $3)) }
-- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling
-- convention
@@ -1674,7 +1674,7 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
: {- empty -} { ([],Nothing) }
| '::' atype { ([mu AnnDcolon $1],Just $2) }
-opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
+opt_tyconsig :: { ([AddAnn], Maybe (Located (Embellished RdrName))) }
: {- empty -} { ([], Nothing) }
| '::' gtycon { ([mu AnnDcolon $1], Just $2) }
@@ -1685,7 +1685,7 @@ sigtypedoc :: { LHsType RdrName }
: ctypedoc { $1 }
-sig_vars :: { Located [Located RdrName] } -- Returned in reversed order
+sig_vars :: { Located [Located (Embellished RdrName)] } -- Returned in reversed order
: sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1)
AnnComma (gl $2)
>> return (sLL $1 $> ($3 : unLoc $1)) }
@@ -1846,8 +1846,8 @@ tyapp :: { LHsAppType RdrName }
[mj AnnSimpleQuote $1] }
atype :: { LHsType RdrName }
- : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples
- | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples])
+ : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples
+ | tyvar { sL1 $1 (HsTyVar NotPromoted (lEmb $1)) } -- (See Note [Unit tuples])
| strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
(fst $ unLoc $1) } -- Constructor sigs only
| '{' fielddecls '}' {% amms (checkRecordSyntax
@@ -1877,10 +1877,10 @@ atype :: { LHsType RdrName }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2)
[mj AnnOpenPE $1,mj AnnCloseP $3] }
| TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy NoParens $ sL1 $1 $ HsVar $
- (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
+ (sL1 $1 (EName $ 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 Promoted $2) [mj AnnSimpleQuote $1] }
| SIMPLEQUOTE '(' ctype ',' comma_types1 ')'
{% addAnnotation (gl $3) AnnComma (gl $4) >>
ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
@@ -1889,7 +1889,7 @@ atype :: { LHsType RdrName }
placeHolderKind $3)
[mj AnnSimpleQuote $1,mos $2,mcs $4] }
| SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2)
- [mj AnnSimpleQuote $1,mj AnnName $2] }
+ [mj AnnSimpleQuote $1] }
-- Two or more [ty, ty, ty] must be a promoted list type, just as
-- if you had written '[ty, ty, ty]
@@ -2089,7 +2089,7 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) }
: 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
| {- empty -} { noLoc ([], Nothing) }
-constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
+constr_stuff :: { Located (LEmbellished RdrName, HsConDeclDetails RdrName) }
-- See Note [Parsing data constructors is hard] in RdrHsSyn
: btype_no_ops {% do { c <- splitCon $1
; return $ sLL $1 $> c } }
@@ -2181,7 +2181,7 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl RdrName }
: sigdecl { $1 }
- | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) };
+ | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2) };
pat <- checkPattern empty e;
_ <- ams (sLL $1 $> ())
(fst $ unLoc $3);
@@ -2517,10 +2517,10 @@ aexp2 :: { LHsExpr RdrName }
-- 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] }
+ | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True $2) ) [mj AnnSimpleQuote $1] }
+ | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True $2) ) [mj AnnSimpleQuote $1] }
+ | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (lEmb $2))) [mj AnnThTyQuote $1] }
+ | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False $2)) [mj AnnThTyQuote $1] }
| '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2))
(if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
| '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2))
@@ -2540,13 +2540,13 @@ aexp2 :: { LHsExpr RdrName }
splice_exp :: { LHsExpr RdrName }
: TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE NoParens
- (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+ (sL1 $1 $ HsVar (sL1 $1 (EName $ 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 NoParens
- (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+ (sL1 $1 $ HsVar (sL1 $1 (EName $ mkUnqual varName
(getTH_ID_TY_SPLICE $1)))))
[mj AnnThIdTySplice $1] }
| '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2)
@@ -2821,7 +2821,7 @@ gdpat :: { LGRHS RdrName (LHsExpr RdrName) }
pat :: { LPat RdrName }
pat : exp {% checkPattern empty $1 }
| '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR
- (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+ (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2)))
[mj AnnBang $1] }
bindpat :: { LPat RdrName }
@@ -2829,14 +2829,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 (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2)))
[mj AnnBang $1] }
apat :: { LPat RdrName }
apat : aexp {% checkPattern empty $1 }
| '!' aexp {% amms (checkPattern empty
(sLL $1 $> (SectionR
- (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+ (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2)))
[mj AnnBang $1] }
apats :: { [LPat RdrName] }
@@ -2948,31 +2948,31 @@ overloaded_label :: { Located FastString }
-----------------------------------------------------------------------------
-- Warnings and deprecations
-name_boolformula_opt :: { LBooleanFormula (Located RdrName) }
+name_boolformula_opt :: { LBooleanFormula (LEmbellished RdrName) }
: name_boolformula { $1 }
| {- empty -} { noLoc mkTrue }
-name_boolformula :: { LBooleanFormula (Located RdrName) }
+name_boolformula :: { LBooleanFormula (LEmbellished RdrName) }
: name_boolformula_and { $1 }
| name_boolformula_and '|' name_boolformula
{% aa $1 (AnnVbar, $2)
>> return (sLL $1 $> (Or [$1,$3])) }
-name_boolformula_and :: { LBooleanFormula (Located RdrName) }
+name_boolformula_and :: { LBooleanFormula (LEmbellished RdrName) }
: name_boolformula_atom { $1 }
| name_boolformula_atom ',' name_boolformula_and
{% aa $1 (AnnComma,$2) >> return (sLL $1 $> (And [$1,$3])) }
-name_boolformula_atom :: { LBooleanFormula (Located RdrName) }
+name_boolformula_atom :: { LBooleanFormula (LEmbellished RdrName) }
: '(' name_boolformula ')' {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] }
| name_var { sL1 $1 (Var $1) }
-namelist :: { Located [Located RdrName] }
+namelist :: { Located [Located (Embellished RdrName)] }
namelist : name_var { sL1 $1 [$1] }
| name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >>
return (sLL $1 $> ($1 : unLoc $3)) }
-name_var :: { Located RdrName }
+name_var :: { Located (Embellished RdrName) }
name_var : var { $1 }
| con { $1 }
@@ -2981,28 +2981,28 @@ name_var : var { $1 }
-- There are two different productions here as lifted list constructors
-- are parsed differently.
-qcon_nowiredlist :: { Located RdrName }
+qcon_nowiredlist :: { Located (Embellished RdrName) }
: gen_qcon { $1 }
- | sysdcon_nolist { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+ | sysdcon_nolist { sL1 $1 $ EName $ nameRdrName (dataConName (unLoc $1)) }
-qcon :: { Located RdrName }
+qcon :: { Located (Embellished RdrName) }
: gen_qcon { $1}
- | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+ | sysdcon { sL1 $1 $ EParens $ sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
-gen_qcon :: { Located RdrName }
- : qconid { $1 }
- | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
+gen_qcon :: { Located (Embellished RdrName) }
+ : qconid { sL1 $1 (EName $ unLoc $1) }
+ | '(' qconsym ')' {% ams (sLL $1 $> (EParens $2))
+ [mop $1,mcp $3] }
-- The case of '[:' ':]' is part of the production `parr'
-con :: { Located RdrName }
- : conid { $1 }
- | '(' consym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
- | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+con :: { Located (Embellished RdrName) }
+ : conid { sL1 $1 (EName (unLoc $1)) }
+ | '(' consym ')' {% ams (sLL $1 $> (EParens $2))
+ [mop $1,mcp $3] }
+ | sysdcon { sL1 $1 $ EName $ nameRdrName (dataConName (unLoc $1)) }
-con_list :: { Located [Located RdrName] }
+con_list :: { Located [Located (Embellished RdrName)] }
con_list : con { sL1 $1 [$1] }
| con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >>
return (sLL $1 $> ($1 : unLoc $3)) }
@@ -3019,16 +3019,16 @@ sysdcon :: { Located DataCon }
: sysdcon_nolist { $1 }
| '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] }
-conop :: { Located RdrName }
- : consym { $1 }
- | '`' conid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
+conop :: { Located (Embellished RdrName) }
+ : consym { sL1 $1 (EName (unLoc $1)) }
+ | '`' conid '`' {% ams (sLL $1 $> (EBackquotes $2))
+ [mj AnnBackquote $1
,mj AnnBackquote $3] }
-qconop :: { Located RdrName }
- : qconsym { $1 }
- | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
+qconop :: { Located (Embellished RdrName) }
+ : qconsym { sL1 $1 $ (EName $ unLoc $1) }
+ | '`' qconid '`' {% ams (sLL $1 $> (EBackquotes $2))
+ [mj AnnBackquote $1
,mj AnnBackquote $3] }
----------------------------------------------------------------------------
@@ -3037,47 +3037,47 @@ qconop :: { Located RdrName }
-- See Note [Unit tuples] in HsTypes for the distinction
-- between gtycon and ntgtycon
-gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples
+gtycon :: { Located (Embellished RdrName) } -- A "general" qualified tycon, including unit tuples
: ntgtycon { $1 }
- | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon)
+ | '(' ')' {% ams (sLL $1 $> $ EName $ getRdrName unitTyCon)
[mop $1,mcp $2] }
- | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)
+ | '(#' '#)' {% ams (sLL $1 $> $ EName $ getRdrName unboxedUnitTyCon)
[mo $1,mc $2] }
-ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples
+ntgtycon :: { Located (Embellished RdrName) } -- A "general" qualified tycon, excluding unit tuples
: oqtycon { $1 }
- | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed
+ | '(' commas ')' {% ams (sLL $1 $> $ EName $ getRdrName (tupleTyCon Boxed
(snd $2 + 1)))
(mop $1:mcp $3:(mcommas (fst $2))) }
- | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
+ | '(#' commas '#)' {% ams (sLL $1 $> $ EName $ getRdrName (tupleTyCon Unboxed
(snd $2 + 1)))
(mo $1:mc $3:(mcommas (fst $2))) }
- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon)
+ | '(' '->' ')' {% ams (sLL $1 $> $ EName $ 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)
+ | '[' ']' {% ams (sLL $1 $> $ EName $ listTyCon_RDR) [mos $1,mcs $2] }
+ | '[:' ':]' {% ams (sLL $1 $> $ EName $ parrTyCon_RDR) [mo $1,mc $2] }
+ | '(' '~#' ')' {% ams (sLL $1 $> $ EName $ getRdrName eqPrimTyCon)
[mop $1,mj AnnTildehsh $2,mcp $3] }
-oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon;
+oqtycon :: { Located (Embellished RdrName) } -- An "ordinary" qualified tycon;
-- These can appear in export lists
- : qtycon { $1 }
- | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR)
- [mop $1,mj AnnVal $2,mcp $3] }
+ : qtycon { sL1 $1 (EName $ unLoc $1) }
+ | '(' qtyconsym ')' {% ams (sLL $1 $> (EParens $2))
+ [mop $1,mcp $3] }
+ | '(' '~' ')' {% ams (sLL $1 $> $ EParens (sL1 $1 eqTyCon_RDR))
+ [mop $1,mcp $3] }
-oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mistaken
+oqtycon_no_varcon :: { Located (Embellished RdrName) } -- Type constructor which cannot be mistaken
-- for variable constructor in export lists
-- see Note [Type constructors in export list]
- : qtycon { $1 }
+ : qtycon { sL1 $1 (EName $ unLoc $1) }
| '(' QCONSYM ')' {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2)
- in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
+ in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] }
| '(' CONSYM ')' {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2)
- in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
+ in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] }
| '(' ':' ')' {% let name = sL1 $2 $! consDataCon_RDR
- in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] }
+ in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] }
+ | '(' '~' ')' {% ams (sLL $1 $> $ EParens (sL1 $2 eqTyCon_RDR)) [mop $1,mcp $3] }
{- Note [Type constructors in export list]
~~~~~~~~~~~~~~~~~~~~~
@@ -3099,10 +3099,10 @@ until after renaming when we resolve the proper namespace for each exported
child.
-}
-qtyconop :: { Located RdrName } -- Qualified or unqualified
- : qtyconsym { $1 }
- | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
+qtyconop :: { Located (Embellished RdrName) } -- Qualified or unqualified
+ : qtyconsym { sL1 $1 $ EName (unLoc $1) }
+ | '`' qtycon '`' {% ams (sLL $1 $> (EBackquotes $2))
+ [mj AnnBackquote $1
,mj AnnBackquote $3] }
qtycon :: { Located RdrName } -- Qualified or unqualified
@@ -3110,8 +3110,8 @@ qtycon :: { Located RdrName } -- Qualified or unqualified
| tycon { $1 }
qtycondoc :: { LHsType RdrName } -- Qualified or unqualified
- : qtycon { sL1 $1 (HsTyVar NotPromoted $1) }
- | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) }
+ : qtycon { sL1 $1 (HsTyVar NotPromoted (lEmb $1)) }
+ | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted (lEmb $1))) $2) }
tycon :: { Located RdrName } -- Unqualified
: CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
@@ -3133,14 +3133,14 @@ tyconsym :: { Located RdrName }
-----------------------------------------------------------------------------
-- Operators
-op :: { Located RdrName } -- used in infix decls
+op :: { Located (Embellished RdrName) } -- used in infix decls
: varop { $1 }
| conop { $1 }
-varop :: { Located RdrName }
- : varsym { $1 }
- | '`' varid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
+varop :: { Located (Embellished RdrName) }
+ : varsym { sL1 $1 (EName $ unLoc $1) }
+ | '`' varid '`' {% ams (sLL $1 $> (EBackquotes $2))
+ [mj AnnBackquote $1
,mj AnnBackquote $3] }
qop :: { LHsExpr RdrName } -- used in sections
@@ -3154,16 +3154,16 @@ qopm :: { LHsExpr RdrName } -- used in sections
: qvaropm { sL1 $1 $ HsVar $1 }
| qconop { sL1 $1 $ HsVar $1 }
-qvarop :: { Located RdrName }
- : qvarsym { $1 }
- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
+qvarop :: { Located (Embellished RdrName) }
+ : qvarsym { sL1 $1 $ EName (unLoc $1) }
+ | '`' qvarid '`' {% ams (sLL $1 $> (EBackquotes $2))
+ [mj AnnBackquote $1
,mj AnnBackquote $3] }
-qvaropm :: { Located RdrName }
- : qvarsym_no_minus { $1 }
- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
+qvaropm :: { Located (Embellished RdrName) }
+ : qvarsym_no_minus { sL1 $1 $ EName (unLoc $1) }
+ | '`' qvarid '`' {% ams (sLL $1 $> (EBackquotes $2))
+ [mj AnnBackquote $1
,mj AnnBackquote $3] }
-----------------------------------------------------------------------------
@@ -3172,9 +3172,9 @@ qvaropm :: { Located RdrName }
tyvar :: { Located RdrName }
tyvar : tyvarid { $1 }
-tyvarop :: { Located RdrName }
-tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
+tyvarop :: { Located (Embellished RdrName) }
+tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (EBackquotes $2))
+ [mj AnnBackquote $1
,mj AnnBackquote $3] }
| '.' {% parseErrorSDoc (getLoc $1)
(vcat [text "Illegal symbol '.' in type",
@@ -3192,21 +3192,21 @@ tyvarid :: { Located RdrName }
-----------------------------------------------------------------------------
-- Variables
-var :: { Located RdrName }
- : varid { $1 }
- | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
+var :: { Located (Embellished RdrName) }
+ : varid { sL1 $1 (EName $ unLoc $1) }
+ | '(' varsym ')' {% ams (sLL $1 $> (EParens $2))
+ [mop $1,mcp $3] }
-- Lexing type applications depends subtly on what characters can possibly
-- end a qvar. Currently (June 2015), only $idchars and ")" can end a qvar.
-- If you're changing this, please see Note [Lexing type applications] in
-- Lexer.x.
-qvar :: { Located RdrName }
- : qvarid { $1 }
- | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
- | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
+qvar :: { Located (Embellished RdrName) }
+ : qvarid { sL1 $1 (EName (unLoc $1)) }
+ | '(' varsym ')' {% ams (sLL $1 $> (EParens $2))
+ [mop $1,mcp $3] }
+ | '(' qvarsym1 ')' {% ams (sLL $1 $> (EParens $2))
+ [mop $1,mcp $3] }
-- We've inlined qvarsym here so that the decision about
-- whether it's a qvar or a var can be postponed until
-- *after* we see the close paren.
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 2c63c428b6..4fc18dd30a 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -293,7 +293,7 @@ mkSpliceDecl lexpr@(L loc expr)
= SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
- -> Located RdrName -- type being annotated
+ -> LEmbellished RdrName -- type being annotated
-> [Located (Maybe FastString)] -- roles
-> P (LRoleAnnotDecl RdrName)
mkRoleAnnotDecl loc tycon roles
@@ -463,7 +463,7 @@ So the plan is:
-}
splitCon :: LHsType RdrName
- -> P (Located RdrName, HsConDeclDetails RdrName)
+ -> P (LEmbellished RdrName, HsConDeclDetails RdrName)
-- See Note [Parsing data constructors is hard]
-- This gets given a "type" that should look like
-- C Int Bool
@@ -474,34 +474,37 @@ splitCon ty
where
-- This is used somewhere where HsAppsTy is not used
split (L _ (HsAppTy t u)) ts = split t (u : ts)
- split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc
- return (data_con, mk_rest ts)
+ split (L l (HsTyVar _ (L _ tc))) ts
+ = do data_con <- tyConToDataCon l tc
+ return (data_con, mk_rest ts)
split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
- = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
+ = return (L l (EName $ getRdrName (tupleDataCon Boxed (length ts)))
+ , PrefixCon ts)
split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
mk_rest ts = PrefixCon ts
-tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
+tyConToDataCon :: SrcSpan -> Embellished RdrName -> P (LEmbellished RdrName)
-- See Note [Parsing data constructors is hard]
-- Data constructor RHSs are parsed as types
tyConToDataCon loc tc
| isTcOcc occ
, isLexCon (occNameFS occ)
- = return (L loc (setRdrNameSpace tc srcDataName))
+ -- = return (L loc (setRdrNameSpace tc srcDataName))
+ = return (L loc $ fmap (\n -> setRdrNameSpace n srcDataName) tc)
| otherwise
= parseErrorSDoc loc (msg $$ extra)
where
- occ = rdrNameOcc tc
+ occ = rdrNameOcc $ unEmb tc
msg = text "Not a data constructor:" <+> quotes (ppr tc)
- extra | tc == forall_tv_RDR
+ extra | unEmb tc == forall_tv_RDR
= text "Perhaps you intended to use ExistentialQuantification"
| otherwise = empty
-mkPatSynMatchGroup :: Located RdrName
+mkPatSynMatchGroup :: LEmbellished RdrName
-> Located (OrdList (LHsDecl RdrName))
-> P (MatchGroup RdrName (LHsExpr RdrName))
mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
@@ -510,7 +513,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
; return $ mkMatchGroup FromSource matches }
where
fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) =
- do { unless (name == patsyn_name) $
+ do { unless (name == unEmb patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
PrefixCon pats ->
@@ -542,7 +545,7 @@ recordPatSynErr loc pat =
text "record syntax not supported for pattern synonym declarations:" $$
ppr pat
-mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
+mkConDeclH98 :: LEmbellished RdrName -> Maybe [LHsTyVarBndr RdrName]
-> LHsContext RdrName -> HsConDeclDetails RdrName
-> ConDecl RdrName
@@ -555,7 +558,7 @@ mkConDeclH98 name mb_forall cxt details
, con_details = details
, con_doc = Nothing }
-mkGadtDecl :: [Located RdrName]
+mkGadtDecl :: [LEmbellished RdrName]
-> LHsSigType RdrName -- Always a HsForAllTy
-> ConDecl RdrName
mkGadtDecl names ty = ConDeclGADT { con_names = names
@@ -691,9 +694,9 @@ checkTyVars pp_what equals_or_where tc tparms
-- Check that the name space is correct!
chk (L l (HsKindSig
(L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
- | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k))
+ | isRdrTyVar $ unEmb tv = return (L l (KindedTyVar (L lv $ unEmb tv) k))
chk (L l (HsTyVar _ (L ltv tv)))
- | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv)))
+ | isRdrTyVar $ unEmb tv = return (L l (UserTyVar (L ltv $ unEmb tv)))
chk t@(L loc _)
= Left (loc,
vcat [ text "Unexpected type" <+> quotes (ppr t)
@@ -743,7 +746,7 @@ checkTyClHdr is_cls ty
goL (L l ty) acc ann fix = go l ty acc ann fix
go l (HsTyVar _ (L _ tc)) acc ann fix
- | isRdrTc tc = return (L l tc, acc, fix, ann)
+ | isRdrTc $ unEmb tc = return (L l $ unEmb tc, acc, fix, ann)
go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix
| isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann)
go l (HsParTy ty) acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix
@@ -753,9 +756,9 @@ checkTyClHdr is_cls ty
= goL head (args ++ acc) ann fixity
go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix
- | occNameFS (rdrNameOcc star) == fsLit "*"
+ | occNameFS (rdrNameOcc $ unEmb star) == fsLit "*"
= return (L loc (nameRdrName starKindTyConName), [], fix, ann)
- | occNameFS (rdrNameOcc star) == fsLit "★"
+ | occNameFS (rdrNameOcc $ unEmb star) == fsLit "★"
= return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)
go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix
@@ -806,7 +809,8 @@ checkLPat msg e@(L l _) = checkPat msg l e []
checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
-> P (LPat RdrName)
checkPat _ loc (L l (HsVar (L _ c))) args
- | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
+ | isRdrDataCon $ unEmb c
+ = return (L loc (ConPatIn (L l $ unEmb c) (PrefixCon args)))
checkPat msg loc e args -- OK to let this happen even if bang-patterns
-- are not enabled, because there is no valid
-- non-bang-pattern parse of (C ! e)
@@ -827,9 +831,9 @@ checkAPat msg loc e0 = do
pState <- getPState
let opts = options pState
case e0 of
- EWildPat -> return (WildPat placeHolderType)
- HsVar x -> return (VarPat x)
- HsLit l -> return (LitPat l)
+ EWildPat -> return (WildPat placeHolderType)
+ HsVar (L l x) -> return (VarPat (L l $ unEmb x))
+ HsLit l -> return (LitPat l)
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
@@ -839,7 +843,7 @@ checkAPat msg loc e0 = do
-> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
SectionR (L lb (HsVar (L _ bang))) e -- (! x)
- | bang == bang_RDR
+ | unEmb bang == bang_RDR
-> do { bang_on <- extension bangPatEnabled
; if bang_on then do { e' <- checkLPat msg e
; addAnnotation loc AnnBang lb
@@ -857,14 +861,17 @@ checkAPat msg loc e0 = do
-- n+k patterns
OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
(L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
- | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
- -> return (mkNPlusKPat (L nloc n) (L lloc lit))
+ | extopt LangExt.NPlusKPatterns opts &&
+ (unEmb plus == plus_RDR)
+ -> return (mkNPlusKPat (L nloc $ unEmb n) (L lloc lit))
OpApp l op _fix r -> do l <- checkLPat msg l
r <- checkLPat msg r
case op of
- L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c)
- -> return (ConPatIn (L cl c) (InfixCon l r))
+ L cl (HsVar (L _ c))
+ | isDataOcc (rdrNameOcc $ unEmb c)
+ -> return (ConPatIn (L cl $ unEmb c)
+ (InfixCon l r))
_ -> patFail msg loc e0
HsPar e -> checkLPat msg e >>= (return . ParPat)
@@ -893,7 +900,7 @@ checkAPat msg loc e0 = do
placeHolderPunRhs :: LHsExpr RdrName
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when debugging
-placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR))
+placeHolderPunRhs = noLoc (HsVar (noEmb pun_RDR))
plus_RDR, bang_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
@@ -974,11 +981,11 @@ checkPatBind msg lhs (L _ (_,grhss))
; return ([],PatBind lhs grhss placeHolderType placeHolderNames
([],[])) }
-checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName)
-checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
- | isUnqual v
- , not (isDataOcc (rdrNameOcc v))
- = return lrdr
+checkValSigLhs :: LHsExpr RdrName -> P (LEmbellished RdrName)
+checkValSigLhs (L _ (HsVar (L l v)))
+ | isUnqual $ unEmb v
+ , not (isDataOcc (rdrNameOcc $ unEmb v))
+ = return (L l v)
checkValSigLhs lhs@(L l _)
= parseErrorSDoc l ((text "Invalid type signature:" <+>
@@ -997,7 +1004,7 @@ checkValSigLhs lhs@(L l _)
-- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805
-- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
- looks_like s (L _ (HsVar (L _ v))) = v == s
+ looks_like s (L _ (HsVar (L _ v))) = unEmb v == s
looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
looks_like _ _ = False
@@ -1033,7 +1040,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
-- Splits (f ! g a b) into (f, [(! g), a, b])
splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))
- | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
+ | unEmb op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
where
l' = combineLocs bang arg1
(arg1,argns) = split_bang r_arg []
@@ -1058,7 +1065,8 @@ isFunLhs :: LHsExpr RdrName
isFunLhs e = go e [] []
where
go (L loc (HsVar (L _ f))) es ann
- | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
+ | not (isRdrDataCon $ unEmb f)
+ = return (Just (L loc (unEmb f), Prefix, es, ann))
go (L _ (HsApp f e)) es ann = go f (e:es) ann
go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
@@ -1079,10 +1087,10 @@ isFunLhs e = go e [] []
| Just (e',es') <- splitBang e
= do { bang_on <- extension bangPatEnabled
; if bang_on then go e' (es' ++ es) ann
- else return (Just (L loc' op, Infix, (l:r:es), ann)) }
+ else return (Just (L loc' (unEmb op), Infix, (l:r:es), ann)) }
-- No bangs; behave just like the next case
- | not (isRdrDataCon op) -- We have found the function!
- = return (Just (L loc' op, Infix, (l:r:es), ann))
+ | not (isRdrDataCon $ unEmb op) -- We have found the function!
+ = return (Just (L loc' (unEmb op), Infix, (l:r:es), ann))
| otherwise -- Infix data con; keep going
= do { mb_l <- go l es ann
; case mb_l of
@@ -1132,7 +1140,7 @@ splitTildeApps (t : rest) = do
ty))))
= addAnnotation l AnnTilde tilde_loc >>
return
- [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
+ [L tilde_loc (HsAppInfix (L tilde_loc $ EName eqTyCon_RDR)),
L l (HsAppPrefix ty)]
-- NOTE: no annotation is attached to an HsAppPrefix, so the
-- surrounding SrcSpan is not critical
@@ -1260,8 +1268,8 @@ mkRecConstrOrUpdate
-> P (HsExpr RdrName)
mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)
- | isRdrDataCon c
- = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
+ | isRdrDataCon $ unEmb c
+ = return (mkRdrRecordCon (L l $ unEmb c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
| dd = parseErrorSDoc l (text "You cannot use `..' in a record update")
| otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
View Lorry Controller Status