summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/Parser.y321
-rw-r--r--compiler/parser/RdrHsSyn.hs533
2 files changed, 421 insertions, 433 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 01d2424a08..3a6ab1bc5b 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -760,7 +760,7 @@ unitdecl :: { LHsUnitDecl PackageName }
signature :: { Located (HsModule GhcPs) }
: maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
+ ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
(snd $ snd $7) $4 $1)
)
([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) }
@@ -768,13 +768,13 @@ signature :: { Located (HsModule GhcPs) }
module :: { Located (HsModule GhcPs) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
+ ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
(snd $ snd $7) $4 $1)
)
([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }
| body2
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule Nothing Nothing
+ ams (L loc (HsModule Nothing Nothing
(fst $ snd $1) (snd $ snd $1) Nothing Nothing))
(fst $1) }
@@ -825,15 +825,15 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
header :: { Located (HsModule GhcPs) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
)) [mj AnnModule $2,mj AnnWhere $6] }
| maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
)) [mj AnnModule $2,mj AnnWhere $6] }
| header_body2
{% fileSrcSpan >>= \ loc ->
- return (cL loc (HsModule Nothing Nothing $1 [] Nothing
+ return (L loc (HsModule Nothing Nothing $1 [] Nothing
Nothing)) }
header_body :: { [LImportDecl GhcPs] }
@@ -905,7 +905,7 @@ qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }
qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list
: qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of
- l@(dL->L _ ImpExpQcWildcard) ->
+ l@(L _ ImpExpQcWildcard) ->
return ([mj AnnComma $2, mj AnnDotdot l]
,(snd (unLoc $3) : snd $1))
l -> (ams (head (snd $1)) [mj AnnComma $2] >>
@@ -967,7 +967,7 @@ importdecl :: { LImportDecl GhcPs }
: 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec
{% do {
; checkImportDecl $4 $7
- ; ams (cL (comb4 $1 $6 (snd $8) $9) $
+ ; ams (L (comb4 $1 $6 (snd $8) $9) $
ImportDecl { ideclExt = noExtField
, ideclSourceSrc = snd $ fst $2
, ideclName = $6, ideclPkgQual = snd $5
@@ -1014,7 +1014,7 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) }
: impspec {% let (b, ie) = unLoc $1 in
checkImportSpec ie
>>= \checkedIe ->
- return (cL (gl $1) (Just (b, checkedIe))) }
+ return (L (gl $1) (Just (b, checkedIe))) }
| {- empty -} { noLoc Nothing }
impspec :: { Located (Bool, Located [LIE GhcPs]) }
@@ -1163,7 +1163,7 @@ inst_decl :: { LInstDecl GhcPs }
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
+ ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
-- type instance declarations
@@ -1250,24 +1250,24 @@ where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) }
ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
: '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3]
,Just (unLoc $2)) }
- | vocurly ty_fam_inst_eqns close { let (dL->L loc _) = $2 in
- cL loc ([],Just (unLoc $2)) }
+ | vocurly ty_fam_inst_eqns close { let (L loc _) = $2 in
+ L loc ([],Just (unLoc $2)) }
| '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2
,mcc $3],Nothing) }
- | vocurly '..' close { let (dL->L loc _) = $2 in
- cL loc ([mj AnnDotdot $2],Nothing) }
+ | vocurly '..' close { let (L loc _) = $2 in
+ L loc ([mj AnnDotdot $2],Nothing) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
- {% let (dL->L loc (anns, eqn)) = $3 in
- asl (unLoc $1) $2 (cL loc eqn)
+ {% let (L loc (anns, eqn)) = $3 in
+ asl (unLoc $1) $2 (L loc eqn)
>> ams $3 anns
- >> return (sLL $1 $> (cL loc eqn : unLoc $1)) }
+ >> 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 {% let (dL->L loc (anns, eqn)) = $1 in
+ | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in
ams $1 anns
- >> return (sLL $1 $> [cL loc eqn]) }
+ >> return (sLL $1 $> [L loc eqn]) }
| {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
@@ -1504,7 +1504,7 @@ where_decls :: { Located ([AddAnn]
, Located (OrdList (LHsDecl GhcPs))) }
: 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2
:mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) }
- | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
+ | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
,sL1 $3 (snd $ unLoc $3)) }
pattern_synonym_sig :: { LSig GhcPs }
@@ -1588,7 +1588,7 @@ decllist_inst
:: { Located ([AddAnn]
, OrdList (LHsDecl GhcPs)) } -- Reversed
: '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }
- | vocurly decls_inst close { cL (gl $2) (unLoc $2) }
+ | vocurly decls_inst close { L (gl $2) (unLoc $2) }
-- Instance body
--
@@ -1624,7 +1624,7 @@ decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }
decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) }
: '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
,sL1 $2 $ snd $ unLoc $2) }
- | vocurly decls close { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
+ | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
-- Binding groups other than those of class and instance declarations
--
@@ -1638,7 +1638,7 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
| '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3]
,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }
- | vocurly dbinds close { cL (getLoc $2) ([]
+ | vocurly dbinds close { L (getLoc $2) ([]
,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }
@@ -1666,7 +1666,7 @@ rule :: { LRuleDecl GhcPs }
{%runECP_P $4 >>= \ $4 ->
runECP_P $6 >>= \ $6 ->
ams (sLL $1 $> $ HsRule { rd_ext = noExtField
- , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1)
+ , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
, rd_lhs = $4, rd_rhs = $6 })
@@ -1778,14 +1778,14 @@ deprecation :: { OrdList (LWarnDecl GhcPs) }
(fst $ unLoc $2) }
strings :: { Located ([AddAnn],[Located StringLiteral]) }
- : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) }
+ : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
| '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
stringlist :: { Located (OrdList (Located StringLiteral)) }
: stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> (unLoc $1 `snocOL`
- (cL (gl $3) (getStringLiteral $3)))) }
- | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) }
+ (L (gl $3) (getStringLiteral $3)))) }
+ | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
| {- empty -} { noLoc nilOL }
-----------------------------------------------------------------------------
@@ -1839,7 +1839,7 @@ safety :: { Located Safety }
fspec :: { Located ([AddAnn]
,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) }
: STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3]
- ,(cL (getLoc $1)
+ ,(L (getLoc $1)
(getStringLiteral $1), $2, mkLHsSigType $4)) }
| var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2]
,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
@@ -2005,13 +2005,13 @@ typedoc :: { LHsType GhcPs }
[mu AnnRarrow $2] }
| btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $
- HsFunTy noExtField (cL (comb2 $1 $2)
+ HsFunTy noExtField (L (comb2 $1 $2)
(HsDocTy noExtField $1 $2))
$4)
[mu AnnRarrow $3] }
| docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $
- HsFunTy noExtField (cL (comb2 $1 $2)
+ HsFunTy noExtField (L (comb2 $1 $2)
(HsDocTy noExtField $2 $1))
$4)
[mu AnnRarrow $3] }
@@ -2157,7 +2157,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] }
| fd { sL1 $1 [$1] }
fd :: { Located (FunDep (Located RdrName)) }
- : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3)
+ : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3)
(reverse (unLoc $1), reverse (unLoc $3)))
[mu AnnRarrow $2] }
@@ -2200,13 +2200,13 @@ gadt_constrlist :: { Located ([AddAnn]
,[LConDecl GhcPs]) } -- Returned in order
: 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $
- cL (comb2 $1 $3)
+ L (comb2 $1 $3)
([mj AnnWhere $1
,moc $2
,mcc $4]
, unLoc $3) }
| 'where' vocurly gadt_constrs close {% checkEmptyGADTs $
- cL (comb2 $1 $3)
+ L (comb2 $1 $3)
([mj AnnWhere $1]
, unLoc $3) }
| {- empty -} { noLoc ([],[]) }
@@ -2214,8 +2214,8 @@ gadt_constrlist :: { Located ([AddAnn]
gadt_constrs :: { Located [LConDecl GhcPs] }
: gadt_constr_with_doc ';' gadt_constrs
{% addAnnotation (gl $1) AnnSemi (gl $2)
- >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) }
- | gadt_constr_with_doc { cL (gl $1) [$1] }
+ >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
+ | gadt_constr_with_doc { L (gl $1) [$1] }
| {- empty -} { noLoc [] }
-- We allow the following forms:
@@ -2252,7 +2252,7 @@ allowed in usual data constructors, but not in GADTs).
-}
constrs :: { Located ([AddAnn],[LConDecl GhcPs]) }
- : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2]
+ : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2]
,addConDocs (unLoc $3) $1)}
constrs1 :: { Located [LConDecl GhcPs] }
@@ -2316,7 +2316,7 @@ They must be kept identical except for their treatment of 'docprev'.
constr :: { LConDecl GhcPs }
: maybe_docnext forall constr_context '=>' constr_stuff
{% ams (let (con,details,doc_prev) = unLoc $5 in
- addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con
+ addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
(snd $ unLoc $2)
(Just $3)
details))
@@ -2324,7 +2324,7 @@ constr :: { LConDecl GhcPs }
(mu AnnDarrow $4:(fst $ unLoc $2)) }
| maybe_docnext forall constr_stuff
{% ams ( let (con,details,doc_prev) = unLoc $3 in
- addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con
+ addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
(snd $ unLoc $2)
Nothing -- No context
details))
@@ -2352,8 +2352,8 @@ fielddecls1 :: { [LConDeclField GhcPs] }
fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: maybe_docnext sig_vars '::' ctype maybe_docprev
- {% ams (cL (comb2 $2 $4)
- (ConDeclField noExtField (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5)))
+ {% ams (L (comb2 $2 $4)
+ (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5)))
[mu AnnDcolon $3] }
-- Reversed!
@@ -2371,17 +2371,17 @@ derivings :: { HsDeriving GhcPs }
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField Nothing $2)
+ in ams (L full_loc $ HsDerivingClause noExtField Nothing $2)
[mj AnnDeriving $1] }
| 'deriving' deriv_strategy_no_via deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField (Just $2) $3)
+ in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3)
[mj AnnDeriving $1] }
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField (Just $3) $2)
+ in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2)
[mj AnnDeriving $1] }
deriv_clause_types :: { Located [LHsSigType GhcPs] }
@@ -2439,7 +2439,7 @@ decl_no_th :: { LHsDecl GhcPs }
case r of {
(FunBind _ n _ _ _) ->
amsL l (mj AnnFunId n:(fst $2)) >> return () ;
- (PatBind _ (dL->L lh _lhs) _rhs _) ->
+ (PatBind _ (L lh _lhs) _rhs _) ->
amsL lh (fst $2) >> return () } ;
_ <- amsL l (ann ++ (fst $ unLoc $3));
return $! (sL l $ ValD noExtField r) } }
@@ -2764,7 +2764,7 @@ aexp :: { ECP }
(mj AnnDo $1:(fst $ unLoc $2)) }
| 'mdo' stmtlist {% runPV $2 >>= \ $2 ->
fmap ecpFromExp $
- ams (cL (comb2 $1 $2)
+ ams (L (comb2 $1 $2)
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
@@ -2812,7 +2812,7 @@ aexp2 :: { ECP }
| '(#' texp '#)' { ECP $
runECP_PV $2 >>= \ $2 ->
- amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [cL (gl $2) (Just $2)]))
+ amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)]))
[mo $1,mc $3] }
| '(#' tup_exprs '#)' { ECP $
$2 >>= \ $2 ->
@@ -2946,7 +2946,7 @@ tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) }
{ $2 >>= \ $2 ->
do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
; return
- ([],Tuple (map (\l -> cL l Nothing) (fst $1) ++ $2)) } }
+ ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } }
| bars texp bars0
{ runECP_PV $2 >>= \ $2 -> return $
@@ -2959,16 +2959,16 @@ commas_tup_tail : commas tup_tail
do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)
; return (
(head $ fst $1
- ,(map (\l -> cL l Nothing) (tail $ fst $1)) ++ $2)) } }
+ ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } }
-- Always follows a comma
tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] }
: texp commas_tup_tail { runECP_PV $1 >>= \ $1 ->
$2 >>= \ $2 ->
addAnnotation (gl $1) AnnComma (fst $2) >>
- return ((cL (gl $1) (Just $1)) : snd $2) }
+ return ((L (gl $1) (Just $1)) : snd $2) }
| texp { runECP_PV $1 >>= \ $1 ->
- return [cL (gl $1) (Just $1)] }
+ return [L (gl $1) (Just $1)] }
| {- empty -} { return [noLoc Nothing] }
-----------------------------------------------------------------------------
@@ -2983,32 +2983,32 @@ list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) }
| lexps { \loc -> $1 >>= \ $1 ->
mkHsExplicitListPV loc (reverse $1) }
| texp '..' { \loc -> runECP_PV $1 >>= \ $1 ->
- ams (cL loc $ ArithSeq noExtField Nothing (From $1))
+ ams (L loc $ ArithSeq noExtField Nothing (From $1))
[mj AnnDotdot $2]
>>= ecpFromExp' }
| texp ',' exp '..' { \loc ->
runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromThen $1 $3))
+ ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3))
[mj AnnComma $2,mj AnnDotdot $4]
>>= ecpFromExp' }
| texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromTo $1 $3))
+ ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3))
[mj AnnDotdot $2]
>>= ecpFromExp' }
| texp ',' exp '..' exp { \loc ->
runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
runECP_PV $5 >>= \ $5 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))
+ ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))
[mj AnnComma $2,mj AnnDotdot $4]
>>= ecpFromExp' }
| texp '|' flattenedpquals
{ \loc ->
checkMonadComp >>= \ ctxt ->
runECP_PV $1 >>= \ $1 ->
- ams (cL loc $ mkHsComp ctxt (unLoc $3) $1)
+ ams (L loc $ mkHsComp ctxt (unLoc $3) $1)
[mj AnnVbar $2]
>>= ecpFromExp' }
@@ -3043,7 +3043,7 @@ pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }
: squals '|' pquals
{% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >>
return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) }
- | squals { cL (getLoc $1) [reverse (unLoc $1)] }
+ | squals { L (getLoc $1) [reverse (unLoc $1)] }
squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last
-- one can "grab" the earlier ones
@@ -3056,7 +3056,7 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau
addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| transformqual {% ams $1 (fst $ unLoc $1) >>
- return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
+ return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) }
| qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
@@ -3095,7 +3095,7 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs
-- Guards
guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
- : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) }
+ : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 ',' qual {% runPV $3 >>= \ $3 ->
@@ -3113,7 +3113,7 @@ altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Loca
sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse (snd $ unLoc $2))) }
| vocurly alts close { $2 >>= \ $2 -> return $
- cL (getLoc $2) (fst $ unLoc $2
+ L (getLoc $2) (fst $ unLoc $2
,(reverse (snd $ unLoc $2))) }
| '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) }
| vocurly close { return $ noLoc ([],[]) }
@@ -3210,7 +3210,7 @@ stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Locat
sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?
| vocurly stmts close { $2 >>= \ $2 -> return $
- cL (gl $2) (fst $ unLoc $2
+ L (gl $2) (fst $ unLoc $2
,reverse $ snd $ unLoc $2) }
-- do { ;; s ; s ; ; s ;; }
@@ -3765,87 +3765,87 @@ maybe_docnext :: { Maybe LHsDocString }
happyError :: P a
happyError = srcParseFail
-getVARID (dL->L _ (ITvarid x)) = x
-getCONID (dL->L _ (ITconid x)) = x
-getVARSYM (dL->L _ (ITvarsym x)) = x
-getCONSYM (dL->L _ (ITconsym x)) = x
-getQVARID (dL->L _ (ITqvarid x)) = x
-getQCONID (dL->L _ (ITqconid x)) = x
-getQVARSYM (dL->L _ (ITqvarsym x)) = x
-getQCONSYM (dL->L _ (ITqconsym x)) = x
-getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x
-getLABELVARID (dL->L _ (ITlabelvarid x)) = x
-getCHAR (dL->L _ (ITchar _ x)) = x
-getSTRING (dL->L _ (ITstring _ x)) = x
-getINTEGER (dL->L _ (ITinteger x)) = x
-getRATIONAL (dL->L _ (ITrational x)) = x
-getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x
-getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x
-getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x
-getPRIMWORD (dL->L _ (ITprimword _ x)) = x
-getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x
-getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x
-getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl)
-getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike)
-getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
-getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x
-
-getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x
-getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x
-getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x
-getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x)
-
-getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src
-getCHARs (dL->L _ (ITchar src _)) = src
-getSTRINGs (dL->L _ (ITstring src _)) = src
-getPRIMCHARs (dL->L _ (ITprimchar src _)) = src
-getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src
-getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src
-getPRIMWORDs (dL->L _ (ITprimword src _)) = src
+getVARID (L _ (ITvarid x)) = x
+getCONID (L _ (ITconid x)) = x
+getVARSYM (L _ (ITvarsym x)) = x
+getCONSYM (L _ (ITconsym x)) = x
+getQVARID (L _ (ITqvarid x)) = x
+getQCONID (L _ (ITqconid x)) = x
+getQVARSYM (L _ (ITqvarsym x)) = x
+getQCONSYM (L _ (ITqconsym x)) = x
+getIPDUPVARID (L _ (ITdupipvarid x)) = x
+getLABELVARID (L _ (ITlabelvarid x)) = x
+getCHAR (L _ (ITchar _ x)) = x
+getSTRING (L _ (ITstring _ x)) = x
+getINTEGER (L _ (ITinteger x)) = x
+getRATIONAL (L _ (ITrational x)) = x
+getPRIMCHAR (L _ (ITprimchar _ x)) = x
+getPRIMSTRING (L _ (ITprimstring _ x)) = x
+getPRIMINTEGER (L _ (ITprimint _ x)) = x
+getPRIMWORD (L _ (ITprimword _ x)) = x
+getPRIMFLOAT (L _ (ITprimfloat x)) = x
+getPRIMDOUBLE (L _ (ITprimdouble x)) = x
+getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl)
+getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike)
+getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x
+
+getDOCNEXT (L _ (ITdocCommentNext x)) = x
+getDOCPREV (L _ (ITdocCommentPrev x)) = x
+getDOCNAMED (L _ (ITdocCommentNamed x)) = x
+getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
+
+getINTEGERs (L _ (ITinteger (IL src _ _))) = src
+getCHARs (L _ (ITchar src _)) = src
+getSTRINGs (L _ (ITstring src _)) = src
+getPRIMCHARs (L _ (ITprimchar src _)) = src
+getPRIMSTRINGs (L _ (ITprimstring src _)) = src
+getPRIMINTEGERs (L _ (ITprimint src _)) = src
+getPRIMWORDs (L _ (ITprimword src _)) = src
-- See Note [Pragma source text] in BasicTypes for the following
-getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src
-getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src
-getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src
-getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src
-getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src
-getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src
-getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src
-getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src
-getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src
-getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src
-getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src
-getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src
-getANN_PRAGs (dL->L _ (ITann_prag src)) = src
-getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src
-getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src
-getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src
-getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src
-getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src
-getCTYPEs (dL->L _ (ITctype src)) = src
+getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src
+getSPEC_PRAGs (L _ (ITspec_prag src)) = src
+getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src
+getSOURCE_PRAGs (L _ (ITsource_prag src)) = src
+getRULES_PRAGs (L _ (ITrules_prag src)) = src
+getWARNING_PRAGs (L _ (ITwarning_prag src)) = src
+getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src
+getSCC_PRAGs (L _ (ITscc_prag src)) = src
+getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src
+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
+getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src
+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src
+getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src
+getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src
+getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src
+getCTYPEs (L _ (ITctype src)) = src
getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
isUnicode :: Located Token -> Bool
-isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
+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
-hasE (dL->L _ (ITopenExpQuote HasE _)) = True
-hasE (dL->L _ (ITopenTExpQuote HasE)) = True
+hasE (L _ (ITopenExpQuote HasE _)) = True
+hasE (L _ (ITopenTExpQuote HasE)) = True
hasE _ = False
getSCC :: Located Token -> P FastString
@@ -3857,39 +3857,36 @@ getSCC lt = do let s = getSTRING lt
else return s
-- Utilities for combining source spans
-comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
+comb2 :: Located a -> Located b -> SrcSpan
comb2 a b = a `seq` b `seq` combineLocs a b
-comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
- a -> b -> c -> SrcSpan
+comb3 :: Located a -> Located b -> Located c -> SrcSpan
comb3 a b c = a `seq` b `seq` c `seq`
combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
-comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) =>
- a -> b -> c -> d -> SrcSpan
+comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
(combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
combineSrcSpans (getLoc c) (getLoc d))
-- strict constructor version:
{-# INLINE sL #-}
-sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
-sL span a = span `seq` a `seq` cL span a
+sL :: SrcSpan -> a -> Located a
+sL span a = span `seq` a `seq` L span a
-- See Note [Adding location info] for how these utility functions are used
-- replaced last 3 CPP macros in this file
{-# INLINE sL0 #-}
-sL0 :: HasSrcSpan a => SrcSpanLess a -> a
-sL0 = cL noSrcSpan -- #define L0 L noSrcSpan
+sL0 :: a -> Located a
+sL0 = L noSrcSpan -- #define L0 L noSrcSpan
{-# INLINE sL1 #-}
-sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b
+sL1 :: Located a -> b -> Located b
sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sLL #-}
-sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
- a -> b -> SrcSpanLess c -> c
+sLL :: Located a -> Located b -> c -> Located c
sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
{- Note [Adding location info]
@@ -3990,7 +3987,7 @@ in ApiAnnotation.hs
-- |Construct an AddAnn from the annotation keyword and the location
-- of the keyword itself
-mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn
+mj :: AnnKeywordId -> Located e -> AddAnn
mj a l = AddAnn a (gl l)
@@ -3998,25 +3995,25 @@ mj a l = AddAnn a (gl l)
-- the token has a unicode equivalent and this has been used, provide the
-- unicode variant of the annotation.
mu :: AnnKeywordId -> Located Token -> AddAnn
-mu a lt@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l
+mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
-gl :: HasSrcSpan a => a -> SrcSpan
+gl :: Located a -> SrcSpan
gl = getLoc
-- |Add an annotation to the located element, and return the located
-- element as a pass through
-aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a
-aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a
+aa :: Located a -> (AnnKeywordId, Located c) -> P (Located a)
+aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a
-- |Add an annotation to a located element resulting from a monadic action
-am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a
+am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)
am a (b,s) = do
- av@(dL->L l _) <- a
+ av@(L l _) <- a
addAnnotation l b (gl s)
return av
@@ -4033,27 +4030,27 @@ am a (b,s) = do
-- as any annotations that may arise in the binds. This will include open
-- and closing braces if they are used to delimit the let expressions.
--
-ams :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m a
-ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
+ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)
+ams a@(L l _) bs = addAnnsAt l bs >> return a
amsL :: SrcSpan -> [AddAnn] -> P ()
amsL sp bs = addAnnsAt sp bs >> return ()
-- |Add all [AddAnn] to an AST element, and wrap it in a 'Just'
-ajs :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m (Maybe a)
+ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a))
ajs a bs = Just <$> ams a bs
-- |Add a list of AddAnns to the given AST element, where the AST element is the
-- result of a monadic action
-amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a
-amms a bs = do { av@(dL->L l _) <- a
+amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a)
+amms a bs = do { av@(L l _) <- a
; addAnnsAt l bs
; return av }
-- |Add a list of AddAnns to the AST element, and return the element as a
-- OrdList
-amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a)
-amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a)
+amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))
+amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)
-- |Synonyms for AddAnn versions of AnnOpen and AnnClose
mo,mc :: Located Token -> AddAnn
@@ -4083,14 +4080,14 @@ mvbars :: [SrcSpan] -> [AddAnn]
mvbars = map (AddAnn AnnVbar)
-- |Get the location of the last element of a OrdList, or noSrcSpan
-oll :: HasSrcSpan a => OrdList a -> SrcSpan
+oll :: OrdList (Located a) -> SrcSpan
oll l =
if isNilOL l then noSrcSpan
else getLoc (lastOL l)
-- |Add a semicolon annotation in the right place in a list. If the
-- leading list is empty, add it to the tail
-asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P()
-asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls
-asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
+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
}
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 89634193e4..617f1c08b2 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -160,10 +160,10 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
-- *** See Note [The Naming story] in GHC.Hs.Decls ****
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d)
+mkTyClD (L loc d) = L loc (TyClD noExtField d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkInstD (dL->L loc d) = cL loc (InstD noExtField d)
+mkInstD (L loc d) = L loc (InstD noExtField d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
@@ -171,21 +171,21 @@ mkClassDecl :: SrcSpan
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
-mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
+mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams
; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt
- , tcdLName = cls, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdFDs = snd (unLoc fds)
- , tcdSigs = mkClassOpSigs sigs
- , tcdMeths = binds
- , tcdATs = ats, tcdATDefs = at_defs
- , tcdDocs = docs })) }
+ ; return (L loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt
+ , tcdLName = cls, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdFDs = snd (unLoc fds)
+ , tcdSigs = mkClassOpSigs sigs
+ , tcdMeths = binds
+ , tcdATs = ats, tcdATDefs = at_defs
+ , tcdDocs = docs })) }
mkTyData :: SrcSpan
-> NewOrData
@@ -195,17 +195,17 @@ mkTyData :: SrcSpan
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
-mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
+mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (cL loc (DataDecl { tcdDExt = noExtField,
- tcdLName = tc, tcdTyVars = tyvars,
- tcdFixity = fixity,
- tcdDataDefn = defn })) }
+ ; return (L loc (DataDecl { tcdDExt = noExtField,
+ tcdLName = tc, tcdTyVars = tyvars,
+ tcdFixity = fixity,
+ tcdDataDefn = defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
@@ -234,10 +234,10 @@ mkTySynonym loc lhs rhs
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (SynDecl { tcdSExt = noExtField
- , tcdLName = tc, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdRhs = rhs })) }
+ ; return (L loc (SynDecl { tcdSExt = noExtField
+ , tcdLName = tc, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
@@ -247,7 +247,7 @@ mkStandaloneKindSig
mkStandaloneKindSig loc lhs rhs =
do { vs <- mapM check_lhs_name (unLoc lhs)
; v <- check_singular_lhs (reverse vs)
- ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
+ ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
where
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
@@ -292,7 +292,7 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
+ ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExtField
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -304,7 +304,7 @@ mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn
- = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn)))
+ = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
@@ -317,7 +317,7 @@ mkFamDecl loc info lhs ksig injAnn
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (FamDecl noExtField (FamilyDecl
+ ; return (L loc (FamDecl noExtField (FamilyDecl
{ fdExt = noExtField
, fdInfo = info, fdLName = tc
, fdTyVars = tyvars
@@ -340,15 +340,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration. See #10945
-mkSpliceDecl lexpr@(dL->L loc expr)
+mkSpliceDecl lexpr@(L loc expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
- = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice)
+ = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
- = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice)
+ = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
| otherwise
- = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice BareSplice lexpr))
+ = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr))
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
@@ -357,16 +357,16 @@ mkRoleAnnotDecl :: SrcSpan
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles
= do { roles' <- mapM parse_role roles
- ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' }
+ ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' }
where
role_data_type = dataTypeOf (undefined :: Role)
all_roles = map fromConstr $ dataTypeConstrs role_data_type
possible_roles = [(fsFromRole role, role) | role <- all_roles]
- parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing
- parse_role (dL->L loc_role (Just role))
+ parse_role (L loc_role Nothing) = return $ L loc_role Nothing
+ parse_role (L loc_role (Just role))
= case lookup role possible_roles of
- Just found_role -> return $ cL loc_role $ Just found_role
+ Just found_role -> return $ L loc_role $ Just found_role
Nothing ->
let nearby = fuzzyLookup (unpackFS role)
(mapFst unpackFS possible_roles)
@@ -374,8 +374,6 @@ mkRoleAnnotDecl loc tycon roles
addFatalError loc_role
(text "Illegal role name" <+> quotes (ppr role) $$
suggestions nearby)
- parse_role _ = panic "parse_role: Impossible Match"
- -- due to #15884
suggestions [] = empty
suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
@@ -400,9 +398,9 @@ cvTopDecls decls = go (fromOL decls)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [] = []
- go ((dL->L l (ValD x b)) : ds)
- = cL l' (ValD x b') : go ds'
- where (dL->L l' b', ds') = getMonoBind (cL l b) ds
+ go ((L l (ValD x b)) : ds)
+ = L l' (ValD x b') : go ds'
+ where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
-- Declaration list may only contain value bindings and signatures.
@@ -422,24 +420,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = return (emptyBag, [], [], [], [], [])
- go ((dL->L l (ValD _ b)) : ds)
+ go ((L l (ValD _ b)) : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
where
- (b', ds') = getMonoBind (cL l b) ds
- go ((dL->L l decl) : ds)
+ (b', ds') = getMonoBind (L l b) ds
+ go ((L l decl) : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds
; case decl of
SigD _ s
- -> return (bs, cL l s : ss, ts, tfis, dfis, docs)
+ -> return (bs, L l s : ss, ts, tfis, dfis, docs)
TyClD _ (FamDecl _ t)
- -> return (bs, ss, cL l t : ts, tfis, dfis, docs)
+ -> return (bs, ss, L l t : ts, tfis, dfis, docs)
InstD _ (TyFamInstD { tfid_inst = tfi })
- -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs)
+ -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
InstD _ (DataFamInstD { dfid_inst = dfi })
- -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs)
+ -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
DocD _ d
- -> return (bs, ss, ts, tfis, dfis, cL l d : docs)
+ -> return (bs, ss, ts, tfis, dfis, L l d : docs)
SpliceD _ d
-> addFatalError l $
hang (text "Declaration splices are allowed only" <+>
@@ -465,25 +463,25 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
- , fun_matches =
- MG { mg_alts = (dL->L _ mtchs1) } }))
+getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
+ , fun_matches =
+ MG { mg_alts = (L _ mtchs1) } }))
binds
| has_args mtchs1
= go mtchs1 loc1 binds []
where
go mtchs loc
- ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
- , fun_matches =
- MG { mg_alts = (dL->L _ mtchs2) } })))
+ ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)
+ , fun_matches =
+ MG { mg_alts = (L _ mtchs2) } })))
: binds) _
| f1 == f2 = go (mtchs2 ++ mtchs)
(combineSrcSpans loc loc2) binds []
- go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls
+ go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
= let doc_decls' = doc_decl : doc_decls
in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
go mtchs loc binds doc_decls
- = ( cL loc (makeFunBind fun_id1 (reverse mtchs))
+ = ( L loc (makeFunBind fun_id1 (reverse mtchs))
, (reverse doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order
-- Do the same thing with the trailing doc comments
@@ -491,14 +489,13 @@ getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
getMonoBind bind binds = (bind, binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
-has_args [] = panic "RdrHsSyn:has_args"
-has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args)
+has_args [] = panic "RdrHsSyn:has_args"
+has_args (L _ (Match { m_pats = args }) : _) = not (null args)
-- Don't group together FunBinds if they have
-- no arguments. This is necessary now that variable bindings
-- with no arguments are now treated as FunBinds rather
-- than pattern bindings (tests/rename/should_fail/rnfail002).
-has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec
-has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884
+has_args (L _ (XMatch nec) : _) = noExtCon nec
{- **********************************************************************
@@ -589,7 +586,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon loc tc
| isTcOcc occ || isDataOcc occ
, isLexCon (occNameFS occ)
- = return (cL loc (setRdrNameSpace tc srcDataName))
+ = return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
= Left (loc, msg)
@@ -600,14 +597,14 @@ tyConToDataCon loc tc
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
-mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
+mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
do { matches <- mapM fromDecl (fromOL decls)
; when (null matches) (wrongNumberErr loc)
; return $ mkMatchGroup FromSource matches }
where
- fromDecl (dL->L loc decl@(ValD _ (PatBind _
- pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details))
- rhs _))) =
+ fromDecl (L loc decl@(ValD _ (PatBind _
+ pat@(L _ (ConPatIn ln@(L _ name) details))
+ rhs _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
@@ -629,8 +626,8 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
, mc_strictness = NoSrcStrict }
RecCon{} -> recordPatSynErr loc pat
- ; return $ cL loc match }
- fromDecl (dL->L loc decl) = extraDeclErr loc decl
+ ; return $ L loc match }
+ fromDecl (L loc decl) = extraDeclErr loc decl
extraDeclErr loc decl =
addFatalError loc $
@@ -672,7 +669,7 @@ mkGadtDecl :: [Located RdrName]
mkGadtDecl names ty
= (ConDeclGADT { con_g_ext = noExtField
, con_names = names
- , con_forall = cL l $ isLHsForAllTy ty'
+ , con_forall = L l $ isLHsForAllTy ty'
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args
@@ -680,13 +677,13 @@ mkGadtDecl names ty
, con_doc = Nothing }
, anns1 ++ anns2)
where
- (ty'@(dL->L l _),anns1) = peel_parens ty []
+ (ty'@(L l _),anns1) = peel_parens ty []
(tvs, rho) = splitLHsForAllTyInvis ty'
(mcxt, tau, anns2) = split_rho rho []
- split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
+ split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
= (Just cxt, tau, ann)
- split_rho (dL->L l (HsParTy _ ty)) ann
+ split_rho (L l (HsParTy _ ty)) ann
= split_rho ty (ann++mkParensApiAnn l)
split_rho tau ann
= (Nothing, tau, ann)
@@ -694,12 +691,12 @@ mkGadtDecl names ty
(args, res_ty) = split_tau tau
-- See Note [GADT abstract syntax] in GHC.Hs.Decls
- split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
- = (RecCon (cL loc rf), res_ty)
+ split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
+ = (RecCon (L loc rf), res_ty)
split_tau tau
= (PrefixCon [], tau)
- peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty
+ peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
(ann++mkParensApiAnn l)
peel_parens ty ann = (ty, ann)
@@ -823,19 +820,18 @@ checkTyVars pp_what equals_or_where tc tparms
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddAnn] -> LHsType GhcPs
-> P (LHsTyVarBndr GhcPs, [AddAnn])
- chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l
- ++ acc) ty
+ chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty
chkParens acc ty = do
tv <- chk ty
return (tv, reverse acc)
-- Check that the name space is correct!
chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs)
- chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
- | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k))
- chk (dL->L l (HsTyVar _ _ (dL->L ltv tv)))
- | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv)))
- chk t@(dL->L loc _)
+ chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
+ | isRdrTyVar tv = return (L l (KindedTyVar noExtField (L lv tv) k))
+ chk (L l (HsTyVar _ _ (L ltv tv)))
+ | isRdrTyVar tv = return (L l (UserTyVar noExtField (L ltv tv)))
+ chk t@(L loc _)
= addFatalError loc $
vcat [ text "Unexpected type" <+> quotes (ppr t)
, text "In the" <+> pp_what
@@ -893,14 +889,14 @@ mkRuleTyVarBndrs = fmap (fmap cvt_one)
-- See note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
- where check (dL->L loc (Unqual occ)) = do
+ where check (L loc (Unqual occ)) = do
when ((occNameString occ ==) `any` ["forall","family","role"])
(addFatalError loc (text $ "parse error on input "
++ occNameString occ))
check _ = panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
-checkRecordSyntax lr@(dL->L loc r)
+checkRecordSyntax lr@(L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit
unless allowed $ addError loc $
text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r
@@ -910,7 +906,7 @@ checkRecordSyntax lr@(dL->L loc r)
-- `data T where` to avoid affecting existing error message, see #8258.
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
-checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration.
+checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
= do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax
unless gadtSyntax $ addError span $ vcat
[ text "Illegal keyword 'where' in data declaration"
@@ -934,23 +930,23 @@ checkTyClHdr :: Bool -- True <=> class header
checkTyClHdr is_cls ty
= goL ty [] [] Prefix
where
- goL (dL->L l ty) acc ann fix = go l ty acc ann fix
+ goL (L l ty) acc ann fix = go l ty acc ann fix
-- workaround to define '*' despite StarIsType
- go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix
+ go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
= do { warnStarBndr l
; let name = mkOccName tcClsName (starSym isUni)
- ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
+ ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
- go _ (HsTyVar _ _ ltc@(dL->L _ tc)) acc ann fix
+ go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix
| isRdrTc tc = return (ltc, acc, fix, ann)
- go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix
+ go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
| isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)
go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix
go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
- = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann)
+ = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
@@ -987,7 +983,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
HsCmdDo {} -> check "do command" cmd
_ -> return ()
- check :: (HasSrcSpan a, Outputable a) => String -> a -> PV ()
+ check :: Outputable a => String -> Located a -> PV ()
check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
@@ -1007,22 +1003,22 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
-- (((Eq a))) --> [Eq a]
-- @
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
-checkContext (dL->L l orig_t)
- = check [] (cL l orig_t)
+checkContext (L l orig_t)
+ = check [] (L l orig_t)
where
- check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
+ check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
-- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
-- be used as context constraints.
- = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto ()
+ = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
- check anns (dL->L lp1 (HsParTy _ ty))
+ check anns (L lp1 (HsParTy _ ty))
-- to be sure HsParTy doesn't get into the way
= check anns' ty
where anns' = if l == lp1 then anns
else (anns ++ mkParensApiAnn lp1)
-- no need for anns, returning original
- check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t])
+ check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
msg = text "data constructor context"
@@ -1031,9 +1027,9 @@ checkContext (dL->L l orig_t)
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs msg ty = go ty
where
- go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
- go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
- go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep
+ go (L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
+ go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
+ go (L l (HsDocTy _ t ds)) = addError l $ hsep
[ text "Unexpected haddock", quotes (ppr ds)
, text "on", msg, quotes (ppr t) ]
go _ = pure ()
@@ -1076,21 +1072,21 @@ checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLPat e@(dL->L l _) = checkPat l e []
+checkLPat e@(L l _) = checkPat l e []
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
-checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args
- | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
+checkPat loc (L l e@(PatBuilderVar (L _ c))) args
+ | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
| not (null args) && patIsRec c =
localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
patFail l (ppr e)
-checkPat loc (dL->L _ (PatBuilderApp f e)) args
+checkPat loc (L _ (PatBuilderApp f e)) args
= do p <- checkLPat e
checkPat loc f (p : args)
-checkPat loc (dL->L _ e) []
+checkPat loc (L _ e) []
= do p <- checkAPat loc e
- return (cL loc p)
+ return (L loc p)
checkPat loc e _
= patFail loc (ppr e)
@@ -1104,21 +1100,21 @@ checkAPat loc e0 = do
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
-- NB. Negative *primitive* literals are already handled by the lexer
- PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing)
+ PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
-- n+k patterns
PatBuilderOpApp
- (dL->L nloc (PatBuilderVar (dL->L _ n)))
- (dL->L _ plus)
- (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
+ (L nloc (PatBuilderVar (L _ n)))
+ (L _ plus)
+ (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| nPlusKPatterns && (plus == plus_RDR)
- -> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
+ -> return (mkNPlusKPat (L nloc n) (L lloc lit))
- PatBuilderOpApp l (dL->L cl c) r
+ PatBuilderOpApp l (L cl c) r
| isRdrDataCon c -> do
l <- checkLPat l
r <- checkLPat r
- return (ConPatIn (cL cl c) (InfixCon l r))
+ return (ConPatIn (L cl c) (InfixCon l r))
PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField))
_ -> patFail loc (ppr e0)
@@ -1135,8 +1131,8 @@ pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
-checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld)
- return (cL l (fld { hsRecFieldArg = p }))
+checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)
+ return (L l (fld { hsRecFieldArg = p }))
patFail :: SrcSpan -> SDoc -> PV a
patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
@@ -1157,12 +1153,12 @@ checkValDef lhs (Just sig) grhss
= do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat
checkPatBind lhs' grhss
-checkValDef lhs Nothing g@(dL->L l (_,grhss))
+checkValDef lhs Nothing g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
checkFunBind NoSrcStrict ann (getLoc lhs)
- fun is_infix pats (cL l grhss)
+ fun is_infix pats (L l grhss)
Nothing -> do
lhs' <- checkPattern lhs
checkPatBind lhs' g }
@@ -1175,19 +1171,19 @@ checkFunBind :: SrcStrictness
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
+checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
= do ps <- mapM checkPattern pats
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
return (ann, makeFunBind fun
- [cL match_span (Match { m_ext = noExtField
- , m_ctxt = FunRhs
- { mc_fun = fun
- , mc_fixity = is_infix
- , mc_strictness = strictness }
- , m_pats = ps
- , m_grhss = grhss })])
+ [L match_span (Match { m_ext = noExtField
+ , m_ctxt = FunRhs
+ { mc_fun = fun
+ , mc_fixity = is_infix
+ , mc_strictness = strictness }
+ , m_pats = ps
+ , m_grhss = grhss })])
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
@@ -1205,28 +1201,28 @@ makeFunBind fn ms
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkPatBind lhs (dL->L match_span (_,grhss))
+checkPatBind lhs (L match_span (_,grhss))
| BangPat _ p <- unLoc lhs
, VarPat _ v <- unLoc p
- = return ([], makeFunBind v [cL match_span (m v)])
+ = return ([], makeFunBind v [L match_span (m v)])
where
m v = Match { m_ext = noExtField
- , m_ctxt = FunRhs { mc_fun = cL (getLoc lhs) (unLoc v)
+ , m_ctxt = FunRhs { mc_fun = L (getLoc lhs) (unLoc v)
, mc_fixity = Prefix
, mc_strictness = SrcStrict }
, m_pats = []
, m_grhss = grhss }
-checkPatBind lhs (dL->L _ (_,grhss))
+checkPatBind lhs (L _ (_,grhss))
= return ([],PatBind noExtField lhs grhss ([],[]))
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
-checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
+checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
| isUnqual v
, not (isDataOcc (rdrNameOcc v))
= return lrdr
-checkValSigLhs lhs@(dL->L l _)
+checkValSigLhs lhs@(L l _)
= addFatalError l ((text "Invalid type signature:" <+>
ppr lhs <+> text ":: ...")
$$ text hint)
@@ -1244,8 +1240,8 @@ checkValSigLhs lhs@(dL->L l _)
-- so check for that, and suggest. cf #3805
-- Sadly 'foreign import' still barfs 'parse error' because
-- 'import' is a keyword
- looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s
- looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs
+ looks_like s (L _ (HsVar _ (L _ v))) = v == s
+ looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
looks_like _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
@@ -1253,8 +1249,8 @@ checkValSigLhs lhs@(dL->L l _)
pattern_RDR = mkUnqual varName (fsLit "pattern")
checkDoAndIfThenElse
- :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
- => a -> Bool -> b -> Bool -> c -> PV ()
+ :: (Outputable a, Outputable b, Outputable c)
+ => Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
@@ -1287,21 +1283,21 @@ isFunLhs :: Located (PatBuilder GhcPs)
isFunLhs e = go e [] []
where
- go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann
- | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann))
- go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann
- go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
- go (dL->L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann
+ go (L loc (PatBuilderVar (L _ f))) es ann
+ | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
+ go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann
+ go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
+ go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann
| not (isRdrDataCon op) -- We have found the function!
- = return (Just (cL loc' op, Infix, (l:r:es), ann))
+ = return (Just (L loc' op, Infix, (l:r:es), ann))
| otherwise -- Infix data con; keep going
= do { mb_l <- go l es ann
; case mb_l of
Just (op', Infix, j : k : es', ann')
-> return (Just (op', Infix, j : op_app : es', ann'))
where
- op_app = cL loc (PatBuilderOpApp k
- (cL loc' op) r)
+ op_app = L loc (PatBuilderOpApp k
+ (L loc' op) r)
_ -> return Nothing }
go _ _ _ = return Nothing
@@ -1343,7 +1339,7 @@ pUnpackedness
, SourceText
, SrcUnpackedness
, [Located TyEl] {- remaining TyEl -})
-pUnpackedness ((dL->L l x1) : xs)
+pUnpackedness (L l x1 : xs)
| TyElUnpackedness (anns, prag, unpk) <- x1
= Just (l, anns, prag, unpk, xs)
pUnpackedness _ = Nothing
@@ -1355,13 +1351,13 @@ pBangTy
, LHsType GhcPs {- the resulting BangTy -}
, P () {- add annotations -}
, [Located TyEl] {- remaining TyEl -})
-pBangTy lt@(dL->L l1 _) xs =
+pBangTy lt@(L l1 _) xs =
case pUnpackedness xs of
Nothing -> (False, lt, pure (), xs)
Just (l2, anns, prag, unpk, xs') ->
let bl = combineSrcSpans l1 l2
bt = addUnpackedness (prag, unpk) lt
- in (True, cL bl bt, addAnnsAt bl anns, xs')
+ in (True, L bl bt, addAnnsAt bl anns, xs')
mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy strictness =
@@ -1387,8 +1383,8 @@ addUnpackedness (prag, unpk) t
--
-- See Note [Parsing data constructors is hard]
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
-mergeOps ((dL->L l1 (TyElOpd t)) : xs)
- | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs
+mergeOps ((L l1 (TyElOpd t)) : xs)
+ | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs
, null xs' -- We accept a BangTy only when there are no preceding TyEl.
= addAnns >> return t'
mergeOps all_xs = go (0 :: Int) [] id all_xs
@@ -1398,7 +1394,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [unpk]:
-- handle (NO)UNPACK pragmas
- go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
+ go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
if not (null acc) && null xs
then do { acc' <- eitherToP $ mergeOpsAcc acc
; let a = ops_acc acc'
@@ -1406,7 +1402,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
bl = combineSrcSpans l (getLoc a)
bt = HsBangTy noExtField strictMark a
; addAnnsAt bl anns
- ; return (cL bl bt) }
+ ; return (L bl bt) }
else addFatalError l unpkError
where
unpkSDoc = case unpkSrc of
@@ -1421,38 +1417,35 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [doc]:
-- we do not expect to encounter any docs
- go _ _ _ ((dL->L l (TyElDocPrev _)):_) =
+ go _ _ _ ((L l (TyElDocPrev _)):_) =
failOpDocPrev l
-- clause [opr]:
-- when we encounter an operator, we must have accumulated
-- something for its rhs, and there must be something left
-- to build its lhs.
- go k acc ops_acc ((dL->L l (TyElOpr op)):xs) =
+ go k acc ops_acc ((L l (TyElOpr op)):xs) =
if null acc || null (filter isTyElOpd xs)
- then failOpFewArgs (cL l op)
+ then failOpFewArgs (L l op)
else do { acc' <- eitherToP (mergeOpsAcc acc)
- ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs }
+ ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs }
where
- isTyElOpd (dL->L _ (TyElOpd _)) = True
+ isTyElOpd (L _ (TyElOpd _)) = True
isTyElOpd _ = False
-- clause [opd]:
-- whenever an operand is encountered, it is added to the accumulator
- go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs
+ go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs
-- clause [tyapp]:
-- whenever a type application is encountered, it is added to the accumulator
- go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
+ go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
-- clause [end]
-- See Note [Non-empty 'acc' in mergeOps clause [end]]
go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc)
; return (ops_acc acc') }
- go _ _ _ _ = panic "mergeOps.go: Impossible Match"
- -- due to #15884
-
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = panic "mergeOpsAcc: empty input"
@@ -1524,8 +1517,8 @@ Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause
-}
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
-pInfixSide ((dL->L l (TyElOpd t)):xs)
- | (True, t', addAnns, xs') <- pBangTy (cL l t) xs
+pInfixSide ((L l (TyElOpd t)):xs)
+ | (True, t', addAnns, xs') <- pBangTy (L l t) xs
= Just (t', addAnns, xs')
pInfixSide (el:xs1)
| Just t1 <- pLHsTypeArg el
@@ -1542,15 +1535,15 @@ pInfixSide (el:xs1)
pInfixSide _ = Nothing
pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
-pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a))
-pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
+pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a))
+pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
pLHsTypeArg _ = Nothing
pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev = go Nothing
where
- go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) =
- go (mTrailingDoc `mplus` Just (cL l doc)) xs
+ go mTrailingDoc ((L l (TyElDocPrev doc)):xs) =
+ go (mTrailingDoc `mplus` Just (L l doc)) xs
go mTrailingDoc xs = (mTrailingDoc, xs)
orErr :: Maybe a -> b -> Either b a
@@ -1648,7 +1641,7 @@ mergeDataCon all_xs =
-- A -- ^ Comment on A
-- B -- ^ Comment on B (singleDoc == False)
singleDoc = isJust mTrailingDoc &&
- null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ]
+ null [ () | (L _ (TyElDocPrev _)) <- all_xs' ]
-- The result of merging the list of reversed TyEl into a
-- data constructor, along with [AddAnn].
@@ -1670,38 +1663,38 @@ mergeDataCon all_xs =
trailingFieldDoc | singleDoc = Nothing
| otherwise = mTrailingDoc
- goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
+ goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) }
- goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs)
+ goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs)
| (mConDoc, xs') <- pDocPrev xs
- , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs'
+ , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs'
= do { data_con <- tyConToDataCon l' tc
; let mDoc = mTrailingDoc `mplus` mConDoc
- ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) }
- goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
+ ; return (pure (), (data_con, RecCon (L l fields), mDoc)) }
+ goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
= return ( pure ()
- , ( cL l (getRdrName (tupleDataCon Boxed (length ts)))
+ , ( L l (getRdrName (tupleDataCon Boxed (length ts)))
, PrefixCon ts
, mTrailingDoc ) )
- goFirst ((dL->L l (TyElOpd t)):xs)
- | (_, t', addAnns, xs') <- pBangTy (cL l t) xs
+ goFirst ((L l (TyElOpd t)):xs)
+ | (_, t', addAnns, xs') <- pBangTy (L l t) xs
= go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs'
goFirst (L l (TyElKindApp _ _):_)
= goInfix Monoid.<> Left (l, kindAppErr)
goFirst xs
= go (pure ()) mTrailingDoc [] xs
- go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
+ go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) }
- go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) =
- go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs
- go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs)
- | (_, t', addAnns', xs') <- pBangTy (cL l t) xs
+ go addAnns mLastDoc ts ((L l (TyElDocPrev doc)):xs) =
+ go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs
+ go addAnns mLastDoc ts ((L l (TyElOpd t)):xs)
+ | (_, t', addAnns', xs') <- pBangTy (L l t) xs
, t'' <- mkLHsDocTyMaybe t' mLastDoc
= go (addAnns >> addAnns') Nothing (t'':ts) xs'
- go _ _ _ ((dL->L _ (TyElOpr _)):_) =
+ go _ _ _ ((L _ (TyElOpr _)):_) =
-- Encountered an operator: backtrack to the beginning and attempt
-- to parse as an infix definition.
goInfix
@@ -1719,7 +1712,7 @@ mergeDataCon all_xs =
; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr
; let (mOpDoc, xs2) = pDocPrev xs1
; (op, xs3) <- case xs2 of
- (dL->L l (TyElOpr op)) : xs3 ->
+ (L l (TyElOpr op)) : xs3 ->
do { data_con <- tyConToDataCon l op
; return (data_con, xs3) }
_ -> Left malformedErr
@@ -1782,13 +1775,13 @@ class DisambInfixOp b where
mkHsInfixHolePV :: SrcSpan -> PV (Located b)
instance p ~ GhcPs => DisambInfixOp (HsExpr p) where
- mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v)
- mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v)
- mkHsInfixHolePV l = return $ cL l hsHoleExpr
+ mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)
+ mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)
+ mkHsInfixHolePV l = return $ L l hsHoleExpr
instance DisambInfixOp RdrName where
- mkHsConOpPV (dL->L l v) = return $ cL l v
- mkHsVarOpPV (dL->L l v) = return $ cL l v
+ mkHsConOpPV (L l v) = return $ L l v
+ mkHsVarOpPV (L l v) = return $ L l v
mkHsInfixHolePV l =
addFatalError l $ text "Invalid infix hole, expected an infix operator"
@@ -1915,34 +1908,34 @@ typechecker.
instance p ~ GhcPs => DisambECP (HsCmd p) where
type Body (HsCmd p) = HsCmd
ecpFromCmd' = return
- ecpFromExp' (dL-> L l e) = cmdFail l (ppr e)
- mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg)
- mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e)
+ ecpFromExp' (L l e) = cmdFail l (ppr e)
+ mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg)
+ mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e)
type InfixOp (HsCmd p) = HsExpr p
superInfixOp m = m
mkHsOpAppPV l c1 op c2 = do
- let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c
- return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2]
- mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg)
+ let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c
+ return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2]
+ mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg)
type FunArg (HsCmd p) = HsExpr p
superFunArg m = m
mkHsAppPV l c e = do
checkCmdBlockArguments c
checkExpBlockArguments e
- return $ cL l (HsCmdApp noExtField c e)
+ return $ L l (HsCmdApp noExtField c e)
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
- return $ cL l (mkHsCmdIf c a b)
- mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts)
- mkHsParPV l c = return $ cL l (HsCmdPar noExtField c)
- mkHsVarPV (dL->L l v) = cmdFail l (ppr v)
- mkHsLitPV (dL->L l a) = cmdFail l (ppr a)
- mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a)
+ return $ L l (mkHsCmdIf c a b)
+ mkHsDoPV l stmts = return $ L l (HsCmdDo noExtField stmts)
+ mkHsParPV l c = return $ L l (HsCmdPar noExtField c)
+ mkHsVarPV (L l v) = cmdFail l (ppr v)
+ mkHsLitPV (L l a) = cmdFail l (ppr a)
+ mkHsOverLitPV (L l a) = cmdFail l (ppr a)
mkHsWildCardPV l = cmdFail l (text "_")
mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig)
mkHsExplicitListPV l xs = cmdFail l $
brackets (fsep (punctuate comma (map ppr xs)))
- mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp)
+ mkHsSplicePV (L l sp) = cmdFail l (ppr sp)
mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $
ppr a <+> ppr (mk_rec_fields fbinds ddLoc)
mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)
@@ -1966,42 +1959,42 @@ cmdFail loc e = addFatalError loc $
instance p ~ GhcPs => DisambECP (HsExpr p) where
type Body (HsExpr p) = HsExpr
- ecpFromCmd' (dL -> L l c) = do
+ ecpFromCmd' (L l c) = do
addError l $ vcat
[ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ]
- return (cL l hsHoleExpr)
+ return (L l hsHoleExpr)
ecpFromExp' = return
- mkHsLamPV l mg = return $ cL l (HsLam noExtField mg)
- mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c)
+ mkHsLamPV l mg = return $ L l (HsLam noExtField mg)
+ mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c)
type InfixOp (HsExpr p) = HsExpr p
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
- return $ cL l $ OpApp noExtField e1 op e2
- mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg)
+ return $ L l $ OpApp noExtField e1 op e2
+ mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg)
type FunArg (HsExpr p) = HsExpr p
superFunArg m = m
mkHsAppPV l e1 e2 = do
checkExpBlockArguments e1
checkExpBlockArguments e2
- return $ cL l (HsApp noExtField e1 e2)
+ return $ L l (HsApp noExtField e1 e2)
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
- return $ cL l (mkHsIf c a b)
- mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts)
- mkHsParPV l e = return $ cL l (HsPar noExtField e)
- mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v)
- mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a)
- mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a)
- mkHsWildCardPV l = return $ cL l hsHoleExpr
- mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
- mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs)
+ return $ L l (mkHsIf c a b)
+ mkHsDoPV l stmts = return $ L l (HsDo noExtField DoExpr stmts)
+ mkHsParPV l e = return $ L l (HsPar noExtField e)
+ mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v)
+ mkHsLitPV (L l a) = return $ L l (HsLit noExtField a)
+ mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a)
+ mkHsWildCardPV l = return $ L l hsHoleExpr
+ mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
+ mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp
mkHsRecordPV l lrec a (fbinds, ddLoc) = do
r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)
- checkRecordSyntax (cL l r)
- mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr)
- mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e)
+ checkRecordSyntax (L l r)
+ mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)
+ mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)
mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty
mkHsAsPatPV l v e =
patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $
@@ -2018,7 +2011,7 @@ patSynErr item l e explanation =
sep [text item <+> text "in expression context:",
nest 4 (ppr e)] $$
explanation
- ; return (cL l hsHoleExpr) }
+ ; return (L l hsHoleExpr) }
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
@@ -2042,10 +2035,10 @@ instance Outputable (PatBuilder GhcPs) where
instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
- ecpFromCmd' (dL-> L l c) =
+ ecpFromCmd' (L l c) =
addFatalError l $
text "Command syntax in pattern:" <+> ppr c
- ecpFromExp' (dL-> L l e) =
+ ecpFromExp' (L l e) =
addFatalError l $
text "Expression syntax in pattern:" <+> ppr e
mkHsLamPV l _ = addFatalError l $
@@ -2054,54 +2047,54 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
- mkHsOpAppPV l p1 op p2 = return $ cL l $ PatBuilderOpApp p1 op p2
+ mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2
mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
- mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2)
+ mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern"
- mkHsParPV l p = return $ cL l (PatBuilderPar p)
- mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v)
- mkHsLitPV lit@(dL->L l a) = do
+ mkHsParPV l p = return $ L l (PatBuilderPar p)
+ mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)
+ mkHsLitPV lit@(L l a) = do
checkUnboxedStringLitPat lit
- return $ cL l (PatBuilderPat (LitPat noExtField a))
- mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a)
- mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField))
+ return $ L l (PatBuilderPat (LitPat noExtField a))
+ mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)
+ mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))
mkHsTySigPV l b sig = do
p <- checkLPat b
- return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig)))
+ return $ L l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig)))
mkHsExplicitListPV l xs = do
ps <- traverse checkLPat xs
- return (cL l (PatBuilderPat (ListPat noExtField ps)))
- mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp))
+ return (L l (PatBuilderPat (ListPat noExtField ps)))
+ mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))
mkHsRecordPV l _ a (fbinds, ddLoc) = do
r <- mkPatRec a (mk_rec_fields fbinds ddLoc)
- checkRecordSyntax (cL l r)
- mkHsNegAppPV l (dL->L lp p) = do
+ checkRecordSyntax (L l r)
+ mkHsNegAppPV l (L lp p) = do
lit <- case p of
- PatBuilderOverLit pos_lit -> return (cL lp pos_lit)
+ PatBuilderOverLit pos_lit -> return (L lp pos_lit)
_ -> patFail l (text "-" <> ppr p)
- return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))
+ return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))
mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)
mkHsViewPatPV l a b = do
p <- checkLPat b
- return $ cL l (PatBuilderPat (ViewPat noExtField a p))
+ return $ L l (PatBuilderPat (ViewPat noExtField a p))
mkHsAsPatPV l v e = do
p <- checkLPat e
- return $ cL l (PatBuilderPat (AsPat noExtField v p))
+ return $ L l (PatBuilderPat (AsPat noExtField v p))
mkHsLazyPatPV l e = do
p <- checkLPat e
- return $ cL l (PatBuilderPat (LazyPat noExtField p))
+ return $ L l (PatBuilderPat (LazyPat noExtField p))
mkHsBangPatPV l e = do
p <- checkLPat e
let pb = BangPat noExtField p
hintBangPat l pb
- return $ cL l (PatBuilderPat pb)
+ return $ L l (PatBuilderPat pb)
mkSumOrTuplePV = mkSumOrTuplePat
checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
-checkUnboxedStringLitPat (dL->L loc lit) =
+checkUnboxedStringLitPat (L loc lit) =
case lit of
HsStringPrim _ _ -- Trac #13260
-> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)
@@ -2573,7 +2566,7 @@ checkPrecP
:: Located (SourceText,Int) -- ^ precedence
-> Located (OrdList (Located RdrName)) -- ^ operators
-> P ()
-checkPrecP (dL->L l (_,i)) (dL->L _ ol)
+checkPrecP (L l (_,i)) (L _ ol)
| 0 <= i, i <= maxPrecedence = pure ()
| all specialOp ol = pure ()
| otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))
@@ -2587,9 +2580,9 @@ mkRecConstrOrUpdate
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
-mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
- = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd))
+ = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp _ (fs,dd)
| Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
| otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
@@ -2607,15 +2600,13 @@ mkRdrRecordCon con flds
mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs
- , rec_dotdot = Just (cL s (length fs)) }
+ , rec_dotdot = Just (L s (length fs)) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
-mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun)
+mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
= HsRecField (L loc (Unambiguous noExtField rdr)) arg pun
-mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _)
+mk_rec_upd_field (HsRecField (L _ (XFieldOcc nec)) _ _)
= noExtCon nec
-mk_rec_upd_field (HsRecField _ _ _)
- = panic "mk_rec_upd_field: Impossible Match" -- due to #15884
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
@@ -2658,7 +2649,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
-- name (cf section 8.5.1 in Haskell 2010 report).
mkCImport = do
let e = unpackFS entity
- case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of
+ case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
Nothing -> addFatalError loc (text "Malformed entity string")
Just importSpec -> returnSpec importSpec
@@ -2670,7 +2661,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
then mkExtName (unLoc v)
else entity
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
- importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc)
+ importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
returnSpec spec = return $ ForD noExtField $ ForeignImport
{ fd_i_ext = noExtField
@@ -2745,11 +2736,11 @@ parseCImport cconv safety nm str sourceText =
mkExport :: Located CCallConv
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
-mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty)
+mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
= return $ ForD noExtField $
ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty
- , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv))
- (cL le esrc) }
+ , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
+ (L le esrc) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
@@ -2776,15 +2767,15 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName)
| ImpExpQcWildcard
mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
-mkModuleImpExp (dL->L l specname) subs =
+mkModuleImpExp (L l specname) subs =
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
- -> return $ IEVar noExtField (cL l (ieNameFromSpec specname))
- | otherwise -> IEThingAbs noExtField . cL l <$> nameT
- ImpExpAll -> IEThingAll noExtField . cL l <$> nameT
+ -> return $ IEVar noExtField (L l (ieNameFromSpec specname))
+ | otherwise -> IEThingAbs noExtField . L l <$> nameT
+ ImpExpAll -> IEThingAll noExtField . L l <$> nameT
ImpExpList xs ->
- (\newName -> IEThingWith noExtField (cL l newName)
+ (\newName -> IEThingWith noExtField (L l newName)
NoIEWildcard (wrapped xs) []) <$> nameT
ImpExpAllWith xs ->
do allowed <- getBit PatternSynonymsBit
@@ -2795,7 +2786,7 @@ mkModuleImpExp (dL->L l specname) subs =
(findIndex isImpExpQcWildcard withs)
ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
in (\newName
- -> IEThingWith noExtField (cL l newName) pos ies [])
+ -> IEThingWith noExtField (L l newName) pos ies [])
<$> nameT
else addFatalError l
(text "Illegal export form (use PatternSynonyms to enable)")
@@ -2821,7 +2812,7 @@ mkModuleImpExp (dL->L l specname) subs =
ieNameFromSpec (ImpExpQcType ln) = IEType ln
ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
- wrapped = map (onHasSrcSpan ieNameFromSpec)
+ wrapped = map (mapLoc ieNameFromSpec)
mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName)
@@ -2832,8 +2823,8 @@ mkTypeImpExp name =
return (fmap (`setRdrNameSpace` tcClsName) name)
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
-checkImportSpec ie@(dL->L _ specs) =
- case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
+checkImportSpec ie@(L _ specs) =
+ case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
(l:_) -> importSpecError l
where
@@ -2845,7 +2836,7 @@ checkImportSpec ie@(dL->L _ specs) =
-- In the correct order
mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
-mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] =
+mkImpExpSubSpec [L _ ImpExpQcWildcard] =
return ([], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
@@ -2901,7 +2892,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg
$$ text " including the definition module, you must qualify it."
failOpFewArgs :: Located RdrName -> P a
-failOpFewArgs (dL->L loc op) =
+failOpFewArgs (L loc op) =
do { star_is_type <- getBit StarIsTypeBit
; let msg = too_few $$ starInfo star_is_type op
; addFatalError loc msg }
@@ -3108,14 +3099,14 @@ mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExp
-- Tuple
mkSumOrTupleExpr l boxity (Tuple es) =
- return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity)
+ return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity)
where
toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
toTupArg = mapLoc (maybe missingTupArg (Present noExtField))
-- Sum
mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
- return $ cL l (ExplicitSum noExtField alt arity e)
+ return $ L l (ExplicitSum noExtField alt arity e)
mkSumOrTupleExpr l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
@@ -3125,17 +3116,17 @@ mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Loc
-- Tuple
mkSumOrTuplePat l boxity (Tuple ps) = do
ps' <- traverse toTupPat ps
- return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity))
+ return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity))
where
toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
- toTupPat (dL -> L l p) = case p of
+ toTupPat (L l p) = case p of
Nothing -> addFatalError l (text "Tuple section in pattern context")
Just p' -> checkLPat p'
-- Sum
mkSumOrTuplePat l Unboxed (Sum alt arity p) = do
p' <- checkLPat p
- return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity))
+ return $ L l (PatBuilderPat (SumPat noExtField p' alt arity))
mkSumOrTuplePat l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
@@ -3143,12 +3134,12 @@ mkSumOrTuplePat l Boxed a@Sum{} =
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y =
let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
- in cL loc (mkHsOpTy x op y)
+ in L loc (mkHsOpTy x op y)
mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy t doc =
let loc = getLoc t `combineSrcSpans` getLoc doc
- in cL loc (HsDocTy noExtField t doc)
+ in L loc (HsDocTy noExtField t doc)
mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t)
View Lorry Controller Status