summaryrefslogtreecommitdiff
path: root/compiler/GHC/Parser.y
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2021-02-21 21:23:40 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-03-20 07:48:38 -0400
commit95275a5f25a2e70b71240d4756109180486af1b1 (patch)
treeeb4801bb0e00098b8b9d513479de4fbbd779ddac /compiler/GHC/Parser.y
parentf940fd466a86c2f8e93237b36835797be3f3c898 (diff)
downloadhaskell-95275a5f25a2e70b71240d4756109180486af1b1.tar.gz
GHC Exactprint main commit
Metric Increase: T10370 parsing001 Updates haddock submodule
Diffstat (limited to 'compiler/GHC/Parser.y')
-rw-r--r--compiler/GHC/Parser.y2638
1 files changed, 1418 insertions, 1220 deletions
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index c17444ddcb..f786940591 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -62,6 +62,8 @@ import GHC.Data.Maybe ( orElse )
import GHC.Utils.Outputable
import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
+import GHC.Utils.Panic
+import GHC.Prelude
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString)
@@ -85,6 +87,8 @@ import GHC.Parser.Errors
import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,
unboxedUnitTyCon, unboxedUnitDataCon,
listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR)
+
+import qualified Data.Semigroup as Semi
}
%expect 0 -- shift/reduce conflicts
@@ -497,7 +501,7 @@ Ambiguity:
{- Note [Parser API Annotations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A lot of the productions are now cluttered with calls to
-aa,am,ams,amms etc.
+aa,am,acs,acsA etc.
These are helper functions to make sure that the locations of the
various keywords such as do / let / in are captured for use by tools
@@ -511,10 +515,6 @@ See
https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations
for some background.
-If you modify the parser and want to ensure that the API annotations are processed
-correctly, see the README in (REPO)/utils/check-api-annotations for details on
-how to set up a test using the check-api-annotations utility, and interpret the
-output it generates.
-}
{- Note [Parsing lists]
@@ -747,15 +747,15 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) }
-----------------------------------------------------------------------------
-- Identifiers; one of the entry points
-identifier :: { Located RdrName }
+identifier :: { LocatedN RdrName }
: qvar { $1 }
| qcon { $1 }
| qvarop { $1 }
| qconop { $1 }
- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- [mop $1,mu AnnRarrow $2,mcp $3] }
- | '->' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- [mu AnnRarrow $1] }
+ | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
+ (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
+ (NameAnnRArrow (glAA $1) []) }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -802,7 +802,7 @@ litpkgname_segment :: { Located FastString }
-- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.
-- See Note [Minus tokens] in GHC.Parser.Lexer
-HYPHEN :: { [AddAnn] }
+HYPHEN :: { [AddApiAnn] }
: '-' { [mj AnnMinus $1 ] }
| PREFIX_MINUS { [mj AnnMinus $1 ] }
| VARSYM {% if (getVARSYM $1 == fsLit "-")
@@ -846,12 +846,12 @@ unitdecl :: { LHsUnitDecl PackageName }
NotBoot -> HsSrcFile
IsBoot -> HsBootFile)
$3
- (Just $ sL1 $1 (HsModule (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }
+ (Just $ sL1 $1 (HsModule noAnn (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }
| 'signature' modid maybemodwarning maybeexports 'where' body
{ sL1 $1 $ DeclD
HsigFile
$2
- (Just $ sL1 $1 (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }
+ (Just $ sL1 $1 (HsModule noAnn (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }
| 'module' maybe_src modid
{ sL1 $1 $ DeclD (case snd $2 of
NotBoot -> HsSrcFile
@@ -880,23 +880,23 @@ unitdecl :: { LHsUnitDecl PackageName }
signature :: { Located HsModule }
: 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)
- (snd $ sndOf3 $6) $3 Nothing)
- )
- ([mj AnnSignature $1, mj AnnWhere $5] ++ fstOf3 $6) }
+ acs (\cs-> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+ (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)
+ (snd $ sndOf3 $6) $3 Nothing))
+ ) }
module :: { Located HsModule }
: 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)
+ acsFinal (\cs -> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+ (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)
(snd $ sndOf3 $6) $3 Nothing)
- )
- ([mj AnnModule $1, mj AnnWhere $5] ++ fstOf3 $6) }
+ )) }
| body2
{% fileSrcSpan >>= \ loc ->
- ams (L loc (HsModule (thdOf3 $1) Nothing Nothing
- (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))
- (fstOf3 $1) }
+ acsFinal (\cs -> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)
+ (thdOf3 $1) Nothing Nothing
+ (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))) }
missing_module_keyword :: { () }
: {- empty -} {% pushModuleContext }
@@ -904,38 +904,39 @@ missing_module_keyword :: { () }
implicit_top :: { () }
: {- empty -} {% pushModuleContext }
-maybemodwarning :: { Maybe (Located WarningTxt) }
+maybemodwarning :: { Maybe (LocatedP WarningTxt) }
: '{-# DEPRECATED' strings '#-}'
- {% ajs (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))
- (mo $1:mc $3: (fst $ unLoc $2)) }
+ {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (snd $ unLoc $2))
+ (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }
| '{-# WARNING' strings '#-}'
- {% ajs (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2))
- (mo $1:mc $3 : (fst $ unLoc $2)) }
+ {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (snd $ unLoc $2))
+ (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))}
| {- empty -} { Nothing }
-body :: { ([AddAnn]
+body :: { (AnnList
,([LImportDecl GhcPs], [LHsDecl GhcPs])
,LayoutInfo) }
- : '{' top '}' { (moc $1:mcc $3:(fst $2)
+ : '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)
, snd $2, ExplicitBraces) }
- | vocurly top close { (fst $2, snd $2, VirtualBraces (getVOCURLY $1)) }
+ | vocurly top close { (AnnList Nothing Nothing Nothing [] (fst $2)
+ , snd $2, VirtualBraces (getVOCURLY $1)) }
-body2 :: { ([AddAnn]
+body2 :: { (AnnList
,([LImportDecl GhcPs], [LHsDecl GhcPs])
,LayoutInfo) }
- : '{' top '}' { (moc $1:mcc $3
- :(fst $2), snd $2, ExplicitBraces) }
- | missing_module_keyword top close { ([],snd $2, VirtualBraces leftmostColumn) }
+ : '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)
+ , snd $2, ExplicitBraces) }
+ | missing_module_keyword top close { (AnnList Nothing Nothing Nothing [] [], snd $2, VirtualBraces leftmostColumn) }
-top :: { ([AddAnn]
+top :: { ([TrailingAnn]
,([LImportDecl GhcPs], [LHsDecl GhcPs])) }
: semis top1 { ($1, $2) }
top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
- : importdecls_semi topdecls_semi { (reverse $1, cvTopDecls $2) }
- | importdecls_semi topdecls { (reverse $1, cvTopDecls $2) }
- | importdecls { (reverse $1, []) }
+ : importdecls_semi topdecls_cs_semi { (reverse $1, cvTopDecls $2) }
+ | importdecls_semi topdecls_cs { (reverse $1, cvTopDecls $2) }
+ | importdecls { (reverse $1, []) }
-----------------------------------------------------------------------------
-- Module declaration & imports only
@@ -943,15 +944,17 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
header :: { Located HsModule }
: 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing
- )) [mj AnnModule $1,mj AnnWhere $5] }
+ acs (\cs -> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)
+ NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing
+ ))) }
| 'signature' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing
- )) [mj AnnModule $1,mj AnnWhere $5] }
+ acs (\cs -> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)
+ NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing
+ ))) }
| header_body2
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule NoLayoutInfo Nothing Nothing $1 [] Nothing
+ return (L loc (HsModule noAnn NoLayoutInfo Nothing Nothing $1 [] Nothing
Nothing)) }
header_body :: { [LImportDecl GhcPs] }
@@ -972,73 +975,80 @@ header_top_importdecls :: { [LImportDecl GhcPs] }
-----------------------------------------------------------------------------
-- The Export List
-maybeexports :: { (Maybe (Located [LIE GhcPs])) }
- : '(' exportlist ')' {% amsL (comb2 $1 $>) ([mop $1,mcp $3] ++ (fst $2)) >>
- return (Just (sLL $1 $> (fromOL $ snd $2))) }
+maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) }
+ : '(' exportlist ')' {% fmap Just $ amsrl (sLL $1 $> (fromOL $ snd $2))
+ (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) }
| {- empty -} { Nothing }
-exportlist :: { ([AddAnn], OrdList (LIE GhcPs)) }
+exportlist :: { ([AddApiAnn], OrdList (LIE GhcPs)) }
: exportlist1 { ([], $1) }
| {- empty -} { ([], nilOL) }
-- trailing comma:
- | exportlist1 ',' { ([mj AnnComma $2], $1) }
+ | exportlist1 ',' {% case $1 of
+ SnocOL hs t -> do
+ t' <- addTrailingCommaA t (gl $2)
+ return ([], snocOL hs t')}
| ',' { ([mj AnnComma $1], nilOL) }
exportlist1 :: { OrdList (LIE GhcPs) }
: exportlist1 ',' export
- {% (addAnnotation (oll $1) AnnComma (gl $2) ) >>
- return ($1 `appOL` $3) }
+ {% let ls = $1
+ in if isNilOL ls
+ then return (ls `appOL` $3)
+ else case ls of
+ SnocOL hs t -> do
+ t' <- addTrailingCommaA t (gl $2)
+ return (snocOL hs t' `appOL` $3)}
| export { $1 }
-- No longer allow things like [] and (,,,) to be exported
-- They are built in syntax, always available
export :: { OrdList (LIE GhcPs) }
- : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2)
- >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
- | 'module' modid {% amsu (sLL $1 $> (IEModuleContents noExtField $2))
- [mj AnnModule $1] }
- | 'pattern' qcon {% amsu (sLL $1 $> (IEVar noExtField (sLL $1 $> (IEPattern $2))))
- [mj AnnPattern $1] }
-
-export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
+ : qcname_ext export_subspec {% mkModuleImpExp (fst $ unLoc $2) $1 (snd $ unLoc $2)
+ >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc $1) $> ie)) }
+ | 'module' modid {% fmap (unitOL . reLocA) (acs (\cs -> sLL $1 $> (IEModuleContents (ApiAnn (glR $1) [mj AnnModule $1] cs) $2))) }
+ | 'pattern' qcon { unitOL (reLocA (sLL $1 (reLocN $>)
+ (IEVar noExtField (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2))))) }
+
+export_subspec :: { Located ([AddApiAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
| '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2))
>>= \(as,ie) -> return $ sLL $1 $>
(as ++ [mop $1,mcp $3] ++ fst $2, ie) }
-
-qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }
+qcnames :: { ([AddApiAnn], [LocatedA ImpExpQcSpec]) }
: {- empty -} { ([],[]) }
| qcnames1 { $1 }
-qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list
- : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of
- l@(L _ ImpExpQcWildcard) ->
- return ([mj AnnComma $2, mj AnnDotdot l]
- ,(snd (unLoc $3) : snd $1))
- l -> (ams (head (snd $1)) [mj AnnComma $2] >>
- return (fst $1 ++ fst (unLoc $3),
- snd (unLoc $3) : snd $1)) }
-
+qcnames1 :: { ([AddApiAnn], [LocatedA ImpExpQcSpec]) } -- A reversed list
+ : qcnames1 ',' qcname_ext_w_wildcard {% case (snd $1) of
+ (l@(L la ImpExpQcWildcard):t) ->
+ do { l' <- addTrailingCommaA l (gl $2)
+ ; return ([mj AnnDotdot (reLoc l),
+ mj AnnComma $2]
+ ,(snd (unLoc $3) : l' : t)) }
+ (l:t) ->
+ do { l' <- addTrailingCommaA l (gl $2)
+ ; return (fst $1 ++ fst (unLoc $3)
+ , snd (unLoc $3) : l' : t)} }
-- Annotations re-added in mkImpExpSubSpec
| qcname_ext_w_wildcard { (fst (unLoc $1),[snd (unLoc $1)]) }
-- Variable, data constructor or wildcard
-- or tagged type constructor
-qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) }
- : qcname_ext { sL1 $1 ([],$1) }
- | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) }
+qcname_ext_w_wildcard :: { Located ([AddApiAnn], LocatedA ImpExpQcSpec) }
+ : qcname_ext { sL1A $1 ([],$1) }
+ | '..' { sL1 $1 ([mj AnnDotdot $1], sL1a $1 ImpExpQcWildcard) }
-qcname_ext :: { Located ImpExpQcSpec }
- : qcname { sL1 $1 (ImpExpQcName $1) }
+qcname_ext :: { LocatedA ImpExpQcSpec }
+ : qcname { reLocA $ sL1N $1 (ImpExpQcName $1) }
| 'type' oqtycon {% do { n <- mkTypeImpExp $2
- ; ams (sLL $1 $> (ImpExpQcType n))
- [mj AnnType $1] } }
+ ; return $ sLLa $1 (reLocN $>) (ImpExpQcType (glAA $1) n) }}
-qcname :: { Located RdrName } -- Variable or type constructor
+qcname :: { LocatedN RdrName } -- Variable or type constructor
: qvar { $1 } -- Things which look like functions
-- Note: This includes record selectors but
-- also (-.->), see #11432
@@ -1051,13 +1061,13 @@ qcname :: { Located RdrName } -- Variable or type constructor
-- top handles the fact that these may be optional.
-- One or more semicolons
-semis1 :: { [AddAnn] }
-semis1 : semis1 ';' { mj AnnSemi $2 : $1 }
- | ';' { [mj AnnSemi $1] }
+semis1 :: { [TrailingAnn] }
+semis1 : semis1 ';' { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) }
+ | ';' { msemi $1 }
-- Zero or more semicolons
-semis :: { [AddAnn] }
-semis : semis ';' { mj AnnSemi $2 : $1 }
+semis :: { [TrailingAnn] }
+semis : semis ';' { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) }
| {- empty -} { [] }
-- No trailing semicolons, non-empty
@@ -1070,7 +1080,8 @@ importdecls
importdecls_semi :: { [LImportDecl GhcPs] }
importdecls_semi
: importdecls_semi importdecl semis1
- {% ams $2 $3 >> return ($2 : $1) }
+ {% do { i <- amsA $2 $3
+ ; return (i : $1)} }
| {- empty -} { [] }
importdecl :: { LImportDecl GhcPs }
@@ -1079,60 +1090,67 @@ importdecl :: { LImportDecl GhcPs }
; let { ; mPreQual = unLoc $4
; mPostQual = unLoc $7 }
; checkImportDecl mPreQual mPostQual
- ; ams (L (comb5 $1 $6 $7 (snd $8) $9) $
- ImportDecl { ideclExt = noExtField
+ ; let anns
+ = ApiAnnImportDecl
+ { importDeclAnnImport = glAA $1
+ , importDeclAnnPragma = fst $ fst $2
+ , importDeclAnnSafe = fst $3
+ , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual
+ , importDeclAnnPackage = fst $5
+ , importDeclAnnAs = fst $8
+ }
+ ; fmap reLocA $ acs (\cs -> L (comb5 $1 $6 $7 (snd $8) $9) $
+ ImportDecl { ideclExt = ApiAnn (glR $1) anns cs
, ideclSourceSrc = snd $ fst $2
, ideclName = $6, ideclPkgQual = snd $5
, ideclSource = snd $2, ideclSafe = snd $3
- , ideclQualified = importDeclQualifiedStyle mPreQual mPostQual
+ , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual
, ideclImplicit = False
, ideclAs = unLoc (snd $8)
, ideclHiding = unLoc $9 })
- (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList mPreQual)
- ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList mPostQual) ++ fst $8)
}
}
-maybe_src :: { (([AddAnn],SourceText),IsBootInterface) }
- : '{-# SOURCE' '#-}' { (([mo $1,mc $2],getSOURCE_PRAGs $1)
+maybe_src :: { ((Maybe (AnnAnchor,AnnAnchor),SourceText),IsBootInterface) }
+ : '{-# SOURCE' '#-}' { ((Just (glAA $1,glAA $2),getSOURCE_PRAGs $1)
, IsBoot) }
- | {- empty -} { (([],NoSourceText),NotBoot) }
+ | {- empty -} { ((Nothing,NoSourceText),NotBoot) }
-maybe_safe :: { ([AddAnn],Bool) }
- : 'safe' { ([mj AnnSafe $1],True) }
- | {- empty -} { ([],False) }
+maybe_safe :: { (Maybe AnnAnchor,Bool) }
+ : 'safe' { (Just (glAA $1),True) }
+ | {- empty -} { (Nothing, False) }
-maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
+maybe_pkg :: { (Maybe AnnAnchor,Maybe StringLiteral) }
: STRING {% do { let { pkgFS = getSTRING $1 }
; unless (looksLikePackageName (unpackFS pkgFS)) $
addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc $1)
- ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
- | {- empty -} { ([],Nothing) }
+ ; return (Just (glAA $1), Just (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }
+ | {- empty -} { (Nothing,Nothing) }
-optqualified :: { Located (Maybe (Located Token)) }
- : 'qualified' { sL1 $1 (Just $1) }
+optqualified :: { Located (Maybe AnnAnchor) }
+ : 'qualified' { sL1 $1 (Just (glAA $1)) }
| {- empty -} { noLoc Nothing }
-maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) }
- : 'as' modid { ([mj AnnAs $1]
+maybeas :: { (Maybe AnnAnchor,Located (Maybe (Located ModuleName))) }
+ : 'as' modid { (Just (glAA $1)
,sLL $1 $> (Just $2)) }
- | {- empty -} { ([],noLoc Nothing) }
+ | {- empty -} { (Nothing,noLoc Nothing) }
-maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) }
+maybeimpspec :: { Located (Maybe (Bool, LocatedL [LIE GhcPs])) }
: impspec {% let (b, ie) = unLoc $1 in
checkImportSpec ie
>>= \checkedIe ->
return (L (gl $1) (Just (b, checkedIe))) }
| {- empty -} { noLoc Nothing }
-impspec :: { Located (Bool, Located [LIE GhcPs]) }
- : '(' exportlist ')' {% ams (sLL $1 $> (False,
- sLL $1 $> $ fromOL (snd $2)))
- ([mop $1,mcp $3] ++ (fst $2)) }
- | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True,
- sLL $1 $> $ fromOL (snd $3)))
- ([mj AnnHiding $1,mop $2,mcp $4] ++ (fst $3)) }
+impspec :: { Located (Bool, LocatedL [LIE GhcPs]) }
+ : '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)
+ (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) [])
+ ; return $ sLL $1 $> (False, es)} }
+ | 'hiding' '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3)
+ (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])
+ ; return $ sLL $1 $> (True, es)} }
-----------------------------------------------------------------------------
-- Fixity Declarations
@@ -1147,10 +1165,12 @@ infix :: { Located FixityDirection }
| 'infixl' { sL1 $1 InfixL }
| 'infixr' { sL1 $1 InfixR }
-ops :: { Located (OrdList (Located RdrName)) }
- : ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
- return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))}
- | op { sL1 $1 (unitOL $1) }
+ops :: { Located (OrdList (LocatedN RdrName)) }
+ : ops ',' op {% case (unLoc $1) of
+ SnocOL hs t -> do
+ t' <- addTrailingCommaN t (gl $2)
+ return (sLL $1 (reLocN $>) (snocOL hs t' `appOL` unitOL $3)) }
+ | op { sL1N $1 (unitOL $1) }
-----------------------------------------------------------------------------
-- Top-Level Declarations
@@ -1161,27 +1181,39 @@ topdecls :: { OrdList (LHsDecl GhcPs) }
-- May have trailing semicolons, can be empty
topdecls_semi :: { OrdList (LHsDecl GhcPs) }
- : topdecls_semi topdecl semis1 {% ams $2 $3 >> return ($1 `snocOL` $2) }
+ : topdecls_semi topdecl semis1 {% do { t <- amsA $2 $3
+ ; return ($1 `snocOL` t) }}
| {- empty -} { nilOL }
+
+-----------------------------------------------------------------------------
+-- Each topdecl accumulates prior comments
+-- No trailing semicolons, non-empty
+topdecls_cs :: { OrdList (LHsDecl GhcPs) }
+ : topdecls_cs_semi topdecl_cs { $1 `snocOL` $2 }
+
+-- May have trailing semicolons, can be empty
+topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) }
+ : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsA $2 $3
+ ; return ($1 `snocOL` t) }}
+ | {- empty -} { nilOL }
+topdecl_cs :: { LHsDecl GhcPs }
+topdecl_cs : topdecl {% commentsPA $1 }
+
+-----------------------------------------------------------------------------
topdecl :: { LHsDecl GhcPs }
: cl_decl { sL1 $1 (TyClD noExtField (unLoc $1)) }
| ty_decl { sL1 $1 (TyClD noExtField (unLoc $1)) }
| standalone_kind_sig { sL1 $1 (KindSigD noExtField (unLoc $1)) }
| inst_decl { sL1 $1 (InstD noExtField (unLoc $1)) }
- | stand_alone_deriving { sLL $1 $> (DerivD noExtField (unLoc $1)) }
+ | stand_alone_deriving { sL1 $1 (DerivD noExtField (unLoc $1)) }
| role_annot { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }
- | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD noExtField (DefaultDecl noExtField $3)))
- [mj AnnDefault $1
- ,mop $2,mcp $4] }
- | 'foreign' fdecl {% ams (sLL $1 $> (snd $ unLoc $2))
- (mj AnnForeign $1:(fst $ unLoc $2)) }
- | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getDEPRECATED_PRAGs $1) (fromOL $2)))
- [mo $1,mc $3] }
- | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getWARNING_PRAGs $1) (fromOL $2)))
- [mo $1,mc $3] }
- | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD noExtField (HsRules noExtField (getRULES_PRAGs $1) (fromOL $2)))
- [mo $1,mc $3] }
+ | 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $>
+ (DefD noExtField (DefaultDecl (ApiAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }
+ | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (ApiAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }
+ | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (ApiAnn (glR $1) [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2))) }
+ | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (ApiAnn (glR $1) [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2))) }
+ | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (ApiAnn (glR $1) [mo $1,mc $3] cs) (getRULES_PRAGs $1) (reverse $2))) }
| annotation { $1 }
| decl_no_th { $1 }
@@ -1190,13 +1222,14 @@ topdecl :: { LHsDecl GhcPs }
-- but we treat an arbitrary expression just as if
-- it had a $(..) wrapped around it
| infixexp {% runPV (unECP $1) >>= \ $1 ->
- return $ sLL $1 $> $ mkSpliceDecl $1 }
+ do { d <- mkSpliceDecl $1
+ ; commentsPA d }}
-- Type classes
--
cl_decl :: { LTyClDecl GhcPs }
: 'class' tycl_hdr fds where_cls
- {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))
+ {% (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))
(mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) }
-- Type declarations (toplevel)
@@ -1211,152 +1244,148 @@ ty_decl :: { LTyClDecl GhcPs }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% amms (mkTySynonym (comb2 $1 $4) $2 $4)
- [mj AnnType $1,mj AnnEqual $3] }
+ {% mkTySynonym (comb2A $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] }
-- type family declarations
| 'type' 'family' type opt_tyfam_kind_sig opt_injective_info
where_type_family
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3
- (snd $ unLoc $4) (snd $ unLoc $5))
- (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)
- ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }
+ {% mkFamDecl (comb4 $1 (reLoc $3) $4 $5) (snd $ unLoc $6) TopLevel $3
+ (snd $ unLoc $4) (snd $ unLoc $5)
+ (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)
+ ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }
-- ordinary data type or newtype declaration
| data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings
- {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
+ {% mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
Nothing (reverse (snd $ unLoc $4))
- (fmap reverse $5))
+ (fmap reverse $5)
+ ((fst $ unLoc $1):(fst $ unLoc $4)) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
- ((fst $ unLoc $1):(fst $ unLoc $4)) }
-- ordinary GADT declaration
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
maybe_derivings
- {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
+ {% mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
(snd $ unLoc $4) (snd $ unLoc $5)
- (fmap reverse $6) )
+ (fmap reverse $6)
+ ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
- ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- data/newtype family
| 'data' 'family' type opt_datafam_kind_sig
- {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3
- (snd $ unLoc $4) Nothing)
- (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
+ {% mkFamDecl (comb3 $1 $2 $4) DataFamily TopLevel $3
+ (snd $ unLoc $4) Nothing
+ (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
-- standalone kind signature
standalone_kind_sig :: { LStandaloneKindSig GhcPs }
: 'type' sks_vars '::' sigktype
- {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4)
- [mj AnnType $1,mu AnnDcolon $3] }
+ {% mkStandaloneKindSig (comb2A $1 $4) (L (gl $2) $ unLoc $2) $4
+ [mj AnnType $1,mu AnnDcolon $3]}
-- See also: sig_vars
-sks_vars :: { Located [Located RdrName] } -- Returned in reverse order
+sks_vars :: { Located [LocatedN RdrName] } -- Returned in reverse order
: sks_vars ',' oqtycon
- {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
- return (sLL $1 $> ($3 : unLoc $1)) }
- | oqtycon { sL1 $1 [$1] }
+ {% case unLoc $1 of
+ (h:t) -> do
+ h' <- addTrailingCommaN h (gl $2)
+ return (sLL $1 (reLocN $>) ($3 : h' : t)) }
+ | oqtycon { sL1N $1 [$1] }
inst_decl :: { LInstDecl GhcPs }
: 'instance' overlap_pragma inst_type where_inst
{% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
- ; let cid = ClsInstDecl { cid_ext = noExtField
+ ; let anns = (mj AnnInstance $1 : (fst $ unLoc $4))
+ ; let cid cs = ClsInstDecl
+ { cid_ext = (ApiAnn (glR $1) anns cs, NoAnnSortKey)
, cid_poly_ty = $3, cid_binds = binds
, cid_sigs = mkClassOpSigs sigs
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
- (mj AnnInstance $1 : (fst $ unLoc $4)) } }
+ ; acsA (\cs -> L (comb3 $1 (reLoc $3) $4)
+ (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))
+ } }
-- type instance declarations
| 'type' 'instance' ty_fam_inst_eqn
- {% ams $3 (fst $ unLoc $3)
- >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))
- (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
+ {% mkTyFamInst (comb2A $1 $3) (unLoc $3)
+ (mj AnnType $1:mj AnnInstance $2:[]) }
-- data/newtype instance declaration
| data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs
maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
+ {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)
Nothing (reverse (snd $ unLoc $5))
- (fmap reverse $6))
- ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
+ (fmap reverse $6)
+ ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
-- GADT instance declaration
| data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig
gadt_constrlist
maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4)
+ {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (unLoc $4)
(snd $ unLoc $5) (snd $ unLoc $6)
- (fmap reverse $7))
- ((fst $ unLoc $1):mj AnnInstance $2
- :(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
-
-overlap_pragma :: { Maybe (Located OverlapMode) }
- : '{-# OVERLAPPABLE' '#-}' {% ajs (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))
- [mo $1,mc $2] }
- | '{-# OVERLAPPING' '#-}' {% ajs (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))
- [mo $1,mc $2] }
- | '{-# OVERLAPS' '#-}' {% ajs (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))
- [mo $1,mc $2] }
- | '{-# INCOHERENT' '#-}' {% ajs (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))
- [mo $1,mc $2] }
+ (fmap reverse $7)
+ ((fst $ unLoc $1):mj AnnInstance $2
+ :(fst $ unLoc $5)++(fst $ unLoc $6)) }
+
+overlap_pragma :: { Maybe (LocatedP OverlapMode) }
+ : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))
+ (AnnPragma (mo $1) (mc $2) []) }
+ | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))
+ (AnnPragma (mo $1) (mc $2) []) }
+ | '{-# OVERLAPS' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))
+ (AnnPragma (mo $1) (mc $2) []) }
+ | '{-# INCOHERENT' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))
+ (AnnPragma (mo $1) (mc $2) []) }
| {- empty -} { Nothing }
deriv_strategy_no_via :: { LDerivStrategy GhcPs }
- : 'stock' {% ams (sL1 $1 StockStrategy)
- [mj AnnStock $1] }
- | 'anyclass' {% ams (sL1 $1 AnyclassStrategy)
- [mj AnnAnyclass $1] }
- | 'newtype' {% ams (sL1 $1 NewtypeStrategy)
- [mj AnnNewtype $1] }
+ : 'stock' {% acs (\cs -> sL1 $1 (StockStrategy (ApiAnn (glR $1) [mj AnnStock $1] cs))) }
+ | 'anyclass' {% acs (\cs -> sL1 $1 (AnyclassStrategy (ApiAnn (glR $1) [mj AnnAnyclass $1] cs))) }
+ | 'newtype' {% acs (\cs -> sL1 $1 (NewtypeStrategy (ApiAnn (glR $1) [mj AnnNewtype $1] cs))) }
deriv_strategy_via :: { LDerivStrategy GhcPs }
- : 'via' sigktype {% ams (sLL $1 $> (ViaStrategy $2))
- [mj AnnVia $1] }
+ : 'via' sigktype {% acs (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (ApiAnn (glR $1) [mj AnnVia $1] cs)
+ $2))) }
deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
- : 'stock' {% ajs (sL1 $1 StockStrategy)
- [mj AnnStock $1] }
- | 'anyclass' {% ajs (sL1 $1 AnyclassStrategy)
- [mj AnnAnyclass $1] }
- | 'newtype' {% ajs (sL1 $1 NewtypeStrategy)
- [mj AnnNewtype $1] }
+ : 'stock' {% fmap Just $ acs (\cs -> sL1 $1 (StockStrategy (ApiAnn (glR $1) [mj AnnStock $1] cs))) }
+ | 'anyclass' {% fmap Just $ acs (\cs -> sL1 $1 (AnyclassStrategy (ApiAnn (glR $1) [mj AnnAnyclass $1] cs))) }
+ | 'newtype' {% fmap Just $ acs (\cs -> sL1 $1 (NewtypeStrategy (ApiAnn (glR $1) [mj AnnNewtype $1] cs))) }
| deriv_strategy_via { Just $1 }
| {- empty -} { Nothing }
-- Injective type families
-opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn GhcPs)) }
+opt_injective_info :: { Located ([AddApiAnn], Maybe (LInjectivityAnn GhcPs)) }
: {- empty -} { noLoc ([], Nothing) }
| '|' injectivity_cond { sLL $1 $> ([mj AnnVbar $1]
, Just ($2)) }
injectivity_cond :: { LInjectivityAnn GhcPs }
: tyvarid '->' inj_varids
- {% ams (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3))))
- [mu AnnRarrow $2] }
+ {% acs (\cs -> sLL (reLocN $1) $> (InjectivityAnn (ApiAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) }
-inj_varids :: { Located [Located RdrName] }
- : inj_varids tyvarid { sLL $1 $> ($2 : unLoc $1) }
- | tyvarid { sLL $1 $> [$1] }
+inj_varids :: { Located [LocatedN RdrName] }
+ : inj_varids tyvarid { sLL $1 (reLocN $>) ($2 : unLoc $1) }
+ | tyvarid { sL1N $1 [$1] }
-- Closed type families
-where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) }
+where_type_family :: { Located ([AddApiAnn],FamilyInfo GhcPs) }
: {- empty -} { noLoc ([],OpenTypeFamily) }
| 'where' ty_fam_inst_eqn_list
{ sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }
-ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
+ty_fam_inst_eqn_list :: { Located ([AddApiAnn],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
@@ -1368,27 +1397,29 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
- {% let (L loc (anns, eqn)) = $3 in
- asl (unLoc $1) $2 (L loc eqn)
- >> ams $3 anns
- >> return (sLL $1 $> (L loc eqn : unLoc $1)) }
- | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
- >> return (sLL $1 $> (unLoc $1)) }
- | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in
- ams $1 anns
- >> return (sLL $1 $> [L loc eqn]) }
+ {% let (L loc eqn) = $3 in
+ case unLoc $1 of
+ [] -> return (sLLlA $1 $> (L loc eqn : unLoc $1))
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (sLLlA $1 $> ($3 : h' : t)) }
+ | ty_fam_inst_eqns ';' {% case unLoc $1 of
+ [] -> return (sLL $1 $> (unLoc $1))
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (sLL $1 $> (h':t)) }
+ | ty_fam_inst_eqn { sLLAA $1 $> [$1] }
| {- empty -} { noLoc [] }
-ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
+ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }
: 'forall' tv_bndrs '.' type '=' ktype
{% do { hintExplicitForall $1
; tvbs <- fromSpecTyVarBndrs $2
- ; (eqn,ann) <- mkTyFamInstEqn (mkHsOuterExplicit tvbs) $4 $6
- ; return (sLL $1 $>
- (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } }
+ ; let loc = comb2A $1 $>
+ ; cs <- getCommentsFor loc
+ ; mkTyFamInstEqn loc (mkHsOuterExplicit (ApiAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}
| type '=' ktype
- {% do { (eqn,ann) <- mkTyFamInstEqn mkHsOuterImplicit $1 $3
- ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
+ {% mkTyFamInstEqn (comb2A (reLoc $1) $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) }
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
@@ -1404,40 +1435,38 @@ ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
at_decl_cls :: { LHsDecl GhcPs }
: -- data family declarations, with optional 'family' keyword
'data' opt_family type opt_datafam_kind_sig
- {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3
- (snd $ unLoc $4) Nothing))
- (mj AnnData $1:$2++(fst $ unLoc $4)) }
+ {% liftM mkTyClD (mkFamDecl (comb3 $1 (reLoc $3) $4) DataFamily NotTopLevel $3
+ (snd $ unLoc $4) Nothing
+ (mj AnnData $1:$2++(fst $ unLoc $4))) }
-- type family declarations, with optional 'family' keyword
-- (can't use opt_instance because you get shift/reduce errors
| 'type' type opt_at_kind_inj_sig
- {% amms (liftM mkTyClD
- (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2
+ {% liftM mkTyClD
+ (mkFamDecl (comb3 $1 (reLoc $2) $3) OpenTypeFamily NotTopLevel $2
(fst . snd $ unLoc $3)
- (snd . snd $ unLoc $3)))
- (mj AnnType $1:(fst $ unLoc $3)) }
+ (snd . snd $ unLoc $3)
+ (mj AnnType $1:(fst $ unLoc $3)) )}
| 'type' 'family' type opt_at_kind_inj_sig
- {% amms (liftM mkTyClD
- (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3
+ {% liftM mkTyClD
+ (mkFamDecl (comb3 $1 (reLoc $3) $4) OpenTypeFamily NotTopLevel $3
(fst . snd $ unLoc $4)
- (snd . snd $ unLoc $4)))
- (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) }
+ (snd . snd $ unLoc $4)
+ (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))}
-- default type instances, with optional 'instance' keyword
| 'type' ty_fam_inst_eqn
- {% ams $2 (fst $ unLoc $2) >>
- amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2)))
- (mj AnnType $1:(fst $ unLoc $2)) }
+ {% liftM mkInstD (mkTyFamInst (comb2A $1 $2) (unLoc $2)
+ [mj AnnType $1]) }
| 'type' 'instance' ty_fam_inst_eqn
- {% ams $3 (fst $ unLoc $3) >>
- amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)))
- (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
+ {% liftM mkInstD (mkTyFamInst (comb2A $1 $3) (unLoc $3)
+ (mj AnnType $1:mj AnnInstance $2:[]) )}
-opt_family :: { [AddAnn] }
+opt_family :: { [AddApiAnn] }
: {- empty -} { [] }
| 'family' { [mj AnnFamily $1] }
-opt_instance :: { [AddAnn] }
+opt_instance :: { [AddApiAnn] }
: {- empty -} { [] }
| 'instance' { [mj AnnInstance $1] }
@@ -1448,55 +1477,54 @@ at_decl_inst :: { LInstDecl GhcPs }
: 'type' opt_instance ty_fam_inst_eqn
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- {% ams $3 (fst $ unLoc $3) >>
- amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))
- (mj AnnType $1:$2++(fst $ unLoc $3)) }
+ {% mkTyFamInst (comb2A $1 $3) (unLoc $3)
+ (mj AnnType $1:$2) }
-- data/newtype instance declaration, with optional 'instance' keyword
| data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
+ {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)
Nothing (reverse (snd $ unLoc $5))
- (fmap reverse $6))
- ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) }
+ (fmap reverse $6)
+ ((fst $ unLoc $1):$2++(fst $ unLoc $5)) }
-- GADT instance declaration, with optional 'instance' keyword
| data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig
gadt_constrlist
maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
- (snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)
- (fmap reverse $7))
- ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
+ {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
+ (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)
+ (fmap reverse $7)
+ ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }
-data_or_newtype :: { Located (AddAnn, NewOrData) }
+data_or_newtype :: { Located (AddApiAnn, NewOrData) }
: 'data' { sL1 $1 (mj AnnData $1,DataType) }
| 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) }
-- Family result/return kind signatures
-opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) }
+opt_kind_sig :: { Located ([AddApiAnn], Maybe (LHsKind GhcPs)) }
: { noLoc ([] , Nothing) }
- | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) }
+ | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], Just $2) }
-opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) }
+opt_datafam_kind_sig :: { Located ([AddApiAnn], LFamilyResultSig GhcPs) }
: { noLoc ([] , noLoc (NoSig noExtField) )}
- | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))}
+ | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig noExtField $2))}
-opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) }
+opt_tyfam_kind_sig :: { Located ([AddApiAnn], LFamilyResultSig GhcPs) }
: { noLoc ([] , noLoc (NoSig noExtField) )}
- | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))}
+ | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig noExtField $2))}
| '=' tv_bndr {% do { tvb <- fromSpecTyVarBndr $2
- ; return $ sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExtField tvb))} }
+ ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLL $1 (reLoc $>) (TyVarSig noExtField tvb))} }
-opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs
+opt_at_kind_inj_sig :: { Located ([AddApiAnn], ( LFamilyResultSig GhcPs
, Maybe (LInjectivityAnn GhcPs)))}
: { noLoc ([], (noLoc (NoSig noExtField), Nothing)) }
- | '::' kind { sLL $1 $> ( [mu AnnDcolon $1]
- , (sLL $2 $> (KindSig noExtField $2), Nothing)) }
+ | '::' kind { sLL $1 (reLoc $>) ( [mu AnnDcolon $1]
+ , (sL1A $> (KindSig noExtField $2), Nothing)) }
| '=' tv_bndr_no_braces '|' injectivity_cond
{% do { tvb <- fromSpecTyVarBndr $2
; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]
- , (sLL $1 $2 (TyVarSig noExtField tvb), Just $4))} }
+ , (sLL $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} }
-- tycl_hdr parses the header of a class or data type decl,
-- which takes the form
@@ -1506,39 +1534,36 @@ opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs
-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
- : context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
- >> (return (sLL $1 $> (Just $1, $3)))
- }
- | type { sL1 $1 (Nothing, $1) }
+ : context '=>' type {% acs (\cs -> (sLLAA $1 $> (Just (addTrailingDarrowC $1 $2 cs), $3))) }
+ | type { sL1A $1 (Nothing, $1) }
-datafam_inst_hdr :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) }
+datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) }
: 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall $1
>> fromSpecTyVarBndrs $2
- >>= \tvbs -> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)
- >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
- , (Just $4, mkHsOuterExplicit tvbs, $6)))
- )
+ >>= \tvbs ->
+ (acs (\cs -> (sLL $1 (reLoc $>)
+ (Just ( addTrailingDarrowC $4 $5 cs)
+ , mkHsOuterExplicit (ApiAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) noCom) tvbs, $6))))
}
| 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1
; tvbs <- fromSpecTyVarBndrs $2
- ; return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
- , (Nothing, mkHsOuterExplicit tvbs, $4)))
+ ; let loc = comb2 $1 (reLoc $>)
+ ; cs <- getCommentsFor loc
+ ; return (sL loc (Nothing, mkHsOuterExplicit (ApiAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))
} }
- | context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
- >> (return (sLL $1 $>([], (Just $1, mkHsOuterImplicit, $3))))
- }
- | type { sL1 $1 ([], (Nothing, mkHsOuterImplicit, $1)) }
+ | context '=>' type {% acs (\cs -> (sLLAA $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }
+ | type { sL1A $1 (Nothing, mkHsOuterImplicit, $1) }
-capi_ctype :: { Maybe (Located CType) }
+capi_ctype :: { Maybe (LocatedP CType) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
- {% ajs (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
+ {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
(getSTRINGs $3,getSTRING $3)))
- [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }
+ (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) }
| '{-# CTYPE' STRING '#-}'
- {% ajs (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))
- [mo $1,mj AnnVal $2,mc $3] }
+ {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))
+ (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) }
| { Nothing }
@@ -1550,17 +1575,16 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
: 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $5) }
- ; ams (sLL $1 $>
- (DerivDecl noExtField (mkHsWildCardBndrs $5) $2 $4))
- [mj AnnDeriving $1, mj AnnInstance $3] } }
+ ; acsA (\cs -> sLL $1 (reLoc $>)
+ (DerivDecl (ApiAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $5) $2 $4)) }}
-----------------------------------------------------------------------------
-- Role annotations
role_annot :: { LRoleAnnotDecl GhcPs }
role_annot : 'type' 'role' oqtycon maybe_roles
- {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4)))
- [mj AnnType $1,mj AnnRole $2] }
+ {% mkRoleAnnotDecl (comb3N $1 $4 $3) $3 (reverse (unLoc $4))
+ [mj AnnType $1,mj AnnRole $2] }
-- Reversed!
maybe_roles :: { Located [Located (Maybe FastString)] }
@@ -1581,52 +1605,51 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 }
-- Glasgow extension: pattern synonyms
pattern_synonym_decl :: { LHsDecl GhcPs }
: 'pattern' pattern_synonym_lhs '=' pat
- {% let (name, args,as ) = $2 in
- ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4
- ImplicitBidirectional)
- (as ++ [mj AnnPattern $1, mj AnnEqual $3])
- }
+ {% let (name, args, as ) = $2 in
+ acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4
+ ImplicitBidirectional
+ (ApiAnn (glR $1) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) }
| 'pattern' pattern_synonym_lhs '<-' pat
{% let (name, args, as) = $2 in
- ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional)
- (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) }
+ acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4 Unidirectional
+ (ApiAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) }
| 'pattern' pattern_synonym_lhs '<-' pat where_decls
{% do { let (name, args, as) = $2
- ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)
- ; ams (sLL $1 $> . ValD noExtField $
- mkPatSynBind name args $4 (ExplicitBidirectional mg))
- (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )
+ ; mg <- mkPatSynMatchGroup name $5
+ ; acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $
+ mkPatSynBind name args $4 (ExplicitBidirectional mg)
+ (ApiAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs))
}}
-pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails GhcPs, [AddAnn]) }
+pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddApiAnn]) }
: con vars0 { ($1, PrefixCon noTypeArgs $2, []) }
| varid conop varid { ($2, InfixCon $1 $3, []) }
| con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }
-vars0 :: { [Located RdrName] }
+vars0 :: { [LocatedN RdrName] }
: {- empty -} { [] }
| varid vars0 { $1 : $2 }
cvars1 :: { [RecordPatSynField GhcPs] }
: var { [RecordPatSynField (mkFieldOcc $1) $1] }
- | var ',' cvars1 {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >>
- return ((RecordPatSynField (mkFieldOcc $1) $1) : $3 )}
+ | var ',' cvars1 {% do { h <- addTrailingCommaN $1 (gl $2)
+ ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}}
-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))
- ,sL1 $3 (snd $ unLoc $3)) }
+where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }
+ : 'where' '{' decls '}' {% amsrl (sLL $1 $> (snd $ unLoc $3))
+ (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) }
+ | 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3))
+ (AnnList (Just $ glR $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))}
pattern_synonym_sig :: { LSig GhcPs }
: 'pattern' con_list '::' sigtype
- {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) $4)
- [mj AnnPattern $1, mu AnnDcolon $3] }
+ {% acsA (\cs -> sLL $1 (reLoc $>)
+ $ PatSynSig (ApiAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs)
+ (unLoc $2) $4) }
-qvarcon :: { Located RdrName }
+qvarcon :: { LocatedN RdrName }
: qvar { $1 }
| qcon { $1 }
@@ -1645,26 +1668,30 @@ decl_cls : at_decl_cls { $1 }
do { v <- checkValSigLhs $2
; let err = text "in default signature" <> colon <+>
quotes (ppr $2)
- ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $4)
- [mj AnnDefault $1,mu AnnDcolon $3] } }
+ ; acsA (\cs -> sLL $1 (reLoc $>) $ SigD noExtField $ ClassOpSig (ApiAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }}
-decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
+decls_cls :: { Located ([AddApiAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
: decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+ then return (sLLlA $1 $> ((mz AnnSemi $2) ++ (fst $ unLoc $1)
, unitOL $3))
- else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]
- >> return (sLL $1 $> (fst $ unLoc $1
- ,(snd $ unLoc $1) `appOL` unitOL $3)) }
+ else case (snd $ unLoc $1) of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (sLLlA $1 $> (fst $ unLoc $1
+ , snocOL hs t' `appOL` unitOL $3)) }
| decls_cls ';' {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+ then return (sLL $1 $> ((mz AnnSemi $2) ++ (fst $ unLoc $1)
,snd $ unLoc $1))
- else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]
- >> return (sLL $1 $> (unLoc $1)) }
- | decl_cls { sL1 $1 ([], unitOL $1) }
+ else case (snd $ unLoc $1) of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (sLL $1 $> (fst $ unLoc $1
+ , snocOL hs t')) }
+ | decl_cls { sL1A $1 ([], unitOL $1) }
| {- empty -} { noLoc ([],nilOL) }
decllist_cls
- :: { Located ([AddAnn]
+ :: { Located ([AddApiAnn]
, OrdList (LHsDecl GhcPs)
, LayoutInfo) } -- Reversed
: '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
@@ -1674,7 +1701,7 @@ decllist_cls
-- Class body
--
-where_cls :: { Located ([AddAnn]
+where_cls :: { Located ([AddApiAnn]
,(OrdList (LHsDecl GhcPs)) -- Reversed
,LayoutInfo) }
-- No implicit parameters
@@ -1686,34 +1713,38 @@ where_cls :: { Located ([AddAnn]
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl GhcPs)) }
-decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) }
- | decl { sLL $1 $> (unitOL $1) }
+decl_inst : at_decl_inst { sL1A $1 (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) }
+ | decl { sL1A $1 (unitOL $1) }
-decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
+decls_inst :: { Located ([AddApiAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
: decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+ then return (sLL $1 $> ((mz AnnSemi $2) ++ (fst $ unLoc $1)
, unLoc $3))
- else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
- >> return
- (sLL $1 $> (fst $ unLoc $1
- ,(snd $ unLoc $1) `appOL` unLoc $3)) }
+ else case (snd $ unLoc $1) of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (sLL $1 $> (fst $ unLoc $1
+ , snocOL hs t' `appOL` unLoc $3)) }
| decls_inst ';' {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+ then return (sLL $1 $> ((mz AnnSemi $2) ++ (fst $ unLoc $1)
,snd $ unLoc $1))
- else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
- >> return (sLL $1 $> (unLoc $1)) }
+ else case (snd $ unLoc $1) of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (sLL $1 $> (fst $ unLoc $1
+ , snocOL hs t')) }
| decl_inst { sL1 $1 ([],unLoc $1) }
| {- empty -} { noLoc ([],nilOL) }
decllist_inst
- :: { Located ([AddAnn]
+ :: { Located ([AddApiAnn]
, 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) }
-- Instance body
--
-where_inst :: { Located ([AddAnn]
+where_inst :: { Located ([AddApiAnn]
, OrdList (LHsDecl GhcPs)) } -- Reversed
-- No implicit parameters
-- May have type declarations
@@ -1723,78 +1754,89 @@ where_inst :: { Located ([AddAnn]
-- Declarations in binding groups other than classes and instances
--
-decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }
+decls :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }
: decls ';' decl {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+ then return (sLLlA $1 $> ((msemi $2) ++ (fst $ unLoc $1)
, unitOL $3))
- else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
- >> return (
- let { this = unitOL $3;
- rest = snd $ unLoc $1;
- these = rest `appOL` this }
- in rest `seq` this `seq` these `seq`
- (sLL $1 $> (fst $ unLoc $1,these))) }
+ else case (snd $ unLoc $1) of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ let { this = unitOL $3;
+ rest = snocOL hs t';
+ these = rest `appOL` this }
+ return (rest `seq` this `seq` these `seq`
+ (sLLlA $1 $> (fst $ unLoc $1, these))) }
| decls ';' {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1)
+ then return (sLL $1 $> (((msemi $2) ++ (fst $ unLoc $1)
,snd $ unLoc $1)))
- else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
- >> return (sLL $1 $> (unLoc $1)) }
- | decl { sL1 $1 ([], unitOL $1) }
+ else case (snd $ unLoc $1) of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (sLL $1 $> (fst $ unLoc $1
+ , snocOL hs t')) }
+ | decl { sL1A $1 ([], unitOL $1) }
| {- empty -} { noLoc ([],nilOL) }
-decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) }
- : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
+decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }
+ : '{' decls '}' { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)
+ ,sL1 $2 $ snd $ unLoc $2) }
+ | vocurly decls close { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)
,sL1 $2 $ snd $ unLoc $2) }
- | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
-- Binding groups other than those of class and instance declarations
--
-binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
+binds :: { Located (HsLocalBinds GhcPs) }
-- May have implicit parameters
-- No type declarations
: decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)
- ; return (sL1 $1 (fst $ unLoc $1
- ,sL1 $1 $ HsValBinds noExtField val_binds)) } }
+ ; cs <- getCommentsFor (gl $1)
+ ; if (isNilOL (unLoc $ snd $ unLoc $1))
+ then return (sL1 $1 $ HsValBinds (ApiAnn (glR $1) (AnnList (Just $ glR $1) Nothing Nothing [] []) cs) val_binds)
+ else return (sL1 $1 $ HsValBinds (ApiAnn (glR $1) (fst $ unLoc $1) cs) val_binds) } }
- | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3]
- ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }
+ | '{' dbinds '}' {% acs (\cs -> (L (comb3 $1 $2 $3)
+ $ HsIPBinds (ApiAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
- | vocurly dbinds close { L (getLoc $2) ([]
- ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }
+ | vocurly dbinds close {% acs (\cs -> (L (gl $2)
+ $ HsIPBinds (ApiAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
-wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
+wherebinds :: { Maybe (Located (HsLocalBinds GhcPs)) }
-- May have implicit parameters
-- No type declarations
- : 'where' binds { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2)
- ,snd $ unLoc $2) }
- | {- empty -} { noLoc ([],noLoc emptyLocalBinds) }
-
+ : 'where' binds { Just (sLL $1 $> (annBinds (mj AnnWhere $1) (unLoc $2))) }
+ | {- empty -} { Nothing }
-----------------------------------------------------------------------------
-- Transformation Rules
-rules :: { OrdList (LRuleDecl GhcPs) }
- : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2)
- >> return ($1 `snocOL` $3) }
- | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2)
- >> return $1 }
- | rule { unitOL $1 }
- | {- empty -} { nilOL }
+rules :: { [LRuleDecl GhcPs] } -- Reversed
+ : rules ';' rule {% case $1 of
+ [] -> return ($3:$1)
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return ($3:h':t) }
+ | rules ';' {% case $1 of
+ [] -> return $1
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (h':t) }
+ | rule { [$1] }
+ | {- empty -} { [] }
rule :: { LRuleDecl GhcPs }
: STRING rule_activation rule_foralls infixexp '=' exp
{%runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
- ams (sLL $1 $> $ HsRule { rd_ext = noExtField
+ acsA (\cs -> (sLLlA $1 $> $ HsRule
+ { rd_ext = ApiAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs
, rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
- , rd_lhs = $4, rd_rhs = $6 })
- (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) }
+ , rd_lhs = $4, rd_rhs = $6 })) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
-rule_activation :: { ([AddAnn],Maybe Activation) }
+rule_activation :: { ([AddApiAnn],Maybe Activation) }
-- See Note [%shift: rule_activation -> {- empty -}]
: {- empty -} %shift { ([],Nothing) }
| rule_explicit_activation { (fst $1,Just (snd $1)) }
@@ -1807,14 +1849,14 @@ rule_activation :: { ([AddAnn],Maybe Activation) }
-- without a space [~1] (the PREFIX_TILDE case), or
-- with a space [~ 1] (the VARSYM case).
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
-rule_activation_marker :: { [AddAnn] }
+rule_activation_marker :: { [AddApiAnn] }
: PREFIX_TILDE { [mj AnnTilde $1] }
| VARSYM {% if (getVARSYM $1 == fsLit "~")
then return [mj AnnTilde $1]
else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc $1)
; return [] } }
-rule_explicit_activation :: { ([AddAnn]
+rule_explicit_activation :: { ([AddApiAnn]
,Activation) } -- In brackets
: '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3]
,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }
@@ -1825,28 +1867,29 @@ rule_explicit_activation :: { ([AddAnn]
{ ($2++[mos $1,mcs $3]
,NeverActive) }
-rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }
+rule_foralls :: { ([AddApiAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }
: 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2
in hintExplicitForall $1
>> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)
- >> return ([mu AnnForall $1,mj AnnDot $3,
- mu AnnForall $4,mj AnnDot $6],
+ >> return (\anns -> HsRuleAnn
+ (Just (mu AnnForall $1,mj AnnDot $3))
+ (Just (mu AnnForall $4,mj AnnDot $6))
+ anns,
Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }
-- See Note [%shift: rule_foralls -> 'forall' rule_vars '.']
- | 'forall' rule_vars '.' %shift { ([mu AnnForall $1,mj AnnDot $3],
+ | 'forall' rule_vars '.' %shift { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns,
Nothing, mkRuleBndrs $2) }
-- See Note [%shift: rule_foralls -> {- empty -}]
- | {- empty -} %shift { ([], Nothing, []) }
+ | {- empty -} %shift { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) }
rule_vars :: { [LRuleTyTmVar] }
: rule_var rule_vars { $1 : $2 }
| {- empty -} { [] }
rule_var :: { LRuleTyTmVar }
- : varid { sLL $1 $> (RuleTyTmVar $1 Nothing) }
- | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleTyTmVar $2 (Just $4)))
- [mop $1,mu AnnDcolon $3,mcp $5] }
+ : varid { sL1N $1 (RuleTyTmVar noAnn $1 Nothing) }
+ | '(' varid '::' ctype ')' {% acs (\cs -> sLL $1 $> (RuleTyTmVar (ApiAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }
{- Note [Parsing explicit foralls in Rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1875,42 +1918,66 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
-- Warnings and deprecations (c.f. rules)
warnings :: { OrdList (LWarnDecl GhcPs) }
- : warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2)
- >> return ($1 `appOL` $3) }
- | warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2)
- >> return $1 }
+ : warnings ';' warning {% if isNilOL $1
+ then return ($1 `appOL` $3)
+ else case $1 of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (snocOL hs t' `appOL` $3) }
+ | warnings ';' {% if isNilOL $1
+ then return $1
+ else case $1 of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (snocOL hs t') }
| warning { $1 }
| {- empty -} { nilOL }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LWarnDecl GhcPs) }
: namelist strings
- {% amsu (sLL $1 $> (Warning noExtField (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
- (fst $ unLoc $2) }
+ {% fmap unitOL $ acsA (\cs -> sLL $1 $>
+ (Warning (ApiAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)
+ (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
: deprecations ';' deprecation
- {% addAnnotation (oll $1) AnnSemi (gl $2)
- >> return ($1 `appOL` $3) }
- | deprecations ';' {% addAnnotation (oll $1) AnnSemi (gl $2)
- >> return $1 }
+ {% if isNilOL $1
+ then return ($1 `appOL` $3)
+ else case $1 of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (snocOL hs t' `appOL` $3) }
+ | deprecations ';' {% if isNilOL $1
+ then return $1
+ else case $1 of
+ SnocOL hs t -> do
+ t' <- addTrailingSemiA t (gl $2)
+ return (snocOL hs t') }
| deprecation { $1 }
| {- empty -} { nilOL }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { OrdList (LWarnDecl GhcPs) }
: namelist strings
- {% amsu (sLL $1 $> $ (Warning noExtField (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
- (fst $ unLoc $2) }
+ {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (ApiAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)
+ (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }
-strings :: { Located ([AddAnn],[Located StringLiteral]) }
+strings :: { Located ([AddApiAnn],[Located StringLiteral]) }
: STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
| '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
stringlist :: { Located (OrdList (Located StringLiteral)) }
- : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
- return (sLL $1 $> (unLoc $1 `snocOL`
- (L (gl $3) (getStringLiteral $3)))) }
+ : stringlist ',' STRING {% if isNilOL (unLoc $1)
+ then return (sLL $1 $> (unLoc $1 `snocOL`
+ (L (gl $3) (getStringLiteral $3))))
+ else case (unLoc $1) of
+ SnocOL hs t -> do
+ let { t' = addTrailingCommaS t (glAA $2) }
+ return (sLL $1 $> (snocOL hs t' `snocOL`
+ (L (gl $3) (getStringLiteral $3))))
+
+}
| STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
| {- empty -} { noLoc nilOL }
@@ -1918,28 +1985,27 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
-- Annotations
annotation :: { LHsDecl GhcPs }
: '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
- ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
+ acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
+ (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs)
(getANN_PRAGs $1)
- (ValueAnnProvenance $2) $3))
- [mo $1,mc $4] }
+ (ValueAnnProvenance $2) $3)) }
| '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->
- ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
+ acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
+ (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs)
(getANN_PRAGs $1)
- (TypeAnnProvenance $3) $4))
- [mo $1,mj AnnType $2,mc $5] }
+ (TypeAnnProvenance $3) $4)) }
| '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
- ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
+ acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
+ (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs)
(getANN_PRAGs $1)
- ModuleAnnProvenance $3))
- [mo $1,mj AnnModule $2,mc $4] }
-
+ ModuleAnnProvenance $3)) }
-----------------------------------------------------------------------------
-- Foreign import and export declarations
-fdecl :: { Located ([AddAnn],HsDecl GhcPs) }
+fdecl :: { Located ([AddApiAnn],ApiAnn -> HsDecl GhcPs) }
fdecl : 'import' callconv safety fspec
{% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->
return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) }
@@ -1962,13 +2028,13 @@ safety :: { Located Safety }
| 'safe' { sLL $1 $> PlaySafe }
| 'interruptible' { sLL $1 $> PlayInterruptible }
-fspec :: { Located ([AddAnn]
- ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) }
- : STRING var '::' sigtype { sLL $1 $> ([mu AnnDcolon $3]
+fspec :: { Located ([AddApiAnn]
+ ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) }
+ : STRING var '::' sigtype { sLL $1 (reLoc $>) ([mu AnnDcolon $3]
,(L (getLoc $1)
(getStringLiteral $1), $2, $4)) }
- | var '::' sigtype { sLL $1 $> ([mu AnnDcolon $2]
- ,(noLoc (StringLiteral NoSourceText nilFS), $1, $3)) }
+ | var '::' sigtype { sLL (reLocN $1) (reLoc $>) ([mu AnnDcolon $2]
+ ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }
-- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling
-- convention
@@ -1976,11 +2042,11 @@ fspec :: { Located ([AddAnn]
-----------------------------------------------------------------------------
-- Type signatures
-opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) }
- : {- empty -} { ([],Nothing) }
- | '::' ctype { ([mu AnnDcolon $1],Just $2) }
+opt_sig :: { Maybe (AddApiAnn, LHsType GhcPs) }
+ : {- empty -} { Nothing }
+ | '::' ctype { Just (mu AnnDcolon $1, $2) }
-opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
+opt_tyconsig :: { ([AddApiAnn], Maybe (LocatedN RdrName)) }
: {- empty -} { ([], Nothing) }
| '::' gtycon { ([mu AnnDcolon $1], Just $2) }
@@ -1988,9 +2054,8 @@ opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
-- See Note [forall-or-nothing rule] in GHC.Hs.Type.
sigktype :: { LHsSigType GhcPs }
: sigtype { $1 }
- | ctype '::' kind {% ams (sLL $1 $> $ mkHsImplicitSigType $
- sLL $1 $> $ HsKindSig noExtField $1 $3)
- [mu AnnDcolon $2] }
+ | ctype '::' kind {% acsA (\cs -> sLLAA $1 $> $ mkHsImplicitSigType $
+ sLLa (reLoc $1) (reLoc $>) $ HsKindSig (ApiAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }
-- Like ctype, but for types that obey the forall-or-nothing rule.
-- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the
@@ -1999,17 +2064,18 @@ sigktype :: { LHsSigType GhcPs }
sigtype :: { LHsSigType GhcPs }
: ctype { hsTypeToHsSigType $1 }
-sig_vars :: { Located [Located RdrName] } -- Returned in reversed order
- : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1)
- AnnComma (gl $2)
- >> return (sLL $1 $> ($3 : unLoc $1)) }
- | var { sL1 $1 [$1] }
+sig_vars :: { Located [LocatedN RdrName] } -- Returned in reversed order
+ : sig_vars ',' var {% case unLoc $1 of
+ [] -> return (sLL $1 (reLocN $>) ($3 : unLoc $1))
+ (h:t) -> do
+ h' <- addTrailingCommaN h (gl $2)
+ return (sLL $1 (reLocN $>) ($3 : h' : t)) }
+ | var { sL1N $1 [$1] }
-sigtypes1 :: { (OrdList (LHsSigType GhcPs)) }
+sigtypes1 :: { OrdList (LHsSigType GhcPs) }
: sigtype { unitOL $1 }
- | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2)
- >> return (unitOL $1 `appOL` $3) }
-
+ | sigtype ',' sigtypes1 {% do { st <- addTrailingCommaA $1 (gl $2)
+ ; return $ unitOL st `appOL` $3 } }
-----------------------------------------------------------------------------
-- Types
@@ -2017,37 +2083,32 @@ unpackedness :: { Located UnpackednessPragma }
: '{-# UNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }
| '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }
-forall_telescope :: { Located ([AddAnn], HsForAllTelescope GhcPs) }
+forall_telescope :: { Located (HsForAllTelescope GhcPs) }
: 'forall' tv_bndrs '.' {% do { hintExplicitForall $1
- ; pure $ sLL $1 $>
- ( [mu AnnForall $1, mu AnnDot $3]
- , mkHsForAllInvisTele $2 ) }}
+ ; acs (\cs -> (sLL $1 $> $
+ mkHsForAllInvisTele (ApiAnn (glR $1) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}
| 'forall' tv_bndrs '->' {% do { hintExplicitForall $1
; req_tvbs <- fromSpecTyVarBndrs $2
- ; pure $ sLL $1 $> $
- ( [mu AnnForall $1, mu AnnRarrow $3]
- , mkHsForAllVisTele req_tvbs ) }}
+ ; acs (\cs -> (sLL $1 $> $
+ mkHsForAllVisTele (ApiAnn (glR $1) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}
-- A ktype is a ctype, possibly with a kind annotation
ktype :: { LHsType GhcPs }
: ctype { $1 }
- | ctype '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3)
- [mu AnnDcolon $2] }
+ | ctype '::' kind {% acsA (\cs -> sLLAA $1 $> $ HsKindSig (ApiAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }
+
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
- : forall_telescope ctype {% let (forall_anns, forall_tele) = unLoc $1 in
- ams (sLL $1 $> $
- HsForAllTy { hst_tele = forall_tele
+ : forall_telescope ctype { reLocA $ sLL $1 (reLoc $>) $
+ HsForAllTy { hst_tele = unLoc $1
, hst_xforall = noExtField
- , hst_body = $2 })
- forall_anns }
- | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
- >> return (sLL $1 $> $
- HsQualTy { hst_ctxt = Just $1
- , hst_xqual = noExtField
- , hst_body = $3 }) }
- | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExtField $1 $3))
- [mu AnnDcolon $2] }
+ , hst_body = $2 } }
+ | context '=>' ctype {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $
+ HsQualTy { hst_ctxt = Just (addTrailingDarrowC $1 $2 cs)
+ , hst_xqual = NoExtField
+ , hst_body = $3 })) }
+
+ | ipvar '::' type {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (ApiAnn (glR $1) [mu AnnDcolon $2] cs) $1 $3)) }
| type { $1 }
----------------------
@@ -2058,12 +2119,7 @@ ctype :: { LHsType GhcPs }
-- looks so much like a tuple type. We can't tell until we find the =>
context :: { LHsContext GhcPs }
- : btype {% do { (anns,ctx) <- checkContext $1
- ; if null (unLoc ctx)
- then addAnnotation (gl $1) AnnUnit (gl $1)
- else return ()
- ; ams ctx anns
- } }
+ : btype {% checkContext $1 }
{- Note [GADT decl discards annotations]
~~~~~~~~~~~~~~~~~~~~~
@@ -2084,38 +2140,36 @@ is connected to the first type too.
type :: { LHsType GhcPs }
-- See Note [%shift: type -> btype]
: btype %shift { $1 }
- | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See Note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy noExtField (HsUnrestrictedArrow (toUnicode $2)) $1 $3)
- [mu AnnRarrow $2] }
+ | btype '->' ctype {% acsA (\cs -> sLL (reLoc $1) (reLoc $>)
+ $ HsFunTy (ApiAnn (glAR $1) (mau $2) cs) (HsUnrestrictedArrow (toUnicode $2)) $1 $3) }
| btype mult '->' ctype {% hintLinear (getLoc $2)
- >> let (arr, ann) = (unLoc $2) (toUnicode $3)
- in (ams $1 [ann,mu AnnRarrow $3] -- See Note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy noExtField arr $1 $4)
- [ann,mu AnnRarrow $3]) }
+ >> let arr = (unLoc $2) (toUnicode $3)
+ in acsA (\cs -> sLL (reLoc $1) (reLoc $>)
+ $ HsFunTy (ApiAnn (glAR $1) (mau $3) cs) arr $1 $4) }
- | btype '->.' ctype {% hintLinear (getLoc $2)
- >> ams $1 [mu AnnLollyU $2] -- See Note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) $1 $3)
- [mu AnnLollyU $2] }
+ | btype '->.' ctype {% hintLinear (getLoc $2) >>
+ acsA (\cs -> sLL (reLoc $1) (reLoc $>)
+ $ HsFunTy (ApiAnn (glAR $1) (mau $2) cs) (HsLinearArrow UnicodeSyntax Nothing) $1 $3) }
+ -- [mu AnnLollyU $2] }
-mult :: { Located (IsUnicodeSyntax -> (HsArrow GhcPs, AddAnn)) }
- : PREFIX_PERCENT atype { sLL $1 $> (\u -> mkMultTy u $1 $2) }
+mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }
+ : PREFIX_PERCENT atype { sLL $1 (reLoc $>) (\u -> mkMultTy u $1 $2) }
btype :: { LHsType GhcPs }
: infixtype {% runPV $1 }
-infixtype :: { forall b. DisambTD b => PV (Located b) }
+infixtype :: { forall b. DisambTD b => PV (LocatedA b) }
-- See Note [%shift: infixtype -> ftype]
: ftype %shift { $1 }
| ftype tyop infixtype { $1 >>= \ $1 ->
$3 >>= \ $3 ->
- do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLoc $2)
+ do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2)
; mkHsOpTyPV $1 $2 $3 } }
| unpackedness infixtype { $2 >>= \ $2 ->
mkUnpackednessPV $1 $2 }
-ftype :: { forall b. DisambTD b => PV (Located b) }
+ftype :: { forall b. DisambTD b => PV (LocatedA b) }
: atype { mkHsAppTyHeadPV $1 }
| tyop { failOpFewArgs $1 }
| ftype tyarg { $1 >>= \ $1 ->
@@ -2127,74 +2181,61 @@ tyarg :: { LHsType GhcPs }
: atype { $1 }
| unpackedness atype {% addUnpackednessP $1 $2 }
-tyop :: { Located RdrName }
+tyop :: { LocatedN RdrName }
: qtyconop { $1 }
| tyvarop { $1 }
- | SIMPLEQUOTE qconop {% ams (sLL $1 $> (unLoc $2))
- [mj AnnSimpleQuote $1,mj AnnVal $2] }
- | SIMPLEQUOTE varop {% ams (sLL $1 $> (unLoc $2))
- [mj AnnSimpleQuote $1,mj AnnVal $2] }
+ | SIMPLEQUOTE qconop {% amsrn (sLL $1 (reLoc $>) (unLoc $2))
+ (NameAnnQuote (glAA $1) (gl $2) []) }
+ | SIMPLEQUOTE varop {% amsrn (sLL $1 (reLoc $>) (unLoc $2))
+ (NameAnnQuote (glAA $1) (gl $2) []) }
atype :: { LHsType GhcPs }
- : ntgtycon { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- Not including unit tuples
+ : ntgtycon {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (ApiAnn (glNR $1) [] cs) NotPromoted $1)) } -- Not including unit tuples
-- See Note [%shift: atype -> tyvar]
- | tyvar %shift { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- (See Note [Unit tuples])
+ | tyvar %shift {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (ApiAnn (glNR $1) [] cs) NotPromoted $1)) } -- (See Note [Unit tuples])
| '*' {% do { warnStarIsType (getLoc $1)
- ; return $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }
+ ; return $ reLocA $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
- | PREFIX_TILDE atype {% ams (sLL $1 $> (mkBangTy SrcLazy $2)) [mj AnnTilde $1] }
- | PREFIX_BANG atype {% ams (sLL $1 $> (mkBangTy SrcStrict $2)) [mj AnnBang $1] }
+ | PREFIX_TILDE atype {% acsA (\cs -> sLLlA $1 $> (mkBangTy (ApiAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) }
+ | PREFIX_BANG atype {% acsA (\cs -> sLLlA $1 $> (mkBangTy (ApiAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) }
- | '{' fielddecls '}' {% amms (checkRecordSyntax
- (sLL $1 $> $ HsRecTy noExtField $2))
+ | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (ApiAnn (glR $1) (AnnList (Just $ listAsAnchor $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))
+ ; checkRecordSyntax decls }}
-- Constructor sigs only
- [moc $1,mcc $3] }
- | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExtField
- HsBoxedOrConstraintTuple [])
- [mop $1,mcp $2] }
- | '(' ktype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
- (gl $3) >>
- ams (sLL $1 $> $ HsTupleTy noExtField
-
- HsBoxedOrConstraintTuple ($2 : $4))
- [mop $1,mcp $5] }
- | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple [])
- [mo $1,mc $2] }
- | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple $2)
- [mo $1,mc $3] }
- | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExtField $2)
- [mo $1,mc $3] }
- | '[' ktype ']' {% ams (sLL $1 $> $ HsListTy noExtField $2) [mos $1,mcs $3] }
- | '(' ktype ')' {% ams (sLL $1 $> $ HsParTy noExtField $2) [mop $1,mcp $3] }
- | quasiquote { mapLoc (HsSpliceTy noExtField) $1 }
- | splice_untyped { mapLoc (HsSpliceTy noExtField) $1 }
+ | '(' ')' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)
+ HsBoxedOrConstraintTuple []) }
+ | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)
+ ; acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $5)) cs)
+ HsBoxedOrConstraintTuple (h : $4)) }}
+ | '(#' '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) }
+ | '(#' comma_types1 '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) }
+ | '(#' bar_types2 '#)' {% acsA (\cs -> sLL $1 $> $ HsSumTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) }
+ | '[' ktype ']' {% acsA (\cs -> sLL $1 $> $ HsListTy (ApiAnn (glR $1) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) }
+ | '(' ktype ')' {% acsA (\cs -> sLL $1 $> $ HsParTy (ApiAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $3)) cs) $2) }
+ | quasiquote { mapLocA (HsSpliceTy noExtField) $1 }
+ | splice_untyped { mapLocA (HsSpliceTy noExtField) $1 }
-- see Note [Promotion] for the followings
- | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
+ | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }
| SIMPLEQUOTE '(' ktype ',' comma_types1 ')'
- {% addAnnotation (gl $3) AnnComma (gl $4) >>
- ams (sLL $1 $> $ HsExplicitTupleTy noExtField ($3 : $5))
- [mj AnnSimpleQuote $1,mop $2,mcp $6] }
- | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExtField IsPromoted $3)
- [mj AnnSimpleQuote $1,mos $2,mcs $4] }
- | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2)
- [mj AnnSimpleQuote $1,mj AnnName $2] }
+ {% do { h <- addTrailingCommaA $3 (gl $4)
+ ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }}
+ | SIMPLEQUOTE '[' comma_types0 ']' {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) }
+ | SIMPLEQUOTE var {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }
-- Two or more [ty, ty, ty] must be a promoted list type, just as
-- if you had written '[ty, ty, ty]
-- (One means a list type, zero means the list type constructor,
-- so you have to quote those.)
- | '[' ktype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma
- (gl $3) >>
- ams (sLL $1 $> $ HsExplicitListTy noExtField NotPromoted ($2 : $4))
- [mos $1,mcs $5] }
- | INTEGER { sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)
+ | '[' ktype ',' comma_types1 ']' {% do { h <- addTrailingCommaA $2 (gl $3)
+ ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (ApiAnn (glR $1) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }}
+ | INTEGER { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)
(il_value (getINTEGER $1)) }
- | CHAR { sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)
+ | CHAR { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)
(getCHAR $1) }
- | STRING { sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)
+ | STRING { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)
(getSTRING $1) }
- | '_' { sL1 $1 $ mkAnonWildCardTy }
+ | '_' { reLocA $ sL1 $1 $ mkAnonWildCardTy }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
@@ -2205,8 +2246,8 @@ inst_type :: { LHsSigType GhcPs }
deriv_types :: { [LHsSigType GhcPs] }
: sigktype { [$1] }
- | sigktype ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2)
- >> return ($1 : $3) }
+ | sigktype ',' deriv_types {% do { h <- addTrailingCommaA $1 (gl $2)
+ ; return (h : $3) } }
comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty
: comma_types1 { $1 }
@@ -2214,14 +2255,14 @@ comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty
comma_types1 :: { [LHsType GhcPs] } -- One or more: ty,ty,ty
: ktype { [$1] }
- | ktype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2)
- >> return ($1 : $3) }
+ | ktype ',' comma_types1 {% do { h <- addTrailingCommaA $1 (gl $2)
+ ; return (h : $3) }}
bar_types2 :: { [LHsType GhcPs] } -- Two or more: ty|ty|ty
- : ktype '|' ktype {% addAnnotation (gl $1) AnnVbar (gl $2)
- >> return [$1,$3] }
- | ktype '|' bar_types2 {% addAnnotation (gl $1) AnnVbar (gl $2)
- >> return ($1 : $3) }
+ : ktype '|' ktype {% do { h <- addTrailingVbarA $1 (gl $2)
+ ; return [h,$3] }}
+ | ktype '|' bar_types2 {% do { h <- addTrailingVbarA $1 (gl $2)
+ ; return (h : $3) }}
tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }
: tv_bndr tv_bndrs { $1 : $2 }
@@ -2229,36 +2270,34 @@ tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }
tv_bndr :: { LHsTyVarBndr Specificity GhcPs }
: tv_bndr_no_braces { $1 }
- | '{' tyvar '}' {% ams (sLL $1 $> (UserTyVar noExtField InferredSpec $2))
- [moc $1, mcc $3] }
- | '{' tyvar '::' kind '}' {% ams (sLL $1 $> (KindedTyVar noExtField InferredSpec $2 $4))
- [moc $1,mu AnnDcolon $3
- ,mcc $5] }
+ | '{' tyvar '}' {% acsA (\cs -> sLL $1 $> (UserTyVar (ApiAnn (glR $1) [mop $1, mcp $3] cs) InferredSpec $2)) }
+ | '{' tyvar '::' kind '}' {% acsA (\cs -> sLL $1 $> (KindedTyVar (ApiAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) InferredSpec $2 $4)) }
tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }
- : tyvar { sL1 $1 (UserTyVar noExtField SpecifiedSpec $1) }
- | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExtField SpecifiedSpec $2 $4))
- [mop $1,mu AnnDcolon $3
- ,mcp $5] }
+ : tyvar {% acsA (\cs -> (sL1 (reLocN $1) (UserTyVar (ApiAnn (glNR $1) [] cs) SpecifiedSpec $1))) }
+ | '(' tyvar '::' kind ')' {% acsA (\cs -> (sLL $1 $> (KindedTyVar (ApiAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) }
-fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) }
+fds :: { Located ([AddApiAnn],[LHsFunDep GhcPs]) }
: {- empty -} { noLoc ([],[]) }
| '|' fds1 { (sLL $1 $> ([mj AnnVbar $1]
,reverse (unLoc $2))) }
-fds1 :: { Located [Located (FunDep (Located RdrName))] }
- : fds1 ',' fd {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2)
- >> return (sLL $1 $> ($3 : unLoc $1)) }
- | fd { sL1 $1 [$1] }
+fds1 :: { Located [LHsFunDep GhcPs] }
+ : fds1 ',' fd {%
+ do { let (h:t) = unLoc $1 -- Safe from fds1 rules
+ ; h' <- addTrailingCommaA h (gl $2)
+ ; return (sLLlA $1 $> ($3 : h' : t)) }}
+ | fd { sL1A $1 [$1] }
-fd :: { Located (FunDep (Located RdrName)) }
- : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3)
- (reverse (unLoc $1), reverse (unLoc $3)))
- [mu AnnRarrow $2] }
+fd :: { LHsFunDep GhcPs }
+ : varids0 '->' varids0 {% acsA (\cs -> L (comb3 $1 $2 $3)
+ (FunDep (ApiAnn (glR $1) [mu AnnRarrow $2] cs)
+ (reverse (unLoc $1))
+ (reverse (unLoc $3)))) }
-varids0 :: { Located [Located RdrName] }
+varids0 :: { Located [LocatedN RdrName] }
: {- empty -} { noLoc [] }
- | varids0 tyvar { sLL $1 $> ($2 : unLoc $1) }
+ | varids0 tyvar { sLL $1 (reLocN $>) ($2 : (unLoc $1)) }
-----------------------------------------------------------------------------
-- Kinds
@@ -2291,7 +2330,7 @@ And both become a HsTyVar ("Zero", DataName) after the renamer.
-----------------------------------------------------------------------------
-- Datatype declarations
-gadt_constrlist :: { Located ([AddAnn]
+gadt_constrlist :: { Located ([AddApiAnn]
,[LConDecl GhcPs]) } -- Returned in order
: 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $
@@ -2308,9 +2347,9 @@ gadt_constrlist :: { Located ([AddAnn]
gadt_constrs :: { Located [LConDecl GhcPs] }
: gadt_constr ';' gadt_constrs
- {% addAnnotation (gl $1) AnnSemi (gl $2)
- >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
- | gadt_constr { L (gl $1) [$1] }
+ {% do { h <- addTrailingSemiA $1 (gl $2)
+ ; return (L (comb2 (reLoc $1) $3) (h : unLoc $3)) }}
+ | gadt_constr { L (glA $1) [$1] }
| {- empty -} { noLoc [] }
-- We allow the following forms:
@@ -2322,10 +2361,9 @@ gadt_constrs :: { Located [LConDecl GhcPs] }
gadt_constr :: { LConDecl GhcPs }
-- see Note [Difference in parsing GADT and data constructors]
-- Returns a list because of: C,D :: ty
+ -- TODO:AZ capture the optSemi. Why leading?
: optSemi con_list '::' sigtype
- {% do { (decl, anns) <- mkGadtDecl (unLoc $2) $4
- ; ams (sLL $2 $> decl)
- (mu AnnDcolon $3:anns) } }
+ {% mkGadtDecl (comb2A $2 $>) (unLoc $2) $4 [mu AnnDcolon $3] }
{- Note [Difference in parsing GADT and data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2339,39 +2377,42 @@ consequence, GADT constructor names are restricted (names like '(*)' are
allowed in usual data constructors, but not in GADTs).
-}
-constrs :: { Located ([AddAnn],[LConDecl GhcPs]) }
+constrs :: { Located ([AddApiAnn],[LConDecl GhcPs]) }
: '=' constrs1 { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)}
constrs1 :: { Located [LConDecl GhcPs] }
: constrs1 '|' constr
- {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2)
- >> return (sLL $1 $> ($3 : unLoc $1)) }
- | constr { sL1 $1 [$1] }
+ {% do { let (h:t) = unLoc $1
+ ; h' <- addTrailingVbarA h (gl $2)
+ ; return (sLLlA $1 $> ($3 : h' : t)) }}
+ | constr { sL1A $1 [$1] }
constr :: { LConDecl GhcPs }
: forall context '=>' constr_stuff
- {% ams (let (con,details) = unLoc $4 in
- (L (comb4 $1 $2 $3 $4) (mkConDeclH98 con
- (snd $ unLoc $1)
- (Just $2)
- details)))
- (mu AnnDarrow $3:(fst $ unLoc $1)) }
+ {% acsA (\cs -> let (con,details) = unLoc $4 in
+ (L (comb4 $1 (reLoc $2) $3 $4) (mkConDeclH98
+ (ApiAnn (spanAsAnchor (comb4 $1 (reLoc $2) $3 $4))
+ (mu AnnDarrow $3:(fst $ unLoc $1)) cs)
+ con
+ (snd $ unLoc $1)
+ (Just $2)
+ details))) }
| forall constr_stuff
- {% ams (let (con,details) = unLoc $2 in
- (L (comb2 $1 $2) (mkConDeclH98 con
- (snd $ unLoc $1)
- Nothing -- No context
- details)))
- (fst $ unLoc $1) }
-
-forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
+ {% acsA (\cs -> let (con,details) = unLoc $2 in
+ (L (comb2 $1 $2) (mkConDeclH98 (ApiAnn (spanAsAnchor (comb2 $1 $2)) (fst $ unLoc $1) cs)
+ con
+ (snd $ unLoc $1)
+ Nothing -- No context
+ details))) }
+
+forall :: { Located ([AddApiAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
: 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
| {- empty -} { noLoc ([], Nothing) }
-constr_stuff :: { Located (Located RdrName, HsConDeclH98Details GhcPs) }
- : infixtype {% fmap (mapLoc (\b -> (dataConBuilderCon b,
- dataConBuilderDetails b)))
- (runPV $1) }
+constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }
+ : infixtype {% fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b,
+ dataConBuilderDetails b))))
+ (runPV $1) }
fielddecls :: { [LConDeclField GhcPs] }
: {- empty -} { [] }
@@ -2379,53 +2420,50 @@ fielddecls :: { [LConDeclField GhcPs] }
fielddecls1 :: { [LConDeclField GhcPs] }
: fielddecl ',' fielddecls1
- {% addAnnotation (gl $1) AnnComma (gl $2) >>
- return ($1 : $3) }
+ {% do { h <- addTrailingCommaA $1 (gl $2)
+ ; return (h : $3) }}
| fielddecl { [$1] }
fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: sig_vars '::' ctype
- {% ams (L (comb2 $1 $3)
- (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))
- [mu AnnDcolon $2] }
+ {% acsA (\cs -> L (comb2 $1 (reLoc $3))
+ (ConDeclField (ApiAnn (glR $1) [mu AnnDcolon $2] cs)
+ (reverse (map (\ln@(L l n) -> L (locA l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))}
-- Reversed!
-maybe_derivings :: { HsDeriving GhcPs }
+maybe_derivings :: { Located (HsDeriving GhcPs) }
: {- empty -} { noLoc [] }
| derivings { $1 }
-- A list of one or more deriving clauses at the end of a datatype
-derivings :: { HsDeriving GhcPs }
- : derivings deriving { sLL $1 $> $ $2 : unLoc $1 }
+derivings :: { Located (HsDeriving GhcPs) }
+ : derivings deriving { sLL $1 $> ($2 : unLoc $1) } -- AZ: order?
| deriving { sLL $1 $> [$1] }
-- The outer Located is just to allow the caller to
-- know the rightmost extremity of the 'deriving' clause
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_clause_types
- {% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause noExtField Nothing $2)
- [mj AnnDeriving $1] }
+ {% let { full_loc = comb2A $1 $> }
+ in acs (\cs -> L full_loc $ HsDerivingClause (ApiAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) }
| 'deriving' deriv_strategy_no_via deriv_clause_types
- {% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3)
- [mj AnnDeriving $1] }
+ {% let { full_loc = comb2A $1 $> }
+ in acs (\cs -> L full_loc $ HsDerivingClause (ApiAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) }
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2)
- [mj AnnDeriving $1] }
+ in acs (\cs -> L full_loc $ HsDerivingClause (ApiAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }
deriv_clause_types :: { LDerivClauseTys GhcPs }
- : qtycon { let { tc = sL1 $1 $ mkHsImplicitSigType $
- sL1 $1 $ HsTyVar noExtField NotPromoted $1 } in
- sL1 $1 (DctSingle noExtField tc) }
- | '(' ')' {% ams (sLL $1 $> (DctMulti noExtField []))
- [mop $1,mcp $2] }
- | '(' deriv_types ')' {% ams (sLL $1 $> (DctMulti noExtField $2))
- [mop $1,mcp $3] }
+ : qtycon { let { tc = sL1 (reLocL $1) $ mkHsImplicitSigType $
+ sL1 (reLocL $1) $ HsTyVar noAnn NotPromoted $1 } in
+ sL1 (reLocC $1) (DctSingle noExtField tc) }
+ | '(' ')' {% amsrc (sLL $1 $> (DctMulti noExtField []))
+ (AnnContext Nothing [glAA $1] [glAA $2]) }
+ | '(' deriv_types ')' {% amsrc (sLL $1 $> (DctMulti noExtField $2))
+ (AnnContext Nothing [glAA $1] [glAA $3])}
-----------------------------------------------------------------------------
-- Value definitions
@@ -2456,18 +2494,13 @@ decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
| infixexp opt_sig rhs {% runPV (unECP $1) >>= \ $1 ->
- do { (ann,r) <- checkValDef $1 (snd $2) $3;
- let { l = comb2 $1 $> };
+ do { let { l = comb2Al $1 $> }
+ ; r <- checkValDef l $1 $2 $3;
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
- case r of {
- (FunBind _ n _ _) ->
- amsL l (mj AnnFunId n:(fst $2)) >> return () ;
- (PatBind _ (L lh _lhs) _rhs _) ->
- amsL lh (fst $2) >> return () } ;
- _ <- amsL l (ann ++ (fst $ unLoc $3));
- return $! (sL l $ ValD noExtField r) } }
+ ; cs <- getCommentsFor l
+ ; return $! (sL (commentsA l cs) $ ValD noExtField r) } }
| pattern_synonym_decl { $1 }
decl :: { LHsDecl GhcPs }
@@ -2476,17 +2509,16 @@ decl :: { LHsDecl GhcPs }
-- Why do we only allow naked declaration splices in top-level
-- declarations and not here? Short answer: because readFail009
-- fails terribly with a panic in cvBindsAndSigs otherwise.
- | splice_exp { sLL $1 $> $ mkSpliceDecl $1 }
-
-rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
- : '=' exp wherebinds {% runPV (unECP $2) >>= \ $2 -> return $
- sL (comb3 $1 $2 $3)
- ((mj AnnEqual $1 : (fst $ unLoc $3))
- ,GRHSs noExtField (unguardedRHS (comb3 $1 $2 $3) $2)
- (snd $ unLoc $3)) }
- | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2
- ,GRHSs noExtField (reverse (unLoc $1))
- (snd $ unLoc $2)) }
+ | splice_exp {% mkSpliceDecl $1 }
+
+rhs :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }
+ : '=' exp wherebinds {% runPV (unECP $2) >>= \ $2 ->
+ do { let loc = (comb3 $1 (reLoc $2) (adaptWhereBinds $3))
+ ; acs (\cs ->
+ sL loc (GRHSs NoExtField (unguardedRHS (ApiAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) cs) loc $2)
+ (unLoc $ (adaptWhereBinds $3)))) } }
+ | gdrhs wherebinds { sL (comb2 $1 (adaptWhereBinds $>))
+ (GRHSs noExtField (reverse (unLoc $1)) (unLoc $ (adaptWhereBinds $2))) }
gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
: gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) }
@@ -2494,8 +2526,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
: '|' guardquals '=' exp {% runPV (unECP $4) >>= \ $4 ->
- ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4)
- [mj AnnVbar $1,mj AnnEqual $3] }
+ acs (\cs -> sL (comb2A $1 $>) $ GRHS (ApiAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }
sigdecl :: { LHsDecl GhcPs }
:
@@ -2503,79 +2534,68 @@ sigdecl :: { LHsDecl GhcPs }
infixexp '::' sigtype
{% do { $1 <- runPV (unECP $1)
; v <- checkValSigLhs $1
- ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
- ; return (sLL $1 $> $ SigD noExtField $
- TypeSig noExtField [v] (mkHsWildCardBndrs $3))} }
+ ; acsA (\cs -> (sLLAl $1 (reLoc $>) $ SigD noExtField $
+ TypeSig (ApiAnn (glAR $1) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} }
| var ',' sig_vars '::' sigtype
- {% do { let sig = TypeSig noExtField ($1 : reverse (unLoc $3))
- (mkHsWildCardBndrs $5)
- ; addAnnotation (gl $1) AnnComma (gl $2)
- ; ams ( sLL $1 $> $ SigD noExtField sig )
- [mu AnnDcolon $4] } }
+ {% do { v <- addTrailingCommaN $1 (gl $2)
+ ; let sig cs = TypeSig (ApiAnn (glNR $1) (AnnSig (mu AnnDcolon $4) []) cs) (v : reverse (unLoc $3))
+ (mkHsWildCardBndrs $5)
+ ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }}
| infix prec ops
{% checkPrecP $2 $3 >>
- ams (sLL $1 $> $ SigD noExtField
- (FixSig noExtField (FixitySig noExtField (fromOL $ unLoc $3)
- (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1)))))
- [mj AnnInfix $1,mj AnnVal $2] }
+ acsA (\cs -> sLL $1 $> $ SigD noExtField
+ (FixSig (ApiAnn (glR $1) [mj AnnInfix $1,mj AnnVal $2] cs) (FixitySig noExtField (fromOL $ unLoc $3)
+ (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) }
- | pattern_synonym_sig { sLL $1 $> . SigD noExtField . unLoc $ $1 }
+ | pattern_synonym_sig { sL1 $1 . SigD noExtField . unLoc $ $1 }
| '{-# COMPLETE' con_list opt_tyconsig '#-}'
{% let (dcolon, tc) = $3
- in ams
- (sLL $1 $>
- (SigD noExtField (CompleteMatchSig noExtField (getCOMPLETE_PRAGs $1) $2 tc)))
- ([ mo $1 ] ++ dcolon ++ [mc $4]) }
+ in acsA
+ (\cs -> sLL $1 $>
+ (SigD noExtField (CompleteMatchSig (ApiAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs) (getCOMPLETE_PRAGs $1) $2 tc))) }
-- This rule is for both INLINE and INLINABLE pragmas
| '{-# INLINE' activation qvarcon '#-}'
- {% ams ((sLL $1 $> $ SigD noExtField (InlineSig noExtField $3
+ {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (ApiAnn (glR $1) ((mo $1:fst $2) ++ [mc $4]) cs) $3
(mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
- (snd $2)))))
- ((mo $1:fst $2) ++ [mc $4]) }
+ (snd $2))))) }
| '{-# SCC' qvar '#-}'
- {% ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 Nothing)))
- [mo $1, mc $3] }
+ {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (ApiAnn (glR $1) [mo $1, mc $3] cs) (getSCC_PRAGs $1) $2 Nothing))) }
| '{-# SCC' qvar STRING '#-}'
{% do { scc <- getSCC $3
- ; let str_lit = StringLiteral (getSTRINGs $3) scc
- ; ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))
- [mo $1, mc $4] } }
+ ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing
+ ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (ApiAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) }}
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
- {% ams (
+ {% acsA (\cs ->
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(NoUserInlinePrag, FunLike) (snd $2)
- in sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5) inl_prag))
- (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
+ in sLL $1 $> $ SigD noExtField (SpecSig (ApiAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- {% ams (sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5)
+ {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (ApiAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5)
(mkInlinePragma (getSPEC_INLINE_PRAGs $1)
- (getSPEC_INLINE $1) (snd $2))))
- (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
+ (getSPEC_INLINE $1) (snd $2)))) }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
- {% ams (sLL $1 $>
- $ SigD noExtField (SpecInstSig noExtField (getSPEC_PRAGs $1) $3))
- [mo $1,mj AnnInstance $2,mc $4] }
+ {% acsA (\cs -> sLL $1 $>
+ $ SigD noExtField (SpecInstSig (ApiAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs) (getSPEC_PRAGs $1) $3)) }
-- A minimal complete definition
| '{-# MINIMAL' name_boolformula_opt '#-}'
- {% ams (sLL $1 $> $ SigD noExtField (MinimalSig noExtField (getMINIMAL_PRAGs $1) $2))
- [mo $1,mc $3] }
+ {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig (ApiAnn (glR $1) [mo $1,mc $3] cs) (getMINIMAL_PRAGs $1) $2)) }
-activation :: { ([AddAnn],Maybe Activation) }
- : -- See Note [%shift: activation -> {- empty -}]
- {- empty -} %shift { ([],Nothing) }
+activation :: { ([AddApiAnn],Maybe Activation) }
+ -- See Note [%shift: activation -> {- empty -}]
+ : {- empty -} %shift { ([],Nothing) }
| explicit_activation { (fst $1,Just (snd $1)) }
-explicit_activation :: { ([AddAnn],Activation) } -- In brackets
+explicit_activation :: { ([AddApiAnn],Activation) } -- In brackets
: '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]
,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }
| '[' rule_activation_marker INTEGER ']'
@@ -2593,39 +2613,35 @@ quasiquote :: { Located (HsSplice GhcPs) }
| TH_QQUASIQUOTE { let { loc = getLoc $1
; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkQual varName (qual, quoter) }
- in sL (getLoc $1) (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }
+ in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }
exp :: { ECP }
: infixexp '::' ctype
{ ECP $
unECP $1 >>= \ $1 ->
rejectPragmaPV $1 >>
- amms (mkHsTySigPV (comb2 $1 $>) $1 $3)
- [mu AnnDcolon $2] }
+ mkHsTySigPV (noAnnSrcSpan $ comb2Al $1 (reLoc $>)) $1 $3
+ [(mu AnnDcolon $2)] }
| infixexp '-<' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3
- HsFirstOrderApp True)
- [mu Annlarrowtail $2] }
+ acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (ApiAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3
+ HsFirstOrderApp True) }
| infixexp '>-' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1
- HsFirstOrderApp False)
- [mu Annrarrowtail $2] }
+ acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (ApiAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1
+ HsFirstOrderApp False) }
| infixexp '-<<' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3
- HsHigherOrderApp True)
- [mu AnnLarrowtail $2] }
+ acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (ApiAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3
+ HsHigherOrderApp True) }
| infixexp '>>-' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1
- HsHigherOrderApp False)
- [mu AnnRarrowtail $2] }
+ acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (ApiAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1
+ HsHigherOrderApp False) }
-- See Note [%shift: exp -> infixexp]
| infixexp %shift { $1 }
| exp_prag(exp) { $1 } -- See Note [Pragmas and operator fixity]
@@ -2639,8 +2655,7 @@ infixexp :: { ECP }
unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
rejectPragmaPV $1 >>
- amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
- [mj AnnVal $2] }
+ (mkHsOpAppPV (comb2A (reLoc $1) $3) $1 $2 $3) }
-- AnnVal annotation for NPlusKPat, which discards the operator
exp10p :: { ECP }
@@ -2651,15 +2666,14 @@ exp_prag(e) :: { ECP }
: prag_e e -- See Note [Pragmas and operator fixity]
{% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
- (fst $ unLoc $1) }
+ return $ (reLocA $ sLLlA $1 $> $ HsPragE noExtField (unLoc $1) $2) }
exp10 :: { ECP }
-- See Note [%shift: exp10 -> '-' fexp]
: '-' fexp %shift { ECP $
unECP $2 >>= \ $2 ->
- amms (mkHsNegAppPV (comb2 $1 $>) $2)
- [mj AnnMinus $1] }
+ mkHsNegAppPV (comb2A $1 $>) $2
+ [mj AnnMinus $1] }
-- See Note [%shift: exp10 -> fexp]
| fexp %shift { $1 }
@@ -2712,33 +2726,34 @@ may sound unnecessary, but it's actually needed to support a common idiom:
f $ {-# SCC ann $-} ...
-}
-prag_e :: { Located ([AddAnn], HsPragE GhcPs) }
- : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2
- ; return $ sLL $1 $>
- ([mo $1,mj AnnValStr $2,mc $3],
- HsPragSCC noExtField
+prag_e :: { Located (HsPragE GhcPs) }
+ : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2
+ ; acs (\cs -> (sLL $1 $>
+ (HsPragSCC
+ (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs)
(getSCC_PRAGs $1)
- (StringLiteral (getSTRINGs $2) scc)) }
- | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
- HsPragSCC noExtField
- (getSCC_PRAGs $1)
- (StringLiteral NoSourceText (getVARID $2))) }
+ (StringLiteral (getSTRINGs $2) scc Nothing))))} }
+ | '{-# SCC' VARID '#-}' {% acs (\cs -> (sLL $1 $>
+ (HsPragSCC
+ (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs)
+ (getSCC_PRAGs $1)
+ (StringLiteral NoSourceText (getVARID $2) Nothing)))) }
+
fexp :: { ECP }
: fexp aexp { ECP $
superFunArg $
unECP $1 >>= \ $1 ->
unECP $2 >>= \ $2 ->
- mkHsAppPV (comb2 $1 $>) $1 $2 }
+ mkHsAppPV (noAnnSrcSpan $ comb2A (reLoc $1) $>) $1 $2 }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
| fexp PREFIX_AT atype { ECP $
unECP $1 >>= \ $1 ->
- amms (mkHsAppTypePV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }
+ mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (getLoc $2) $3 }
| 'static' aexp {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- ams (sLL $1 $> $ HsStatic noExtField $2)
- [mj AnnStatic $1] }
+ acsA (\cs -> sLL $1 (reLoc $>) $ HsStatic (ApiAnn (glR $1) [mj AnnStatic $1] cs) $2) }
| aexp { $1 }
@@ -2747,83 +2762,78 @@ aexp :: { ECP }
: qvar TIGHT_INFIX_AT aexp
{ ECP $
unECP $3 >>= \ $3 ->
- amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }
+ mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 $3 [mj AnnAt $2] }
+
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
| PREFIX_TILDE aexp { ECP $
unECP $2 >>= \ $2 ->
- amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] }
+ mkHsLazyPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnTilde $1] }
| PREFIX_BANG aexp { ECP $
unECP $2 >>= \ $2 ->
- amms (mkHsBangPatPV (comb2 $1 $>) $2) [mj AnnBang $1] }
+ mkHsBangPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnBang $1] }
| PREFIX_MINUS aexp { ECP $
unECP $2 >>= \ $2 ->
- amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] }
+ mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] }
| '\\' apat apats '->' exp
{ ECP $
unECP $5 >>= \ $5 ->
- amms (mkHsLamPV (comb2 $1 $>) (mkMatchGroup FromSource
- [sLL $1 $> $ Match { m_ext = noExtField
- , m_ctxt = LambdaExpr
- , m_pats = $2:$3
- , m_grhss = unguardedGRHSs $5 }]))
- [mj AnnLam $1, mu AnnRarrow $4] }
+ mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource
+ (reLocA $ sLLlA $1 $>
+ [reLocA $ sLLlA $1 $>
+ $ Match { m_ext = ApiAnn (glR $1) [mj AnnLam $1] cs
+ , m_ctxt = LambdaExpr
+ , m_pats = $2:$3
+ , m_grhss = unguardedGRHSs (comb2 $4 (reLoc $5)) $5 (ApiAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) noCom) }])) }
| 'let' binds 'in' exp { ECP $
unECP $4 >>= \ $4 ->
- amms (mkHsLetPV (comb2 $1 $>) (snd (unLoc $2)) $4)
- (mj AnnLet $1:mj AnnIn $3
- :(fst $ unLoc $2)) }
+ mkHsLetPV (comb2A $1 $>) (unLoc $2) $4
+ (AnnsLet (glAA $1) (glAA $3)) }
| '\\' 'lcase' altslist
{ ECP $ $3 >>= \ $3 ->
- amms (mkHsLamCasePV (comb2 $1 $>)
- (mkMatchGroup FromSource (snd $ unLoc $3)))
- (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
+ mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
- {% runPV (unECP $2) >>= \ $2 ->
+ {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
unECP $5 >>= \ $5 ->
unECP $8 >>= \ $8 ->
- amms (mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8)
- (mj AnnIf $1:mj AnnThen $4
+ mkHsIfPV (comb2A $1 $>) $2 (snd $3) $5 (snd $6) $8
+ (mj AnnIf $1:mj AnnThen $4
:mj AnnElse $7
- :(map (\l -> mj AnnSemi l) (fst $3))
- ++(map (\l -> mj AnnSemi l) (fst $6))) }
+ :(concatMap (\l -> mz AnnSemi l) (fst $3))
+ ++(concatMap (\l -> mz AnnSemi l) (fst $6))) }
+
| 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ ->
fmap ecpFromExp $
- ams (sLL $1 $> $ HsMultiIf noExtField
- (reverse $ snd $ unLoc $2))
- (mj AnnIf $1:(fst $ unLoc $2)) }
- | 'case' exp 'of' altslist {% runPV (unECP $2) >>= \ $2 ->
+ acsA (\cs -> sLL $1 $> $ HsMultiIf (ApiAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs)
+ (reverse $ snd $ unLoc $2)) }
+ | 'case' exp 'of' altslist {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
$4 >>= \ $4 ->
- amms (mkHsCasePV (comb3 $1 $3 $4) $2 (mkMatchGroup
- FromSource (snd $ unLoc $4)))
- (mj AnnCase $1:mj AnnOf $3
- :(fst $ unLoc $4)) }
+ mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4
+ (ApiAnnHsCase (glAA $1) (glAA $3) []) }
-- QualifiedDo.
| DO stmtlist {% do
hintQualifiedDo $1
return $ ECP $
$2 >>= \ $2 ->
- amms (mkHsDoPV (comb2 $1 $2)
- (fmap mkModuleNameFS (getDO $1))
- (mapLoc snd $2))
- (mj AnnDo $1:(fst $ unLoc $2)) }
+ mkHsDoPV (comb2A $1 $2)
+ (fmap mkModuleNameFS (getDO $1))
+ $2
+ (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnDo $1] []) }
| MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->
fmap ecpFromExp $
- ams (L (comb2 $1 $2)
- (mkHsDo (MDoExpr $
- fmap mkModuleNameFS (getMDO $1))
- (snd $ unLoc $2)))
- (mj AnnMdo $1:(fst $ unLoc $2)) }
+ acsA (\cs -> L (comb2A $1 $2)
+ (mkHsDoAnns (MDoExpr $
+ fmap mkModuleNameFS (getMDO $1))
+ $2
+ (ApiAnn (glR $1) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }
| 'proc' aexp '->' exp
{% (checkPattern <=< runPV) (unECP $2) >>= \ p ->
runPV (unECP $4) >>= \ $4@cmd ->
fmap ecpFromExp $
- ams (sLL $1 $> $ HsProc noExtField p (sLL $1 $> $ HsCmdTop noExtField cmd))
- -- TODO: is LL right here?
- [mj AnnProc $1,mu AnnRarrow $3] }
+ acsA (\cs -> sLLlA $1 $> $ HsProc (ApiAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLlA $1 $> $ HsCmdTop noExtField cmd)) }
| aexp1 { $1 }
@@ -2832,14 +2842,17 @@ aexp1 :: { ECP }
getBit OverloadedRecordUpdateBit >>= \ overloaded ->
unECP $1 >>= \ $1 ->
$3 >>= \ $3 ->
- amms (mkHsRecordPV overloaded (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3))
- (moc $2:mcc $4:(fst $3))
+ mkHsRecordPV overloaded (comb2 (reLoc $1) $>) (comb2 $2 $4) $1 $3
+ [moc $2,mcc $4]
}
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
| aexp1 TIGHT_INFIX_PROJ field
{% runPV (unECP $1) >>= \ $1 ->
- fmap ecpFromExp $ ams (mkRdrGetField (comb2 $1 $>) $1 $3) [mj AnnDot $2] }
+ fmap ecpFromExp $ acsa (\cs ->
+ let fl = sLL $2 $> (HsFieldLabel ((ApiAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) noCom)) $3) in
+ mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (ApiAnn (glAR $1) NoApiAnns cs)) }
+
| aexp2 { $1 }
@@ -2847,15 +2860,15 @@ aexp2 :: { ECP }
: qvar { ECP $ mkHsVarPV $! $1 }
| qcon { ECP $ mkHsVarPV $! $1 }
-- See Note [%shift: aexp2 -> ipvar]
- | ipvar %shift { ecpFromExp $ sL1 $1 (HsIPVar noExtField $! unLoc $1) }
- | overloaded_label { ecpFromExp $ sL1 $1 (HsOverLabel noExtField $! unLoc $1) }
- | literal { ECP $ mkHsLitPV $! $1 }
+ | ipvar %shift {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) }
+ | overloaded_label {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) $! unLoc $1)) }
+ | literal { ECP $ pvA (mkHsLitPV $! $1) }
-- This will enable overloaded strings permanently. Normally the renamer turns HsString
-- into HsOverLit when -foverloaded-strings is on.
-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)
-- (getSTRING $1) noExtField) }
- | INTEGER { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) }
- | RATIONAL { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) }
+ | INTEGER { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) }
+ | RATIONAL { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) }
-- N.B.: sections get parsed by these next two productions.
-- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
@@ -2863,104 +2876,94 @@ aexp2 :: { ECP }
-- but the less cluttered version fell out of having texps.
| '(' texp ')' { ECP $
unECP $2 >>= \ $2 ->
- amms (mkHsParPV (comb2 $1 $>) $2) [mop $1,mcp $3] }
+ mkHsParPV (comb2 $1 $>) $2 (AnnParen AnnParens (glAA $1) (glAA $3)) }
| '(' tup_exprs ')' { ECP $
$2 >>= \ $2 ->
- amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2))
- ((mop $1:fst $2) ++ [mcp $3]) }
+ mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2
+ [mop $1,mcp $3]}
-- This case is only possible when 'OverloadedRecordDotBit' is enabled.
| '(' projection ')' { ECP $
- let (loc, (anns, fIELDS)) = $2
- span = combineSrcSpans (combineSrcSpans (getLoc $1) loc) (getLoc $3)
- expr = mkRdrProjection span (reverse fIELDS)
- in amms (ecpFromExp' expr) ([mop $1] ++ reverse anns ++ [mcp $3])
+ acsA (\cs -> sLL $1 $> $ mkRdrProjection (reverse (unLoc $2)) (ApiAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))
+ >>= ecpFromExp'
}
| '(#' texp '#)' { ECP $
unECP $2 >>= \ $2 ->
- amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)]))
- [mo $1,mc $3] }
+ mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2])
+ [moh $1,mch $3] }
| '(#' tup_exprs '#)' { ECP $
$2 >>= \ $2 ->
- amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (snd $2))
- ((mo $1:fst $2) ++ [mc $3]) }
+ mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2
+ [moh $1,mch $3] }
- | '[' list ']' { ECP $ $2 (comb2 $1 $>) >>= \a -> ams a [mos $1,mcs $3] }
- | '_' { ECP $ mkHsWildCardPV (getLoc $1) }
+ | '[' list ']' { ECP $ $2 (comb2 $1 $>) (mos $1,mcs $3) }
+ | '_' { ECP $ pvA $ mkHsWildCardPV (getLoc $1) }
-- Template Haskell Extension
- | splice_untyped { ECP $ mkHsSplicePV $1 }
- | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noExtField) $1 }
+ | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }
+ | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA $1) }
- | SIMPLEQUOTE qvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
- | SIMPLEQUOTE qcon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
- | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
- | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+ | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
+ | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
+ | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
+ | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
-- See Note [%shift: aexp2 -> TH_TY_QUOTE]
| TH_TY_QUOTE %shift {% reportEmptyDoubleQuotes (getLoc $1) }
| '[|' exp '|]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- ams (sLL $1 $> $ HsBracket noExtField (ExpBr noExtField $2))
- (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
- else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }
+ acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
+ else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) }
| '[||' exp '||]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- ams (sLL $1 $> $ HsBracket noExtField (TExpBr noExtField $2))
- (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
+ acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) (TExpBr noExtField $2)) }
| '[t|' ktype '|]' {% fmap ecpFromExp $
- ams (sLL $1 $> $ HsBracket noExtField (TypBr noExtField $2)) [mo $1,mu AnnCloseQ $3] }
+ acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }
| '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->
fmap ecpFromExp $
- ams (sLL $1 $> $ HsBracket noExtField (PatBr noExtField p))
- [mo $1,mu AnnCloseQ $3] }
+ acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }
| '[d|' cvtopbody '|]' {% fmap ecpFromExp $
- ams (sLL $1 $> $ HsBracket noExtField (DecBrL noExtField (snd $2)))
- (mo $1:mu AnnCloseQ $3:fst $2) }
- | quasiquote { ECP $ mkHsSplicePV $1 }
+ acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }
+ | quasiquote { ECP $ pvA $ mkHsSplicePV $1 }
-- arrow notation extension
| '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 ->
- fmap ecpFromCmd $
- ams (sLL $1 $> $ HsCmdArrForm noExtField $2 Prefix
- Nothing (reverse $3))
- [mu AnnOpenB $1,mu AnnCloseB $4] }
+ fmap ecpFromCmd $
+ acsA (\cs -> sLL $1 $> $ HsCmdArrForm (ApiAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix
+ Nothing (reverse $3)) }
-projection :: { (SrcSpan, ([AddAnn], [Located FastString])) }
+projection :: { Located [Located (HsFieldLabel GhcPs)] }
projection
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
: projection TIGHT_INFIX_PROJ field
- { let (loc, (anns, fs)) = $1 in
- (combineSrcSpans (combineSrcSpans loc (gl $2)) (gl $3), (mj AnnDot $2 : anns, $3 : fs)) }
- | PREFIX_PROJ field { (comb2 $1 $2, ([mj AnnDot $1], [$2])) }
+ {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) : unLoc $1)) }
+ | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> [sLL $1 $> $ HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2]) }
splice_exp :: { LHsExpr GhcPs }
- : splice_untyped { mapLoc (HsSpliceE noExtField) $1 }
- | splice_typed { mapLoc (HsSpliceE noExtField) $1 }
+ : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) }
+ | splice_typed { mapLoc (HsSpliceE noAnn) (reLocA $1) }
splice_untyped :: { Located (HsSplice GhcPs) }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
: PREFIX_DOLLAR aexp2 {% runPV (unECP $2) >>= \ $2 ->
- ams (sLL $1 $> $ mkUntypedSplice DollarSplice $2)
- [mj AnnDollar $1] }
+ acs (\cs -> sLLlA $1 $> $ mkUntypedSplice (ApiAnn (glR $1) [mj AnnDollar $1] cs) DollarSplice $2) }
splice_typed :: { Located (HsSplice GhcPs) }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
: PREFIX_DOLLAR_DOLLAR aexp2
{% runPV (unECP $2) >>= \ $2 ->
- ams (sLL $1 $> $ mkTypedSplice DollarSplice $2)
- [mj AnnDollarDollar $1] }
+ acs (\cs -> sLLlA $1 $> $ mkTypedSplice (ApiAnn (glR $1) [mj AnnDollarDollar $1] cs) DollarSplice $2) }
cmdargs :: { [LHsCmdTop GhcPs] }
: cmdargs acmd { $2 : $1 }
| {- empty -} { [] }
acmd :: { LHsCmdTop GhcPs }
- : aexp {% runPV (unECP $1) >>= \ cmd ->
+ : aexp {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->
runPV (checkCmdBlockArguments cmd) >>= \ _ ->
- return (sL1 cmd $ HsCmdTop noExtField cmd) }
+ return (sL1A cmd $ HsCmdTop noExtField cmd) }
-cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) }
+cvtopbody :: { ([AddApiAnn],[LHsDecl GhcPs]) }
: '{' cvtopdecls0 '}' { ([mj AnnOpenC $1
,mj AnnCloseC $3],$2) }
| vocurly cvtopdecls0 close { ([],$2) }
@@ -2974,7 +2977,7 @@ cvtopdecls0 :: { [LHsDecl GhcPs] }
-- "texp" is short for tuple expressions:
-- things that can appear unparenthesized as long as they're
--- inside parens or delimitted by commas
+-- inside parens or delimited by commas
texp :: { ECP }
: exp { $1 }
@@ -2994,62 +2997,58 @@ texp :: { ECP }
runPV (rejectPragmaPV $1) >>
runPV $2 >>= \ $2 ->
return $ ecpFromExp $
- sLL $1 $> $ SectionL noExtField $1 $2 }
+ reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (n2l $2) }
| qopm infixexp { ECP $
superInfixOp $
unECP $2 >>= \ $2 ->
$1 >>= \ $1 ->
- mkHsSectionR_PV (comb2 $1 $>) $1 $2 }
+ pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }
-- View patterns get parenthesized above
| exp '->' texp { ECP $
unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
- amms (mkHsViewPatPV (comb2 $1 $>) $1 $3) [mu AnnRarrow $2] }
+ mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }
-- Always at least one comma or bar.
-- Though this can parse just commas (without any expressions), it won't
-- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]
-- in GHC.Hs.Expr.
-tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) }
+tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }
: texp commas_tup_tail
{ unECP $1 >>= \ $1 ->
$2 >>= \ $2 ->
- do { addAnnotation (gl $1) AnnComma (fst $2)
- ; return ([],Tuple ((sL1 $1 (Just $1)) : snd $2)) } }
-
- | texp bars { unECP $1 >>= \ $1 -> return $
- (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) }
-
+ do { t <- amsA $1 [AddCommaAnn (AR $ rs $ fst $2)]
+ ; return (Tuple (Right t : snd $2)) } }
| commas tup_tail
{ $2 >>= \ $2 ->
- do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
- ; return
- ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } }
+ do { let {cos = map (\ll -> (Left (ApiAnn (anc $ rs ll) (AR $ rs ll) noCom))) (fst $1) }
+ ; return (Tuple (cos ++ $2)) } }
+
+ | texp bars { unECP $1 >>= \ $1 -> return $
+ (Sum 1 (snd $2 + 1) $1 [] (fst $2)) }
| bars texp bars0
{ unECP $2 >>= \ $2 -> return $
- (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) }
+ (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 (fst $1) (fst $3)) }
-- Always starts with commas; always follows an expr
-commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))]) }
+commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (ApiAnn' AnnAnchor) (LocatedA b)]) }
commas_tup_tail : commas tup_tail
{ $2 >>= \ $2 ->
- do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)
- ; return (
- (head $ fst $1
- ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } }
+ do { let {cos = map (\l -> (Left (ApiAnn (anc $ rs l) (AR $ rs l) noCom))) (tail $ fst $1) }
+ ; return ((head $ fst $1, cos ++ $2)) } }
-- Always follows a comma
-tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] }
+tup_tail :: { forall b. DisambECP b => PV [Either (ApiAnn' AnnAnchor) (LocatedA b)] }
: texp commas_tup_tail { unECP $1 >>= \ $1 ->
$2 >>= \ $2 ->
- addAnnotation (gl $1) AnnComma (fst $2) >>
- return ((L (gl $1) (Just $1)) : snd $2) }
+ do { t <- amsA $1 [AddCommaAnn (AR $ rs $ fst $2)]
+ ; return (Right t : snd $2) } }
| texp { unECP $1 >>= \ $1 ->
- return [L (gl $1) (Just $1)] }
+ return [Right $1] }
-- See Note [%shift: tup_tail -> {- empty -}]
- | {- empty -} %shift { return [noLoc Nothing] }
+ | {- empty -} %shift { return [Left noAnn] }
-----------------------------------------------------------------------------
-- List expressions
@@ -3057,51 +3056,48 @@ tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] }
-- The rules below are little bit contorted to keep lexps left-recursive while
-- avoiding another shift/reduce-conflict.
-- Never empty.
-list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) }
- : texp { \loc -> unECP $1 >>= \ $1 ->
- mkHsExplicitListPV loc [$1] }
- | lexps { \loc -> $1 >>= \ $1 ->
- mkHsExplicitListPV loc (reverse $1) }
- | texp '..' { \loc -> unECP $1 >>= \ $1 ->
- ams (L loc $ ArithSeq noExtField Nothing (From $1))
- [mj AnnDotdot $2]
+list :: { forall b. DisambECP b => SrcSpan -> (AddApiAnn, AddApiAnn) -> PV (LocatedA b) }
+ : texp { \loc (ao,ac) -> unECP $1 >>= \ $1 ->
+ mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] []) }
+ | lexps { \loc (ao,ac) -> $1 >>= \ $1 ->
+ mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) }
+ | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 ->
+ acsA (\cs -> L loc $ ArithSeq (ApiAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (From $1))
>>= ecpFromExp' }
- | texp ',' exp '..' { \loc ->
+ | texp ',' exp '..' { \loc (ao,ac) ->
unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
- ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3))
- [mj AnnComma $2,mj AnnDotdot $4]
+ acsA (\cs -> L loc $ ArithSeq (ApiAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThen $1 $3))
>>= ecpFromExp' }
- | texp '..' exp { \loc -> unECP $1 >>= \ $1 ->
+ | texp '..' exp { \loc (ao,ac) ->
+ unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
- ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3))
- [mj AnnDotdot $2]
+ acsA (\cs -> L loc $ ArithSeq (ApiAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (FromTo $1 $3))
>>= ecpFromExp' }
- | texp ',' exp '..' exp { \loc ->
+ | texp ',' exp '..' exp { \loc (ao,ac) ->
unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
unECP $5 >>= \ $5 ->
- ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))
- [mj AnnComma $2,mj AnnDotdot $4]
+ acsA (\cs -> L loc $ ArithSeq (ApiAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThenTo $1 $3 $5))
>>= ecpFromExp' }
| texp '|' flattenedpquals
- { \loc ->
+ { \loc (ao,ac) ->
checkMonadComp >>= \ ctxt ->
- unECP $1 >>= \ $1 ->
- ams (L loc $ mkHsComp ctxt (unLoc $3) $1)
- [mj AnnVbar $2]
- >>= ecpFromExp' }
+ unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2)
+ ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc $3) t (ApiAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs))
+ >>= ecpFromExp' } }
-lexps :: { forall b. DisambECP b => PV [Located b] }
+lexps :: { forall b. DisambECP b => PV [LocatedA b] }
: lexps ',' texp { $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
- addAnnotation (gl $ head $ $1)
- AnnComma (gl $2) >>
- return (((:) $! $3) $! $1) }
+ case $1 of
+ (h:t) -> do
+ h' <- addTrailingCommaA h (gl $2)
+ return (((:) $! $3) $! (h':t)) }
| texp ',' texp { unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
- addAnnotation (gl $1) AnnComma (gl $2) >>
- return [$3,$1] }
+ do { h <- addTrailingCommaA $1 (gl $2)
+ ; return [$3,h] }}
-----------------------------------------------------------------------------
-- List Comprehensions
@@ -3112,7 +3108,7 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
- qss -> sL1 $1 [sL1 $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |
+ qss -> sL1 $1 [sL1a $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |
qs <- qss]
noExpr noSyntaxExpr]
-- We actually found some actual parallel lists so
@@ -3121,24 +3117,28 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }
: squals '|' pquals
- {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >>
- return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) }
+ {% case unLoc $1 of
+ (h:t) -> do
+ h' <- addTrailingVbarA h (gl $2)
+ return (sLL $1 $> (reverse (h':t) : unLoc $3)) }
| squals { L (getLoc $1) [reverse (unLoc $1)] }
squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last
-- one can "grab" the earlier ones
: squals ',' transformqual
- {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
- amsL (comb2 $1 $>) (fst $ unLoc $3) >>
- return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
+ {% case unLoc $1 of
+ (h:t) -> do
+ h' <- addTrailingCommaA h (gl $2)
+ return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (glRR $1) (reverse (h':t)))]) }
| squals ',' qual
{% runPV $3 >>= \ $3 ->
- 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) [])]) }
+ case unLoc $1 of
+ (h:t) -> do
+ h' <- addTrailingCommaA h (gl $2)
+ return (sLL $1 (reLoc $>) ($3 : (h':t))) }
+ | transformqual {% return (sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])]) }
| qual {% runPV $1 >>= \ $1 ->
- return $ sL1 $1 [$1] }
+ return $ sL1A $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
-- | '{|' pquals '|}' { sL1 $1 [$2] }
@@ -3147,24 +3147,25 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau
-- consensus on the syntax, this feature is not being used until we
-- get user demand.
-transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }
+transformqual :: { Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }
-- Function is applied to a list of stmts *in order*
- : 'then' exp {% runPV (unECP $2) >>= \ $2 -> return $
- sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) }
+ : 'then' exp {% runPV (unECP $2) >>= \ $2 ->
+ acs (\cs->
+ sLLlA $1 $> (\r ss -> (mkTransformStmt (ApiAnn (anc r) [mj AnnThen $1] cs) ss $2))) }
| 'then' exp 'by' exp {% runPV (unECP $2) >>= \ $2 ->
runPV (unECP $4) >>= \ $4 ->
- return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy $3],
- \ss -> (mkTransformByStmt ss $2 $4)) }
+ acs (\cs -> sLLlA $1 $> (
+ \r ss -> (mkTransformByStmt (ApiAnn (anc r) [mj AnnThen $1,mj AnnBy $3] cs) ss $2 $4))) }
| 'then' 'group' 'using' exp
{% runPV (unECP $4) >>= \ $4 ->
- return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3],
- \ss -> (mkGroupUsingStmt ss $4)) }
+ acs (\cs -> sLLlA $1 $> (
+ \r ss -> (mkGroupUsingStmt (ApiAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] cs) ss $4))) }
| 'then' 'group' 'by' exp 'using' exp
{% runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
- return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5],
- \ss -> (mkGroupByUsingStmt ss $4 $6)) }
+ acs (\cs -> sLLlA $1 $> (
+ \r ss -> (mkGroupByUsingStmt (ApiAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] cs) ss $4 $6))) }
-- Note that 'group' is a special_id, which means that you can enable
-- TransformListComp while still using Data.List.group. However, this
@@ -3179,70 +3180,70 @@ guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 ',' qual {% runPV $3 >>= \ $3 ->
- addAnnotation (gl $ head $ unLoc $1) AnnComma
- (gl $2) >>
- return (sLL $1 $> ($3 : unLoc $1)) }
+ case unLoc $1 of
+ (h:t) -> do
+ h' <- addTrailingCommaA h (gl $2)
+ return (sLL $1 (reLoc $>) ($3 : (h':t))) }
| qual {% runPV $1 >>= \ $1 ->
- return $ sL1 $1 [$1] }
+ return $ sL1A $1 [$1] }
-----------------------------------------------------------------------------
-- Case alternatives
-altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }
- : '{' alts '}' { $2 >>= \ $2 -> return $
- sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
- ,(reverse (snd $ unLoc $2))) }
- | vocurly alts close { $2 >>= \ $2 -> return $
- L (getLoc $2) (fst $ unLoc $2
- ,(reverse (snd $ unLoc $2))) }
- | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) }
- | vocurly close { return $ noLoc ([],[]) }
-
-alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }
+altslist :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }
+ : '{' alts '}' { $2 >>= \ $2 -> amsrl
+ (sLL $1 $> (reverse (snd $ unLoc $2)))
+ (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }
+ | vocurly alts close { $2 >>= \ $2 -> amsrl
+ (L (getLoc $2) (reverse (snd $ unLoc $2)))
+ (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }
+ | '{' '}' { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }
+ | vocurly close { return $ noLocA [] }
+
+alts :: { forall b. DisambECP b => PV (Located ([AddApiAnn],[LMatch GhcPs (LocatedA b)])) }
: alts1 { $1 >>= \ $1 -> return $
sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts { $2 >>= \ $2 -> return $
- sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2))
+ sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2))
,snd $ unLoc $2) }
-alts1 :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }
+alts1 :: { forall b. DisambECP b => PV (Located ([AddApiAnn],[LMatch GhcPs (LocatedA b)])) }
: alts1 ';' alt { $1 >>= \ $1 ->
$3 >>= \ $3 ->
- if null (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
- ,[$3]))
- else (ams (head $ snd $ unLoc $1)
- (mj AnnSemi $2:(fst $ unLoc $1))
- >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) }
+ case snd $ unLoc $1 of
+ [] -> return (sLL $1 (reLoc $>) ((mz AnnSemi $2) ++(fst $ unLoc $1)
+ ,[$3]))
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) }
| alts1 ';' { $1 >>= \ $1 ->
- if null (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
- ,snd $ unLoc $1))
- else (ams (head $ snd $ unLoc $1)
- (mj AnnSemi $2:(fst $ unLoc $1))
- >> return (sLL $1 $> ([],snd $ unLoc $1))) }
- | alt { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) }
-
-alt :: { forall b. DisambECP b => PV (LMatch GhcPs (Located b)) }
+ case snd $ unLoc $1 of
+ [] -> return (sLL $1 $> ((mz AnnSemi $2) ++(fst $ unLoc $1)
+ ,[]))
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (sLL $1 $> (fst $ unLoc $1, h' : t)) }
+ | alt { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) }
+
+alt :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }
: pat alt_rhs { $2 >>= \ $2 ->
- ams (sLL $1 $> (Match { m_ext = noExtField
+ acsA (\cs -> sLL (reLoc $1) $>
+ (Match { m_ext = (ApiAnn (glAR $1) [] cs)
, m_ctxt = CaseAlt
, m_pats = [$1]
- , m_grhss = snd $ unLoc $2 }))
- (fst $ unLoc $2)}
+ , m_grhss = unLoc $2 }))}
-alt_rhs :: { forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b))) }
+alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
: ralt wherebinds { $1 >>= \alt ->
- return $ sLL alt $> (fst $ unLoc $2, GRHSs noExtField (unLoc alt) (snd $ unLoc $2)) }
+ return $ sLL alt (adaptWhereBinds $>) (GRHSs noExtField (unLoc alt) (unLoc $ adaptWhereBinds $2)) }
-ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) }
+ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
: '->' exp { unECP $2 >>= \ $2 ->
- ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
- [mu AnnRarrow $1] }
+ acs (\cs -> sLLlA $1 $> (unguardedRHS (ApiAnn (glR $1) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }
| gdpats { $1 >>= \gdpats ->
return $ sL1 gdpats (reverse (unLoc gdpats)) }
-gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) }
+gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
: gdpats gdpat { $1 >>= \gdpats ->
$2 >>= \gdpat ->
return $ sLL gdpats gdpat (gdpat : unLoc gdpats) }
@@ -3251,17 +3252,16 @@ gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) }
-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to
-- generate the open brace in addition to the vertical bar in the lexer, and
-- we don't need it.
-ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
+ifgdpats :: { Located ([AddApiAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
: '{' gdpats '}' {% runPV $2 >>= \ $2 ->
return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2) }
| gdpats close {% runPV $1 >>= \ $1 ->
return $ sL1 $1 ([],unLoc $1) }
-gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) }
+gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }
: '|' guardquals '->' exp
{ unECP $4 >>= \ $4 ->
- ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4)
- [mj AnnVbar $1,mu AnnRarrow $3] }
+ acs (\cs -> sL (comb2A $1 $>) $ GRHS (ApiAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) }
-- 'pat' recognises a pattern, including one with a bang at the top
-- e.g. "!x" or "!(x,y)" or "C a b" etc
@@ -3285,13 +3285,11 @@ apats :: { [LPat GhcPs] }
-----------------------------------------------------------------------------
-- Statement sequences
-stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) }
- : '{' stmts '}' { $2 >>= \ $2 -> return $
- sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
- ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?
- | vocurly stmts close { $2 >>= \ $2 -> return $
- L (gl $2) (fst $ unLoc $2
- ,reverse $ snd $ unLoc $2) }
+stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }
+ : '{' stmts '}' { $2 >>= \ $2 -> amsrl
+ (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)) } -- AZ:performance of reverse?
+ | vocurly stmts close { $2 >>= \ $2 -> amsrl
+ (L (gl $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)) }
-- do { ;; s ; s ; ; s ;; }
-- The last Stmt should be an expression, but that's hard to enforce
@@ -3299,26 +3297,24 @@ stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Locat
-- So we use BodyStmts throughout, and switch the last one over
-- in ParseUtils.checkDo instead
-stmts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) }
+stmts :: { forall b. DisambECP b => PV (Located ([TrailingAnn],[LStmt GhcPs (LocatedA b)])) }
: stmts ';' stmt { $1 >>= \ $1 ->
- $3 >>= \ $3 ->
- if null (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
- ,$3 : (snd $ unLoc $1)))
- else do
- { ams (head $ snd $ unLoc $1) [mj AnnSemi $2]
- ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }}
+ $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) ->
+ case (snd $ unLoc $1) of
+ [] -> return (sLL $1 (reLoc $>) ((msemi $2) ++ (fst $ unLoc $1)
+ ,$3 : (snd $ unLoc $1)))
+ (h:t) -> do
+ { h' <- addTrailingSemiA h (gl $2)
+ ; return $ sLL $1 (reLoc $>) (fst $ unLoc $1,$3 :(h':t)) }}
| stmts ';' { $1 >>= \ $1 ->
- if null (snd $ unLoc $1)
- then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1))
- else do
- { ams (head $ snd $ unLoc $1)
- [mj AnnSemi $2]
- ; return $1 }
- }
+ case (snd $ unLoc $1) of
+ [] -> return (sLL $1 $> ((msemi $2) ++ (fst $ unLoc $1),snd $ unLoc $1))
+ (h:t) -> do
+ { h' <- addTrailingSemiA h (gl $2)
+ ; return $ sL1 $1 (fst $ unLoc $1,h':t) }}
| stmt { $1 >>= \ $1 ->
- return $ sL1 $1 ([],[$1]) }
+ return $ sL1A $1 ([],[$1]) }
| {- empty -} { return $ noLoc ([],[]) }
@@ -3332,100 +3328,110 @@ maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }
e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
: stmt {% runPV $1 }
-stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
+stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: qual { $1 }
| 'rec' stmtlist { $2 >>= \ $2 ->
- ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2))
- (mj AnnRec $1:(fst $ unLoc $2)) }
+ acsA (\cs -> (sLL $1 (reLoc $>) $ mkRecStmt
+ (ApiAnn (glR $1) (hsDoAnn $1 $2 AnnRec) cs)
+ $2)) }
-qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
+qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: bindpat '<-' exp { unECP $3 >>= \ $3 ->
- ams (sLL $1 $> $ mkPsBindStmt $1 $3)
- [mu AnnLarrow $2] }
+ acsA (\cs -> sLLlA (reLoc $1) $>
+ $ mkPsBindStmt (ApiAnn (glAR $1) [mu AnnLarrow $2] cs) $1 $3) }
| exp { unECP $1 >>= \ $1 ->
return $ sL1 $1 $ mkBodyStmt $1 }
- | 'let' binds { ams (sLL $1 $> $ LetStmt noExtField (snd $ unLoc $2))
- (mj AnnLet $1:(fst $ unLoc $2)) }
+ | 'let' binds { acsA (\cs -> (sLL $1 $>
+ $ mkLetStmt (ApiAnn (glR $1) [mj AnnLet $1] cs) (unLoc $2))) }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
-fbinds :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) }
+fbinds :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }
: fbinds1 { $1 }
- | {- empty -} { return ([],([], Nothing)) }
+ | {- empty -} { return ([], Nothing) }
-fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) }
+fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }
: fbind ',' fbinds1
{ $1 >>= \ $1 ->
- $3 >>= \ $3 ->
- let gl' = \case { Left (L l _) -> l; Right (L l _) -> l } in
- addAnnotation (gl' $1) AnnComma (gl $2) >>
- return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) }
+ $3 >>= \ $3 -> do
+ h <- addTrailingCommaFBind $1 (gl $2)
+ return (case $3 of (flds, dd) -> (h : flds, dd)) }
| fbind { $1 >>= \ $1 ->
- return ([],([$1], Nothing)) }
- | '..' { return ([mj AnnDotdot $1],([], Just (getLoc $1))) }
+ return ([$1], Nothing) }
+ | '..' { return ([], Just (getLoc $1)) }
fbind :: { forall b. DisambECP b => PV (Fbind b) }
: qvar '=' texp { unECP $3 >>= \ $3 ->
- fmap Left $ ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) [mj AnnEqual $2]
- }
+ fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsRecField (ApiAnn (glNR $1) [mj AnnEqual $2] cs) (sL1N $1 $ mkFieldOcc $1) $3 False) }
-- RHS is a 'texp', allowing view patterns (#6038)
-- and, incidentally, sections. Eg
-- f (R { x = show -> s }) = ...
| qvar { placeHolderPunRhs >>= \rhs ->
- fmap Left $ return (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True)
- }
+ fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsRecField (ApiAnn (glNR $1) [] cs) (sL1N $1 $ mkFieldOcc $1) rhs True) }
-- In the punning case, use a place-holder
-- The renamer fills in the final value
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
+ -- AZ: need to pull out the let block into a helper
| field TIGHT_INFIX_PROJ fieldToUpdate '=' texp
{ do
- let top = $1
- fields = top : reverse $3
+ let top = sL1 $1 $ HsFieldLabel noAnn $1
+ ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)
+ lf' = comb2 $2 (L lf ())
+ fields = top : L lf' (HsFieldLabel (ApiAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) noCom) f) : t
final = last fields
- l = comb2 top final
+ l = comb2 $1 $3
isPun = False
$5 <- unECP $5
- fmap Right $ mkHsProjUpdatePV (comb2 $1 $5) (L l fields) $5 isPun
+ fmap Right $ mkHsProjUpdatePV (comb2 $1 (reLoc $5)) (L l fields) $5 isPun
+ [mj AnnEqual $4]
}
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
+ -- AZ: need to pull out the let block into a helper
| field TIGHT_INFIX_PROJ fieldToUpdate
{ do
- let top = $1
- fields = top : reverse $3
+ let top = sL1 $1 $ HsFieldLabel noAnn $1
+ ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)
+ lf' = comb2 $2 (L lf ())
+ fields = top : L lf' (HsFieldLabel (ApiAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) noCom) f) : t
final = last fields
- l = comb2 top final
+ l = comb2 $1 $3
isPun = True
- var <- mkHsVarPV (noLoc (mkRdrUnqual . mkVarOcc . unpackFS . unLoc $ final))
- fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun
+ var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . hflLabel . unLoc $ final))
+ fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []
}
-fieldToUpdate :: { [Located FastString] }
+fieldToUpdate :: { Located [Located (HsFieldLabel GhcPs)] }
fieldToUpdate
-- See Note [Whitespace-sensitive operator parsing] in Lexer.x
- : fieldToUpdate TIGHT_INFIX_PROJ field { $3 : $1 }
- | field { [$1] }
+ : fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLoc $3) >>= \cs ->
+ return (sLL $1 $> ((sLL $2 $> (HsFieldLabel (ApiAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }
+ | field {% getCommentsFor (getLoc $1) >>= \cs ->
+ return (sL1 $1 [sL1 $1 (HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) }
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
-dbinds :: { Located [LIPBind GhcPs] }
+dbinds :: { Located [LIPBind GhcPs] } -- reversed
: dbinds ';' dbind
- {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >>
- return (let { this = $3; rest = unLoc $1 }
- in rest `seq` this `seq` sLL $1 $> (this : rest)) }
- | dbinds ';' {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >>
- return (sLL $1 $> (unLoc $1)) }
- | dbind { let this = $1 in this `seq` sL1 $1 [this] }
+ {% case unLoc $1 of
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (let { this = $3; rest = h':t }
+ in rest `seq` this `seq` sLL $1 (reLoc $>) (this : rest)) }
+ | dbinds ';' {% case unLoc $1 of
+ (h:t) -> do
+ h' <- addTrailingSemiA h (gl $2)
+ return (sLL $1 $> (h':t)) }
+ | dbind { let this = $1 in this `seq` (sL1 (reLoc $1) [this]) }
-- | {- empty -} { [] }
dbind :: { LIPBind GhcPs }
dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 ->
- ams (sLL $1 $> (IPBind noExtField (Left $1) $3))
- [mj AnnEqual $2] }
+ acsA (\cs -> sLLlA $1 $> (IPBind (ApiAnn (glR $1) [mj AnnEqual $2] cs) (Left $1) $3)) }
ipvar :: { Located HsIPName }
: IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
@@ -3439,35 +3445,37 @@ overloaded_label :: { Located FastString }
-----------------------------------------------------------------------------
-- Warnings and deprecations
-name_boolformula_opt :: { LBooleanFormula (Located RdrName) }
+name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }
: name_boolformula { $1 }
- | {- empty -} { noLoc mkTrue }
+ | {- empty -} { noLocA mkTrue }
-name_boolformula :: { LBooleanFormula (Located RdrName) }
+name_boolformula :: { LBooleanFormula (LocatedN RdrName) }
: name_boolformula_and { $1 }
| name_boolformula_and '|' name_boolformula
- {% aa $1 (AnnVbar, $2)
- >> return (sLL $1 $> (Or [$1,$3])) }
+ {% do { h <- addTrailingVbarL $1 (gl $2)
+ ; return (reLocA $ sLLAA $1 $> (Or [h,$3])) } }
-name_boolformula_and :: { LBooleanFormula (Located RdrName) }
+name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }
: name_boolformula_and_list
- { sLL (head $1) (last $1) (And ($1)) }
+ { reLocA $ sLLAA (head $1) (last $1) (And ($1)) }
-name_boolformula_and_list :: { [LBooleanFormula (Located RdrName)] }
+name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }
: name_boolformula_atom { [$1] }
| name_boolformula_atom ',' name_boolformula_and_list
- {% aa $1 (AnnComma, $2) >> return ($1 : $3) }
+ {% do { h <- addTrailingCommaL $1 (gl $2)
+ ; return (h : $3) } }
-name_boolformula_atom :: { LBooleanFormula (Located RdrName) }
- : '(' name_boolformula ')' {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] }
- | name_var { sL1 $1 (Var $1) }
+name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }
+ : '(' name_boolformula ')' {% amsrl (sLL $1 $> (Parens $2))
+ (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }
+ | name_var { reLocA $ sL1N $1 (Var $1) }
-namelist :: { Located [Located RdrName] }
-namelist : name_var { sL1 $1 [$1] }
- | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >>
- return (sLL $1 $> ($1 : unLoc $3)) }
+namelist :: { Located [LocatedN RdrName] }
+namelist : name_var { sL1N $1 [$1] }
+ | name_var ',' namelist {% do { h <- addTrailingCommaN $1 (gl $2)
+ ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}
-name_var :: { Located RdrName }
+name_var :: { LocatedN RdrName }
name_var : var { $1 }
| con { $1 }
@@ -3476,55 +3484,53 @@ name_var : var { $1 }
-- There are two different productions here as lifted list constructors
-- are parsed differently.
-qcon_nowiredlist :: { Located RdrName }
+qcon_nowiredlist :: { LocatedN RdrName }
: gen_qcon { $1 }
- | sysdcon_nolist { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+ | sysdcon_nolist { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }
-qcon :: { Located RdrName }
+qcon :: { LocatedN RdrName }
: gen_qcon { $1}
- | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+ | sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }
-gen_qcon :: { Located RdrName }
+gen_qcon :: { LocatedN RdrName }
: qconid { $1 }
- | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
+ | '(' qconsym ')' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }
-con :: { Located RdrName }
+con :: { LocatedN RdrName }
: conid { $1 }
- | '(' consym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
- | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+ | '(' consym ')' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }
+ | sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }
-con_list :: { Located [Located RdrName] }
-con_list : con { sL1 $1 [$1] }
- | con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >>
- return (sLL $1 $> ($1 : unLoc $3)) }
+con_list :: { Located [LocatedN RdrName] }
+con_list : con { sL1N $1 [$1] }
+ | con ',' con_list {% do { h <- addTrailingCommaN $1 (gl $2)
+ ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}
-- See Note [ExplicitTuple] in GHC.Hs.Expr
-sysdcon_nolist :: { Located DataCon } -- Wired in data constructors
- : '(' ')' {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] }
- | '(' commas ')' {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))
- (mop $1:mcp $3:(mcommas (fst $2))) }
- | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] }
- | '(#' commas '#)' {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))
- (mo $1:mc $3:(mcommas (fst $2))) }
+sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors
+ : '(' ')' {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }
+ | '(' commas ')' {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))
+ (NameAnnCommas NameParens (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) }
+ | '(#' '#)' {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }
+ | '(#' commas '#)' {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))
+ (NameAnnCommas NameParensHash (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) }
-- See Note [Empty lists] in GHC.Hs.Expr
-sysdcon :: { Located DataCon }
+sysdcon :: { LocatedN DataCon }
: sysdcon_nolist { $1 }
- | '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] }
+ | '[' ']' {% amsrn (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }
-conop :: { Located RdrName }
+conop :: { LocatedN RdrName }
: consym { $1 }
- | '`' conid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
+ | '`' conid '`' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }
-qconop :: { Located RdrName }
+qconop :: { LocatedN RdrName }
: qconsym { $1 }
- | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
+ | '`' qconid '`' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }
----------------------------------------------------------------------------
-- Type constructors
@@ -3532,44 +3538,45 @@ qconop :: { Located RdrName }
-- See Note [Unit tuples] in GHC.Hs.Type for the distinction
-- between gtycon and ntgtycon
-gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples
+gtycon :: { LocatedN RdrName } -- A "general" qualified tycon, including unit tuples
: ntgtycon { $1 }
- | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon)
- [mop $1,mcp $2] }
- | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)
- [mo $1,mc $2] }
+ | '(' ')' {% amsrn (sLL $1 $> $ getRdrName unitTyCon)
+ (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }
+ | '(#' '#)' {% amsrn (sLL $1 $> $ getRdrName unboxedUnitTyCon)
+ (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }
-ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples
+ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit tuples
: oqtycon { $1 }
- | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed
+ | '(' commas ')' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed
(snd $2 + 1)))
- (mop $1:mcp $3:(mcommas (fst $2))) }
- | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
+ (NameAnnCommas NameParens (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) }
+ | '(#' commas '#)' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
(snd $2 + 1)))
- (mo $1:mc $3:(mcommas (fst $2))) }
- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- [mop $1,mu AnnRarrow $2,mcp $3] }
- | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }
+ (NameAnnCommas NameParensHash (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) }
+ | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
+ (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ | '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR)
+ (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }
-oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon;
+oqtycon :: { LocatedN RdrName } -- An "ordinary" qualified tycon;
-- These can appear in export lists
: qtycon { $1 }
- | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
+ | '(' qtyconsym ')' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }
-oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mistaken
+oqtycon_no_varcon :: { LocatedN RdrName } -- Type constructor which cannot be mistaken
-- for variable constructor in export lists
-- see Note [Type constructors in export list]
: qtycon { $1 }
| '(' 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] }
+ in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
| '(' 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] }
+ in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
| '(' ':' ')' {% let { name :: Located RdrName
; name = sL1 $2 $! consDataCon_RDR }
- in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
+ in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
{- Note [Type constructors in export list]
~~~~~~~~~~~~~~~~~~~~~
@@ -3591,101 +3598,95 @@ until after renaming when we resolve the proper namespace for each exported
child.
-}
-qtyconop :: { Located RdrName } -- Qualified or unqualified
+qtyconop :: { LocatedN RdrName } -- Qualified or unqualified
-- See Note [%shift: qtyconop -> qtyconsym]
: qtyconsym %shift { $1 }
- | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
+ | '`' qtycon '`' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }
-qtycon :: { Located RdrName } -- Qualified or unqualified
- : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) }
+qtycon :: { LocatedN RdrName } -- Qualified or unqualified
+ : QCONID { sL1n $1 $! mkQual tcClsName (getQCONID $1) }
| tycon { $1 }
-tycon :: { Located RdrName } -- Unqualified
- : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
+tycon :: { LocatedN RdrName } -- Unqualified
+ : CONID { sL1n $1 $! mkUnqual tcClsName (getCONID $1) }
-qtyconsym :: { Located RdrName }
- : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) }
- | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) }
+qtyconsym :: { LocatedN RdrName }
+ : QCONSYM { sL1n $1 $! mkQual tcClsName (getQCONSYM $1) }
+ | QVARSYM { sL1n $1 $! mkQual tcClsName (getQVARSYM $1) }
| tyconsym { $1 }
-tyconsym :: { Located RdrName }
- : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
- | VARSYM { sL1 $1 $!
+tyconsym :: { LocatedN RdrName }
+ : CONSYM { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) }
+ | VARSYM { sL1n $1 $!
-- See Note [eqTyCon (~) is built-in syntax] in GHC.Builtin.Types
if getVARSYM $1 == fsLit "~"
then eqTyCon_RDR
else mkUnqual tcClsName (getVARSYM $1) }
- | ':' { sL1 $1 $! consDataCon_RDR }
- | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
- | '.' { sL1 $1 $! mkUnqual tcClsName (fsLit ".") }
+ | ':' { sL1n $1 $! consDataCon_RDR }
+ | '-' { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }
+ | '.' { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }
-- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version.
-- These can appear in `ANN type` declarations (#19374).
-otycon :: { Located RdrName }
+otycon :: { LocatedN RdrName }
: tycon { $1 }
- | '(' tyconsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
+ | '(' tyconsym ')' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }
-----------------------------------------------------------------------------
-- Operators
-op :: { Located RdrName } -- used in infix decls
+op :: { LocatedN RdrName } -- used in infix decls
: varop { $1 }
| conop { $1 }
- | '->' { sL1 $1 $ getRdrName unrestrictedFunTyCon }
+ | '->' { sL1n $1 $ getRdrName unrestrictedFunTyCon }
-varop :: { Located RdrName }
+varop :: { LocatedN RdrName }
: varsym { $1 }
- | '`' varid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
+ | '`' varid '`' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }
-qop :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections
+qop :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in sections
: qvarop { mkHsVarOpPV $1 }
| qconop { mkHsConOpPV $1 }
- | hole_op { $1 }
+ | hole_op { pvN $1 }
-qopm :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections
+qopm :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in sections
: qvaropm { mkHsVarOpPV $1 }
| qconop { mkHsConOpPV $1 }
- | hole_op { $1 }
+ | hole_op { pvN $1 }
hole_op :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections
-hole_op : '`' '_' '`' { amms (mkHsInfixHolePV (comb2 $1 $>))
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
+hole_op : '`' '_' '`' { mkHsInfixHolePV (comb2 $1 $>)
+ (\cs -> ApiAnn (glR $1) (ApiAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) }
-qvarop :: { Located RdrName }
+qvarop :: { LocatedN RdrName }
: qvarsym { $1 }
- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
+ | '`' qvarid '`' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }
-qvaropm :: { Located RdrName }
+qvaropm :: { LocatedN RdrName }
: qvarsym_no_minus { $1 }
- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
+ | '`' qvarid '`' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }
-----------------------------------------------------------------------------
-- Type variables
-tyvar :: { Located RdrName }
+tyvar :: { LocatedN RdrName }
tyvar : tyvarid { $1 }
-tyvarop :: { Located RdrName }
-tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2))
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
-
-tyvarid :: { Located RdrName }
- : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) }
- | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) }
- | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") }
- | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") }
- | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") }
+tyvarop :: { LocatedN RdrName }
+tyvarop : '`' tyvarid '`' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }
+
+tyvarid :: { LocatedN RdrName }
+ : VARID { sL1n $1 $! mkUnqual tvName (getVARID $1) }
+ | special_id { sL1n $1 $! mkUnqual tvName (unLoc $1) }
+ | 'unsafe' { sL1n $1 $! mkUnqual tvName (fsLit "unsafe") }
+ | 'safe' { sL1n $1 $! mkUnqual tvName (fsLit "safe") }
+ | 'interruptible' { sL1n $1 $! mkUnqual tvName (fsLit "interruptible") }
-- If this changes relative to varid, update 'checkRuleTyVarBndrNames'
-- in GHC.Parser.PostProcess
-- See Note [Parsing explicit foralls in Rules]
@@ -3693,17 +3694,17 @@ tyvarid :: { Located RdrName }
-----------------------------------------------------------------------------
-- Variables
-var :: { Located RdrName }
+var :: { LocatedN RdrName }
: varid { $1 }
- | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
+ | '(' varsym ')' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }
-qvar :: { Located RdrName }
+qvar :: { LocatedN RdrName }
: qvarid { $1 }
- | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
- | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2))
- [mop $1,mj AnnVal $2,mcp $3] }
+ | '(' varsym ')' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }
+ | '(' qvarsym1 ')' {% amsrn (sLL $1 $> (unLoc $2))
+ (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }
-- We've inlined qvarsym here so that the decision about
-- whether it's a qvar or a var can be postponed until
-- *after* we see the close paren.
@@ -3711,45 +3712,45 @@ qvar :: { Located RdrName }
field :: { Located FastString }
: VARID { sL1 $1 $! getVARID $1 }
-qvarid :: { Located RdrName }
+qvarid :: { LocatedN RdrName }
: varid { $1 }
- | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) }
+ | QVARID { sL1n $1 $! mkQual varName (getQVARID $1) }
-- Note that 'role' and 'family' get lexed separately regardless of
-- the use of extensions. However, because they are listed here,
-- this is OK and they can be used as normal varids.
-- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer
-varid :: { Located RdrName }
- : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) }
- | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) }
- | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") }
- | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") }
- | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible")}
- | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") }
- | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") }
- | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") }
+varid :: { LocatedN RdrName }
+ : VARID { sL1n $1 $! mkUnqual varName (getVARID $1) }
+ | special_id { sL1n $1 $! mkUnqual varName (unLoc $1) }
+ | 'unsafe' { sL1n $1 $! mkUnqual varName (fsLit "unsafe") }
+ | 'safe' { sL1n $1 $! mkUnqual varName (fsLit "safe") }
+ | 'interruptible' { sL1n $1 $! mkUnqual varName (fsLit "interruptible")}
+ | 'forall' { sL1n $1 $! mkUnqual varName (fsLit "forall") }
+ | 'family' { sL1n $1 $! mkUnqual varName (fsLit "family") }
+ | 'role' { sL1n $1 $! mkUnqual varName (fsLit "role") }
-- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'
-- in GHC.Parser.PostProcess
-- See Note [Parsing explicit foralls in Rules]
-qvarsym :: { Located RdrName }
+qvarsym :: { LocatedN RdrName }
: varsym { $1 }
| qvarsym1 { $1 }
-qvarsym_no_minus :: { Located RdrName }
+qvarsym_no_minus :: { LocatedN RdrName }
: varsym_no_minus { $1 }
| qvarsym1 { $1 }
-qvarsym1 :: { Located RdrName }
-qvarsym1 : QVARSYM { sL1 $1 $ mkQual varName (getQVARSYM $1) }
+qvarsym1 :: { LocatedN RdrName }
+qvarsym1 : QVARSYM { sL1n $1 $ mkQual varName (getQVARSYM $1) }
-varsym :: { Located RdrName }
+varsym :: { LocatedN RdrName }
: varsym_no_minus { $1 }
- | '-' { sL1 $1 $ mkUnqual varName (fsLit "-") }
+ | '-' { sL1n $1 $ mkUnqual varName (fsLit "-") }
-varsym_no_minus :: { Located RdrName } -- varsym not including '-'
- : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) }
- | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) }
+varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-'
+ : VARSYM { sL1n $1 $ mkUnqual varName (getVARSYM $1) }
+ | special_sym { sL1n $1 $ mkUnqual varName (unLoc $1) }
-- These special_ids are treated as keywords in various places,
@@ -3785,22 +3786,22 @@ special_sym : '.' { sL1 $1 (fsLit ".") }
-----------------------------------------------------------------------------
-- Data constructors
-qconid :: { Located RdrName } -- Qualified or unqualified
+qconid :: { LocatedN RdrName } -- Qualified or unqualified
: conid { $1 }
- | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) }
+ | QCONID { sL1n $1 $! mkQual dataName (getQCONID $1) }
-conid :: { Located RdrName }
- : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) }
+conid :: { LocatedN RdrName }
+ : CONID { sL1n $1 $ mkUnqual dataName (getCONID $1) }
-qconsym :: { Located RdrName } -- Qualified or unqualified
+qconsym :: { LocatedN RdrName } -- Qualified or unqualified
: consym { $1 }
- | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) }
+ | QCONSYM { sL1n $1 $ mkQual dataName (getQCONSYM $1) }
-consym :: { Located RdrName }
- : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) }
+consym :: { LocatedN RdrName }
+ : CONSYM { sL1n $1 $ mkUnqual dataName (getCONSYM $1) }
-- ':' means only list cons
- | ':' { sL1 $1 $ consDataCon_RDR }
+ | ':' { sL1n $1 $ consDataCon_RDR }
-----------------------------------------------------------------------------
@@ -3843,13 +3844,13 @@ commas :: { ([SrcSpan],Int) } -- One or more commas
: commas ',' { ((fst $1)++[gl $2],snd $1 + 1) }
| ',' { ([gl $1],1) }
-bars0 :: { ([SrcSpan],Int) } -- Zero or more bars
+bars0 :: { ([AnnAnchor],Int) } -- Zero or more bars
: bars { $1 }
| { ([], 0) }
-bars :: { ([SrcSpan],Int) } -- One or more bars
- : bars '|' { ((fst $1)++[gl $2],snd $1 + 1) }
- | '|' { ([gl $1],1) }
+bars :: { ([AnnAnchor],Int) } -- One or more bars
+ : bars '|' { ((fst $1)++[glAA $2],snd $1 + 1) }
+ | '|' { ([glAA $1],1) }
{
happyError :: P a
@@ -3910,7 +3911,7 @@ getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src
getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src
getCTYPEs (L _ (ITctype src)) = src
-getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
+getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing
isUnicode :: Located Token -> Bool
isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax
@@ -3946,10 +3947,28 @@ getSCC lt = do let s = getSTRING lt
comb2 :: Located a -> Located b -> SrcSpan
comb2 a b = a `seq` b `seq` combineLocs a b
+-- Utilities for combining source spans
+comb2A :: Located a -> LocatedAn t b -> SrcSpan
+comb2A a b = a `seq` b `seq` combineLocs a (reLoc b)
+
+comb2N :: Located a -> LocatedN b -> SrcSpan
+comb2N a b = a `seq` b `seq` combineLocs a (reLocN b)
+
+comb2Al :: LocatedAn t a -> Located b -> SrcSpan
+comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b
+
comb3 :: Located a -> Located b -> Located c -> SrcSpan
comb3 a b c = a `seq` b `seq` c `seq`
combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
+comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan
+comb3A a b c = a `seq` b `seq` c `seq`
+ combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))
+
+comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan
+comb3N a b c = a `seq` b `seq` c `seq`
+ combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))
+
comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
(combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
@@ -3962,8 +3981,8 @@ comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`
-- strict constructor version:
{-# INLINE sL #-}
-sL :: SrcSpan -> a -> Located a
-sL span a = span `seq` a `seq` L span a
+sL :: l -> a -> GenLocated l a
+sL loc a = loc `seq` a `seq` L loc a
-- See Note [Adding location info] for how these utility functions are used
@@ -3973,13 +3992,46 @@ sL0 :: a -> Located a
sL0 = L noSrcSpan -- #define L0 L noSrcSpan
{-# INLINE sL1 #-}
-sL1 :: Located a -> b -> Located b
+sL1 :: GenLocated l a -> b -> GenLocated l b
sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1)
+{-# INLINE sL1A #-}
+sL1A :: LocatedAn t a -> b -> Located b
+sL1A x = sL (getLocA x) -- #define sL1 sL (getLoc $1)
+
+{-# INLINE sL1N #-}
+sL1N :: LocatedN a -> b -> Located b
+sL1N x = sL (getLocA x) -- #define sL1 sL (getLoc $1)
+
+{-# INLINE sL1a #-}
+sL1a :: Located a -> b -> LocatedAn t b
+sL1a x = sL (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1)
+
+{-# INLINE sL1n #-}
+sL1n :: Located a -> b -> LocatedN b
+sL1n x = L (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1)
+
{-# INLINE sLL #-}
sLL :: Located a -> Located b -> c -> Located c
sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
+{-# INLINE sLLa #-}
+sLLa :: Located a -> Located b -> c -> LocatedAn t c
+sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>)
+
+{-# INLINE sLLlA #-}
+sLLlA :: Located a -> LocatedAn t b -> c -> Located c
+sLLlA x y = sL (comb2A x y) -- #define LL sL (comb2 $1 $>)
+
+{-# INLINE sLLAl #-}
+sLLAl :: LocatedAn t a -> Located b -> c -> Located c
+sLLAl x y = sL (comb2A y x) -- #define LL sL (comb2 $1 $>)
+
+{-# INLINE sLLAA #-}
+sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c
+sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL sL (comb2 $1 $>)
+
+
{- Note [Adding location info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -4032,13 +4084,13 @@ hintLinear span = do
unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span
-- Does this look like (a %m)?
-looksLikeMult :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> Bool
+looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool
looksLikeMult ty1 l_op ty2
| Unqual op_name <- unLoc l_op
, occNameFS op_name == fsLit "%"
- , Just ty1_pos <- getBufSpan (getLoc ty1)
- , Just pct_pos <- getBufSpan (getLoc l_op)
- , Just ty2_pos <- getBufSpan (getLoc ty2)
+ , Just ty1_pos <- getBufSpan (getLocA ty1)
+ , Just pct_pos <- getBufSpan (getLocA l_op)
+ , Just ty2_pos <- getBufSpan (getLocA ty2)
, bufSpanEnd ty1_pos /= bufSpanStart pct_pos
, bufSpanEnd pct_pos == bufSpanStart ty2_pos
= True
@@ -4091,17 +4143,31 @@ in GHC.Parser.Annotation
-}
--- |Construct an AddAnn from the annotation keyword and the location
+-- |Construct an AddApiAnn from the annotation keyword and the location
-- of the keyword itself
-mj :: AnnKeywordId -> Located e -> AddAnn
-mj a l = AddAnn a (gl l)
+mj :: AnnKeywordId -> Located e -> AddApiAnn
+mj a l = AddApiAnn a (AR $ rs $ gl l)
+
+mjN :: AnnKeywordId -> LocatedN e -> AddApiAnn
+mjN a l = AddApiAnn a (AR $ rs $ glN l)
+
+-- |Construct an AddApiAnn from the annotation keyword and the location
+-- of the keyword itself, provided the span is not zero width
+mz :: AnnKeywordId -> Located e -> [AddApiAnn]
+mz a l = if isZeroWidthSpan (gl l) then [] else [AddApiAnn a (AR $ rs $ gl l)]
+msemi :: Located e -> [TrailingAnn]
+msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (AR $ rs $ gl l)]
--- |Construct an AddAnn from the annotation keyword and the Located Token. If
+-- |Construct an AddApiAnn 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) = AddAnn (toUnicodeAnn a lt) l
+mu :: AnnKeywordId -> Located Token -> AddApiAnn
+mu a lt@(L l t) = AddApiAnn (toUnicodeAnn a lt) (AR $ rs l)
+
+mau :: Located Token -> TrailingAnn
+mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (AR $ rs l)
+ else AddRarrowAnn (AR $ rs l)
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
@@ -4111,94 +4177,125 @@ toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
toUnicode :: Located Token -> IsUnicodeSyntax
toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax
-gl :: Located a -> SrcSpan
+gl :: GenLocated l a -> l
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
-
--- |Add an annotation to a located element resulting from a monadic action
-am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)
-am a (b,s) = do
- av@(L l _) <- a
- addAnnotation l b (gl s)
- return av
-
--- | Add a list of AddAnns to the given AST element. For example,
--- the parsing rule for @let@ looks like:
---
--- @
--- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
--- (mj AnnLet $1:mj AnnIn $3
--- :(fst $ unLoc $2)) }
--- @
---
--- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well
--- as any annotations that may arise in the binds. This will include open
--- and closing braces if they are used to delimit the let expressions.
---
-ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)
-ams a@(L l _) bs = addAnnsAt l bs >> return a
-
-amsL :: SrcSpan -> [AddAnn] -> P ()
-amsL sp bs = addAnnsAt sp bs >> return ()
-
--- |Add all [AddAnn] to an AST element, and wrap it in a 'Just'
-ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a))
-ajs a bs = Just <$> ams a bs
-
--- |Add a list of AddAnns to the given AST element, where the AST element is the
--- result of a monadic action
-amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a)
-amms a bs = do { av@(L l _) <- a
- ; addAnnsAt l bs
- ; return av }
-
--- |Add a list of AddAnns to the AST element, and return the element as a
--- OrdList
-amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))
-amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)
-
--- |Synonyms for AddAnn versions of AnnOpen and AnnClose
-mo,mc :: Located Token -> AddAnn
+glA :: LocatedAn t a -> SrcSpan
+glA = getLocA
+
+glN :: LocatedN a -> SrcSpan
+glN = getLocA
+
+glR :: Located a -> Anchor
+glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor
+
+glAA :: Located a -> AnnAnchor
+glAA = AR <$> realSrcSpan . getLoc
+
+glRR :: Located a -> RealSrcSpan
+glRR = realSrcSpan . getLoc
+
+glAR :: LocatedAn t a -> Anchor
+glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor
+
+glNR :: LocatedN a -> Anchor
+glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor
+
+glNRR :: LocatedN a -> AnnAnchor
+glNRR = AR <$> realSrcSpan . getLocA
+
+anc :: RealSrcSpan -> Anchor
+anc r = Anchor r UnchangedAnchor
+
+acs :: MonadP m => (ApiAnnComments -> Located a) -> m (Located a)
+acs a = do
+ let (L l _) = a noCom
+ cs <- getCommentsFor l
+ return (a cs)
+
+-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.
+acsFinal :: (ApiAnnComments -> Located a) -> P (Located a)
+acsFinal a = do
+ let (L l _) = a noCom
+ cs <- getCommentsFor l
+ csf <- getFinalCommentsFor l
+ meof <- getEofPos
+ let ce = case meof of
+ Nothing -> AnnComments []
+ Just (pos, gap) -> AnnCommentsBalanced [] [L (realSpanAsAnchor pos) (AnnComment AnnEofComment gap)]
+ return (a (cs Semi.<> csf Semi.<> ce))
+
+acsa :: MonadP m => (ApiAnnComments -> LocatedAn t a) -> m (LocatedAn t a)
+acsa a = do
+ let (L l _) = a noCom
+ cs <- getCommentsFor (locA l)
+ return (a cs)
+
+acsA :: MonadP m => (ApiAnnComments -> Located a) -> m (LocatedAn t a)
+acsA a = reLocA <$> acs a
+
+acsExpr :: (ApiAnnComments -> LHsExpr GhcPs) -> P ECP
+acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a
+ ; return (ecpFromExp $ expr) }
+
+amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)
+amsA (L l a) bs = do
+ cs <- getCommentsFor (locA l)
+ return (L (addAnnsA l bs cs) a)
+
+amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a)
+amsrc a@(L l _) bs = do
+ cs <- getCommentsFor l
+ return (reAnnC bs cs a)
+
+amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a)
+amsrl a@(L l _) bs = do
+ cs <- getCommentsFor l
+ return (reAnnL bs cs a)
+
+amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a)
+amsrp a@(L l _) bs = do
+ cs <- getCommentsFor l
+ return (reAnnL bs cs a)
+
+amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a)
+amsrn (L l a) an = do
+ cs <- getCommentsFor l
+ let ann = (ApiAnn (spanAsAnchor l) an cs)
+ return (L (SrcSpanAnn ann l) a)
+
+-- |Synonyms for AddApiAnn versions of AnnOpen and AnnClose
+mo,mc :: Located Token -> AddApiAnn
mo ll = mj AnnOpen ll
mc ll = mj AnnClose ll
-moc,mcc :: Located Token -> AddAnn
+moc,mcc :: Located Token -> AddApiAnn
moc ll = mj AnnOpenC ll
mcc ll = mj AnnCloseC ll
-mop,mcp :: Located Token -> AddAnn
+mop,mcp :: Located Token -> AddApiAnn
mop ll = mj AnnOpenP ll
mcp ll = mj AnnCloseP ll
-mos,mcs :: Located Token -> AddAnn
+moh,mch :: Located Token -> AddApiAnn
+moh ll = mj AnnOpenPH ll
+mch ll = mj AnnClosePH ll
+
+mos,mcs :: Located Token -> AddApiAnn
mos ll = mj AnnOpenS ll
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 = map (AddAnn AnnCommaTuple)
-
--- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar
--- entry for each SrcSpan
-mvbars :: [SrcSpan] -> [AddAnn]
-mvbars = map (AddAnn AnnVbar)
+pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)
+pvA a = do { av <- a
+ ; return (reLocA av) }
--- |Get the location of the last element of a OrdList, or noSrcSpan
-oll :: OrdList (Located a) -> SrcSpan
-oll l =
- if isNilOL l then noSrcSpan
- else getLoc (lastOL l)
+pvN :: MonadP m => m (Located a) -> m (LocatedN a)
+pvN a = do { (L l av) <- a
+ ; return (L (noAnnSrcSpan l) av) }
--- |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
+pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)
+pvL a = do { av <- a
+ ; return (reLoc av) }
-- | Parse a Haskell module with Haddock comments.
-- This is done in two steps:
@@ -4211,4 +4308,105 @@ asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
-- not insert them into the AST.
parseModule :: P (Located HsModule)
parseModule = parseModuleNoHaddock >>= addHaddockToModule
+
+commentsA :: (Monoid ann) => SrcSpan -> ApiAnnComments -> SrcSpanAnn' (ApiAnn' ann)
+commentsA loc cs = SrcSpanAnn (ApiAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc
+
+-- | Instead of getting the *enclosed* comments, this includes the
+-- *preceding* ones. It is used at the top level to get comments
+-- between top level declarations.
+commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)
+commentsPA la@(L l a) = do
+ cs <- getPriorCommentsFor (getLocA la)
+ return (L (addCommentsToSrcAnn l cs) a)
+
+rs :: SrcSpan -> RealSrcSpan
+rs (RealSrcSpan l _) = l
+rs _ = panic "Parser should only have RealSrcSpan"
+
+hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList
+hsDoAnn (L l _) (L ll _) kw
+ = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddApiAnn kw (AR $ rs l)] []
+
+listAsAnchor :: [LocatedAn t a] -> Anchor
+listAsAnchor [] = spanAsAnchor noSrcSpan
+listAsAnchor (L l _:_) = spanAsAnchor (locA l)
+
+-- -------------------------------------
+
+addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)
+addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l)
+addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)
+
+addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)
+addTrailingVbarA la span = addTrailingAnnA la span AddVbarAnn
+
+addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)
+addTrailingSemiA la span = addTrailingAnnA la span AddSemiAnn
+
+addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)
+addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn
+
+addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (AnnAnchor -> TrailingAnn) -> m (LocatedA a)
+addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do
+ -- cs <- getCommentsFor l
+ let cs = noCom
+ -- AZ:TODO: generalise updating comments into an annotation
+ let
+ anns' = if isZeroWidthSpan ss
+ then anns
+ else addTrailingAnnToA l (ta (AR $ rs ss)) cs anns
+ return (L (SrcSpanAnn anns' l) a)
+
+-- -------------------------------------
+
+addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)
+addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (AR $ rs span))
+
+addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)
+addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (AR $ rs span))
+
+addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)
+addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do
+ cs <- getCommentsFor l
+ let anns' = addTrailingAnnToL l ta cs anns
+ return (L (SrcSpanAnn anns' l) a)
+
+-- -------------------------------------
+
+-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation
+addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)
+addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do
+ -- cs <- getCommentsFor l
+ let cs = noCom
+ -- AZ:TODO: generalise updating comments into an annotation
+ let anns' = if isZeroWidthSpan span
+ then anns
+ else addTrailingCommaToN l anns (AR $ rs span)
+ return (L (SrcSpanAnn anns' l) a)
+
+addTrailingCommaS :: Located StringLiteral -> AnnAnchor -> Located StringLiteral
+addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (annAnchorRealSrcSpan span) })
+
+-- -------------------------------------
+
+addTrailingDarrowC :: LocatedC a -> Located Token -> ApiAnnComments -> LocatedC a
+addTrailingDarrowC (L (SrcSpanAnn ApiAnnNotUsed l) a) lt cs =
+ let
+ u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax
+ in L (SrcSpanAnn (ApiAnn (spanAsAnchor l) (AnnContext (Just (u,glAA lt)) [] []) cs) l) a
+addTrailingDarrowC (L (SrcSpanAnn (ApiAnn lr (AnnContext _ o c) csc) l) a) lt cs =
+ let
+ u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax
+ in L (SrcSpanAnn (ApiAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) l) a
+
+-- -------------------------------------
+
+-- We need a location for the where binds, when computing the SrcSpan
+-- for the AST element using them. Where there is a span, we return
+-- it, else noLoc, which is ignored in the comb2 call.
+adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs)) -> Located (HsLocalBinds GhcPs)
+adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField)
+adaptWhereBinds (Just b) = b
+
}
View Lorry Controller Status