[commit: ghc] master: Move 'HsBangTy' out in constructor arguments (0361fc0)
git at git.haskell.org
git at git.haskell.org
Fri Jun 8 00:07:43 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/0361fc038e117befc3c59fcd589d640006407ed6/ghc
>---------------------------------------------------------------
commit 0361fc038e117befc3c59fcd589d640006407ed6
Author: Alec Theriault <alec.theriault at gmail.com>
Date: Thu Jun 7 13:26:53 2018 -0400
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
>---------------------------------------------------------------
0361fc038e117befc3c59fcd589d640006407ed6
compiler/parser/RdrHsSyn.hs | 29 ++++++++++++++++++++--
.../haddock/should_compile_flag_haddock/all.T | 1 +
.../should_compile_flag_haddock/haddockA038.hs | 14 +++++++++++
.../should_compile_flag_haddock/haddockA038.stderr | 7 ++++++
.../haddock/should_compile_noflag_haddock/all.T | 1 +
.../should_compile_noflag_haddock/haddockC038.hs | 14 +++++++++++
6 files changed, 64 insertions(+), 2 deletions(-)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index dfcccd3..35371af 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 90d4a55..5450fcb 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 0000000..b839bde
--- /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 0000000..94318ef
--- /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 edb2bd0..4e52c2d 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 0000000..b839bde
--- /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
More information about the ghc-commits
mailing list