Fix the bug that generating comments would duplicate existing comments

plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
 
 module Ide.Plugin.HaddockComments where
 
@@ -46,13 +49,16 @@ genList =
   ]
 
 -----------------------------------------------------------------------------
+
+-- | Defines how to generate haddock comments by tweaking annotations of AST
 data GenComments = forall a.
   GenComments
   { title :: T.Text,
     fromDecl :: HsDecl GhcPs -> Maybe a,
     collectKeys :: a -> [AnnKey],
     isFresh :: Annotation -> Bool,
-    updateAnn :: Annotation -> Annotation
+    updateAnn :: Annotation -> Annotation,
+    updateDeclAnn :: Annotation -> Annotation
   }
 
 runGenComments :: GenComments -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit)
@@ -63,7 +69,8 @@ runGenComments GenComments {..} mLocDecls mAnns range
     annKeys <- collectKeys x,
     not $ null annKeys,
     and $ maybe False isFresh . flip Map.lookup anns <$> annKeys,
-    anns' <- foldr (Map.adjust updateAnn) anns annKeys,
+    declKey <- mkAnnKey locDecl,
+    anns' <- Map.adjust updateDeclAnn declKey $ foldr (Map.adjust updateAnn) anns annKeys,
     Just range' <- toRange src,
     result <- T.strip . T.pack $ exactPrint locDecl anns' =
     Just (title, TextEdit range' result)
@@ -80,9 +87,9 @@ genForSig = GenComments {..}
     fromDecl _ = Nothing
 
     updateAnn x = x {annEntryDelta = DP (0, 1), annsDP = dp}
+    updateDeclAnn = cleanPriorComments
 
     isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP]
-
     collectKeys = keyFromTyVar 0
 
     comment = mkComment "-- ^ " noSrcSpan
@@ -98,6 +105,7 @@ genForRecord = GenComments {..}
     fromDecl _ = Nothing
 
     updateAnn x = x {annEntryDelta = DP (1, 2), annPriorComments = [(comment, DP (1, 2))]}
+    updateDeclAnn = cleanPriorComments
 
     isFresh Ann {annPriorComments} = null annPriorComments
 
@@ -120,14 +128,21 @@ toAction title uri edit = CodeAction {..}
 
 toRange :: SrcSpan -> Maybe Range
 toRange src
-  | (RealSrcSpan span) <- src,
-    range' <- realSrcSpanToRange span =
+  | (RealSrcSpan s) <- src,
+    range' <- realSrcSpanToRange s =
     Just range'
   | otherwise = Nothing
 
 isIntersectWith :: Range -> SrcSpan -> Bool
 isIntersectWith Range {_start, _end} x = isInsideSrcSpan _start x || isInsideSrcSpan _end x
 
+getAnnConName :: AnnKey -> String
+getAnnConName (AnnKey _ (unConName -> name)) = name
+
+-- clean prior comments, since src span we get from 'LHsDecl' does not include them
+cleanPriorComments :: Annotation -> Annotation
+cleanPriorComments x = x {annPriorComments = []}
+
 -----------------------------------------------------------------------------
 
 keyFromTyVar :: Int -> LHsType GhcPs -> [AnnKey]

test/testdata/haddockComments/MultivariateFunction.expected.hs

@@ -1,5 +1,7 @@
 module MultivariateFunction where
 
+-- | some
+-- docs
 f :: a -- ^ 
   -> b -- ^ 
   -> c -- ^ 

test/testdata/haddockComments/MultivariateFunction.hs

@@ -1,4 +1,6 @@
 module MultivariateFunction where
 
+-- | some
+-- docs
 f :: a -> b -> c -> d -> e -> f -> g -> g
 f _ _ _ _ _ _ x = x

test/testdata/haddockComments/Record.expected.hs

@@ -1,5 +1,6 @@
 module Record where
 
+-- | A record
 data Record a b c d e f
   = RecordA
       {

test/testdata/haddockComments/Record.hs

@@ -1,5 +1,6 @@
 module Record where
 
+-- | A record
 data Record a b c d e f
   = RecordA
       { a :: a,