diff options
6 files changed, 64 insertions, 2 deletions
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index dfcccd369e..35371af9c8 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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: diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/all.T b/testsuite/tests/haddock/should_compile_flag_haddock/all.T index 90d4a55c3f..5450fcbe7f 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/all.T +++ b/testsuite/tests/haddock/should_compile_flag_haddock/all.T @@ -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. diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.hs new file mode 100644 index 0000000000..b839bdee22 --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.hs @@ -0,0 +1,14 @@ +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 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.stderr new file mode 100644 index 0000000000..94318efe2b --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.stderr @@ -0,0 +1,7 @@ + +==================== 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 diff --git a/testsuite/tests/haddock/should_compile_noflag_haddock/all.T b/testsuite/tests/haddock/should_compile_noflag_haddock/all.T index edb2bd0e05..4e52c2d92c 100644 --- a/testsuite/tests/haddock/should_compile_noflag_haddock/all.T +++ b/testsuite/tests/haddock/should_compile_noflag_haddock/all.T @@ -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. diff --git a/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC038.hs b/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC038.hs new file mode 100644 index 0000000000..b839bdee22 --- /dev/null +++ b/testsuite/tests/haddock/should_compile_noflag_haddock/haddockC038.hs @@ -0,0 +1,14 @@ +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 |