From df99091e23dcd62c4a874a5a6d32a5583915799c Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 4 Jun 2023 13:25:47 +0100 Subject: [PATCH] Fix the balance of haddock comment exact printing. --- src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs | 9 +++------ src/Language/Haskell/GHC/ExactPrint/Utils.hs | 9 ++++++--- tests/examples/ghc94/Haddock.hs | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs index ac1ba0b0..615258e7 100644 --- 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 index b119b09a..1ee0770b 100644 --- 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 index 64c97c2e..85f5f8b5 100644 --- 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