[Git][ghc/ghc][master] Haddock: support strict GADT args with docs

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
99dd5d6b by Alec Theriault at 2019-04-20T03:50:29Z
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 changed files:

- compiler/hsSyn/HsTypes.hs
- compiler/parser/RdrHsSyn.hs
- + testsuite/tests/haddock/should_compile_flag_haddock/T15206.hs
- + testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr
- + testsuite/tests/haddock/should_compile_flag_haddock/T16585.hs
- + testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/all.T


Changes:

=====================================
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)
 
 {-


=====================================
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.


=====================================
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


=====================================
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"
+
+


=====================================
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
+


=====================================
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
+
+


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/99dd5d6b8365ecc8748651395c503b2c0b82490e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/99dd5d6b8365ecc8748651395c503b2c0b82490e
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190419/0f279092/attachment-0001.html>