Merge pull request #129 from alanz/wip/9.4-fix-haddock-printing-2

Fix the balance of haddock comment exact printing.
alanz · Jun 4, 2023 · 7aa5c69 · 7aa5c69
2 parents c034b8a + df99091
commit 7aa5c69
Show file tree

Hide file tree

Showing 3 changed files with 10 additions and 10 deletions.
diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs
@@ -4271,7 +4271,6 @@ instance ExactPrint (ConDecl GhcPs) where
                     , con_mb_cxt = mcxt
                     , con_args = args
                     , con_doc = doc }) = do
-    doc' <- mapM markAnnotated doc
     an0 <- if has_forall
       then markEpAnnL an lidl AnnForall
       else return an
@@ -4291,7 +4290,7 @@ instance ExactPrint (ConDecl GhcPs) where
                        , con_ex_tvs = ex_tvs'
                        , con_mb_cxt = mcxt'
                        , con_args = args'
-                       , con_doc = doc' })
+                       , con_doc = doc })
 
     where
     --   -- In ppr_details: let's not print the multiplicities (they are always 1, by
@@ -4318,7 +4317,6 @@ instance ExactPrint (ConDecl GhcPs) where
                      , con_bndrs = bndrs
                      , con_mb_cxt = mcxt, con_g_args = args
                      , con_res_ty = res_ty, con_doc = doc }) = do
-    doc' <- mapM markAnnotated doc
     cons' <- mapM markAnnotated cons
     an0 <- markEpAnnL an lidl AnnDcolon
     an1 <- annotationsToComments an0 lidl  [AnnOpenP, AnnCloseP]
@@ -4346,7 +4344,7 @@ instance ExactPrint (ConDecl GhcPs) where
                         , con_names = cons'
                         , con_bndrs = bndrs'
                         , con_mb_cxt = mcxt', con_g_args = args'
-                        , con_res_ty = res_ty', con_doc = doc' })
+                        , con_res_ty = res_ty', con_doc = doc })
 
 -- ---------------------------------------------------------------------
 
@@ -4382,8 +4380,7 @@ instance ExactPrint (ConDeclField GhcPs) where
     names' <- markAnnotated names
     an0 <- markEpAnnL an lidl AnnDcolon
     ftype' <- markAnnotated ftype
-    mdoc' <- mapM markAnnotated mdoc
-    return (ConDeclField an0 names' ftype' mdoc')
+    return (ConDeclField an0 names' ftype' mdoc)
 
 -- ---------------------------------------------------------------------
 

diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -215,13 +215,16 @@ tokComment t@(L lt c) =
 hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment]
 hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) =
   let
-    L lx x' = dedentDocChunkBy 4 x
-    str = "-- " ++ printDecorator dec ++ unpackHDSC x'
+    decStr = printDecorator dec
+    L lx x' = dedentDocChunkBy (3 + length decStr) x
+    str = "-- " ++ decStr ++ unpackHDSC x'
     docChunk _ [] = []
     docChunk pt' (L l chunk:cs)
       = Comment ("--" ++ unpackHDSC chunk) (spanAsAnchor l) pt' Nothing : docChunk (rs l) cs
   in
-    (Comment str (spanAsAnchor lx) pt Nothing : docChunk pt (map dedentDocChunk xs))
+    (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs))
+hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk))
+  = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
 hsDocStringComments anc pt (NestedDocString dec (L _ chunk))
   = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
 hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code

diff --git a/tests/examples/ghc94/Haddock.hs b/tests/examples/ghc94/Haddock.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Test