Commit 676c5754 authored by Alan Zimmerman's avatar Alan Zimmerman

Fix API Annotations for GADT constructors

Summary:
This patch completes the work for #14529 by making sure that all API
Annotations end up attached to a SrcSpan that appears in the final
ParsedSource.

Updates Haddock submodule

Test Plan: ./validate

Reviewers: goldfire, bgamari

Subscribers: rwbarton, thomie, mpickering, carter

GHC Trac Issues: #14529

Differential Revision: https://phabricator.haskell.org/D4867
parent 83a7b1cf
......@@ -693,13 +693,13 @@ repAnnProv ModuleAnnProvenance
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
repC (L _ (ConDeclH98 { con_name = con
, con_forall = False
, con_forall = L _ False
, con_mb_cxt = Nothing
, con_args = args }))
= repDataCon con args
repC (L _ (ConDeclH98 { con_name = con
, con_forall = is_existential
, con_forall = L _ is_existential
, con_ex_tvs = con_tvs
, con_mb_cxt = mcxt
, con_args = args }))
......
......@@ -535,14 +535,14 @@ cvtConstr (ForallC tvs ctxt con)
add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
= con { con_forall = not (null all_tvs)
= con { con_forall = noLoc $ not (null all_tvs)
, con_qvars = mkHsQTvs all_tvs
, con_mb_cxt = add_cxt cxt' cxt }
where
all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
= con { con_forall = not (null all_tvs)
= con { con_forall = noLoc $ not (null all_tvs)
, con_ex_tvs = all_tvs
, con_mb_cxt = add_cxt cxt' cxt }
where
......@@ -555,7 +555,7 @@ cvtConstr (GadtC c strtys ty)
; args <- mapM cvt_arg strtys
; L _ ty' <- cvtType ty
; c_ty <- mk_arr_apps args ty'
; returnL $ mkGadtDecl c' c_ty}
; returnL $ fst $ mkGadtDecl c' c_ty}
cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c
......@@ -563,7 +563,7 @@ cvtConstr (RecGadtC c varstrtys ty)
; rec_flds <- mapM cvt_id_arg varstrtys
; let rec_ty = noLoc (HsFunTy noExt
(noLoc $ HsRecTy noExt rec_flds) ty')
; returnL $ mkGadtDecl c' rec_ty }
; returnL $ fst $ mkGadtDecl c' rec_ty }
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
......
......@@ -1236,7 +1236,9 @@ data ConDecl pass
-- The next four fields describe the type after the '::'
-- See Note [GADT abstract syntax]
, con_forall :: Bool -- ^ True <=> explicit forall
-- The following field is Located to anchor API Annotations,
-- AnnForall and AnnDot.
, con_forall :: Located Bool -- ^ True <=> explicit forall
-- False => hsq_explicit is empty
, con_qvars :: LHsQTyVars pass
-- Whether or not there is an /explicit/ forall, we still
......@@ -1254,7 +1256,8 @@ data ConDecl pass
{ con_ext :: XConDeclH98 pass
, con_name :: Located (IdP pass)
, con_forall :: Bool -- ^ True <=> explicit user-written forall
, con_forall :: Located Bool
-- ^ True <=> explicit user-written forall
-- e.g. data T a = forall b. MkT b (b->a)
-- con_ex_tvs = {b}
-- False => con_ex_tvs is empty
......
......@@ -2139,8 +2139,9 @@ gadt_constr :: { LConDecl GhcPs }
-- see Note [Difference in parsing GADT and data constructors]
-- Returns a list because of: C,D :: ty
: con_list '::' sigtypedoc
{% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3))
[mu AnnDcolon $2] }
{% let (gadt,anns) = mkGadtDecl (unLoc $1) $3
in ams (sLL $1 $> gadt)
(mu AnnDcolon $2:anns) }
{- Note [Difference in parsing GADT and data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -629,7 +629,7 @@ mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
mkConDeclH98 name mb_forall mb_cxt args
= ConDeclH98 { con_ext = noExt
, con_name = name
, con_forall = isJust mb_forall
, con_forall = noLoc $ isJust mb_forall
, con_ex_tvs = mb_forall `orElse` []
, con_mb_cxt = mb_cxt
, con_args = args'
......@@ -639,33 +639,39 @@ mkConDeclH98 name mb_forall mb_cxt args
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs -- Always a HsForAllTy
-> ConDecl GhcPs
-> (ConDecl GhcPs, [AddAnn])
mkGadtDecl names ty
= ConDeclGADT { con_g_ext = noExt
, con_names = names
, con_forall = isLHsForAllTy ty
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args'
, con_res_ty = res_ty
, con_doc = Nothing }
= (ConDeclGADT { con_g_ext = noExt
, con_names = names
, con_forall = L l $ isLHsForAllTy ty
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args'
, con_res_ty = res_ty
, con_doc = Nothing }
, anns1 ++ anns2 ++ anns3)
where
(tvs, rho) = splitLHsForAllTy ty
(mcxt, tau) = split_rho rho
(ty'@(L l _),anns1) = peel_parens ty []
(tvs, rho) = splitLHsForAllTy ty'
(mcxt, tau, anns2) = split_rho rho []
split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau }))
= (Just cxt, tau)
split_rho (L _ (HsParTy _ ty)) = split_rho ty
split_rho tau = (Nothing, tau)
split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
= (Just cxt, tau, ann)
split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
split_rho tau ann = (Nothing, tau, ann)
(args, res_ty) = split_tau tau
(args, res_ty, anns3) = split_tau tau []
args' = nudgeHsSrcBangs args
-- See Note [GADT abstract syntax] in HsDecls
split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
= (RecCon (L loc rf), res_ty)
split_tau (L _ (HsParTy _ ty)) = split_tau ty
split_tau tau = (PrefixCon [], tau)
split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty)) ann
= (RecCon (L loc rf), res_ty, ann)
split_tau (L l (HsParTy _ ty)) ann = split_tau ty (ann++mkParensApiAnn l)
split_tau tau ann = (PrefixCon [], tau, ann)
peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
(ann++mkParensApiAnn l)
peel_parens ty ann = (ty, ann)
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
-- ^ This function ensures that fields with strictness or packedness
......
......@@ -2007,7 +2007,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
all_fvs) }}
rnConDecl decl@(ConDeclGADT { con_names = names
, con_forall = explicit_forall
, con_forall = L _ explicit_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt
, con_args = args
......
......@@ -29,9 +29,9 @@
((Test10399.hs:12:30,AnnComma), [Test10399.hs:12:30]),
((Test10399.hs:12:31-32,AnnCloseP), [Test10399.hs:12:32]),
((Test10399.hs:12:31-32,AnnOpenP), [Test10399.hs:12:31]),
((Test10399.hs:(14,1)-(17,69),AnnData), [Test10399.hs:14:1-4]),
((Test10399.hs:(14,1)-(17,69),AnnSemi), [Test10399.hs:19:1]),
((Test10399.hs:(14,1)-(17,69),AnnWhere), [Test10399.hs:14:21-25]),
((Test10399.hs:(14,1)-(18,55),AnnData), [Test10399.hs:14:1-4]),
((Test10399.hs:(14,1)-(18,55),AnnSemi), [Test10399.hs:20:1]),
((Test10399.hs:(14,1)-(18,55),AnnWhere), [Test10399.hs:14:21-25]),
((Test10399.hs:15:5-64,AnnDcolon), [Test10399.hs:15:11-12]),
((Test10399.hs:15:5-64,AnnSemi), [Test10399.hs:16:5]),
((Test10399.hs:15:14-64,AnnDot), [Test10399.hs:15:23]),
......@@ -43,7 +43,10 @@
((Test10399.hs:15:45-46,AnnBang), [Test10399.hs:15:45]),
((Test10399.hs:15:45-46,AnnRarrow), [Test10399.hs:15:48-49]),
((Test10399.hs:15:45-64,AnnRarrow), [Test10399.hs:15:48-49]),
((Test10399.hs:(16,5)-(17,69),AnnCloseP), [Test10399.hs:17:69]),
((Test10399.hs:(16,5)-(17,69),AnnDcolon), [Test10399.hs:16:12-13]),
((Test10399.hs:(16,5)-(17,69),AnnOpenP), [Test10399.hs:16:27]),
((Test10399.hs:(16,5)-(17,69),AnnSemi), [Test10399.hs:18:5]),
((Test10399.hs:(16,15)-(17,69),AnnDot), [Test10399.hs:16:25]),
((Test10399.hs:(16,15)-(17,69),AnnForall), [Test10399.hs:16:15-20]),
((Test10399.hs:(16,27)-(17,69),AnnCloseP), [Test10399.hs:17:69]),
......@@ -57,17 +60,27 @@
((Test10399.hs:17:48-68,AnnRarrow), [Test10399.hs:17:50-51]),
((Test10399.hs:17:66-68,AnnCloseS), [Test10399.hs:17:68]),
((Test10399.hs:17:66-68,AnnOpenS), [Test10399.hs:17:66]),
((Test10399.hs:19:1-25,AnnCloseQ), [Test10399.hs:19:24-25]),
((Test10399.hs:19:1-25,AnnOpen), [Test10399.hs:19:1-3]),
((Test10399.hs:19:1-25,AnnSemi), [Test10399.hs:21:1]),
((Test10399.hs:19:20-22,AnnThIdSplice), [Test10399.hs:19:20-22]),
((Test10399.hs:21:1-21,AnnEqual), [Test10399.hs:21:19]),
((Test10399.hs:21:1-21,AnnFunId), [Test10399.hs:21:1-3]),
((Test10399.hs:21:1-21,AnnSemi), [Test10399.hs:22:1]),
((Test10399.hs:21:5-17,AnnCloseP), [Test10399.hs:21:17]),
((Test10399.hs:21:5-17,AnnOpenPE), [Test10399.hs:21:5-6]),
((Test10399.hs:21:8-15,AnnCloseQ), [Test10399.hs:21:14-15]),
((Test10399.hs:21:8-15,AnnOpen), [Test10399.hs:21:8-10]),
((<no location info>,AnnEofPos), [Test10399.hs:22:1])
((Test10399.hs:18:5-55,AnnCloseP), [Test10399.hs:18:55]),
((Test10399.hs:18:5-55,AnnDcolon), [Test10399.hs:18:16-17]),
((Test10399.hs:18:5-55,AnnOpenP), [Test10399.hs:18:19]),
((Test10399.hs:18:19-55,AnnCloseP), [Test10399.hs:18:55]),
((Test10399.hs:18:19-55,AnnOpenP), [Test10399.hs:18:19]),
((Test10399.hs:18:20-54,AnnDot), [Test10399.hs:18:29]),
((Test10399.hs:18:20-54,AnnForall), [Test10399.hs:18:20-25]),
((Test10399.hs:18:31-36,AnnCloseP), [Test10399.hs:18:36]),
((Test10399.hs:18:31-36,AnnOpenP), [Test10399.hs:18:31]),
((Test10399.hs:18:31-54,AnnRarrow), [Test10399.hs:18:38-39]),
((Test10399.hs:20:1-25,AnnCloseQ), [Test10399.hs:20:24-25]),
((Test10399.hs:20:1-25,AnnOpen), [Test10399.hs:20:1-3]),
((Test10399.hs:20:1-25,AnnSemi), [Test10399.hs:22:1]),
((Test10399.hs:20:20-22,AnnThIdSplice), [Test10399.hs:20:20-22]),
((Test10399.hs:22:1-21,AnnEqual), [Test10399.hs:22:19]),
((Test10399.hs:22:1-21,AnnFunId), [Test10399.hs:22:1-3]),
((Test10399.hs:22:1-21,AnnSemi), [Test10399.hs:23:1]),
((Test10399.hs:22:5-17,AnnCloseP), [Test10399.hs:22:17]),
((Test10399.hs:22:5-17,AnnOpenPE), [Test10399.hs:22:5-6]),
((Test10399.hs:22:8-15,AnnCloseQ), [Test10399.hs:22:14-15]),
((Test10399.hs:22:8-15,AnnOpen), [Test10399.hs:22:8-10]),
((<no location info>,AnnEofPos), [Test10399.hs:23:1])
]
......@@ -15,6 +15,7 @@ data MaybeDefault v where
SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v
-> a -> MaybeDefault [a])
TestParens :: (forall v . (Eq v) -> MaybeDefault v)
[t| Map.Map T.Text $tc |]
......
......@@ -28,15 +28,13 @@ test('T10357', [extra_files(['Test10357.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10357'])
test('T10358', [extra_files(['Test10358.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10358'])
test('T10278', [expect_broken(14529),
extra_files(['Test10278.hs']),
test('T10278', [extra_files(['Test10278.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10278'])
test('T10354', [extra_files(['Test10354.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10354'])
test('T10396', [extra_files(['Test10396.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10396'])
test('T10399', [expect_broken(14529),
extra_files(['Test10399.hs']),
test('T10399', [extra_files(['Test10399.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10399'])
test('T10313', [extra_files(['Test10313.hs', 'stringSource.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10313'])
......
......@@ -33,7 +33,8 @@
({ DumpParsedAst.hs:5:14-17 }
(Unqual
{OccName: Zero}))
(False)
({ <no location info> }
(False))
[]
(Nothing)
(PrefixCon
......@@ -45,7 +46,8 @@
({ DumpParsedAst.hs:5:21-24 }
(Unqual
{OccName: Succ}))
(False)
({ <no location info> }
(False))
[]
(Nothing)
(PrefixCon
......
......@@ -86,7 +86,8 @@
(NoExt)
({ DumpRenamedAst.hs:6:14-17 }
{Name: DumpRenamedAst.Zero})
(False)
({ <no location info> }
(False))
[]
(Nothing)
(PrefixCon
......@@ -97,7 +98,8 @@
(NoExt)
({ DumpRenamedAst.hs:6:21-24 }
{Name: DumpRenamedAst.Succ})
(False)
({ <no location info> }
(False))
[]
(Nothing)
(PrefixCon
......@@ -349,7 +351,8 @@
(NoExt)
[({ DumpRenamedAst.hs:16:3-5 }
{Name: DumpRenamedAst.Nat})]
(False)
({ DumpRenamedAst.hs:16:10-45 }
(False))
(HsQTvs
(HsQTvsRn
[{Name: f}
......
......@@ -39,7 +39,8 @@
(NoExt)
({ T14189.hs:6:15-16 }
{Name: T14189.MT})
(False)
({ <no location info> }
(False))
[]
(Nothing)
(PrefixCon
......@@ -55,7 +56,8 @@
(NoExt)
({ T14189.hs:6:24-25 }
{Name: T14189.NT})
(False)
({ <no location info> }
(False))
[]
(Nothing)
(PrefixCon
......@@ -66,7 +68,8 @@
(NoExt)
({ T14189.hs:6:29 }
{Name: T14189.F})
(False)
({ <no location info> }
(False))
[]
(Nothing)
(RecCon
......
Subproject commit 2755526abb478c2f51c9cf4b894de287dd318868
Subproject commit d58fff78de7d48546a22392cefdd0abab1f1ccec
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