Commit 36787bba authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Marge Bot

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.
parent 12191a99
...@@ -106,6 +106,7 @@ import GHC.Utils.Misc ( count ) ...@@ -106,6 +106,7 @@ import GHC.Utils.Misc ( count )
import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Maybe import Data.Maybe
import GHC.Parser.Annotation
{- {-
************************************************************************ ************************************************************************
...@@ -1325,17 +1326,20 @@ mkHsAppKindTy ext ty k ...@@ -1325,17 +1326,20 @@ mkHsAppKindTy ext ty k
-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
-- Breaks up any parens in the result type: -- Breaks up any parens in the result type:
-- splitHsFunType (a -> (b -> c)) = ([a,b], c) -- splitHsFunType (a -> (b -> c)) = ([a,b], c)
-- It returns API Annotations for any parens removed
splitHsFunType :: splitHsFunType ::
LHsType (GhcPass p) LHsType (GhcPass p)
-> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p)) -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn])
splitHsFunType (L _ (HsParTy _ ty)) splitHsFunType ty = go ty []
= splitHsFunType ty where
go (L l (HsParTy _ ty)) anns
= go ty (anns ++ mkParensApiAnn l)
splitHsFunType (L _ (HsFunTy _ mult x y)) go (L _ (HsFunTy _ mult x y)) anns
| (args, res) <- splitHsFunType y | (args, res, anns') <- go y anns
= (HsScaled mult x:args, res) = (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. -- | Retrieve the name of the \"head\" of a nested type application.
-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more -- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more
......
...@@ -2055,12 +2055,14 @@ type :: { LHsType GhcPs } ...@@ -2055,12 +2055,14 @@ type :: { LHsType GhcPs }
>> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3) >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3)
[mu AnnRarrow $2] } [mu AnnRarrow $2] }
| btype mult '->' ctype {% hintLinear (getLoc $2) >> | btype mult '->' ctype {% hintLinear (getLoc $2)
ams (sLL $1 $> $ HsFunTy noExtField (unLoc $2) $1 $4) >> ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $ HsFunTy noExtField (unLoc $2) $1 $4)
[mu AnnRarrow $3] } [mu AnnRarrow $3] }
| btype '->.' ctype {% hintLinear (getLoc $2) >> | btype '->.' ctype {% hintLinear (getLoc $2)
ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3) >> ams $1 [mu AnnLollyU $2] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
[mu AnnLollyU $2] } [mu AnnLollyU $2] }
mult :: { Located (HsArrow GhcPs) } mult :: { Located (HsArrow GhcPs) }
...@@ -2285,9 +2287,9 @@ gadt_constr :: { LConDecl GhcPs } ...@@ -2285,9 +2287,9 @@ gadt_constr :: { LConDecl GhcPs }
-- see Note [Difference in parsing GADT and data constructors] -- see Note [Difference in parsing GADT and data constructors]
-- Returns a list because of: C,D :: ty -- Returns a list because of: C,D :: ty
: optSemi con_list '::' sigtype : optSemi con_list '::' sigtype
{% do { decl <- mkGadtDecl (unLoc $2) $4 {% do { (decl, anns) <- mkGadtDecl (unLoc $2) $4
; ams (sLL $2 $> decl) ; ams (sLL $2 $> decl)
[mu AnnDcolon $3] } } (mu AnnDcolon $3:anns) } }
{- Note [Difference in parsing GADT and data constructors] {- Note [Difference in parsing GADT and data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -6,6 +6,7 @@ module GHC.Parser.Annotation ( ...@@ -6,6 +6,7 @@ module GHC.Parser.Annotation (
ApiAnns(..), ApiAnns(..),
ApiAnnKey, ApiAnnKey,
AnnKeywordId(..), AnnKeywordId(..),
AddAnn(..),mkParensApiAnn,
AnnotationComment(..), AnnotationComment(..),
IsUnicodeSyntax(..), IsUnicodeSyntax(..),
unicodeAnn, unicodeAnn,
...@@ -148,6 +149,44 @@ data ApiAnns = ...@@ -148,6 +149,44 @@ data ApiAnns =
type ApiAnnKey = (RealSrcSpan,AnnKeywordId) 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' -- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
-- of the annotated AST element, and the known type of the annotation. -- of the annotated AST element, and the known type of the annotation.
getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan] getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan]
......
...@@ -64,7 +64,6 @@ module GHC.Parser.Lexer ( ...@@ -64,7 +64,6 @@ module GHC.Parser.Lexer (
ExtBits(..), ExtBits(..),
xtest, xunset, xset, xtest, xunset, xset,
lexTokenStream, lexTokenStream,
AddAnn(..),mkParensApiAnn,
addAnnsAt, addAnnsAt,
commentToAnnotation, commentToAnnotation,
HdkComment(..), HdkComment(..),
...@@ -3299,45 +3298,12 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) ...@@ -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 :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P ()
addAnnotationOnly l a v = P $ \s -> POk s { addAnnotationOnly l a v = P $ \s -> POk s {
annotations = ((l,a), [v]) : annotations 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 :: RealLocated Token -> P()
queueComment c = P $ \s -> POk s { queueComment c = P $ \s -> POk s {
......
...@@ -633,16 +633,16 @@ mkConDeclH98 name mb_forall mb_cxt args ...@@ -633,16 +633,16 @@ mkConDeclH98 name mb_forall mb_cxt args
-- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.
mkGadtDecl :: [Located RdrName] mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs -> LHsType GhcPs
-> P (ConDecl GhcPs) -> P (ConDecl GhcPs, [AddAnn])
mkGadtDecl names ty = do mkGadtDecl names ty = do
let (args, res_ty) let (args, res_ty, anns)
| L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty
= (RecCon (L loc rf), res_ty) = (RecCon (L loc rf), res_ty, [])
| otherwise | otherwise
= let (arg_types, res_type) = splitHsFunType body_ty = let (arg_types, res_type, anns) = splitHsFunType body_ty
in (PrefixCon arg_types, res_type) in (PrefixCon arg_types, res_type, anns)
pure $ ConDeclGADT { con_g_ext = noExtField pure ( ConDeclGADT { con_g_ext = noExtField
, con_names = names , con_names = names
, con_forall = L (getLoc ty) $ isJust mtvs , con_forall = L (getLoc ty) $ isJust mtvs
, con_qvars = fromMaybe [] mtvs , con_qvars = fromMaybe [] mtvs
...@@ -650,6 +650,7 @@ mkGadtDecl names ty = do ...@@ -650,6 +650,7 @@ mkGadtDecl names ty = do
, con_args = args , con_args = args
, con_res_ty = res_ty , con_res_ty = res_ty
, con_doc = Nothing } , con_doc = Nothing }
, anns )
where where
(mtvs, mcxt, body_ty) = splitLHsGadtTy ty (mtvs, mcxt, body_ty) = splitLHsGadtTy ty
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment