Haddock: support strict GADT args with docs

Rather than massaging the output of the parser to re-arrange docs and
bangs, it is simpler to patch the two places in which the strictness
info is needed (to accept that the `HsBangTy` may be inside an
`HsDocTy`).

Fixes #16585.

7 files changed, 37 insertions, 29 deletions

diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 9bb73c361b..b186b36abb 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -105,14 +105,22 @@ import Data.Data hiding ( Fixity, Prefix, Infix )
 type LBangType pass = Located (BangType pass)
 
 -- | Bang Type
+--
+-- In the parser, strictness and packedness annotations bind more tightly
+-- than docstrings. This means that when consuming a 'BangType' (and looking
+-- for 'HsBangTy') we must be ready to peer behind a potential layer of
+-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.
 type BangType pass  = HsType pass       -- Bangs are in the HsType data type
 
 getBangType :: LHsType a -> LHsType a
-getBangType (L _ (HsBangTy _ _ ty)) = ty
-getBangType ty                      = ty
+getBangType                 (L _ (HsBangTy _ _ lty))       = lty
+getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
+  addCLoc lty lds (HsDocTy x lty lds)
+getBangType lty                                            = lty
 
 getBangStrictness :: LHsType a -> HsSrcBang
-getBangStrictness (L _ (HsBangTy _ s _)) = s
+getBangStrictness                 (L _ (HsBangTy _ s _))     = s
+getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s
 getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
 
 {-
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 3582f13dcc..bfb83bc9b3 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -662,10 +662,8 @@ mkConDeclH98 name mb_forall mb_cxt args
                , con_forall = noLoc $ 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
@@ -676,7 +674,7 @@ mkGadtDecl names ty
                  , con_forall = cL l $ isLHsForAllTy ty'
                  , con_qvars  = mkHsQTvs tvs
                  , con_mb_cxt = mcxt
-                 , con_args   = args'
+                 , con_args   = args
                  , con_res_ty = res_ty
                  , con_doc    = Nothing }
     , anns1 ++ anns2)
@@ -693,7 +691,6 @@ mkGadtDecl names ty
       = (Nothing, tau, ann)
 
     (args, res_ty) = split_tau tau
-    args' = nudgeHsSrcBangs args
 
     -- See Note [GADT abstract syntax] in HsDecls
     split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
@@ -705,27 +702,6 @@ mkGadtDecl names ty
                                                        (ann++mkParensApiAnn l)
     peel_parens ty                   ann = (ty, ann)
 
-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 (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =
-      cL 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.
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T15206.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T15206.hs
new file mode 100644
index 0000000000..3d9b9fc220
--- /dev/null
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T15206.hs
@@ -0,0 +1,4 @@
+module T15206 where
+data Point = Point  -- ^ a 2D point
+               !Int -- ^ x coord
+               !Int -- ^ y coord
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr
new file mode 100644
index 0000000000..8a12344e36
--- /dev/null
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr
@@ -0,0 +1,6 @@
+
+==================== Parser ====================
+module T15206 where
+data Point = " a 2D point" Point !Int " x coord" !Int " y coord"
+
+
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T16585.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T16585.hs
new file mode 100644
index 0000000000..2132c0edb2
--- /dev/null
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T16585.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE GADTs #-}
+module T16585 where
+data F a where
+  X :: !Int -- ^ comment
+    -> F Int
+
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr
new file mode 100644
index 0000000000..9bf18f0f9b
--- /dev/null
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr
@@ -0,0 +1,6 @@
+
+==================== Parser ====================
+module T16585 where
+data F a where X :: !Int " comment" -> F Int
+
+
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/all.T b/testsuite/tests/haddock/should_compile_flag_haddock/all.T
index 5450fcbe7f..72c913a42c 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/all.T
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/all.T
@@ -51,3 +51,5 @@ test('haddockA033', normal, compile, ['-haddock -ddump-parsed'])
 test('haddockA034', normal, compile, ['-haddock -ddump-parsed'])
 test('T10398', normal, compile, ['-haddock -ddump-parsed'])
 test('T11768', normal, compile, ['-haddock -ddump-parsed'])
+test('T15206', normal, compile, ['-haddock -ddump-parsed'])
+test('T16585', normal, compile, ['-haddock -ddump-parsed'])