Commit 0361fc03 authored by Alec Theriault's avatar Alec Theriault Committed by Ben Gamari

Move 'HsBangTy' out in constructor arguments

When run with -haddock, a constructor argument can have both a a
strictness/unpackedness annotation and a docstring. The parser binds
'HsBangTy' more tightly than 'HsDocTy', yet for constructor arguments we
really need the 'HsBangTy' on the outside.

This commit does this shuffling in the 'mkConDeclH98' and 'mkGadtDecl'
smart constructors.

Test Plan: haddockA038, haddockC038

Reviewers: bgamari, dfeuer

Reviewed By: bgamari

Subscribers: dfeuer, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4727
parent efea32cf
......@@ -626,8 +626,10 @@ mkConDeclH98 name mb_forall mb_cxt args
, con_forall = isJust mb_forall
, con_ex_tvs = mb_forall `orElse` []
, con_mb_cxt = mb_cxt
, con_args = args
, con_args = args'
, con_doc = Nothing }
where
args' = nudgeHsSrcBangs args
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs -- Always a HsForAllTy
......@@ -638,7 +640,7 @@ mkGadtDecl names ty
, con_forall = isLHsForAllTy ty
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args
, con_args = args'
, con_res_ty = res_ty
, con_doc = Nothing }
where
......@@ -651,6 +653,7 @@ mkGadtDecl names ty
split_rho tau = (Nothing, tau)
(args, res_ty) = split_tau tau
args' = nudgeHsSrcBangs args
-- See Note [GADT abstract syntax] in HsDecls
split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
......@@ -658,6 +661,28 @@ mkGadtDecl names ty
split_tau (L _ (HsParTy _ ty)) = split_tau ty
split_tau tau = (PrefixCon [], tau)
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
-- ^ This function ensures that fields with strictness or packedness
-- annotations put these annotations on an outer 'HsBangTy'.
--
-- The problem is that in the parser, strictness and packedness annotations
-- bind more tightly that docstrings. However, the expectation downstream of
-- the parser (by functions such as 'getBangType' and 'getBangStrictness')
-- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
-- top-level type.
--
-- See #15206
nudgeHsSrcBangs details
= case details of
PrefixCon as -> PrefixCon (map go as)
RecCon r -> RecCon r
InfixCon a1 a2 -> InfixCon (go a1) (go a2)
where
go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
go lty = lty
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
-- When parsing:
......
......@@ -42,6 +42,7 @@ test('haddockA032', normal, compile, ['-haddock -ddump-parsed'])
test('haddockA035', normal, compile, ['-haddock -ddump-parsed'])
test('haddockA036', normal, compile, ['-haddock -ddump-parsed'])
test('haddockA037', normal, compile, ['-haddock -ddump-parsed'])
test('haddockA038', normal, compile, ['-haddock -ddump-parsed'])
# The tests below this line are not duplicated in
# should_compile_noflag_haddock.
......
module UnamedConstructorStrictFields where
-- See #15206
data A = A
data B = B
data Foo = MkFoo
{-# UNPACK #-} !A -- ^ Unpacked strict field
B
data Bar =
{-# UNPACK #-} !A -- ^ Unpacked strict field
:%%
B
==================== Parser ====================
module UnamedConstructorStrictFields where
data A = A
data B = B
data Foo = MkFoo {-# UNPACK #-} !A Unpacked strict field B
data Bar = {-# UNPACK #-} !A Unpacked strict field :%% B
......@@ -42,6 +42,7 @@ test('haddockC032', normal, compile, [''])
test('haddockC035', normal, compile, [''])
test('haddockC036', normal, compile, [''])
test('haddockC037', normal, compile, [''])
test('haddockC038', normal, compile, [''])
# The tests below this line are not duplicated in
# should_compile_flag_haddock.
......
module UnamedConstructorStrictFields where
-- See #15206
data A = A
data B = B
data Foo = MkFoo
{-# UNPACK #-} !A -- ^ Unpacked strict field
B
data Bar =
{-# UNPACK #-} !A -- ^ Unpacked strict field
:%%
B
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