From 9f866fb58758ceb89064e0eaf6ce60ba1d0da475 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sun, 6 Jul 2025 12:04:47 +0400 Subject: [PATCH 1/3] fix: create directory to dump debug ast --- .../src/Development/IDE/Plugin/CodeAction/Util.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs index 40f3c76127..2a7719fdbe 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs @@ -10,6 +10,7 @@ import Development.IDE.GHC.Compat.ExactPrint as GHC import Development.IDE.GHC.Dump (showAstDataHtml) import GHC.Stack import GHC.Utils.Outputable +import System.Directory.Extra (createDirectoryIfMissing) import System.Environment.Blank (getEnvDefault) import System.IO.Unsafe import Text.Printf @@ -37,6 +38,7 @@ traceAst lbl x doTrace = unsafePerformIO $ do u <- U.newUnique let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u) + createDirectoryIfMissing True "/tmp/hls" writeFile htmlDumpFileName $ renderDump htmlDump return $ unlines [prettyCallStack callStack ++ ":" From 4a6dd289cd46372cadb5051e8529bf882fc81617 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sun, 6 Jul 2025 12:04:47 +0400 Subject: [PATCH 2/3] feat(test): add a repro for 4648 --- plugins/hls-refactor-plugin/test/Main.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index da45083a08..70cea60a35 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3036,6 +3036,21 @@ addFunctionConstraintTests = let , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" ] + -- See https://github.com/haskell/haskell-language-server/issues/4648 + -- When haddock comment appears after the =>, code action was introducing the + -- new constraint in the comment + incompleteConstraintSourceCodeWithCommentInTypeSignature :: T.Text -> T.Text + incompleteConstraintSourceCodeWithCommentInTypeSignature constraint = + T.unlines + + [ "module Testing where" + , "foo " + , " :: (" <> constraint <> ") =>" + , " -- This is a comment" + , " m ()" + , "foo = pure ()" + ] + missingMonadConstraint constraint = T.unlines [ "module Testing where" , "f :: " <> constraint <> "m ()" @@ -3079,6 +3094,11 @@ addFunctionConstraintTests = let "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") + , checkCodeAction + "preexisting constraint, with haddock comment in type signature" + "Add `Applicative m` to the context of the type signature for `foo`" + (incompleteConstraintSourceCodeWithCommentInTypeSignature "") + (incompleteConstraintSourceCodeWithCommentInTypeSignature "Applicative m") , checkCodeAction "missing Monad constraint" "Add `Monad m` to the context of the type signature for `f`" From 80be44c36529bf138f2c343844e31214dc132602 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sun, 6 Jul 2025 15:07:00 +0400 Subject: [PATCH 3/3] fix: produce valid code when adding constraint to context This closes https://github.com/haskell/haskell-language-server/issues/4648. When adding constraint to a context which is followed by a comment, such as: ``` foo :: (Monad m) => -- | This is a comment m () ``` The comment annotation is anchored to the previous token, which is `=>` in this context. If we add a new constraint in the context, the newly generated content goes beyond the anchor and, depending on GHC version, or ghc-exactprint (the reason is not fully understood), the comment is printed BEFORE the new constraint, leading to invalid syntax, such as `(Monad m -- | This is a comment , Applicative m =>)` This commit moves all the comment of the block at the end of the block using the `followingComments` of `EpAnnComments`. It seems super adhoc, but actually, consider the following example: ```haskell bar :: -- BEFORE {- yoto -} (Monad m {- yiti -}){- yutu -} => {- yete -} -- Trailing -- After m () ``` Comment `BEFORE` and `yoto` are attached to the previous block. Comment `yiti` is attached to `Monad m`. The comments `yiti`, `yutu`, `yete`, `Trailing` and `After` are all attached to this block and will hence be moved after the block. However this is not an easy task, all the associated comments should be moved by the relevant offset. TODO: do that instead. --- .../IDE/Plugin/CodeAction/ExactPrint.hs | 25 +++++++++++++++++-- plugins/hls-refactor-plugin/test/Main.hs | 4 +-- 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 0f48a3a649..bffd2a611c 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -63,6 +63,7 @@ import GHC (addAnns, ann) #if MIN_VERSION_ghc(9,9,0) import GHC (NoAnn (..)) +import GHC (EpAnnComments (..)) #endif ------------------------------------------------------------------------------ @@ -170,7 +171,7 @@ appendConstraint constraintT = go . traceAst "appendConstraint" constraint <- liftParseAST df constraintT constraint <- pure $ setEntryDP constraint (SameLine 1) #if MIN_VERSION_ghc(9,9,0) - let l'' = fmap (addParensToCtxt close_dp) l' + let l'' = moveCommentsToTheEnd $ fmap (addParensToCtxt close_dp) l' #else let l'' = (fmap.fmap) (addParensToCtxt close_dp) l' #endif @@ -205,6 +206,26 @@ appendConstraint constraintT = go . traceAst "appendConstraint" return $ reLocA $ L lTop $ HsQualTy noExtField context ast +#if MIN_VERSION_ghc(9,9,0) +-- | This moves comment annotation toward the end of the block +-- This is useful when extending a block, so the comment correctly appears +-- after. +-- +-- See https://github.com/haskell/haskell-language-server/issues/4648 for +-- discussion. +-- +-- For example, the following element, @(Foo) => -- hello@, when introducing an +-- additionnal constraint, `Bar`, instead of getting `@(Foo, Bar) => -- hello@, +-- we get @(Foo, -- hello Bar) =>@ +-- +-- This is a bit painful that the pretty printer is not able to realize that it +-- introduces the token `=>` inside the comment and instead does something with +-- meaning, but that's another story. +moveCommentsToTheEnd :: EpAnn ann -> EpAnn ann +moveCommentsToTheEnd (EpAnn entry anns (EpaComments priors)) = EpAnn entry anns (EpaCommentsBalanced { priorComments = [], followingComments = priors}) +moveCommentsToTheEnd (EpAnn entry anns (EpaCommentsBalanced priors following)) = EpAnn entry anns (EpaCommentsBalanced { priorComments = [], followingComments = priors <> following}) +#endif + liftParseAST :: forall ast l. (ASTElement l ast, ExactPrint (LocatedAn l ast)) => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast) @@ -500,7 +521,7 @@ extendHiding symbol (L l idecls) mlies df = do Nothing -> do #if MIN_VERSION_ghc(9,11,0) let ann :: EpAnn (AnnList (EpToken "hiding", [EpToken ","])) - ann = noAnnSrcSpanDP0 + ann = noAnnSrcSpanDP0 #elif MIN_VERSION_ghc(9,9,0) let ann = noAnnSrcSpanDP0 #else diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 70cea60a35..b06b41ccba 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3045,7 +3045,7 @@ addFunctionConstraintTests = let [ "module Testing where" , "foo " - , " :: (" <> constraint <> ") =>" + , " :: ("<> constraint <> ") =>" , " -- This is a comment" , " m ()" , "foo = pure ()" @@ -3098,7 +3098,7 @@ addFunctionConstraintTests = let "preexisting constraint, with haddock comment in type signature" "Add `Applicative m` to the context of the type signature for `foo`" (incompleteConstraintSourceCodeWithCommentInTypeSignature "") - (incompleteConstraintSourceCodeWithCommentInTypeSignature "Applicative m") + (incompleteConstraintSourceCodeWithCommentInTypeSignature " Applicative m") , checkCodeAction "missing Monad constraint" "Add `Monad m` to the context of the type signature for `f`"