Haddock: support strict GADT args with docs
authorAlec Theriault <alec.theriault@gmail.com>
Thu, 18 Apr 2019 19:53:56 +0000 (12:53 -0700)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Sat, 20 Apr 2019 03:50:29 +0000 (23:50 -0400)
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.

compiler/hsSyn/HsTypes.hs
compiler/parser/RdrHsSyn.hs
testsuite/tests/haddock/should_compile_flag_haddock/T15206.hs [new file with mode: 0644]
testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr [new file with mode: 0644]
testsuite/tests/haddock/should_compile_flag_haddock/T16585.hs [new file with mode: 0644]
testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr [new file with mode: 0644]
testsuite/tests/haddock/should_compile_flag_haddock/all.T

index 9bb73c3..b186b36 100644 (file)
@@ -105,14 +105,22 @@ import Data.Data hiding ( Fixity, Prefix, Infix )
 type LBangType pass = Located (BangType pass)
 
 -- | Bang Type
 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
 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 :: 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)
 
 {-
 getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
 
 {-
index 3582f13..bfb83bc 100644 (file)
@@ -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_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 }
                , con_doc    = Nothing }
-  where
-    args' = nudgeHsSrcBangs args
 
 mkGadtDecl :: [Located RdrName]
            -> LHsType GhcPs     -- Always a HsForAllTy
 
 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_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)
                  , 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
       = (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))
 
     -- 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)
 
                                                        (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.
 
 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 (file)
index 0000000..3d9b9fc
--- /dev/null
@@ -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 (file)
index 0000000..8a12344
--- /dev/null
@@ -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 (file)
index 0000000..2132c0e
--- /dev/null
@@ -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 (file)
index 0000000..9bf18f0
--- /dev/null
@@ -0,0 +1,6 @@
+
+==================== Parser ====================
+module T16585 where
+data F a where X :: !Int " comment" -> F Int
+
+
index 5450fcb..72c913a 100644 (file)
@@ -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('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'])