[Git][ghc/ghc][master] ApiAnnotations : preserve parens in GADTs
Marge Bot
gitlab at gitlab.haskell.org
Fri Oct 9 12:47:41 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
36787bba by Alan Zimmerman at 2020-10-09T08:47:36-04:00
ApiAnnotations : preserve parens in GADTs
A cleanup in 7f418acf61e accidentally discarded some parens in
ConDeclGADT.
Make sure these stay in the AST in a usable format.
Also ensure the AnnLolly does not get lost in a GADT.
- - - - -
5 changed files:
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
Changes:
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -106,6 +106,7 @@ import GHC.Utils.Misc ( count )
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Maybe
+import GHC.Parser.Annotation
{-
************************************************************************
@@ -1325,17 +1326,20 @@ mkHsAppKindTy ext ty k
-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
-- Breaks up any parens in the result type:
-- splitHsFunType (a -> (b -> c)) = ([a,b], c)
+-- It returns API Annotations for any parens removed
splitHsFunType ::
LHsType (GhcPass p)
- -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
-splitHsFunType (L _ (HsParTy _ ty))
- = splitHsFunType ty
+ -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn])
+splitHsFunType ty = go ty []
+ where
+ go (L l (HsParTy _ ty)) anns
+ = go ty (anns ++ mkParensApiAnn l)
-splitHsFunType (L _ (HsFunTy _ mult x y))
- | (args, res) <- splitHsFunType y
- = (HsScaled mult x:args, res)
+ go (L _ (HsFunTy _ mult x y)) anns
+ | (args, res, anns') <- go y anns
+ = (HsScaled mult x:args, res, anns')
-splitHsFunType other = ([], other)
+ go other anns = ([], other, anns)
-- | Retrieve the name of the \"head\" of a nested type application.
-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2055,12 +2055,14 @@ type :: { LHsType GhcPs }
>> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3)
[mu AnnRarrow $2] }
- | btype mult '->' ctype {% hintLinear (getLoc $2) >>
- ams (sLL $1 $> $ HsFunTy noExtField (unLoc $2) $1 $4)
+ | btype mult '->' ctype {% hintLinear (getLoc $2)
+ >> ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $ HsFunTy noExtField (unLoc $2) $1 $4)
[mu AnnRarrow $3] }
- | btype '->.' ctype {% hintLinear (getLoc $2) >>
- ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
+ | btype '->.' ctype {% hintLinear (getLoc $2)
+ >> ams $1 [mu AnnLollyU $2] -- See note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
[mu AnnLollyU $2] }
mult :: { Located (HsArrow GhcPs) }
@@ -2285,9 +2287,9 @@ gadt_constr :: { LConDecl GhcPs }
-- see Note [Difference in parsing GADT and data constructors]
-- Returns a list because of: C,D :: ty
: optSemi con_list '::' sigtype
- {% do { decl <- mkGadtDecl (unLoc $2) $4
+ {% do { (decl, anns) <- mkGadtDecl (unLoc $2) $4
; ams (sLL $2 $> decl)
- [mu AnnDcolon $3] } }
+ (mu AnnDcolon $3:anns) } }
{- Note [Difference in parsing GADT and data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -6,6 +6,7 @@ module GHC.Parser.Annotation (
ApiAnns(..),
ApiAnnKey,
AnnKeywordId(..),
+ AddAnn(..),mkParensApiAnn,
AnnotationComment(..),
IsUnicodeSyntax(..),
unicodeAnn,
@@ -148,6 +149,44 @@ data ApiAnns =
type ApiAnnKey = (RealSrcSpan,AnnKeywordId)
+-- ---------------------------------------------------------------------
+
+-- | Encapsulated call to addAnnotation, requiring only the SrcSpan of
+-- the AST construct the annotation belongs to; together with the
+-- AnnKeywordId, this is the key of the annotation map.
+--
+-- This type is useful for places in the parser where it is not yet
+-- known what SrcSpan an annotation should be added to. The most
+-- common situation is when we are parsing a list: the annotations
+-- need to be associated with the AST element that *contains* the
+-- list, not the list itself. 'AddAnn' lets us defer adding the
+-- annotations until we finish parsing the list and are now parsing
+-- the enclosing element; we then apply the 'AddAnn' to associate
+-- the annotations. Another common situation is where a common fragment of
+-- the AST has been factored out but there is no separate AST node for
+-- this fragment (this occurs in class and data declarations). In this
+-- case, the annotation belongs to the parent data declaration.
+--
+-- The usual way an 'AddAnn' is created is using the 'mj' ("make jump")
+-- function, and then it can be discharged using the 'ams' function.
+data AddAnn = AddAnn AnnKeywordId SrcSpan
+
+-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
+-- 'AddAnn' values for the opening and closing bordering on the start
+-- and end of the span
+mkParensApiAnn :: SrcSpan -> [AddAnn]
+mkParensApiAnn (UnhelpfulSpan _) = []
+mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]
+ where
+ f = srcSpanFile ss
+ sl = srcSpanStartLine ss
+ sc = srcSpanStartCol ss
+ el = srcSpanEndLine ss
+ ec = srcSpanEndCol ss
+ lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) Nothing
+ lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) Nothing
+
+-- ---------------------------------------------------------------------
-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
-- of the annotated AST element, and the known type of the annotation.
getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan]
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -64,7 +64,6 @@ module GHC.Parser.Lexer (
ExtBits(..),
xtest, xunset, xset,
lexTokenStream,
- AddAnn(..),mkParensApiAnn,
addAnnsAt,
commentToAnnotation,
HdkComment(..),
@@ -3299,45 +3298,12 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
%************************************************************************
-}
--- | Encapsulated call to addAnnotation, requiring only the SrcSpan of
--- the AST construct the annotation belongs to; together with the
--- AnnKeywordId, this is the key of the annotation map.
---
--- This type is useful for places in the parser where it is not yet
--- known what SrcSpan an annotation should be added to. The most
--- common situation is when we are parsing a list: the annotations
--- need to be associated with the AST element that *contains* the
--- list, not the list itself. 'AddAnn' lets us defer adding the
--- annotations until we finish parsing the list and are now parsing
--- the enclosing element; we then apply the 'AddAnn' to associate
--- the annotations. Another common situation is where a common fragment of
--- the AST has been factored out but there is no separate AST node for
--- this fragment (this occurs in class and data declarations). In this
--- case, the annotation belongs to the parent data declaration.
---
--- The usual way an 'AddAnn' is created is using the 'mj' ("make jump")
--- function, and then it can be discharged using the 'ams' function.
-data AddAnn = AddAnn AnnKeywordId SrcSpan
addAnnotationOnly :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P ()
addAnnotationOnly l a v = P $ \s -> POk s {
annotations = ((l,a), [v]) : annotations s
} ()
--- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
--- 'AddAnn' values for the opening and closing bordering on the start
--- and end of the span
-mkParensApiAnn :: SrcSpan -> [AddAnn]
-mkParensApiAnn (UnhelpfulSpan _) = []
-mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]
- where
- f = srcSpanFile ss
- sl = srcSpanStartLine ss
- sc = srcSpanStartCol ss
- el = srcSpanEndLine ss
- ec = srcSpanEndCol ss
- lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) Nothing
- lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) Nothing
queueComment :: RealLocated Token -> P()
queueComment c = P $ \s -> POk s {
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -633,16 +633,16 @@ mkConDeclH98 name mb_forall mb_cxt args
-- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs
- -> P (ConDecl GhcPs)
+ -> P (ConDecl GhcPs, [AddAnn])
mkGadtDecl names ty = do
- let (args, res_ty)
+ let (args, res_ty, anns)
| L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty
- = (RecCon (L loc rf), res_ty)
+ = (RecCon (L loc rf), res_ty, [])
| otherwise
- = let (arg_types, res_type) = splitHsFunType body_ty
- in (PrefixCon arg_types, res_type)
+ = let (arg_types, res_type, anns) = splitHsFunType body_ty
+ in (PrefixCon arg_types, res_type, anns)
- pure $ ConDeclGADT { con_g_ext = noExtField
+ pure ( ConDeclGADT { con_g_ext = noExtField
, con_names = names
, con_forall = L (getLoc ty) $ isJust mtvs
, con_qvars = fromMaybe [] mtvs
@@ -650,6 +650,7 @@ mkGadtDecl names ty = do
, con_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
+ , anns )
where
(mtvs, mcxt, body_ty) = splitLHsGadtTy ty
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36787bba78ae5acbb857c84b85b8feb7c83e54a5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36787bba78ae5acbb857c84b85b8feb7c83e54a5
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201009/b1df5718/attachment-0001.html>
More information about the ghc-commits
mailing list