From 1fc705e6deb518f5aa96bb9e558b7f368bae9a85 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 20 Jan 2021 00:27:32 +0800 Subject: [PATCH 1/6] Fix duplicating existed comments --- .../src/Ide/Plugin/HaddockComments.hs | 24 ++++++++++++------- .../MultivariateFunction.expected.hs | 2 ++ .../haddockComments/MultivariateFunction.hs | 2 ++ 3 files changed, 19 insertions(+), 9 deletions(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index a7f4fa4a1b..50a5daf4ea 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.HaddockComments where @@ -49,21 +51,21 @@ genList = data GenComments = forall a. GenComments { title :: T.Text, - fromDecl :: HsDecl GhcPs -> Maybe a, + fromDecl :: LHsDecl GhcPs -> Maybe a, collectKeys :: a -> [AnnKey], isFresh :: Annotation -> Bool, - updateAnn :: Annotation -> Annotation + updateAnn :: AnnKey -> Annotation -> Annotation } runGenComments :: GenComments -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit) runGenComments GenComments {..} mLocDecls mAnns range | Just locDecls <- mLocDecls, Just anns <- mAnns, - [(locDecl, src, x)] <- [(locDecl, l, x) | locDecl@(L l (fromDecl -> Just x)) <- locDecls, range `isIntersectWith` l], + [(locDecl, src, x)] <- [(locDecl, l, x) | Just (locDecl@(L l _), x) <- (\d -> (d,) <$> fromDecl d) <$> locDecls, range `isIntersectWith` l], annKeys <- collectKeys x, not $ null annKeys, and $ maybe False isFresh . flip Map.lookup anns <$> annKeys, - anns' <- foldr (Map.adjust updateAnn) anns annKeys, + anns' <- foldr (Map.adjustWithKey updateAnn) anns annKeys, Just range' <- toRange src, result <- T.strip . T.pack $ exactPrint locDecl anns' = Just (title, TextEdit range' result) @@ -76,14 +78,18 @@ genForSig = GenComments {..} where title = "Generate signature comments" - fromDecl (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ x)))) = Just x + fromDecl d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ x))))) = Just (d, x) fromDecl _ = Nothing - updateAnn x = x {annEntryDelta = DP (0, 1), annsDP = dp} + updateAnn k x + | (AnnKey _ (unConName -> "TypeSig")) <- k = + -- clean prior comments, since src span we get from 'LHsDecl' does not include them + x {annPriorComments = []} + | otherwise = x {annEntryDelta = DP (0, 1), annsDP = dp} isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] - collectKeys = keyFromTyVar 0 + collectKeys (d, x) = mkAnnKey d : keyFromTyVar 0 x comment = mkComment "-- ^ " noSrcSpan dp = [(AnnComment comment, DP (0, 1)), (G AnnRarrow, DP (1, 2))] @@ -93,11 +99,11 @@ genForRecord = GenComments {..} where title = "Generate fields comments" - fromDecl (TyClD _ DataDecl {tcdDataDefn = HsDataDefn {dd_cons = cons}}) = + fromDecl (L _ (TyClD _ DataDecl {tcdDataDefn = HsDataDefn {dd_cons = cons}})) = Just [x | (L _ ConDeclH98 {con_args = x}) <- cons] fromDecl _ = Nothing - updateAnn x = x {annEntryDelta = DP (1, 2), annPriorComments = [(comment, DP (1, 2))]} + updateAnn _ x = x {annEntryDelta = DP (1, 2), annPriorComments = [(comment, DP (1, 2))]} isFresh Ann {annPriorComments} = null annPriorComments diff --git a/test/testdata/haddockComments/MultivariateFunction.expected.hs b/test/testdata/haddockComments/MultivariateFunction.expected.hs index 01d57bac65..73bd53da1c 100644 --- a/test/testdata/haddockComments/MultivariateFunction.expected.hs +++ b/test/testdata/haddockComments/MultivariateFunction.expected.hs @@ -1,5 +1,7 @@ module MultivariateFunction where +-- | some +-- docs f :: a -- ^ -> b -- ^ -> c -- ^ diff --git a/test/testdata/haddockComments/MultivariateFunction.hs b/test/testdata/haddockComments/MultivariateFunction.hs index 48be5c7b0e..a487d05ec9 100644 --- a/test/testdata/haddockComments/MultivariateFunction.hs +++ b/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 From 5db5cd8036586fada2754d895f6837aba2e373cf Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 20 Jan 2021 11:57:35 +0800 Subject: [PATCH 2/6] Factorize and do the same to genForRecord --- .../src/Ide/Plugin/HaddockComments.hs | 41 +++++++++++-------- .../haddockComments/Record.expected.hs | 1 + test/testdata/haddockComments/Record.hs | 1 + 3 files changed, 27 insertions(+), 16 deletions(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 50a5daf4ea..71127bdd32 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall #-} module Ide.Plugin.HaddockComments where @@ -48,24 +49,28 @@ genList = ] ----------------------------------------------------------------------------- + +-- | Defines how to generate haddock comments by tweaking annotations of AST data GenComments = forall a. GenComments { title :: T.Text, - fromDecl :: LHsDecl GhcPs -> Maybe a, + fromDecl :: HsDecl GhcPs -> Maybe a, collectKeys :: a -> [AnnKey], isFresh :: Annotation -> Bool, - updateAnn :: AnnKey -> Annotation -> Annotation + updateAnn :: Annotation -> Annotation, + updateDeclAnn :: Annotation -> Annotation } runGenComments :: GenComments -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit) runGenComments GenComments {..} mLocDecls mAnns range | Just locDecls <- mLocDecls, Just anns <- mAnns, - [(locDecl, src, x)] <- [(locDecl, l, x) | Just (locDecl@(L l _), x) <- (\d -> (d,) <$> fromDecl d) <$> locDecls, range `isIntersectWith` l], + [(locDecl, src, x)] <- [(locDecl, l, x) | locDecl@(L l (fromDecl -> Just x)) <- locDecls, range `isIntersectWith` l], annKeys <- collectKeys x, not $ null annKeys, and $ maybe False isFresh . flip Map.lookup anns <$> annKeys, - anns' <- foldr (Map.adjustWithKey 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) @@ -78,18 +83,14 @@ genForSig = GenComments {..} where title = "Generate signature comments" - fromDecl d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ x))))) = Just (d, x) + fromDecl (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ x)))) = Just x fromDecl _ = Nothing - updateAnn k x - | (AnnKey _ (unConName -> "TypeSig")) <- k = - -- clean prior comments, since src span we get from 'LHsDecl' does not include them - x {annPriorComments = []} - | otherwise = x {annEntryDelta = DP (0, 1), annsDP = dp} + updateAnn x = x {annEntryDelta = DP (0, 1), annsDP = dp} + updateDeclAnn = cleanPriorComments isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] - - collectKeys (d, x) = mkAnnKey d : keyFromTyVar 0 x + collectKeys = keyFromTyVar 0 comment = mkComment "-- ^ " noSrcSpan dp = [(AnnComment comment, DP (0, 1)), (G AnnRarrow, DP (1, 2))] @@ -99,11 +100,12 @@ genForRecord = GenComments {..} where title = "Generate fields comments" - fromDecl (L _ (TyClD _ DataDecl {tcdDataDefn = HsDataDefn {dd_cons = cons}})) = + fromDecl (TyClD _ DataDecl {tcdDataDefn = HsDataDefn {dd_cons = cons}}) = Just [x | (L _ ConDeclH98 {con_args = x}) <- cons] fromDecl _ = Nothing - updateAnn _ x = x {annEntryDelta = DP (1, 2), annPriorComments = [(comment, DP (1, 2))]} + updateAnn x = x {annEntryDelta = DP (1, 2), annPriorComments = [(comment, DP (1, 2))]} + updateDeclAnn = cleanPriorComments isFresh Ann {annPriorComments} = null annPriorComments @@ -126,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] diff --git a/test/testdata/haddockComments/Record.expected.hs b/test/testdata/haddockComments/Record.expected.hs index f7b0a379b8..a6ded3780b 100644 --- a/test/testdata/haddockComments/Record.expected.hs +++ b/test/testdata/haddockComments/Record.expected.hs @@ -1,5 +1,6 @@ module Record where +-- | A record data Record a b c d e f = RecordA { diff --git a/test/testdata/haddockComments/Record.hs b/test/testdata/haddockComments/Record.hs index 1adeb3f436..9071b8363c 100644 --- a/test/testdata/haddockComments/Record.hs +++ b/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, From 8882d74da236900387d91717bdbaa37017aaa920 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 20 Jan 2021 12:17:44 +0800 Subject: [PATCH 3/6] Remove unused pragmas --- .../src/Ide/Plugin/HaddockComments.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 71127bdd32..5bc4c7bd7a 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -3,9 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall #-} module Ide.Plugin.HaddockComments where From 9e441b3632d92c9d7f3a475379c331ff442bd332 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 20 Jan 2021 12:21:10 +0800 Subject: [PATCH 4/6] Remove unused identifiers --- .../src/Ide/Plugin/HaddockComments.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 5bc4c7bd7a..41a1081c67 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -5,7 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.HaddockComments where +module Ide.Plugin.HaddockComments (descriptor) where import Control.Monad (join) import qualified Data.HashMap.Strict as HashMap @@ -26,9 +26,6 @@ descriptor plId = { pluginCodeActionProvider = Just codeActionProvider } -haddockCommentsId :: CommandId -haddockCommentsId = "HaddockCommentsCommand" - codeActionProvider :: CodeActionProvider IdeState codeActionProvider _lspFuncs ideState _pId (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = List diags} = do @@ -134,9 +131,6 @@ toRange src 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 = []} From 3c3597eb70f1016237db24023777aaf73c9ccf64 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 20 Jan 2021 14:08:30 +0800 Subject: [PATCH 5/6] Fix code action positions in tests --- test/functional/HaddockComments.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/functional/HaddockComments.hs b/test/functional/HaddockComments.hs index c4af8af296..9e0378acd8 100644 --- a/test/functional/HaddockComments.hs +++ b/test/functional/HaddockComments.hs @@ -28,7 +28,7 @@ tests = "haddock comments" [ goldenTest "HigherRankFunction" Signature 4 6, goldenTest "KindSigFunction" Signature 9 10, - goldenTest "MultivariateFunction" Signature 2 8, + goldenTest "MultivariateFunction" Signature 4 8, goldenTest "QualFunction" Signature 2 10, goldenTest "Record" Record 7 2, expectedNothing "ConstFunction" Signature 2 2, @@ -37,7 +37,7 @@ tests = ] goldenTest :: FilePath -> GenCommentsType -> Int -> Int -> TestTree -goldenTest fp (toTitle -> expectedTitle) l c = goldenVsStringDiff fp goldenGitDiff goldenFilePath $ +goldenTest fp (toTitle -> expectedTitle) l c = goldenVsStringDiff (fp <> " (golden)") goldenGitDiff goldenFilePath $ runSession hlsCommand fullCaps haddockCommentsPath $ do doc <- openDoc hsFilePath "haskell" _ <- waitForDiagnostics From 989c4998fb4718acf28919c2349f602beda4d542 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 20 Jan 2021 15:26:56 +0800 Subject: [PATCH 6/6] Use new rule: GetAnnotatedParsedSource --- .../src/Ide/Plugin/HaddockComments.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 41a1081c67..ce71531ca0 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -13,6 +13,7 @@ import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat +import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (..), annsA, astA) import Ide.Types import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) @@ -31,9 +32,9 @@ codeActionProvider _lspFuncs ideState _pId (TextDocumentIdentifier uri) range Co do let noErr = and $ (/= Just DsError) . _severity <$> diags nfp = uriToNormalizedFilePath $ toNormalizedUri uri - (join -> pm) <- runAction "HaddockComments.GetParsedModule" ideState $ use GetParsedModule `traverse` nfp - let locDecls = hsmodDecls . unLoc . pm_parsed_source <$> pm - anns = relativiseApiAnns <$> (pm_parsed_source <$> pm) <*> (pm_annotations <$> pm) + (join -> pm) <- runAction "HaddockComments.GetAnnotatedParsedSource" ideState $ use GetAnnotatedParsedSource `traverse` nfp + let locDecls = hsmodDecls . unLoc . astA <$> pm + anns = annsA <$> pm edits = [runGenComments gen locDecls anns range | noErr, gen <- genList] return $ Right $ List [CACodeAction $ toAction title uri edit | (Just (title, edit)) <- edits]