summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
authorShayan-Najd <sh.najd@gmail.com>2018-11-22 01:23:29 +0000
committerAlan Zimmerman <alan.zimm@gmail.com>2018-11-24 12:30:21 +0200
commit509d5be69c7507ba5d0a5f39ffd1613a59e73eea (patch)
treeb3db08f371014cbf235525843a312f67dea77354 /compiler/parser
parentad2d7612dbdf0e928318394ec0606da3b85a8837 (diff)
downloadhaskell-509d5be69c7507ba5d0a5f39ffd1613a59e73eea.tar.gz
[TTG: Handling Source Locations] Foundation and Pat
This patch removes the ping-pong style from HsPat (only, for now), using the plan laid out at https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution A). - the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced - some instances of `HasSrcSpan` are introduced - some constructors `L` are replaced with `cL` - some patterns `L` are replaced with `dL->L` view pattern - some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`) Phab diff: D5036 Trac Issues #15495 Updates haddock submodule
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/Lexer.x32
-rw-r--r--compiler/parser/Parser.y378
-rw-r--r--compiler/parser/RdrHsSyn.hs658
3 files changed, 566 insertions, 502 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 9597f10b0a..a75566ea39 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -48,7 +48,7 @@
module Lexer (
Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
- P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc,
+ P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getRealSrcLoc,
getPState, extopt, withThisPackage,
failLocMsgP, failSpanMsgP, srcParseFail,
getMessages,
@@ -1155,7 +1155,7 @@ parseNestedPragma input@(AI _ buf) = do
setExts (.&. complement (xbit InNestedCommentBit))
postInput@(AI _ postBuf) <- getInput
setInput origInput
- case unLoc lt of
+ case unRealSrcSpan lt of
ITcomment_line_prag -> do
let bytes = byteDiff buf postBuf
diff = lexemeToString buf bytes
@@ -1570,9 +1570,9 @@ alrInitialLoc file = mkRealSrcSpan loc loc
lex_string_prag :: (String -> Token) -> Action
lex_string_prag mkTok span _buf _len
= do input <- getInput
- start <- getSrcLoc
+ start <- getRealSrcLoc
tok <- go [] input
- end <- getSrcLoc
+ end <- getRealSrcLoc
return (L (mkRealSrcSpan start end) tok)
where go acc input
= if isString input "#-}"
@@ -1844,9 +1844,9 @@ getCharOrFail i = do
lex_qquasiquote_tok :: Action
lex_qquasiquote_tok span buf len = do
let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False
- quoteStart <- getSrcLoc
+ quoteStart <- getRealSrcLoc
quote <- lex_quasiquote quoteStart ""
- end <- getSrcLoc
+ end <- getRealSrcLoc
return (L (mkRealSrcSpan (realSrcSpanStart span) end)
(ITqQuasiQuote (qual,
quoter,
@@ -1858,9 +1858,9 @@ lex_quasiquote_tok span buf len = do
let quoter = tail (lexemeToString buf (len - 1))
-- 'tail' drops the initial '[',
-- while the -1 drops the trailing '|'
- quoteStart <- getSrcLoc
+ quoteStart <- getRealSrcLoc
quote <- lex_quasiquote quoteStart ""
- end <- getSrcLoc
+ end <- getRealSrcLoc
return (L (mkRealSrcSpan (realSrcSpanStart span) end)
(ITquasiQuote (mkFastString quoter,
mkFastString (reverse quote),
@@ -2074,8 +2074,8 @@ setExts f = P $ \s -> POk s {
setSrcLoc :: RealSrcLoc -> P ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
-getSrcLoc :: P RealSrcLoc
-getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
+getRealSrcLoc :: P RealSrcLoc
+getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
addSrcFile :: FastString -> P ()
addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
@@ -2626,7 +2626,7 @@ srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
-- not over a token range.
lexError :: String -> P a
lexError str = do
- loc <- getSrcLoc
+ loc <- getRealSrcLoc
(AI end buf) <- getInput
reportLexError loc end buf str
@@ -2664,8 +2664,8 @@ lexTokenAlr = do mPending <- popPendingImplicitToken
alternativeLayoutRuleToken t
Just t ->
return t
- setAlrLastLoc (getLoc t)
- case unLoc t of
+ setAlrLastLoc (getRealSrcSpan t)
+ case unRealSrcSpan t of
ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet)
ITof -> setAlrExpectingOCurly (Just ALRLayoutOf)
@@ -2684,10 +2684,10 @@ alternativeLayoutRuleToken t
transitional <- getALRTransitional
justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
setJustClosedExplicitLetBlock False
- let thisLoc = getLoc t
+ let thisLoc = getRealSrcSpan t
thisCol = srcSpanStartCol thisLoc
newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
- case (unLoc t, context, mExpectingOCurly) of
+ case (unRealSrcSpan t, context, mExpectingOCurly) of
-- This case handles a GHC extension to the original H98
-- layout rule...
(ITocurly, _, Just alrLayout) ->
@@ -2895,7 +2895,7 @@ lexToken = do
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
lt <- t span buf bytes
- case unLoc lt of
+ case unRealSrcSpan lt of
ITlineComment _ -> return lt
ITblockComment _ -> return lt
lt' -> do
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index f5082174ab..cd41da53eb 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -9,6 +9,9 @@
-- ---------------------------------------------------------------------------
{
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
-- | This module provides the generated Happy parser for Haskell. It exports
-- a number of parsers which may be used in any library that uses the GHC API.
-- A common usage pattern is to initialize the parser state with a given string
@@ -747,7 +750,7 @@ unitdecl :: { LHsUnitDecl PackageName }
signature :: { Located (HsModule GhcPs) }
: maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
+ ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
(snd $ snd $7) $4 $1)
)
([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) }
@@ -755,13 +758,13 @@ signature :: { Located (HsModule GhcPs) }
module :: { Located (HsModule GhcPs) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
+ ams (cL 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 (L loc (HsModule Nothing Nothing
+ ams (cL loc (HsModule Nothing Nothing
(fst $ snd $1) (snd $ snd $1) Nothing Nothing))
(fst $1) }
@@ -812,15 +815,15 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
header :: { Located (HsModule GhcPs) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ams (cL 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 (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
)) [mj AnnModule $2,mj AnnWhere $6] }
| header_body2
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule Nothing Nothing $1 [] Nothing
+ return (cL loc (HsModule Nothing Nothing $1 [] Nothing
Nothing)) }
header_body :: { [LImportDecl GhcPs] }
@@ -842,7 +845,7 @@ header_top_importdecls :: { [LImportDecl GhcPs] }
-- The Export List
maybeexports :: { (Maybe (Located [LIE GhcPs])) }
- : '(' exportlist ')' {% ams (sLL $1 $> ()) [mop $1,mcp $3] >>
+ : '(' exportlist ')' {% amsL (comb2 $1 $>) [mop $1,mcp $3] >>
return (Just (sLL $1 $> (fromOL $2))) }
| {- empty -} { Nothing }
@@ -892,7 +895,7 @@ qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }
qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list
: qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of
- l@(L _ ImpExpQcWildcard) ->
+ l@(dL->L _ ImpExpQcWildcard) ->
return ([mj AnnComma $2, mj AnnDotdot l]
,(snd (unLoc $3) : snd $1))
l -> (ams (head (snd $1)) [mj AnnComma $2] >>
@@ -952,7 +955,7 @@ importdecls_semi
importdecl :: { LImportDecl GhcPs }
: 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
- {% ams (L (comb4 $1 $6 (snd $7) $8) $
+ {% ams (cL (comb4 $1 $6 (snd $7) $8) $
ImportDecl { ideclExt = noExt
, ideclSourceSrc = snd $ fst $2
, ideclName = $6, ideclPkgQual = snd $5
@@ -995,7 +998,7 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) }
: impspec {% let (b, ie) = unLoc $1 in
checkImportSpec ie
>>= \checkedIe ->
- return (L (gl $1) (Just (b, checkedIe))) }
+ return (cL (gl $1) (Just (b, checkedIe))) }
| {- empty -} { noLoc Nothing }
impspec :: { Located (Bool, Located [LIE GhcPs]) }
@@ -1129,7 +1132,7 @@ inst_decl :: { LInstDecl GhcPs }
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid }))
+ ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
-- type instance declarations
@@ -1216,24 +1219,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 L loc _ = $2 in
- L loc ([],Just (unLoc $2)) }
+ | vocurly ty_fam_inst_eqns close { let (dL->L loc _) = $2 in
+ cL loc ([],Just (unLoc $2)) }
| '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2
,mcc $3],Nothing) }
- | vocurly '..' close { let L loc _ = $2 in
- L loc ([mj AnnDotdot $2],Nothing) }
+ | vocurly '..' close { let (dL->L loc _) = $2 in
+ cL loc ([mj AnnDotdot $2],Nothing) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
- {% let L loc (anns, eqn) = $3 in
- asl (unLoc $1) $2 (L loc eqn)
+ {% let (dL->L loc (anns, eqn)) = $3 in
+ asl (unLoc $1) $2 (cL loc eqn)
>> ams $3 anns
- >> return (sLL $1 $> (L loc eqn : unLoc $1)) }
+ >> return (sLL $1 $> (cL loc eqn : unLoc $1)) }
| ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
- | ty_fam_inst_eqn {% let L loc (anns, eqn) = $1 in
+ | ty_fam_inst_eqn {% let (dL->L loc (anns, eqn)) = $1 in
ams $1 anns
- >> return (sLL $1 $> [L loc eqn]) }
+ >> return (sLL $1 $> [cL loc eqn]) }
| {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
@@ -1485,7 +1488,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 { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
+ | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
,sL1 $3 (snd $ unLoc $3)) }
pattern_synonym_sig :: { LSig GhcPs }
@@ -1568,7 +1571,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 { L (gl $2) (unLoc $2) }
+ | vocurly decls_inst close { cL (gl $2) (unLoc $2) }
-- Instance body
--
@@ -1604,7 +1607,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 { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
+ | vocurly decls close { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
-- Binding groups other than those of class and instance declarations
--
@@ -1618,7 +1621,7 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
| '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3]
,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
- | vocurly dbinds close { L (getLoc $2) ([]
+ | vocurly dbinds close { cL (getLoc $2) ([]
,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
@@ -1644,7 +1647,7 @@ rules :: { OrdList (LRuleDecl GhcPs) }
rule :: { LRuleDecl GhcPs }
: STRING rule_activation rule_foralls infixexp '=' exp
{%ams (sLL $1 $> $ HsRule { rd_ext = noExt
- , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
+ , rd_name = cL (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 })
@@ -1739,14 +1742,14 @@ deprecation :: { OrdList (LWarnDecl GhcPs) }
(fst $ unLoc $2) }
strings :: { Located ([AddAnn],[Located StringLiteral]) }
- : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
+ : STRING { sL1 $1 ([],[cL (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`
- (L (gl $3) (getStringLiteral $3)))) }
- | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
+ (cL (gl $3) (getStringLiteral $3)))) }
+ | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) }
| {- empty -} { noLoc nilOL }
-----------------------------------------------------------------------------
@@ -1797,7 +1800,7 @@ safety :: { Located Safety }
fspec :: { Located ([AddAnn]
,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) }
: STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3]
- ,(L (getLoc $1)
+ ,(cL (getLoc $1)
(getStringLiteral $1), $2, mkLHsSigType $4)) }
| var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2]
,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
@@ -1953,13 +1956,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 noExt (L (comb2 $1 $2)
+ HsFunTy noExt (cL (comb2 $1 $2)
(HsDocTy noExt $1 $2))
$4)
[mu AnnRarrow $3] }
| docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $
- HsFunTy noExt (L (comb2 $1 $2)
+ HsFunTy noExt (cL (comb2 $1 $2)
(HsDocTy noExt $2 $1))
$4)
[mu AnnRarrow $3] }
@@ -2102,7 +2105,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] }
| fd { sL1 $1 [$1] }
fd :: { Located (FunDep (Located RdrName)) }
- : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3)
+ : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3)
(reverse (unLoc $1), reverse (unLoc $3)))
[mu AnnRarrow $2] }
@@ -2145,13 +2148,13 @@ gadt_constrlist :: { Located ([AddAnn]
,[LConDecl GhcPs]) } -- Returned in order
: 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $
- L (comb2 $1 $3)
+ cL (comb2 $1 $3)
([mj AnnWhere $1
,moc $2
,mcc $4]
, unLoc $3) }
| 'where' vocurly gadt_constrs close {% checkEmptyGADTs $
- L (comb2 $1 $3)
+ cL (comb2 $1 $3)
([mj AnnWhere $1]
, unLoc $3) }
| {- empty -} { noLoc ([],[]) }
@@ -2159,8 +2162,8 @@ gadt_constrlist :: { Located ([AddAnn]
gadt_constrs :: { Located [LConDecl GhcPs] }
: gadt_constr_with_doc ';' gadt_constrs
{% addAnnotation (gl $1) AnnSemi (gl $2)
- >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
- | gadt_constr_with_doc { L (gl $1) [$1] }
+ >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) }
+ | gadt_constr_with_doc { cL (gl $1) [$1] }
| {- empty -} { noLoc [] }
-- We allow the following forms:
@@ -2197,7 +2200,7 @@ allowed in usual data constructors, but not in GADTs).
-}
constrs :: { Located ([AddAnn],[LConDecl GhcPs]) }
- : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2]
+ : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2]
,addConDocs (unLoc $3) $1)}
constrs1 :: { Located [LConDecl GhcPs] }
@@ -2261,7 +2264,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 (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
+ addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con
(snd $ unLoc $2)
(Just $3)
details))
@@ -2269,7 +2272,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 (L (comb2 $2 $3) (mkConDeclH98 con
+ addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con
(snd $ unLoc $2)
Nothing -- No context
details))
@@ -2297,8 +2300,8 @@ fielddecls1 :: { [LConDeclField GhcPs] }
fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: maybe_docnext sig_vars '::' ctype maybe_docprev
- {% ams (L (comb2 $2 $4)
- (ConDeclField noExt (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5)))
+ {% ams (cL (comb2 $2 $4)
+ (ConDeclField noExt (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5)))
[mu AnnDcolon $3] }
-- Reversed!
@@ -2316,17 +2319,17 @@ derivings :: { HsDeriving GhcPs }
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause noExt Nothing $2)
+ in ams (cL full_loc $ HsDerivingClause noExt Nothing $2)
[mj AnnDeriving $1] }
| 'deriving' deriv_strategy_no_via deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3)
+ in ams (cL full_loc $ HsDerivingClause noExt (Just $2) $3)
[mj AnnDeriving $1] }
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2)
+ in ams (cL full_loc $ HsDerivingClause noExt (Just $3) $2)
[mj AnnDeriving $1] }
deriv_clause_types :: { Located [LHsSigType GhcPs] }
@@ -2384,11 +2387,11 @@ decl_no_th :: { LHsDecl GhcPs }
-- [FunBind vs PatBind]
case r of {
(FunBind _ n _ _ _) ->
- ams (L l ()) [mj AnnFunId n] >> return () ;
- (PatBind _ (L lh _lhs) _rhs _) ->
- ams (L lh ()) [] >> return () } ;
+ amsL l [mj AnnFunId n] >> return () ;
+ (PatBind _ (dL->L l _) _rhs _) ->
+ amsL l [] >> return () } ;
- _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
+ _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
return $! (sL l $ ValD noExt r) } }
| infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
@@ -2398,10 +2401,10 @@ decl_no_th :: { LHsDecl GhcPs }
-- [FunBind vs PatBind]
case r of {
(FunBind _ n _ _ _) ->
- ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
- (PatBind _ (L lh _lhs) _rhs _) ->
- ams (L lh ()) (fst $2) >> return () } ;
- _ <- ams (L l ()) (ann ++ (fst $ unLoc $3));
+ amsL l (mj AnnFunId n:(fst $2)) >> return () ;
+ (PatBind _ (dL->L lh _lhs) _rhs _) ->
+ amsL lh (fst $2) >> return () } ;
+ _ <- amsL l (ann ++ (fst $ unLoc $3));
return $! (sL l $ ValD noExt r) } }
| pattern_synonym_decl { $1 }
| docdecl { $1 }
@@ -2435,10 +2438,10 @@ sigdecl :: { LHsDecl GhcPs }
:
-- See Note [Declaration/signature overlap] for why we need infixexp here
infixexp_top '::' sigtypedoc
- {% do v <- checkValSigLhs $1
- ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
- ; return (sLL $1 $> $ SigD noExt $
- TypeSig noExt [v] (mkLHsSigWcType $3)) }
+ {% do { v <- checkValSigLhs $1
+ ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
+ ; return (sLL $1 $> $ SigD noExt $
+ TypeSig noExt [v] (mkLHsSigWcType $3))} }
| var ',' sig_vars '::' sigtypedoc
{% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3))
@@ -2664,15 +2667,15 @@ aexp :: { LHsExpr GhcPs }
ams (sLL $1 $> $ HsMultiIf noExt
(reverse $ snd $ unLoc $2))
(mj AnnIf $1:(fst $ unLoc $2)) }
- | 'case' exp 'of' altslist {% ams (L (comb3 $1 $3 $4) $
+ | 'case' exp 'of' altslist {% ams (cL (comb3 $1 $3 $4) $
HsCase noExt $2 (mkMatchGroup
FromSource (snd $ unLoc $4)))
(mj AnnCase $1:mj AnnOf $3
:(fst $ unLoc $4)) }
- | 'do' stmtlist {% ams (L (comb2 $1 $2)
+ | 'do' stmtlist {% ams (cL (comb2 $1 $2)
(mkHsDo DoExpr (snd $ unLoc $2)))
(mj AnnDo $1:(fst $ unLoc $2)) }
- | 'mdo' stmtlist {% ams (L (comb2 $1 $2)
+ | 'mdo' stmtlist {% ams (cL (comb2 $1 $2)
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
@@ -2687,7 +2690,7 @@ aexp :: { LHsExpr GhcPs }
aexp1 :: { LHsExpr GhcPs }
: aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4)
(snd $3)
- ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3))
+ ; _ <- amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3))
; checkRecordSyntax (sLL $1 $> r) }}
| aexp2 { $1 }
@@ -2712,7 +2715,7 @@ aexp2 :: { LHsExpr GhcPs }
| '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
- | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2)
+ | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2)
(Present noExt $2)] Unboxed))
[mo $1,mc $3] }
| '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)
@@ -2815,7 +2818,7 @@ tup_exprs :: { ([AddAnn],SumOrTuple) }
| commas tup_tail
{% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
; return
- ([],Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } }
+ ([],Tuple (map (\l -> cL l missingTupArg) (fst $1) ++ $2)) } }
| bars texp bars0
{ (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) }
@@ -2826,13 +2829,13 @@ commas_tup_tail : commas tup_tail
{% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)
; return (
(head $ fst $1
- ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } }
+ ,(map (\l -> cL l missingTupArg) (tail $ fst $1)) ++ $2)) } }
-- Always follows a comma
tup_tail :: { [LHsTupArg GhcPs] }
: texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>
- return ((L (gl $1) (Present noExt $1)) : snd $2) }
- | texp { [L (gl $1) (Present noExt $1)] }
+ return ((cL (gl $1) (Present noExt $1)) : snd $2) }
+ | texp { [cL (gl $1) (Present noExt $1)] }
| {- empty -} { [noLoc missingTupArg] }
-----------------------------------------------------------------------------
@@ -2886,19 +2889,19 @@ 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 { L (getLoc $1) [reverse (unLoc $1)] }
+ | squals { cL (getLoc $1) [reverse (unLoc $1)] }
squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last
-- one can "grab" the earlier ones
: squals ',' transformqual
{% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
- ams (sLL $1 $> ()) (fst $ unLoc $3) >>
+ amsL (comb2 $1 $>) (fst $ unLoc $3) >>
return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
| squals ',' qual
{% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| transformqual {% ams $1 (fst $ unLoc $1) >>
- return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) }
+ return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
| qual { sL1 $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
-- | '{|' pquals '|}' { sL1 $1 [$2] }
@@ -2927,7 +2930,7 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs
-- Guards
guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
- : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) }
+ : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma
@@ -2941,7 +2944,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
: '{' alts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse (snd $ unLoc $2))) }
- | vocurly alts close { L (getLoc $2) (fst $ unLoc $2
+ | vocurly alts close { cL (getLoc $2) (fst $ unLoc $2
,(reverse (snd $ unLoc $2))) }
| '{' '}' { sLL $1 $> ([moc $1,mcc $2],[]) }
| vocurly close { noLoc ([],[]) }
@@ -3033,7 +3036,7 @@ apats :: { [LPat GhcPs] }
stmtlist :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) }
: '{' stmts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?
- | vocurly stmts close { L (gl $2) (fst $ unLoc $2
+ | vocurly stmts close { cL (gl $2) (fst $ unLoc $2
,reverse $ snd $ unLoc $2) }
-- do { ;; s ; s ; ; s ;; }
@@ -3254,11 +3257,14 @@ oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mi
-- for variable constructor in export lists
-- see Note [Type constructors in export list]
: qtycon { $1 }
- | '(' QCONSYM ')' {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2)
+ | '(' QCONSYM ')' {% let { name :: Located RdrName
+ ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }
in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
- | '(' CONSYM ')' {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2)
+ | '(' CONSYM ')' {% let { name :: Located RdrName
+ ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }
in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
- | '(' ':' ')' {% let name = sL1 $2 $! consDataCon_RDR
+ | '(' ':' ')' {% let { name :: Located RdrName
+ ; 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] }
@@ -3572,89 +3578,89 @@ maybe_docnext :: { Maybe LHsDocString }
happyError :: P a
happyError = srcParseFail
-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
-getTH_ID_SPLICE (L _ (ITidEscape x)) = x
-getTH_ID_TY_SPLICE (L _ (ITidTyEscape 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
+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
+getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x
+getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape 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
-- See Note [Pragma source text] in BasicTypes for the following
-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
+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
getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
isUnicode :: Located Token -> Bool
-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 (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 _ = False
hasE :: Located Token -> Bool
-hasE (L _ (ITopenExpQuote HasE _)) = True
-hasE (L _ (ITopenTExpQuote HasE)) = True
+hasE (dL->L _ (ITopenExpQuote HasE _)) = True
+hasE (dL->L _ (ITopenTExpQuote HasE)) = True
hasE _ = False
getSCC :: Located Token -> P FastString
@@ -3666,36 +3672,39 @@ getSCC lt = do let s = getSTRING lt
else return s
-- Utilities for combining source spans
-comb2 :: Located a -> Located b -> SrcSpan
+comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
comb2 a b = a `seq` b `seq` combineLocs a b
-comb3 :: Located a -> Located b -> Located c -> SrcSpan
+comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
+ a -> b -> c -> SrcSpan
comb3 a b c = a `seq` b `seq` c `seq`
combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
-comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
+comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) =>
+ a -> b -> c -> 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 :: SrcSpan -> a -> Located a
-sL span a = span `seq` a `seq` L span a
+sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
+sL span a = span `seq` a `seq` cL 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 :: a -> Located a
-sL0 = L noSrcSpan -- #define L0 L noSrcSpan
+sL0 :: HasSrcSpan a => SrcSpanLess a -> a
+sL0 = cL noSrcSpan -- #define L0 L noSrcSpan
{-# INLINE sL1 #-}
-sL1 :: Located a -> b -> Located b
+sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b
sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sLL #-}
-sLL :: Located a -> Located b -> c -> Located c
+sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
+ a -> b -> SrcSpanLess c -> c
sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
{- Note [Adding location info]
@@ -3739,7 +3748,7 @@ incorrect.
-- try to find the span of the whole file (ToDo).
fileSrcSpan :: P SrcSpan
fileSrcSpan = do
- l <- getSrcLoc;
+ l <- getRealSrcLoc;
let loc = mkSrcLoc (srcLocFile l) 1 1;
return (mkSrcSpan loc loc)
@@ -3770,7 +3779,7 @@ hintExplicitForall span = do
]
-- Hint about explicit-forall, assuming UnicodeSyntax is off
-hintExplicitForall' :: SrcSpan -> P (GenLocated SrcSpan RdrName)
+hintExplicitForall' :: SrcSpan -> P (Located RdrName)
hintExplicitForall' span = do
forall <- extension explicitForallEnabled
let illegalDot = "Illegal symbol '.' in type"
@@ -3786,7 +3795,7 @@ hintExplicitForall' span = do
]
checkIfBang :: LHsExpr GhcPs -> Bool
-checkIfBang (L _ (HsVar _ (L _ op))) = op == bang_RDR
+checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR
checkIfBang _ = False
-- | Warn about missing space after bang
@@ -3803,7 +3812,7 @@ warnSpaceAfterBang span = do
-- When two single quotes don't followed by tyvar or gtycon, we report the
-- error as empty character literal, or TH quote that missing proper type
-- variable or constructor. See Trac #13450.
-reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs))
+reportEmptyDoubleQuotes :: SrcSpan -> P (Located (HsExpr GhcPs))
reportEmptyDoubleQuotes span = do
thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState
if thEnabled
@@ -3832,31 +3841,37 @@ in ApiAnnotation.hs
-- |Construct an AddAnn from the annotation keyword and the location
-- of the keyword itself
-mj :: AnnKeywordId -> Located e -> AddAnn
+mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn
mj a l s = addAnnotation s a (gl l)
+mjL :: AnnKeywordId -> SrcSpan -> AddAnn
+mjL a l s = addAnnotation s a l
+
+
+
-- |Construct an AddAnn from the annotation keyword and the Located Token. If
-- 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@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l)
+mu a lt@(dL->L l t) = (\s -> addAnnotation s (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 = getLoc
-- |Add an annotation to the located element, and return the located
-- element as a pass through
-aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a)
-aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a
+aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a
+aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a
-- |Add an annotation to a located element resulting from a monadic action
-am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)
+am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a
am a (b,s) = do
- av@(L l _) <- a
+ av@(dL->L l _) <- a
addAnnotation l b (gl s)
return av
@@ -3874,26 +3889,25 @@ am a (b,s) = do
-- and closing braces if they are used to delimit the let expressions.
--
ams :: Located a -> [AddAnn] -> P (Located a)
-ams a@(L l _) bs = addAnnsAt l bs >> return a
+ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
--- |Add all [AddAnn] to an AST element wrapped in a Just
-aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a))
-aljs 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 wrapped in a Just
-ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a
+ajs a@(Just (dL->L l _)) bs = addAnnsAt l bs >> return a
-- |Add a list of AddAnns to the given AST element, where the AST element is the
-- result of a monadic action
-amms :: P (Located a) -> [AddAnn] -> P (Located a)
-amms a bs = do { av@(L l _) <- a
+amms :: HasSrcSpan a => P a -> [AddAnn] -> P a
+amms a bs = do { av@(dL->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 :: Located a -> [AddAnn] -> P (OrdList (Located a))
-amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)
+amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a)
+amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a)
-- |Synonyms for AddAnn versions of AnnOpen and AnnClose
mo,mc :: Located Token -> AddAnn
@@ -3915,22 +3929,22 @@ mcs ll = mj AnnCloseS ll
-- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma
-- entry for each SrcSpan
mcommas :: [SrcSpan] -> [AddAnn]
-mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss
+mcommas ss = map (mjL AnnCommaTuple) ss
-- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar
-- entry for each SrcSpan
mvbars :: [SrcSpan] -> [AddAnn]
-mvbars ss = map (\s -> mj AnnVbar (L s ())) ss
+mvbars ss = map (mjL AnnVbar) ss
-- |Get the location of the last element of a OrdList, or noSrcSpan
-oll :: OrdList (Located a) -> SrcSpan
+oll :: HasSrcSpan a => OrdList 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 :: [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
+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
}
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 1ac21c6c2d..8c78fb5a0e 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -8,6 +8,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ViewPatterns #-}
module RdrHsSyn (
mkHsOpApp,
@@ -36,8 +37,8 @@ module RdrHsSyn (
mkImport,
parseCImport,
mkExport,
- mkExtName, -- RdrName -> CLabelString
- mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
+ mkExtName, -- RdrName -> CLabelString
+ mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
mkConDeclH98,
mkATDefault,
@@ -136,10 +137,10 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
-- *** See Note [The Naming story] in HsDecls ****
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkTyClD (L loc d) = L loc (TyClD noExt d)
+mkTyClD (dL->L loc d) = cL loc (TyClD noExt d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkInstD (L loc d) = L loc (InstD noExt d)
+mkInstD (dL->L loc d) = cL loc (InstD noExt d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
@@ -147,7 +148,7 @@ mkClassDecl :: SrcSpan
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
-mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
+mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
@@ -155,14 +156,14 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts
; sequence_ anns
- ; return (L loc (ClassDecl { tcdCExt = noExt, 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 (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
+ , tcdLName = cls, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdFDs = snd (unLoc fds)
+ , tcdSigs = mkClassOpSigs sigs
+ , tcdMeths = binds
+ , tcdATs = ats, tcdATDefs = at_defs
+ , tcdDocs = docs })) }
mkATDefault :: LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
@@ -175,20 +176,22 @@ mkATDefault :: LTyFamInstDecl GhcPs
-- The @P ()@ we return corresponds represents an action which will add
-- some necessary paren annotations to the parsing context. Naturally, this
-- is not something that the "Convert" use cares about.
-mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
+mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
| FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats
, feqn_fixity = fixity, feqn_rhs = rhs } <- e
= do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
- ; let f = L loc (FamEqn { feqn_ext = noExt
- , feqn_tycon = tc
- , feqn_bndrs = ASSERT( isNothing bndrs )
- Nothing
- , feqn_pats = tvs
- , feqn_fixity = fixity
- , feqn_rhs = rhs })
+ ; let f = cL loc (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc
+ , feqn_bndrs = ASSERT( isNothing bndrs )
+ Nothing
+ , feqn_pats = tvs
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs })
; pure (f, anns) }
-mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
-mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
+mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
+mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
+mkATDefault _ = panic "mkATDefault: Impossible Match"
+ -- due to #15884
mkTyData :: SrcSpan
-> NewOrData
@@ -198,15 +201,16 @@ mkTyData :: SrcSpan
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
-mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
+ ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (L loc (DataDecl { tcdDExt = noExt,
- tcdLName = tc, tcdTyVars = tyvars,
- tcdFixity = fixity,
- tcdDataDefn = defn })) }
+ ; return (cL loc (DataDecl { tcdDExt = noExt,
+ tcdLName = tc, tcdTyVars = tyvars,
+ tcdFixity = fixity,
+ tcdDataDefn = defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
@@ -234,10 +238,10 @@ mkTySynonym loc lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
- ; return (L loc (SynDecl { tcdSExt = noExt
- , tcdLName = tc, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdRhs = rhs })) }
+ ; return (cL loc (SynDecl { tcdSExt = noExt
+ , tcdLName = tc, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdRhs = rhs })) }
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
@@ -257,16 +261,18 @@ mkTyFamInstEqn bndrs lhs rhs
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
- -> Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)
+ -> Located ( Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
+ , LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
-mkDataFamInst loc new_or_data cType (L _ (mcxt, bndrs, tycl_hdr)) ksig data_cons maybe_deriv
+mkDataFamInst loc new_or_data cType (dL->L _ (mcxt, bndrs, tycl_hdr))
+ ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
+ ; return (cL loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExt
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -278,7 +284,7 @@ mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn
- = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))
+ = return (cL loc (TyFamInstD noExt (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
@@ -290,7 +296,7 @@ mkFamDecl loc info lhs ksig injAnn
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
- ; return (L loc (FamDecl noExt (FamilyDecl
+ ; return (cL loc (FamDecl noExt (FamilyDecl
{ fdExt = noExt
, fdInfo = info, fdLName = tc
, fdTyVars = tyvars
@@ -313,15 +319,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@(L loc expr)
+mkSpliceDecl lexpr@(dL->L loc expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
- = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
+ = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
- = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
+ = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice)
| otherwise
- = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
+ = SpliceD noExt (SpliceDecl noExt (cL loc (mkUntypedSplice NoParens lexpr))
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
@@ -330,21 +336,25 @@ mkRoleAnnotDecl :: SrcSpan
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles
= do { roles' <- mapM parse_role roles
- ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
+ ; return $ cL loc $ RoleAnnotDecl noExt 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 (L loc_role Nothing) = return $ L loc_role Nothing
- parse_role (L loc_role (Just role))
+ parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing
+ parse_role (dL->L loc_role (Just role))
= case lookup role possible_roles of
- Just found_role -> return $ L loc_role $ Just found_role
+ Just found_role -> return $ cL loc_role $ Just found_role
Nothing ->
- let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
+ let nearby = fuzzyLookup (unpackFS role)
+ (mapFst unpackFS possible_roles)
+ in
parseErrorSDoc 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)
@@ -369,14 +379,16 @@ cvTopDecls decls = go (fromOL decls)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [] = []
- 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
+ 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 (d : ds) = d : go ds
-- Declaration list may only contain value bindings and signatures.
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup binding
- = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
+ = do { (mbs, sigs, fam_ds, tfam_insts
+ , dfam_insts, _) <- cvBindsAndSigs binding
; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
return $ ValBinds noExt mbs sigs }
@@ -389,24 +401,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = return (emptyBag, [], [], [], [], [])
- go (L l (ValD _ b) : ds)
+ go ((dL->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 (L l b) ds
- go (L l decl : ds)
+ (b', ds') = getMonoBind (cL l b) ds
+ go ((dL->L l decl) : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds
; case decl of
SigD _ s
- -> return (bs, L l s : ss, ts, tfis, dfis, docs)
+ -> return (bs, cL l s : ss, ts, tfis, dfis, docs)
TyClD _ (FamDecl _ t)
- -> return (bs, ss, L l t : ts, tfis, dfis, docs)
+ -> return (bs, ss, cL l t : ts, tfis, dfis, docs)
InstD _ (TyFamInstD { tfid_inst = tfi })
- -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
+ -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs)
InstD _ (DataFamInstD { dfid_inst = dfi })
- -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
+ -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs)
DocD _ d
- -> return (bs, ss, ts, tfis, dfis, L l d : docs)
+ -> return (bs, ss, ts, tfis, dfis, cL l d : docs)
SpliceD _ d
-> parseErrorSDoc l $
hang (text "Declaration splices are allowed only" <+>
@@ -432,23 +444,25 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
- fun_matches
- = MG { mg_alts = L _ mtchs1 } })) binds
+getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
+ , fun_matches =
+ MG { mg_alts = (dL->L _ mtchs1) } }))
+ binds
| has_args mtchs1
= go mtchs1 loc1 binds []
where
go mtchs loc
- (L loc2 (ValD _ (FunBind { fun_id = L _ f2,
- fun_matches
- = MG { mg_alts = L _ mtchs2 } })) : binds) _
+ ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
+ , fun_matches =
+ MG { mg_alts = (dL->L _ mtchs2) } })))
+ : binds) _
| f1 == f2 = go (mtchs2 ++ mtchs)
(combineSrcSpans loc loc2) binds []
- go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
+ go mtchs loc (doc_decl@(dL->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
- = ( L loc (makeFunBind fun_id1 (reverse mtchs))
+ = ( cL 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
@@ -457,12 +471,13 @@ getMonoBind bind binds = (bind, binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = panic "RdrHsSyn:has_args"
-has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
+has_args ((dL->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 ((L _ (XMatch _)) : _) = panic "has_args"
+has_args ((dL->L _ (XMatch _)) : _) = panic "has_args"
+has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884
{- **********************************************************************
@@ -554,7 +569,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon loc tc
| isTcOcc occ || isDataOcc occ
, isLexCon (occNameFS occ)
- = return (L loc (setRdrNameSpace tc srcDataName))
+ = return (cL loc (setRdrNameSpace tc srcDataName))
| otherwise
= Left (loc, msg $$ extra)
@@ -569,13 +584,13 @@ tyConToDataCon loc tc
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
-mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
+mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
do { matches <- mapM fromDecl (fromOL decls)
; when (null matches) (wrongNumberErr loc)
; return $ mkMatchGroup FromSource matches }
where
- fromDecl (L loc decl@(ValD _ (PatBind _
- pat@(L _ (ConPatIn ln@(L _ name) details))
+ fromDecl (dL->L loc decl@(ValD _ (PatBind _
+ pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details))
rhs _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
@@ -584,18 +599,22 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
, m_ctxt = ctxt, m_pats = pats
, m_grhss = rhs }
where
- ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }
+ ctxt = FunRhs { mc_fun = ln
+ , mc_fixity = Prefix
+ , mc_strictness = NoSrcStrict }
InfixCon p1 p2 -> return $ Match { m_ext = noExt
, m_ctxt = ctxt
, m_pats = [p1, p2]
, m_grhss = rhs }
where
- ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }
+ ctxt = FunRhs { mc_fun = ln
+ , mc_fixity = Infix
+ , mc_strictness = NoSrcStrict }
RecCon{} -> recordPatSynErr loc pat
- ; return $ L loc match }
- fromDecl (L loc decl) = extraDeclErr loc decl
+ ; return $ cL loc match }
+ fromDecl (dL->L loc decl) = extraDeclErr loc decl
extraDeclErr loc decl =
parseErrorSDoc loc $
@@ -603,9 +622,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
ppr decl
wrongNameBindingErr loc decl =
- parseErrorSDoc loc $
- text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
- quotes (ppr patsyn_name) $$ ppr decl
+ parseErrorSDoc loc $
+ text "pattern synonym 'where' clause must bind the pattern synonym's name"
+ <+> quotes (ppr patsyn_name) $$ ppr decl
wrongNumberErr loc =
parseErrorSDoc loc $
@@ -639,7 +658,7 @@ mkGadtDecl :: [Located RdrName]
mkGadtDecl names ty
= (ConDeclGADT { con_g_ext = noExt
, con_names = names
- , con_forall = L l $ isLHsForAllTy ty'
+ , con_forall = cL l $ isLHsForAllTy ty'
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args'
@@ -647,24 +666,27 @@ mkGadtDecl names ty
, con_doc = Nothing }
, anns1 ++ anns2)
where
- (ty'@(L l _),anns1) = peel_parens ty []
+ (ty'@(dL->L l _),anns1) = peel_parens ty []
(tvs, rho) = splitLHsForAllTy ty'
(mcxt, tau, anns2) = split_rho rho []
- split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
- = (Just cxt, tau, ann)
- split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
- split_rho tau ann = (Nothing, tau, ann)
+ split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
+ = (Just cxt, tau, ann)
+ split_rho (dL->L l (HsParTy _ ty)) ann
+ = split_rho ty (ann++mkParensApiAnn l)
+ split_rho tau ann
+ = (Nothing, tau, ann)
(args, res_ty) = split_tau tau
args' = nudgeHsSrcBangs args
-- See Note [GADT abstract syntax] in HsDecls
- split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
- = (RecCon (L loc rf), res_ty)
- split_tau tau = (PrefixCon [], tau)
+ split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
+ = (RecCon (cL loc rf), res_ty)
+ split_tau tau
+ = (PrefixCon [], tau)
- peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
+ peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty
(ann++mkParensApiAnn l)
peel_parens ty ann = (ty, ann)
@@ -685,8 +707,8 @@ nudgeHsSrcBangs details
RecCon r -> RecCon r
InfixCon a1 a2 -> InfixCon (go a1) (go a2)
where
- go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
- L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
+ go (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =
+ cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
go lty = lty
@@ -811,24 +833,29 @@ checkTyVars pp_what equals_or_where tc tparms
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddAnn] -> LHsType GhcPs
-> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ())
- chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty
+ chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l
+ ++ acc) ty
chkParens acc ty = case chk ty of
Left err -> Left err
- Right tv@(L l _) -> Right (tv, addAnnsAt l (reverse acc))
+ Right tv@(dL->L l _) -> Right (tv, addAnnsAt l (reverse acc))
-- Check that the name space is correct!
- chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
- | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k))
- chk (L l (HsTyVar _ _ (L ltv tv)))
- | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv)))
- chk t@(L loc _)
+ chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
+ | isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k))
+ chk (dL->L l (HsTyVar _ _ (dL->L ltv tv)))
+ | isRdrTyVar tv = return (cL l (UserTyVar noExt (cL ltv tv)))
+ chk t@(dL->L loc _)
= Left (loc,
vcat [ text "Unexpected type" <+> quotes (ppr t)
- , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes tc'
- , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))
- , nest 2 (pp_what <+> tc'
- <+> hsep (map text (takeList tparms allNameStrings))
- <+> equals_or_where) ] ])
+ , text "In the" <+> pp_what
+ <+> ptext (sLit "declaration for") <+> quotes tc'
+ , vcat[ (text "A" <+> pp_what
+ <+> ptext (sLit "declaration should have form"))
+ , nest 2
+ (pp_what
+ <+> tc'
+ <+> hsep (map text (takeList tparms allNameStrings))
+ <+> equals_or_where) ] ])
-- Avoid printing a constraint tuple in the error message. Print
-- a plain old tuple instead (since that's what the user probably
@@ -844,7 +871,7 @@ equalsDots = text "= ..."
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Nothing = return ()
-checkDatatypeContext (Just (L loc c))
+checkDatatypeContext (Just (dL->L loc c))
= do allowed <- extension datatypeContextsEnabled
unless allowed $
parseErrorSDoc loc
@@ -859,39 +886,42 @@ data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = fmap (fmap cvt_one)
where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExt v
- cvt_one (RuleTyTmVar v (Just sig)) = RuleBndrSig noExt v (mkLHsSigWcType sig)
+ cvt_one (RuleTyTmVar v (Just sig)) =
+ RuleBndrSig noExt v (mkLHsSigWcType sig)
-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
mkRuleTyVarBndrs = fmap (fmap cvt_one)
where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExt (fmap tm_to_ty v)
- cvt_one (RuleTyTmVar v (Just sig)) = KindedTyVar noExt (fmap tm_to_ty v) sig
- -- takes something in namespace 'varName' to something in namespace 'tvName'
+ cvt_one (RuleTyTmVar v (Just sig))
+ = KindedTyVar noExt (fmap tm_to_ty v) sig
+ -- takes something in namespace 'varName' to something in namespace 'tvName'
tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
tm_to_ty _ = panic "mkRuleTyVarBndrs"
-- See note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
- where check (L loc (Unqual occ)) = do
+ where check (dL->L loc (Unqual occ)) = do
when ((occNameString occ ==) `any` ["forall","family","role"])
- (parseErrorSDoc loc (text $ "parse error on input " ++ occNameString occ))
+ (parseErrorSDoc loc (text $ "parse error on input "
+ ++ occNameString occ))
check _ = panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
-checkRecordSyntax lr@(L loc r)
+checkRecordSyntax lr@(dL->L loc r)
= do allowed <- extension traditionalRecordSyntaxEnabled
if allowed
then return lr
else parseErrorSDoc loc
- (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
- ppr r)
+ (text "Illegal record syntax (use TraditionalRecordSyntax):"
+ <+> ppr r)
-- | Check if the gadt_constrlist is empty. Only raise parse error for
-- `data T where` to avoid affecting existing error message, see #8258.
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
-checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
+checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration.
= do opts <- fmap options getPState
if LangExt.GADTSyntax `extopt` opts -- GADTs implies GADTSyntax
then return gadts
@@ -916,28 +946,28 @@ checkTyClHdr :: Bool -- True <=> class header
checkTyClHdr is_cls ty
= goL ty [] [] Prefix
where
- goL (L l ty) acc ann fix = go l ty acc ann fix
+ goL (dL->L l ty) acc ann fix = go l ty acc ann fix
-- workaround to define '*' despite StarIsType
- go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
+ go _ (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix
= do { warnStarBndr l
; let name = mkOccName tcClsName (if isUni then "★" else "*")
- ; return (L l (Unqual name), acc, fix, ann) }
+ ; return (cL l (Unqual name), acc, fix, ann) }
- go l (HsTyVar _ _ (L _ tc)) acc ann fix
- | isRdrTc tc = return (L l tc, acc, fix, ann)
- go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
+ go l (HsTyVar _ _ (dL->L _ tc)) acc ann fix
+ | isRdrTc tc = return (cL l tc, acc, fix, ann)
+ go _ (HsOpTy _ t1 ltc@(dL->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
go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
- = return (L l (nameRdrName tup_name), ts, fix, ann)
+ = return (cL l (nameRdrName tup_name), ts, fix, ann)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
| otherwise = getName (tupleTyCon Boxed arity)
- -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?)
+ -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?)
go l _ _ _ _
= parseErrorSDoc l (text "Malformed head of type or class declaration:"
<+> ppr ty)
@@ -975,22 +1005,22 @@ checkBlockArguments expr = case unLoc expr of
-- (((Eq a))) --> [Eq a]
-- @
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
-checkContext (L l orig_t)
- = check [] (L l orig_t)
+checkContext (dL->L l orig_t)
+ = check [] (cL l orig_t)
where
- check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
+ check anns (dL->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,L l ts) -- Ditto ()
+ = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto ()
- check anns (L lp1 (HsParTy _ ty))
+ check anns (dL->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 ([],L l [L l orig_t])
+ check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t])
msg = text "data constructor context"
@@ -999,8 +1029,8 @@ checkContext (L l orig_t)
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs msg ty = go ty
where
- go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
- go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
+ go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
+ go (dL->L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
[ text "Unexpected haddock", quotes (ppr ds)
, text "on", msg, quotes (ppr t) ]
go _ = pure ()
@@ -1018,12 +1048,12 @@ checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns msg es = mapM (checkPattern msg) es
checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
-checkLPat msg e@(L l _) = checkPat msg l e []
+checkLPat msg e@(dL->L l _) = checkPat msg l e []
checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
-> P (LPat GhcPs)
-checkPat _ loc (L l e@(HsVar _ (L _ c))) args
- | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
+checkPat _ loc (dL->L l e@(HsVar _ (dL->L _ c))) args
+ | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
| not (null args) && patIsRec c =
patFail (text "Perhaps you intended to use RecursiveDo") l e
checkPat msg loc e args -- OK to let this happen even if bang-patterns
@@ -1032,12 +1062,12 @@ checkPat msg loc e args -- OK to let this happen even if bang-patterns
| Just (e', args') <- splitBang e
= do { args'' <- checkPatterns msg args'
; checkPat msg loc e' (args'' ++ args) }
-checkPat msg loc (L _ (HsApp _ f e)) args
+checkPat msg loc (dL->L _ (HsApp _ f e)) args
= do p <- checkLPat msg e
checkPat msg loc f (p : args)
-checkPat msg loc (L _ e) []
+checkPat msg loc (dL->L _ e) []
= do p <- checkAPat msg loc e
- return (L loc p)
+ return (cL loc p)
checkPat msg loc e _
= patFail msg loc (unLoc e)
@@ -1049,18 +1079,19 @@ checkAPat msg loc e0 = do
EWildPat _ -> return (WildPat noExt)
HsVar _ x -> return (VarPat noExt x)
HsLit _ (HsStringPrim _ _) -- (#13260)
- -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
+ -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:"
+ $$ ppr e0)
HsLit _ l -> return (LitPat noExt l)
-- 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
- HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
- NegApp _ (L l (HsOverLit _ pos_lit)) _
- -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
+ HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing)
+ NegApp _ (dL->L l (HsOverLit _ pos_lit)) _
+ -> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr))
- SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x)
+ SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x)
| bang == bang_RDR
-> do { hintBangPat loc e0
; e' <- checkLPat msg e
@@ -1076,16 +1107,16 @@ checkAPat msg loc e0 = do
return (SigPat noExt e t)
-- n+k patterns
- OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
- (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
+ OpApp _ (dL->L nloc (HsVar _ (dL->L _ n)))
+ (dL->L _ (HsVar _ (dL->L _ plus)))
+ (dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
| extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
- -> return (mkNPlusKPat (L nloc n) (L lloc lit))
-
- OpApp _ l (L cl (HsVar _ (L _ c))) r
+ -> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
+ OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r
| isDataOcc (rdrNameOcc c) -> do
l <- checkLPat msg l
r <- checkLPat msg r
- return (ConPatIn (L cl c) (InfixCon l r))
+ return (ConPatIn (cL cl c) (InfixCon l r))
OpApp {} -> patFail msg loc e0
@@ -1096,9 +1127,10 @@ checkAPat msg loc e0 = do
ExplicitTuple _ es b
| all tupArgPresent es -> do ps <- mapM (checkLPat msg)
- [e | L _ (Present _ e) <- es]
+ [e | (dL->L _ (Present _ e)) <- es]
return (TuplePat noExt ps b)
- | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
+ | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:"
+ $$ ppr e0)
ExplicitSum _ alt arity expr -> do
p <- checkLPat msg expr
@@ -1113,7 +1145,8 @@ checkAPat msg loc e0 = do
placeHolderPunRhs :: LHsExpr GhcPs
-- 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
+-- It's better not to make it an error, in case we want to print it when
+-- debugging
placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))
plus_RDR, bang_RDR, pun_RDR :: RdrName
@@ -1123,8 +1156,8 @@ pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
-checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
- return (L l (fld { hsRecFieldArg = p }))
+checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
+ return (cL l (fld { hsRecFieldArg = p }))
patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail msg loc e = parseErrorSDoc loc err
@@ -1147,15 +1180,15 @@ checkValDef :: SDoc
checkValDef msg _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
- = checkPatBind msg (L (combineLocs lhs sig)
+ = checkPatBind msg (cL (combineLocs lhs sig)
(ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
-checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
+checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
checkFunBind msg strictness ann (getLoc lhs)
- fun is_infix pats (L l grhss)
+ fun is_infix pats (cL l grhss)
Nothing -> checkPatBind msg lhs g }
checkFunBind :: SDoc
@@ -1167,18 +1200,19 @@ checkFunBind :: SDoc
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
+checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
= do ps <- checkPatterns msg 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
- [L match_span (Match { m_ext = noExt
- , m_ctxt = FunRhs { mc_fun = fun
- , mc_fixity = is_infix
- , mc_strictness = strictness }
- , m_pats = ps
- , m_grhss = grhss })])
+ [cL match_span (Match { m_ext = noExt
+ , 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.
@@ -1196,18 +1230,18 @@ checkPatBind :: SDoc
-> LHsExpr GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkPatBind msg lhs (L _ (_,grhss))
+checkPatBind msg lhs (dL->L _ (_,grhss))
= do { lhs <- checkPattern msg lhs
; return ([],PatBind noExt lhs grhss
([],[])) }
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
-checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
+checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
| isUnqual v
, not (isDataOcc (rdrNameOcc v))
= return lrdr
-checkValSigLhs lhs@(L l _)
+checkValSigLhs lhs@(dL->L l _)
= parseErrorSDoc l ((text "Invalid type signature:" <+>
ppr lhs <+> text ":: ...")
$$ text hint)
@@ -1223,9 +1257,10 @@ 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 _ (HsApp _ lhs _)) = looks_like s lhs
+ -- 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 _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
@@ -1259,13 +1294,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
-- not be any OpApps inside the e's
splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
-- 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 noExt bang arg1) : argns)
+splitBang (dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg))
+ | op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns)
where
l' = combineLocs bang arg1
(arg1,argns) = split_bang r_arg []
- split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
- split_bang e es = (e,es)
+ split_bang (dL->L _ (HsApp _ f e)) es = split_bang f (e:es)
+ split_bang e es = (e,es)
splitBang _ = Nothing
-- See Note [isFunLhs vs mergeDataCon]
@@ -1285,47 +1320,47 @@ isFunLhs :: LHsExpr GhcPs
isFunLhs e = go e [] []
where
- go (L loc (HsVar _ (L _ f))) es ann
- | not (isRdrDataCon f) = return (Just (L loc 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)
+ go (dL->L loc (HsVar _ (dL->L _ f))) es ann
+ | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann))
+ go (dL->L _ (HsApp _ f e)) es ann = go f (e:es) ann
+ go (dL->L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
-- Things of the form `!x` are also FunBinds
-- See Note [FunBind vs PatBind]
- go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
- [] ann
+ go (dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang)))
+ (dL->L l (HsVar _ (L _ var))))) [] ann
| bang == bang_RDR
- , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann))
-
- -- For infix function defns, there should be only one infix *function*
- -- (though there may be infix *datacons* involved too). So we don't
- -- need fixity info to figure out which function is being defined.
- -- a `K1` b `op` c `K2` d
- -- must parse as
- -- (a `K1` b) `op` (c `K2` d)
- -- The renamer checks later that the precedences would yield such a parse.
- --
- -- There is a complication to deal with bang patterns.
- --
- -- ToDo: what about this?
- -- x + 1 `op` y = ...
-
- go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
+ , not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann))
+
+ -- For infix function defns, there should be only one infix *function*
+ -- (though there may be infix *datacons* involved too). So we don't
+ -- need fixity info to figure out which function is being defined.
+ -- a `K1` b `op` c `K2` d
+ -- must parse as
+ -- (a `K1` b) `op` (c `K2` d)
+ -- The renamer checks later that the precedences would yield such a parse.
+ --
+ -- There is a complication to deal with bang patterns.
+ --
+ -- ToDo: what about this?
+ -- x + 1 `op` y = ...
+
+ go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann
| 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 (cL loc' 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))
+ = return (Just (cL 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 = L loc (OpApp noExt k
- (L loc' (HsVar noExt (L loc' op))) r)
+ op_app = cL loc (OpApp noExt k
+ (cL loc' (HsVar noExt (cL loc' op))) r)
_ -> return Nothing }
go _ _ _ = return Nothing
@@ -1355,20 +1390,20 @@ pStrictMark
-> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -}
, [AddAnn]
, [Located TyEl] {- remaining TyEl -})
-pStrictMark (L l1 x1 : L l2 x2 : xs)
+pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs)
| Just (strAnnId, str) <- tyElStrictness x1
, TyElUnpackedness (unpkAnns, prag, unpk) <- x2
- = Just ( L (combineSrcSpans l1 l2) (HsSrcBang prag unpk str)
+ = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str)
, unpkAnns ++ [\s -> addAnnotation s strAnnId l1]
, xs )
-pStrictMark (L l x1 : xs)
+pStrictMark ((dL->L l x1) : xs)
| Just (strAnnId, str) <- tyElStrictness x1
- = Just ( L l (HsSrcBang NoSourceText NoSrcUnpack str)
+ = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str)
, [\s -> addAnnotation s strAnnId l]
, xs )
-pStrictMark (L l x1 : xs)
+pStrictMark ((dL->L l x1) : xs)
| TyElUnpackedness (anns, prag, unpk) <- x1
- = Just ( L l (HsSrcBang prag unpk NoSrcStrict)
+ = Just ( cL l (HsSrcBang prag unpk NoSrcStrict)
, anns
, xs )
pStrictMark _ = Nothing
@@ -1380,13 +1415,13 @@ pBangTy
, LHsType GhcPs {- the resulting BangTy -}
, P () {- add annotations -}
, [Located TyEl] {- remaining TyEl -})
-pBangTy lt@(L l1 _) xs =
+pBangTy lt@(dL->L l1 _) xs =
case pStrictMark xs of
Nothing -> (False, lt, pure (), xs)
- Just (L l2 strictMark, anns, xs') ->
+ Just (dL->L l2 strictMark, anns, xs') ->
let bl = combineSrcSpans l1 l2
bt = HsBangTy noExt strictMark lt
- in (True, L bl bt, addAnnsAt bl anns, xs')
+ in (True, cL bl bt, addAnnsAt bl anns, xs')
-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
-- into a type.
@@ -1401,8 +1436,8 @@ pBangTy lt@(L l1 _) xs =
--
-- See Note [Parsing data constructors is hard]
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
-mergeOps (L l1 (TyElOpd t) : xs)
- | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs
+mergeOps ((dL->L l1 (TyElOpd t)) : xs)
+ | (_, t', addAnns, xs') <- pBangTy (cL 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
@@ -1412,14 +1447,14 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [unpk]:
-- handle (NO)UNPACK pragmas
- go k acc ops_acc (L l (TyElUnpackedness (anns, unpkSrc, unpk)):xs) =
+ go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
if not (null acc) && null xs
then do { let a = ops_acc (mergeAcc acc)
strictMark = HsSrcBang unpkSrc unpk NoSrcStrict
bl = combineSrcSpans l (getLoc a)
bt = HsBangTy noExt strictMark a
; addAnnsAt bl anns
- ; return (L bl bt) }
+ ; return (cL bl bt) }
else parseErrorSDoc l unpkError
where
unpkSDoc = case unpkSrc of
@@ -1434,57 +1469,63 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [doc]:
-- we do not expect to encounter any docs
- go _ _ _ (L l (TyElDocPrev _):_) =
+ go _ _ _ ((dL->L l (TyElDocPrev _)):_) =
failOpDocPrev l
-- to improve error messages, we do a bit of guesswork to determine if the
-- user intended a '!' or a '~' as a strictness annotation
- go k acc ops_acc (L l x : xs)
+ go k acc ops_acc ((dL->L l x) : xs)
| Just (_, str) <- tyElStrictness x
, let guess [] = True
- guess (L _ (TyElOpd _):_) = False
- guess (L _ (TyElOpr _):_) = True
- guess (L _ (TyElTilde):_) = True
- guess (L _ (TyElBang):_) = True
- guess (L _ (TyElUnpackedness _):_) = True
- guess (L _ (TyElDocPrev _):xs') = guess xs'
+ guess ((dL->L _ (TyElOpd _)):_) = False
+ guess ((dL->L _ (TyElOpr _)):_) = True
+ guess ((dL->L _ (TyElTilde)):_) = True
+ guess ((dL->L _ (TyElBang)):_) = True
+ guess ((dL->L _ (TyElUnpackedness _)):_) = True
+ guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs'
+ guess _ = panic "mergeOps.go.guess: Impossible Match"
+ -- due to #15884
in guess xs
= if not (null acc) && (k > 1 || length acc > 1)
- then failOpStrictnessCompound (L l str) (ops_acc (mergeAcc acc))
- else failOpStrictnessPosition (L l str)
+ then failOpStrictnessCompound (cL l str) (ops_acc (mergeAcc acc))
+ else failOpStrictnessPosition (cL l str)
-- 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 (L l (TyElOpr op):xs) =
+ go k acc ops_acc ((dL->L l (TyElOpr op)):xs) =
if null acc || null (filter isTyElOpd xs)
- then failOpFewArgs (L l op)
+ then failOpFewArgs (cL l op)
else do { let a = mergeAcc acc
- ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
+ ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc a)) xs }
where
- isTyElOpd (L _ (TyElOpd _)) = True
+ isTyElOpd (dL->L _ (TyElOpd _)) = True
isTyElOpd _ = False
-- clause [opr.1]: interpret 'TyElTilde' as an operator
- go k acc ops_acc (L l TyElTilde:xs) =
+ go k acc ops_acc ((dL->L l TyElTilde):xs) =
let op = eqTyCon_RDR
- in go k acc ops_acc (L l (TyElOpr op):xs)
+ in go k acc ops_acc (cL l (TyElOpr op):xs)
-- clause [opr.2]: interpret 'TyElBang' as an operator
- go k acc ops_acc (L l TyElBang:xs) =
+ go k acc ops_acc ((dL->L l TyElBang):xs) =
let op = mkUnqual tcClsName (fsLit "!")
- in go k acc ops_acc (L l (TyElOpr op):xs)
+ in go k acc ops_acc (cL l (TyElOpr op):xs)
-- clause [opd]:
-- whenever an operand is encountered, it is added to the accumulator
- go k acc ops_acc (L l (TyElOpd a):xs) = go k (L l a:acc) ops_acc xs
+ go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (cL l a:acc) ops_acc xs
-- clause [end]:
-- See Note [Non-empty 'acc' in mergeOps clause [end]]
go _ acc ops_acc [] =
return (ops_acc (mergeAcc acc))
+ go _ _ _ _ = panic "mergeOps.go: Impossible Match"
+ -- due to #15884
+
+
mergeAcc [] = panic "mergeOps.mergeAcc: empty input"
mergeAcc (x:xs) = mkHsAppTys x xs
@@ -1542,12 +1583,12 @@ 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 (L l (TyElOpd t):xs)
- | (True, t', addAnns, xs') <- pBangTy (L l t) xs
+pInfixSide ((dL->L l (TyElOpd t)):xs)
+ | (True, t', addAnns, xs') <- pBangTy (cL l t) xs
= Just (t', addAnns, xs')
-pInfixSide (L l1 (TyElOpd t1):xs1) = go [L l1 t1] xs1
+pInfixSide ((dL->L l1 (TyElOpd t1)):xs1) = go [cL l1 t1] xs1
where
- go acc (L l (TyElOpd t):xs) = go (L l t:acc) xs
+ go acc ((dL->L l (TyElOpd t)):xs) = go (cL l t:acc) xs
go acc xs = Just (mergeAcc acc, pure (), xs)
mergeAcc [] = panic "pInfixSide.mergeAcc: empty input"
mergeAcc (x:xs) = mkHsAppTys x xs
@@ -1556,8 +1597,8 @@ pInfixSide _ = Nothing
pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev = go Nothing
where
- go mTrailingDoc (L l (TyElDocPrev doc):xs) =
- go (mTrailingDoc `mplus` Just (L l doc)) xs
+ go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) =
+ go (mTrailingDoc `mplus` Just (cL l doc)) xs
go mTrailingDoc xs = (mTrailingDoc, xs)
orErr :: Maybe a -> b -> Either b a
@@ -1655,7 +1696,7 @@ mergeDataCon all_xs =
-- A -- ^ Comment on A
-- B -- ^ Comment on B (singleDoc == False)
singleDoc = isJust mTrailingDoc &&
- null [ () | L _ (TyElDocPrev _) <- all_xs' ]
+ null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ]
-- The result of merging the list of reversed TyEl into a
-- data constructor, along with [AddAnn].
@@ -1677,36 +1718,36 @@ mergeDataCon all_xs =
trailingFieldDoc | singleDoc = Nothing
| otherwise = mTrailingDoc
- goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
+ goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) }
- goFirst (L l (TyElOpd (HsRecTy _ fields)):xs)
+ goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs)
| (mConDoc, xs') <- pDocPrev xs
- , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs'
+ , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs'
= do { data_con <- tyConToDataCon l' tc
; let mDoc = mTrailingDoc `mplus` mConDoc
- ; return (pure (), (data_con, RecCon (L l fields), mDoc)) }
- goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
+ ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) }
+ goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
= return ( pure ()
- , ( L l (getRdrName (tupleDataCon Boxed (length ts)))
+ , ( cL l (getRdrName (tupleDataCon Boxed (length ts)))
, PrefixCon ts
, mTrailingDoc ) )
- goFirst (L l (TyElOpd t):xs)
- | (_, t', addAnns, xs') <- pBangTy (L l t) xs
+ goFirst ((dL->L l (TyElOpd t)):xs)
+ | (_, t', addAnns, xs') <- pBangTy (cL l t) xs
= go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs'
goFirst xs =
go (pure ()) mTrailingDoc [] xs
- go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
+ go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) }
- 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
+ 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
, t'' <- mkLHsDocTyMaybe t' mLastDoc
= go (addAnns >> addAnns') Nothing (t'':ts) xs'
- go _ _ _ (L _ (TyElOpr _):_) =
+ go _ _ _ ((dL->L _ (TyElOpr _)):_) =
-- Encountered an operator: backtrack to the beginning and attempt
-- to parse as an infix definition.
goInfix
@@ -1723,7 +1764,7 @@ mergeDataCon all_xs =
; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr
; let (mOpDoc, xs2) = pDocPrev xs1
; (op, xs3) <- case xs2 of
- L l (TyElOpr op) : xs3 ->
+ (dL->L l (TyElOpr op)) : xs3 ->
do { data_con <- tyConToDataCon l op
; return (data_con, xs3) }
_ -> Left malformedErr
@@ -1764,7 +1805,7 @@ checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
checkCommand lc = locMap checkCmd lc
locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
-locMap f (L l a) = f l a >>= (\b -> return $ L l b)
+locMap f (dL->L l a) = f l a >>= (\b -> return $ cL l b)
checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
checkCmd _ (HsArrApp _ e1 e2 haat b) =
@@ -1785,16 +1826,16 @@ checkCmd _ (HsIf _ cf ep et ee) = do
return $ HsCmdIf noExt cf ep pt pe
checkCmd _ (HsLet _ lb e) =
checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
-checkCmd _ (HsDo _ DoExpr (L l stmts)) =
+checkCmd _ (HsDo _ DoExpr (dL->L l stmts)) =
mapM checkCmdLStmt stmts >>=
- (\ss -> return $ HsCmdDo noExt (L l ss) )
+ (\ss -> return $ HsCmdDo noExt (cL l ss) )
checkCmd _ (OpApp _ eLeft op eRight) = do
-- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
c1 <- checkCommand eLeft
c2 <- checkCommand eRight
- let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
- arg2 = L (getLoc c2) $ HsCmdTop noExt c2
+ let arg1 = cL (getLoc c1) $ HsCmdTop noExt c1
+ arg2 = cL (getLoc c2) $ HsCmdTop noExt c2
return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
checkCmd l e = cmdFail l e
@@ -1818,9 +1859,10 @@ checkCmdStmt l stmt = cmdStmtFail l stmt
checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsCmd GhcPs))
-checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
+checkCmdMatchGroup mg@(MG { mg_alts = (dL->L l ms) }) = do
ms' <- mapM (locMap $ const convert) ms
- return $ mg { mg_ext = noExt, mg_alts = L l ms' }
+ return $ mg { mg_ext = noExt
+ , mg_alts = cL l ms' }
where convert match@(Match { m_grhss = grhss }) = do
grhss' <- checkCmdGRHSs grhss
return $ match { m_ext = noExt, m_grhss = grhss'}
@@ -1858,7 +1900,7 @@ checkPrecP
:: Located (SourceText,Int) -- ^ precedence
-> Located (OrdList (Located RdrName)) -- ^ operators
-> P ()
-checkPrecP (L l (_,i)) (L _ ol)
+checkPrecP (dL->L l (_,i)) (dL->L _ ol)
| 0 <= i, i <= maxPrecedence = pure ()
| all specialOp ol = pure ()
| otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
@@ -1872,10 +1914,10 @@ mkRecConstrOrUpdate
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
-> P (HsExpr GhcPs)
-mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
| isRdrDataCon c
- = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
-mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
+ = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd))
+mkRecConstrOrUpdate exp@(dL->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))
@@ -1891,13 +1933,16 @@ mkRdrRecordCon con flds
mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
-mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
+mk_rec_fields fs True = HsRecFields { rec_flds = fs
+ , rec_dotdot = Just (length fs) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
-mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
+mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun)
= HsRecField (L loc (Unambiguous noExt rdr)) arg pun
-mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
+mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc _)) _ _)
= panic "mk_rec_upd_field"
+mk_rec_upd_field (HsRecField _ _ _)
+ = panic "mk_rec_upd_field: Impossible Match" -- due to #15884
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
@@ -1927,12 +1972,12 @@ mkImport :: Located CCallConv
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
- case cconv of
- L _ CCallConv -> mkCImport
- L _ CApiConv -> mkCImport
- L _ StdCallConv -> mkCImport
- L _ PrimCallConv -> mkOtherImport
- L _ JavaScriptCallConv -> mkOtherImport
+ case unLoc cconv of
+ CCallConv -> mkCImport
+ CApiConv -> mkCImport
+ StdCallConv -> mkCImport
+ PrimCallConv -> mkOtherImport
+ JavaScriptCallConv -> mkOtherImport
where
-- Parse a C-like entity string of the following form:
-- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
@@ -1940,7 +1985,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 (L loc esrc) of
+ case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of
Nothing -> parseErrorSDoc loc (text "Malformed entity string")
Just importSpec -> returnSpec importSpec
@@ -1952,7 +1997,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 (L loc esrc)
+ importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc)
returnSpec spec = return $ ForD noExt $ ForeignImport
{ fd_i_ext = noExt
@@ -1997,20 +2042,21 @@ parseCImport cconv safety nm str sourceText =
mk h n = CImport cconv safety h n sourceText
- hdr_char c = not (isSpace c) -- header files are filenames, which can contain
- -- pretty much any char (depending on the platform),
- -- so just accept any non-space character
+ hdr_char c = not (isSpace c)
+ -- header files are filenames, which can contain
+ -- pretty much any char (depending on the platform),
+ -- so just accept any non-space character
id_first_char c = isAlpha c || c == '_'
id_char c = isAlphaNum c || c == '_'
cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
- +++ (do isFun <- case cconv of
- L _ CApiConv ->
+ +++ (do isFun <- case unLoc cconv of
+ CApiConv ->
option True
(do token "value"
skipSpaces
return False)
- _ -> return True
+ _ -> return True
cid' <- cid
return (CFunction (StaticTarget NoSourceText cid'
Nothing isFun)))
@@ -2026,11 +2072,11 @@ parseCImport cconv safety nm str sourceText =
mkExport :: Located CCallConv
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
-mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
+mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty)
= return $ ForD noExt $
ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty
- , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
- (L le esrc) }
+ , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv))
+ (cL le esrc) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
@@ -2057,16 +2103,16 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName)
| ImpExpQcWildcard
mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
-mkModuleImpExp (L l specname) subs =
+mkModuleImpExp (dL->L l specname) subs =
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
- -> return $ IEVar noExt (L l (ieNameFromSpec specname))
- | otherwise -> IEThingAbs noExt . L l <$> nameT
- ImpExpAll -> IEThingAll noExt . L l <$> nameT
- ImpExpList xs ->
- (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
- <$> nameT
+ -> return $ IEVar noExt (cL l (ieNameFromSpec specname))
+ | otherwise -> IEThingAbs noExt . cL l <$> nameT
+ ImpExpAll -> IEThingAll noExt . cL l <$> nameT
+ ImpExpList xs ->
+ (\newName -> IEThingWith noExt (cL l newName)
+ NoIEWildcard (wrapped xs) []) <$> nameT
ImpExpAllWith xs ->
do allowed <- extension patternSynonymsEnabled
if allowed
@@ -2076,7 +2122,8 @@ mkModuleImpExp (L l specname) subs =
(findIndex isImpExpQcWildcard withs)
ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
in (\newName
- -> IEThingWith noExt (L l newName) pos ies []) <$> nameT
+ -> IEThingWith noExt (cL l newName) pos ies [])
+ <$> nameT
else parseErrorSDoc l
(text "Illegal export form (use PatternSynonyms to enable)")
where
@@ -2087,8 +2134,9 @@ mkModuleImpExp (L l specname) subs =
(text "Expecting a type constructor but found a variable,"
<+> quotes (ppr name) <> text "."
$$ if isSymOcc $ rdrNameOcc name
- then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
- <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
+ then text "If" <+> quotes (ppr name)
+ <+> text "is a type constructor"
+ <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
else empty)
else return $ ieNameFromSpec specname
@@ -2100,7 +2148,7 @@ mkModuleImpExp (L l specname) subs =
ieNameFromSpec (ImpExpQcType ln) = IEType ln
ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
- wrapped = map (\(L l x) -> L l (ieNameFromSpec x))
+ wrapped = map (onHasSrcSpan ieNameFromSpec)
mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName)
@@ -2112,8 +2160,8 @@ mkTypeImpExp name =
(text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
-checkImportSpec ie@(L _ specs) =
- case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
+checkImportSpec ie@(dL->L _ specs) =
+ case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
(l:_) -> importSpecError l
where
@@ -2125,7 +2173,7 @@ checkImportSpec ie@(L _ specs) =
-- In the correct order
mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
-mkImpExpSubSpec [L _ ImpExpQcWildcard] =
+mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] =
return ([], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
@@ -2160,7 +2208,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg
$$ text " including the definition module, you must qualify it."
failOpFewArgs :: Located RdrName -> P a
-failOpFewArgs (L loc op) =
+failOpFewArgs (dL->L loc op) =
do { star_is_type <- extension starIsTypeEnabled
; let msg = too_few $$ starInfo star_is_type op
; parseErrorSDoc loc msg }
@@ -2173,14 +2221,14 @@ failOpDocPrev loc = parseErrorSDoc loc msg
msg = text "Unexpected documentation comment."
failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a
-failOpStrictnessCompound (L _ str) (L loc ty) = parseErrorSDoc loc msg
+failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = parseErrorSDoc loc msg
where
msg = text "Strictness annotation applied to a compound type." $$
text "Did you mean to add parentheses?" $$
nest 2 (ppr str <> parens (ppr ty))
failOpStrictnessPosition :: Located SrcStrictness -> P a
-failOpStrictnessPosition (L loc _) = parseErrorSDoc loc msg
+failOpStrictnessPosition (dL->L loc _) = parseErrorSDoc loc msg
where
msg = text "Strictness annotation cannot appear in this position."
@@ -2210,24 +2258,26 @@ mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
-- Sum
mkSumOrTuple Unboxed _ (Sum alt arity e) =
return (ExplicitSum noExt alt arity e)
-mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
- parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
+mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) =
+ parseErrorSDoc l (hang (text "Boxed sums not supported:") 2
+ (ppr_boxed_sum alt arity e))
where
ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
ppr_boxed_sum alt arity e =
- text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
+ text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)
+ <+> text ")"
ppr_bars n = hsep (replicate n (Outputable.char '|'))
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y =
let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
- in L loc (mkHsOpTy x op y)
+ in cL loc (mkHsOpTy x op y)
mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy t doc =
let loc = getLoc t `combineSrcSpans` getLoc doc
- in L loc (HsDocTy noExt t doc)
+ in cL loc (HsDocTy noExt t doc)
mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t)
View Lorry Controller Status