fix: add context code action with trailing comment

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs

@@ -43,7 +43,7 @@ import           GHC                                    (AnnContext (..),
                                                          IsUnicodeSyntax (NormalSyntax),
                                                          NameAdornment (NameParens),
                                                          TrailingAnn (AddCommaAnn),
-                                                         emptyComments, reAnnL)
+                                                         emptyComments, reAnnL, EpAnnComments (..))
 
 
 -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
@@ -170,7 +170,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 +205,24 @@ appendConstraint constraintT = go . traceAst "appendConstraint"
 
     return $ reLocA $ L lTop $ HsQualTy noExtField context ast
 
+-- | 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})
+
 liftParseAST
     :: forall ast l.  (ASTElement l ast, ExactPrint (LocatedAn l ast))
     => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast)
@@ -500,7 +518,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

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs

@@ -13,6 +13,7 @@ import           GHC.Utils.Outputable
 import           System.Environment.Blank              (getEnvDefault)
 import           System.IO.Unsafe
 import           Text.Printf
+import System.Directory.Extra (createDirectoryIfMissing)
 --------------------------------------------------------------------------------
 -- Tracing exactprint terms
 
@@ -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 ++ ":"

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`"