From 5a1138a589cac070bc22be07db1033bfad096aa7 Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 10 Sep 2022 00:29:50 +0800 Subject: [PATCH 01/13] remove 'buildable: False' in cabal --- .../hls-haddock-comments-plugin.cabal | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index 6de352816b..877b8519fe 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -18,10 +18,6 @@ extra-source-files: test/testdata/*.hs library - if impl(ghc >= 9.2) - buildable: False - else - buildable: True exposed-modules: Ide.Plugin.HaddockComments hs-source-dirs: src ghc-options: @@ -32,7 +28,7 @@ library , base >=4.12 && <5 , containers , ghc - , ghc-exactprint < 1 + , ghc-exactprint ^>=1.5.0 , ghcide ^>=1.6 || ^>=1.7 , hls-plugin-api ^>=1.3 || ^>=1.4 , hls-refactor-plugin From b18e37d22f76b70b8605d277c03d28b2aa67a3e0 Mon Sep 17 00:00:00 2001 From: kokobd Date: Mon, 12 Sep 2022 13:36:50 +0800 Subject: [PATCH 02/13] remove constraint on ghc-exactprint --- .../hls-haddock-comments-plugin.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index 877b8519fe..6fbbefe956 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -28,7 +28,7 @@ library , base >=4.12 && <5 , containers , ghc - , ghc-exactprint ^>=1.5.0 + , ghc-exactprint , ghcide ^>=1.6 || ^>=1.7 , hls-plugin-api ^>=1.3 || ^>=1.4 , hls-refactor-plugin From 982ff535cc8e6c96f162d16a710a888cc67d420b Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 15 Sep 2022 19:13:15 +0800 Subject: [PATCH 03/13] wip --- .../src/Ide/Plugin/HaddockComments.hs | 22 +++++++++++++------ 1 file changed, 15 insertions(+), 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 2993219893..0ffb1d231d 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -13,12 +13,13 @@ import Control.Monad.IO.Class import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Text as T +import Debug.Trace (traceShowId) import Development.IDE hiding (pluginHandlers) import Development.IDE.GHC.Compat -import Development.IDE.Plugin.CodeAction import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (..)) -import qualified Development.IDE.GHC.ExactPrint as E +import qualified Development.IDE.GHC.ExactPrint as E +import Development.IDE.Plugin.CodeAction import Ide.Types import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) @@ -58,10 +59,14 @@ data GenComments = forall a. fromDecl :: HsDecl GhcPs -> Maybe a, collectKeys :: a -> [AnnKey], isFresh :: Annotation -> Bool, - updateAnn :: Annotation -> Annotation, + updateAnn :: UpdateAnn, updateDeclAnn :: Annotation -> Annotation } +type UpdateAnn = Bool -- ^ is first + -> Annotation + -> Annotation + runGenComments :: GenComments -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit) runGenComments GenComments {..} mLocDecls mAnns range | Just locDecls <- mLocDecls, @@ -69,9 +74,10 @@ runGenComments GenComments {..} mLocDecls mAnns range [(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, + and $ maybe False isFresh . flip Map.lookup (traceShowId anns) <$> annKeys, declKey <- mkAnnKey locDecl, - anns' <- Map.adjust updateDeclAnn declKey $ foldr (Map.adjust updateAnn) anns annKeys, + anns' <- Map.adjust updateDeclAnn declKey $ foldr (\(key, isFirst) -> + Map.adjust (updateAnn isFirst) key) anns (zip annKeys (True : repeat False)), Just range' <- toRange src, result <- T.strip . T.pack $ exactPrint locDecl anns' = Just (title, TextEdit range' result) @@ -87,7 +93,7 @@ genForSig = GenComments {..} fromDecl (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ x)))) = Just x fromDecl _ = Nothing - updateAnn x = x {annEntryDelta = DP (0, 1), annsDP = dp} + updateAnn _ x = x {annEntryDelta = DP (0, 1), annsDP = dp} updateDeclAnn = cleanPriorComments isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] @@ -111,7 +117,9 @@ genForRecord = GenComments {..} Just [x | (L _ ConDeclH98 {con_args = x}) <- cons] fromDecl _ = Nothing - updateAnn x = x {annEntryDelta = DP (1, 2), annPriorComments = [(comment, DP (1, 2))]} + updateAnn isFirst x = + let delta = if isFirst then (0, 1) else (1, 0) + in x {annEntryDelta = DP (1, 0), annPriorComments = [(comment, DP delta)]} updateDeclAnn = cleanPriorComments isFresh Ann {annPriorComments} = null annPriorComments From 3e10bb6bc6a14eaa2ce6a102a35d65133ced6e29 Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 17 Sep 2022 21:20:08 +0800 Subject: [PATCH 04/13] revert HaddockComments.hs --- .../src/Ide/Plugin/HaddockComments.hs | 18 +++++------------- 1 file changed, 5 insertions(+), 13 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 0ffb1d231d..79acf7b072 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -13,7 +13,6 @@ import Control.Monad.IO.Class import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Text as T -import Debug.Trace (traceShowId) import Development.IDE hiding (pluginHandlers) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.ExactPrint @@ -59,14 +58,10 @@ data GenComments = forall a. fromDecl :: HsDecl GhcPs -> Maybe a, collectKeys :: a -> [AnnKey], isFresh :: Annotation -> Bool, - updateAnn :: UpdateAnn, + updateAnn :: Annotation -> Annotation, updateDeclAnn :: Annotation -> Annotation } -type UpdateAnn = Bool -- ^ is first - -> Annotation - -> Annotation - runGenComments :: GenComments -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit) runGenComments GenComments {..} mLocDecls mAnns range | Just locDecls <- mLocDecls, @@ -74,10 +69,9 @@ runGenComments GenComments {..} mLocDecls mAnns range [(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 (traceShowId anns) <$> annKeys, + and $ maybe False isFresh . flip Map.lookup anns <$> annKeys, declKey <- mkAnnKey locDecl, - anns' <- Map.adjust updateDeclAnn declKey $ foldr (\(key, isFirst) -> - Map.adjust (updateAnn isFirst) key) anns (zip annKeys (True : repeat False)), + 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) @@ -93,7 +87,7 @@ genForSig = GenComments {..} fromDecl (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ x)))) = Just x fromDecl _ = Nothing - updateAnn _ x = x {annEntryDelta = DP (0, 1), annsDP = dp} + updateAnn x = x {annEntryDelta = DP (0, 1), annsDP = dp} updateDeclAnn = cleanPriorComments isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] @@ -117,9 +111,7 @@ genForRecord = GenComments {..} Just [x | (L _ ConDeclH98 {con_args = x}) <- cons] fromDecl _ = Nothing - updateAnn isFirst x = - let delta = if isFirst then (0, 1) else (1, 0) - in x {annEntryDelta = DP (1, 0), annPriorComments = [(comment, DP delta)]} + updateAnn x = x {annEntryDelta = DP (1, 2), annPriorComments = [(comment, DP (1, 2))]} updateDeclAnn = cleanPriorComments isFresh Ann {annPriorComments} = null annPriorComments From 01c1ed48e9dcfe9bfed9e28a4cd5ee64a962c92b Mon Sep 17 00:00:00 2001 From: kokobd Date: Sun, 18 Sep 2022 18:06:35 +0800 Subject: [PATCH 05/13] generate haddock comments for constructors --- .../hls-haddock-comments-plugin.cabal | 7 +- .../src/Ide/Plugin/HaddockComments.hs | 65 +++++----- .../src/Ide/Plugin/HaddockComments/Data.hs | 114 ++++++++++++++++++ .../src/Ide/Plugin/HaddockComments/Prelude.hs | 24 ++++ 4 files changed, 180 insertions(+), 30 deletions(-) create mode 100644 plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs create mode 100644 plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index dfa141018e..a5ba7bffda 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -18,7 +18,10 @@ extra-source-files: test/testdata/*.hs library - exposed-modules: Ide.Plugin.HaddockComments + exposed-modules: + Ide.Plugin.HaddockComments + Ide.Plugin.HaddockComments.Data + Ide.Plugin.HaddockComments.Prelude hs-source-dirs: src ghc-options: -Wall -Wno-name-shadowing -Wredundant-constraints @@ -35,6 +38,8 @@ library , lsp-types , text , unordered-containers + , transformers + , mtl default-language: Haskell2010 default-extensions: 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 79acf7b072..a9a1b7afed 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -8,8 +9,9 @@ module Ide.Plugin.HaddockComments (descriptor) where -import Control.Monad (join) +import Control.Monad (join, when) import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Text as T @@ -19,6 +21,8 @@ import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (..)) import qualified Development.IDE.GHC.ExactPrint as E import Development.IDE.Plugin.CodeAction +import Ide.Plugin.HaddockComments.Data (genForDataDecl) +import Ide.Plugin.HaddockComments.Prelude import Ide.Types import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) @@ -40,47 +44,50 @@ codeActionProvider ideState _pId (CodeActionParams _ _ (TextDocumentIdentifier u (join -> pm) <- liftIO $ 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] + edits = [gen locDecls anns range | noErr, gen <- genList] return $ Right $ List [InR $ toAction title uri edit | (Just (title, edit)) <- edits] -genList :: [GenComments] +genList :: [Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit)] genList = - [ genForSig, - genForRecord + [ runGenCommentsSimple genForSig, + -- runGenCommentsSimple genForRecord + runGenComments genForDataDecl ] ----------------------------------------------------------------------------- --- | 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, - updateDeclAnn :: Annotation -> Annotation - } - runGenComments :: GenComments -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit) -runGenComments GenComments {..} mLocDecls mAnns range +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], - annKeys <- collectKeys x, - not $ null annKeys, - and $ maybe False isFresh . flip Map.lookup anns <$> annKeys, - declKey <- mkAnnKey locDecl, - anns' <- Map.adjust updateDeclAnn declKey $ foldr (Map.adjust updateAnn) anns annKeys, + [(locDecl, src)] <- [(locDecl, l) | locDecl@(L l _) <- locDecls, range `isIntersectWith` l], Just range' <- toRange src, - result <- T.strip . T.pack $ exactPrint locDecl anns' = - Just (title, TextEdit range' result) + Just (_, (anns', _), _) <- runTransformT anns (updateAnns locDecl), + result <- T.strip . T.pack $ exactPrint locDecl anns' + = Just (title, TextEdit range' result) | otherwise = Nothing +runGenCommentsSimple :: GenCommentsSimple -> Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit) +runGenCommentsSimple GenCommentsSimple {..} = runGenComments GenComments { + title = title, + updateAnns = updateAnns + } + where + updateAnns :: LHsDecl GhcPs -> TransformT Maybe () + updateAnns locDecl@(L _ decl) = do + x <- lift $ fromDecl decl + let annKeys = collectKeys x + anns <- getAnnsT + when (null annKeys || not (and $ maybe False isFresh . flip Map.lookup anns <$> annKeys)) $ + lift Nothing + let declKey = mkAnnKey locDecl + anns' = Map.adjust updateDeclAnn declKey $ foldr (Map.adjust updateAnn) anns annKeys + putAnnsT anns' + ----------------------------------------------------------------------------- -genForSig :: GenComments -genForSig = GenComments {..} +genForSig :: GenCommentsSimple +genForSig = GenCommentsSimple {..} where title = "Generate signature comments" @@ -102,8 +109,8 @@ genForSig = GenComments {..} #endif dp = [(AnnComment comment, DP (0, 1)), (G AnnRarrow, DP (1, 2))] -genForRecord :: GenComments -genForRecord = GenComments {..} +genForRecord :: GenCommentsSimple +genForRecord = GenCommentsSimple {..} where title = "Generate fields comments" diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs new file mode 100644 index 0000000000..54c04b12c1 --- /dev/null +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.HaddockComments.Data + ( genForDataDecl + ) where + +import Control.Monad (unless, when) +import Control.Monad.Trans.Class (lift) +import Data.Data (Data) +import Data.Foldable (for_) +import Data.List (isPrefixOf) +import qualified Data.Map.Strict as Map +import Development.IDE (realSpan) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.ExactPrint +import Ide.Plugin.HaddockComments.Prelude +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) +import Language.Haskell.GHC.ExactPrint.Utils (mkComment) + +genForDataDecl :: GenComments +genForDataDecl = + GenComments { + title = "Generate fields comments", + updateAnns = updateDataAnns + } + +updateDataAnns :: LHsDecl GhcPs -> TransformT Maybe () +updateDataAnns (L declLoc (TyClD _ DataDecl {tcdDataDefn = HsDataDefn { dd_cons = cons }})) = do + -- skip if all constructors and fields already have a haddock comment + getAnnsT >>= (\anns -> unless (missingSomeHaddock anns cons) (lift Nothing)) + + -- visit each constructor and field + for_ (zip cons (Nothing: fmap Just cons)) $ \(con, prevCon) -> do + let sameLineAsPrev = maybe False (\prevCon' -> notSeperatedByLineEnding prevCon' con) prevCon + when sameLineAsPrev $ modifyAnnsT $ \anns -> + let updateSepAnn :: Annotation -> Annotation + updateSepAnn ann = ann {annsDP = + Map.toList . Map.adjust (const (DP (1, 0))) (G AnnVbar) . Map.fromList $ annsDP ann} + in flip (maybe anns) prevCon $ \prevCon' -> Map.adjust updateSepAnn (mkAnnKey prevCon') anns + let anchorCol = maybe 0 srcSpanStartCol . realSpan $ maybe declLoc getLoc prevCon + modifyAnnsT $ + let updateCurrent :: Annotation -> Annotation + updateCurrent ann = ann { + annPriorComments = + case annPriorComments ann of + (c, dp) : rem -> (emptyPriorHaddockComment, dp) : (c, DP (2,0)) : rem + _ -> [(emptyPriorHaddockComment, annEntryDelta ann)], + annEntryDelta = DP (1, dpCol) + } + dpCol = if sameLineAsPrev then 0 + else (maybe 2 srcSpanStartCol . realSpan $ getLoc con) - anchorCol + in Map.adjust updateCurrent (mkAnnKey con) + -- TODO: add haddock comments to fields +updateDataAnns _ = pure () + + {- + for each constructor: + if it's on the same line as the previous one, move it to the next line + add a leading comment, inherit the constructor's DP + move the constructor to the next line, preserving its indentation + for each field: + add a leading comment, inherit the field's DP + move the field to the next line, preserving the indentation + + special case: + if there is an existing constructor/field on the same line, move the current constructor/field to + the next line first, using the previous constructor/field's indentation + + algorithm to move an element to the next line, preserving its indentation: + - if the row offset was 0, change col offset to col - col of the previous element + col of the anchor + - otherwise, preserve the col offset + -} + +missingSomeHaddock :: Anns -> [LConDecl GhcPs] -> Bool +missingSomeHaddock anns = any $ \lcon@(L _ conDecl) -> case conDecl of + ConDeclH98 { con_args = RecCon (L _ fields) } -> + elem (Just False) $ hasHaddock anns lcon : fmap (hasHaddock anns) fields + _ -> False -- GADT is not supported yet + +notSeperatedByLineEnding :: Located a + -> Located a + -> Bool +notSeperatedByLineEnding (L (RealSrcSpan x _) _) (L (RealSrcSpan y _) _) = + srcLocLine (realSrcSpanEnd x) == srcLocLine (realSrcSpanStart y) +notSeperatedByLineEnding _ _ = False + +updateAnnsByConDecl :: LConDecl GhcPs -> Anns -> Maybe Anns +updateAnnsByConDecl lconDecl@(L (RealSrcSpan conLoc _) ConDeclH98 { con_args = RecCon (L _ fields) }) anns = do + annConDecl <- anns Map.!? mkAnnKey lconDecl + + Nothing -- TODO + where + conStartLoc = realSrcSpanStart conLoc +updateAnnsByConDecl _ _ = Nothing + +emptyPriorHaddockComment :: Comment +emptyPriorHaddockComment = mkComment "-- | " noSrcSpan + +hasHaddock :: Data a => Anns -> Located a -> Maybe Bool +hasHaddock anns node = fmap annHasHaddock (anns Map.!? key) + where + key = mkAnnKey node + annHasHaddock ann = + any (isPriorHaddock . fst) (annPriorComments ann) + || any (isFollowingHaddock . fst) (annFollowingComments ann) + + isPriorHaddock :: Comment -> Bool + isPriorHaddock comment = any (`isPrefixOf` commentContents comment) ["-- |", "{-|", "{- |"] + + isFollowingHaddock :: Comment -> Bool + isFollowingHaddock comment = any (`isPrefixOf` commentContents comment) ["-- ^", "{-^", "{- ^"] + diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs new file mode 100644 index 0000000000..44eb1527e1 --- /dev/null +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Ide.Plugin.HaddockComments.Prelude where +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import Development.IDE.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint (AnnKey, Annotation) + +data GenComments = GenComments + { title :: T.Text, + updateAnns :: LHsDecl GhcPs -> TransformT Maybe () + } + +-- | Defines how to generate haddock comments by tweaking annotations of AST +data GenCommentsSimple = forall a. + GenCommentsSimple + { title :: T.Text, + fromDecl :: HsDecl GhcPs -> Maybe a, + collectKeys :: a -> [AnnKey], + isFresh :: Annotation -> Bool, + updateAnn :: Annotation -> Annotation, + updateDeclAnn :: Annotation -> Annotation + } From 8bb7b031a1e81aaadc39b11822858be532a87bc3 Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 21 Sep 2022 13:07:11 +0800 Subject: [PATCH 06/13] fix tests --- .../src/Ide/Plugin/HaddockComments.hs | 27 ----- .../src/Ide/Plugin/HaddockComments/Data.hs | 103 ++++++++---------- .../test/testdata/Record.expected.hs | 30 ++--- .../test/testdata/StaleRecord.hs | 7 +- 4 files changed, 69 insertions(+), 98 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 a9a1b7afed..724e82efbf 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -109,30 +109,6 @@ genForSig = GenCommentsSimple {..} #endif dp = [(AnnComment comment, DP (0, 1)), (G AnnRarrow, DP (1, 2))] -genForRecord :: GenCommentsSimple -genForRecord = GenCommentsSimple {..} - where - title = "Generate fields comments" - - 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))]} - updateDeclAnn = cleanPriorComments - - isFresh Ann {annPriorComments} = null annPriorComments - - collectKeys = keyFromCon - -#if MIN_VERSION_ghc(9,2,0) - comment = mkComment "-- | " (spanAsAnchor noSrcSpan) -#elif MIN_VERSION_ghc(9,0,0) - comment = mkComment "-- | " badRealSrcSpan -#else - comment = mkComment "-- | " noSrcSpan -#endif - ----------------------------------------------------------------------------- toAction :: T.Text -> Uri -> TextEdit -> CodeAction @@ -183,7 +159,4 @@ keyFromTyVar dep (L _ (HsParTy _ x)) = keyFromTyVar (succ dep) x keyFromTyVar dep (L _ (HsBangTy _ _ x)) = keyFromTyVar dep x keyFromTyVar _ _ = [] -keyFromCon :: [HsConDeclDetails GhcPs] -> [AnnKey] -keyFromCon cons = mconcat [mkAnnKey <$> xs | (RecCon (L _ xs)) <- cons] - ----------------------------------------------------------------------------- diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs index 54c04b12c1..a7c1e1b986 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.HaddockComments.Data @@ -11,6 +12,7 @@ import Data.Data (Data) import Data.Foldable (for_) import Data.List (isPrefixOf) import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) import Development.IDE (realSpan) import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint @@ -27,51 +29,44 @@ genForDataDecl = } updateDataAnns :: LHsDecl GhcPs -> TransformT Maybe () -updateDataAnns (L declLoc (TyClD _ DataDecl {tcdDataDefn = HsDataDefn { dd_cons = cons }})) = do +updateDataAnns decl@(L declLoc (TyClD _ DataDecl {tcdDataDefn = HsDataDefn { dd_cons = cons }})) = do -- skip if all constructors and fields already have a haddock comment getAnnsT >>= (\anns -> unless (missingSomeHaddock anns cons) (lift Nothing)) -- visit each constructor and field - for_ (zip cons (Nothing: fmap Just cons)) $ \(con, prevCon) -> do - let sameLineAsPrev = maybe False (\prevCon' -> notSeperatedByLineEnding prevCon' con) prevCon - when sameLineAsPrev $ modifyAnnsT $ \anns -> - let updateSepAnn :: Annotation -> Annotation - updateSepAnn ann = ann {annsDP = - Map.toList . Map.adjust (const (DP (1, 0))) (G AnnVbar) . Map.fromList $ annsDP ann} - in flip (maybe anns) prevCon $ \prevCon' -> Map.adjust updateSepAnn (mkAnnKey prevCon') anns - let anchorCol = maybe 0 srcSpanStartCol . realSpan $ maybe declLoc getLoc prevCon - modifyAnnsT $ - let updateCurrent :: Annotation -> Annotation - updateCurrent ann = ann { - annPriorComments = - case annPriorComments ann of - (c, dp) : rem -> (emptyPriorHaddockComment, dp) : (c, DP (2,0)) : rem - _ -> [(emptyPriorHaddockComment, annEntryDelta ann)], - annEntryDelta = DP (1, dpCol) - } - dpCol = if sameLineAsPrev then 0 - else (maybe 2 srcSpanStartCol . realSpan $ getLoc con) - anchorCol - in Map.adjust updateCurrent (mkAnnKey con) - -- TODO: add haddock comments to fields + addHaddockCommentsToList True declLoc cons + for_ cons $ \case + L conLoc ConDeclH98 { con_args = RecCon (L _ fields) } -> addHaddockCommentsToList False conLoc fields + _ -> pure () + modifyAnnsT $ Map.adjust (\ann -> ann {annPriorComments = []}) (mkAnnKey decl) updateDataAnns _ = pure () - {- - for each constructor: - if it's on the same line as the previous one, move it to the next line - add a leading comment, inherit the constructor's DP - move the constructor to the next line, preserving its indentation - for each field: - add a leading comment, inherit the field's DP - move the field to the next line, preserving the indentation - - special case: - if there is an existing constructor/field on the same line, move the current constructor/field to - the next line first, using the previous constructor/field's indentation - - algorithm to move an element to the next line, preserving its indentation: - - if the row offset was 0, change col offset to col - col of the previous element + col of the anchor - - otherwise, preserve the col offset - -} +-- TODO Add explaination to this complex function. +addHaddockCommentsToList :: (Data a, Monad m) => Bool -> SrcSpan -> [Located a] -> TransformT m () +addHaddockCommentsToList usePrevNodeAsAnchor outerLoc nodes = + for_ (zip nodes (Nothing: fmap Just nodes)) $ \(node, prevNode) -> do + addHaddockCommentToCurrentNode <- fmap (not . fromMaybe True . flip hasHaddock node) getAnnsT + when addHaddockCommentToCurrentNode $ do + let sameLineAsPrev = maybe False (\prevNode' -> notSeperatedByLineEnding prevNode' node) prevNode + when sameLineAsPrev $ modifyAnnsT $ \anns -> + let updateSepAnn :: Annotation -> Annotation + updateSepAnn ann = ann {annsDP = + Map.toList . Map.adjust (const (DP (1,0))) (G AnnVbar) . Map.fromList $ annsDP ann} + in flip (maybe anns) prevNode $ \prevNode' -> Map.adjust updateSepAnn (mkAnnKey prevNode') anns + let anchorCol = maybe 0 srcSpanStartCol . realSpan . maybe outerLoc getLoc $ + if usePrevNodeAsAnchor then prevNode else Nothing + modifyAnnsT $ + let updateCurrent :: Annotation -> Annotation + updateCurrent ann = ann { + annPriorComments = + case annPriorComments ann of + (c, dp) : rem -> (emptyPriorHaddockComment, dp) : (c, DP (2,0)) : rem + _ -> [(emptyPriorHaddockComment, annEntryDelta ann)], + annEntryDelta = DP (1, dpCol) + } + dpCol = if sameLineAsPrev then 0 + else (maybe 2 srcSpanStartCol . realSpan $ getLoc node) - anchorCol + in Map.adjust updateCurrent (mkAnnKey node) missingSomeHaddock :: Anns -> [LConDecl GhcPs] -> Bool missingSomeHaddock anns = any $ \lcon@(L _ conDecl) -> case conDecl of @@ -86,29 +81,27 @@ notSeperatedByLineEnding (L (RealSrcSpan x _) _) (L (RealSrcSpan y _) _) = srcLocLine (realSrcSpanEnd x) == srcLocLine (realSrcSpanStart y) notSeperatedByLineEnding _ _ = False -updateAnnsByConDecl :: LConDecl GhcPs -> Anns -> Maybe Anns -updateAnnsByConDecl lconDecl@(L (RealSrcSpan conLoc _) ConDeclH98 { con_args = RecCon (L _ fields) }) anns = do - annConDecl <- anns Map.!? mkAnnKey lconDecl - - Nothing -- TODO - where - conStartLoc = realSrcSpanStart conLoc -updateAnnsByConDecl _ _ = Nothing - emptyPriorHaddockComment :: Comment -emptyPriorHaddockComment = mkComment "-- | " noSrcSpan +emptyPriorHaddockComment = mkComment "-- |" noSrcSpan hasHaddock :: Data a => Anns -> Located a -> Maybe Bool hasHaddock anns node = fmap annHasHaddock (anns Map.!? key) where key = mkAnnKey node annHasHaddock ann = - any (isPriorHaddock . fst) (annPriorComments ann) - || any (isFollowingHaddock . fst) (annFollowingComments ann) + any (matchCommentPrefix priorCommentPrefix . fst) (annPriorComments ann) + || any (matchCommentPrefix followingCommentPrefix . fst) (annFollowingComments ann) + || any (keywordIdIsHaddockComment . fst) (annsDP ann) + +keywordIdIsHaddockComment :: KeywordId -> Bool +keywordIdIsHaddockComment (AnnComment comment) = any (`isPrefixOf` commentContents comment) (priorCommentPrefix ++ followingCommentPrefix) +keywordIdIsHaddockComment _ = False - isPriorHaddock :: Comment -> Bool - isPriorHaddock comment = any (`isPrefixOf` commentContents comment) ["-- |", "{-|", "{- |"] +priorCommentPrefix :: [String] +priorCommentPrefix = ["-- |", "{-|", "{- |"] - isFollowingHaddock :: Comment -> Bool - isFollowingHaddock comment = any (`isPrefixOf` commentContents comment) ["-- ^", "{-^", "{- ^"] +followingCommentPrefix :: [String] +followingCommentPrefix = ["-- ^", "{-^", "{- ^"] +matchCommentPrefix :: [String] -> Comment -> Bool +matchCommentPrefix prefix comment = any (`isPrefixOf` commentContents comment) prefix diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/Record.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/Record.expected.hs index a6ded3780b..9ac5afcf73 100644 --- a/plugins/hls-haddock-comments-plugin/test/testdata/Record.expected.hs +++ b/plugins/hls-haddock-comments-plugin/test/testdata/Record.expected.hs @@ -2,19 +2,21 @@ module Record where -- | A record data Record a b c d e f - = RecordA - { - -- | - a :: a, - -- | - b :: b + = -- | + RecordA + { -- | + a :: a, + -- | + b :: b } - | Pair c d - | RecordB - { - -- | - c :: e, - -- | - d :: f + | -- | + Pair c d + | -- | + RecordB + { -- | + c :: e, + -- | + d :: f } - | Void + | -- | + Void diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/StaleRecord.hs b/plugins/hls-haddock-comments-plugin/test/testdata/StaleRecord.hs index 466db4c136..3b639bafae 100644 --- a/plugins/hls-haddock-comments-plugin/test/testdata/StaleRecord.hs +++ b/plugins/hls-haddock-comments-plugin/test/testdata/StaleRecord.hs @@ -1,6 +1,9 @@ module StaleRecord where -data Record = Record - { a :: Int, -- ^ ... +data Record = + -- | ... + Record + { a :: Int -- ^ aaa + , -- | bbb b :: String } From 3963421fe0a49783bcd9ec26f06f9afbd9af9e38 Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 21 Sep 2022 13:12:55 +0800 Subject: [PATCH 07/13] restore constraints --- .../hls-haddock-comments-plugin.cabal | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index a5ba7bffda..f305f50a11 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -18,6 +18,10 @@ extra-source-files: test/testdata/*.hs library + if impl(ghc >= 9.2) + buildable: False + else + buildable: True exposed-modules: Ide.Plugin.HaddockComments Ide.Plugin.HaddockComments.Data @@ -31,7 +35,7 @@ library , base >=4.12 && <5 , containers , ghc - , ghc-exactprint + , ghc-exactprint < 1 , ghcide ^>=1.8 , hls-plugin-api ^>=1.5 , hls-refactor-plugin From 481acf4e937c06632ab7d03422a86ccd47b62a2f Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 21 Sep 2022 14:28:32 +0800 Subject: [PATCH 08/13] make it compatible with ghc 9.0 --- .../src/Ide/Plugin/HaddockComments/Data.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs index a7c1e1b986..9a126622b0 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -82,7 +83,12 @@ notSeperatedByLineEnding (L (RealSrcSpan x _) _) (L (RealSrcSpan y _) _) = notSeperatedByLineEnding _ _ = False emptyPriorHaddockComment :: Comment -emptyPriorHaddockComment = mkComment "-- |" noSrcSpan +emptyPriorHaddockComment = mkComment "-- |" +#if MIN_VERSION_ghc(9,0,0) + badRealSrcSpan +#else + noSrcSpan +#endif hasHaddock :: Data a => Anns -> Located a -> Maybe Bool hasHaddock anns node = fmap annHasHaddock (anns Map.!? key) From 88f063f26ec6fc5d3353f62a342bd91f1a57078a Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 21 Sep 2022 22:35:41 +0800 Subject: [PATCH 09/13] add more tests --- .../src/Ide/Plugin/HaddockComments/Data.hs | 2 +- plugins/hls-haddock-comments-plugin/test/Main.hs | 6 ++++-- .../test/testdata/InlineRecord.expected.hs | 10 ++++++++++ .../test/testdata/InlineRecord.hs | 4 ++++ .../test/testdata/Record2.expected.hs | 10 ++++++++++ .../test/testdata/Record2.hs | 7 +++++++ 6 files changed, 36 insertions(+), 3 deletions(-) create mode 100644 plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs create mode 100644 plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.hs create mode 100644 plugins/hls-haddock-comments-plugin/test/testdata/Record2.expected.hs create mode 100644 plugins/hls-haddock-comments-plugin/test/testdata/Record2.hs diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs index 9a126622b0..ddc3c21030 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs @@ -25,7 +25,7 @@ import Language.Haskell.GHC.ExactPrint.Utils (mkComment) genForDataDecl :: GenComments genForDataDecl = GenComments { - title = "Generate fields comments", + title = "Generate haddock comments", updateAnns = updateDataAnns } diff --git a/plugins/hls-haddock-comments-plugin/test/Main.hs b/plugins/hls-haddock-comments-plugin/test/Main.hs index 22189c2590..eaf10903a0 100644 --- a/plugins/hls-haddock-comments-plugin/test/Main.hs +++ b/plugins/hls-haddock-comments-plugin/test/Main.hs @@ -30,9 +30,11 @@ tests = goldenWithHaddockComments "MultivariateFunction" Signature 4 8, goldenWithHaddockComments "QualFunction" Signature 2 10, goldenWithHaddockComments "Record" Record 7 2, + goldenWithHaddockComments "Record2" Record 3 6, + goldenWithHaddockComments "InlineRecord" Record 3 20, expectedNothing "ConstFunction" Signature 2 2, expectedNothing "StaleFunction" Signature 3 3, - expectedNothing "StaleRecord" Record 3 12 + expectedNothing "StaleRecord" Record 4 9 ] goldenWithHaddockComments :: FilePath -> GenCommentsType -> UInt -> UInt -> TestTree @@ -54,7 +56,7 @@ data GenCommentsType = Signature | Record toTitle :: GenCommentsType -> Text toTitle Signature = "Generate signature comments" -toTitle Record = "Generate fields comments" +toTitle Record = "Generate haddock comments" caTitle :: (Command |? CodeAction) -> Maybe Text caTitle (InR CodeAction {_title}) = Just _title diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs new file mode 100644 index 0000000000..6f60a758d1 --- /dev/null +++ b/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs @@ -0,0 +1,10 @@ +module Record2 where + +-- | A record +data Record = -- | + A { -- | + a :: Int , -- | + b :: String } + | -- | + B { -- | + bb :: Double } diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.hs b/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.hs new file mode 100644 index 0000000000..c2f48dd98e --- /dev/null +++ b/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.hs @@ -0,0 +1,4 @@ +module Record2 where + +-- | A record +data Record = A { a :: Int , b :: String } | B { bb :: Double } diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/Record2.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/Record2.expected.hs new file mode 100644 index 0000000000..c5968e5353 --- /dev/null +++ b/plugins/hls-haddock-comments-plugin/test/testdata/Record2.expected.hs @@ -0,0 +1,10 @@ +module Record2 where + +-- | A record +data Record = -- | + RecordA + { -- | + a :: Int + , -- | + b :: String + } diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/Record2.hs b/plugins/hls-haddock-comments-plugin/test/testdata/Record2.hs new file mode 100644 index 0000000000..49ee7ba383 --- /dev/null +++ b/plugins/hls-haddock-comments-plugin/test/testdata/Record2.hs @@ -0,0 +1,7 @@ +module Record2 where + +-- | A record +data Record = RecordA + { a :: Int + , b :: String + } From 2f425aeb61aabe47e97b9d9fbb315a1afb303efc Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 22 Sep 2022 10:27:27 +0000 Subject: [PATCH 10/13] add comments & fix dp calculation for inline case --- .../src/Ide/Plugin/HaddockComments.hs | 1 - .../src/Ide/Plugin/HaddockComments/Data.hs | 86 +++++++++++++++---- .../src/Ide/Plugin/HaddockComments/Prelude.hs | 5 ++ .../test/testdata/InlineRecord.expected.hs | 5 +- 4 files changed, 77 insertions(+), 20 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 724e82efbf..66ea479416 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -50,7 +50,6 @@ codeActionProvider ideState _pId (CodeActionParams _ _ (TextDocumentIdentifier u genList :: [Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit)] genList = [ runGenCommentsSimple genForSig, - -- runGenCommentsSimple genForRecord runGenComments genForDataDecl ] diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs index ddc3c21030..8f6fa4b510 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs @@ -13,7 +13,7 @@ import Data.Data (Data) import Data.Foldable (for_) import Data.List (isPrefixOf) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Development.IDE (realSpan) import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint @@ -35,46 +35,95 @@ updateDataAnns decl@(L declLoc (TyClD _ DataDecl {tcdDataDefn = HsDataDefn { dd_ getAnnsT >>= (\anns -> unless (missingSomeHaddock anns cons) (lift Nothing)) -- visit each constructor and field - addHaddockCommentsToList True declLoc cons + addHaddockCommentsToList True declLoc (G AnnVbar) cons for_ cons $ \case - L conLoc ConDeclH98 { con_args = RecCon (L _ fields) } -> addHaddockCommentsToList False conLoc fields + L conLoc ConDeclH98 { con_args = RecCon (L _ fields) } -> addHaddockCommentsToList False conLoc (G AnnComma) fields _ -> pure () modifyAnnsT $ Map.adjust (\ann -> ann {annPriorComments = []}) (mkAnnKey decl) -updateDataAnns _ = pure () +updateDataAnns _ = lift Nothing --- TODO Add explaination to this complex function. -addHaddockCommentsToList :: (Data a, Monad m) => Bool -> SrcSpan -> [Located a] -> TransformT m () -addHaddockCommentsToList usePrevNodeAsAnchor outerLoc nodes = +-- | Add haddock comments to a list of nodes +addHaddockCommentsToList + :: (Data a, Monad m) + => Bool -- ^ If true, for each node, use previous node in the list as the anchor. Otherwise, use the outer node + -> SrcSpan -- ^ The outer node + -> KeywordId -- ^ The seperator between adjacent nodes + -> [Located a] -- ^ The list of nodes. Haddock comments will be added to each of them + -> TransformT m () +addHaddockCommentsToList usePrevNodeAsAnchor outerLoc seperator nodes = + -- If you want to understand this function, please first read this page carefully: + -- https://hackage.haskell.org/package/ghc-exactprint-0.6.4/docs/Language-Haskell-GHC-ExactPrint-Delta.html + -- The important part is that for DP(r,c), if r is zero, c is the offset start from the end of the previous node. + -- However, if r is greater than zero, c is the offset start from the 'anchor'. + -- Generally speaking, the 'anchor' is the node that "enclose" for_ (zip nodes (Nothing: fmap Just nodes)) $ \(node, prevNode) -> do addHaddockCommentToCurrentNode <- fmap (not . fromMaybe True . flip hasHaddock node) getAnnsT + -- We don't add new haddock comments to nodes with existing ones. when addHaddockCommentToCurrentNode $ do - let sameLineAsPrev = maybe False (\prevNode' -> notSeperatedByLineEnding prevNode' node) prevNode - when sameLineAsPrev $ modifyAnnsT $ \anns -> - let updateSepAnn :: Annotation -> Annotation + -- 'sameLineAsPrev' is a flag to determine the inline case, for example: + -- data T = A { a :: Int, b :: String } | B { b :: Double } + -- Note that it's a 'Maybe (Located a)', containing the previous node if the current node + -- and the previous node are on the same line. + -- + -- For the multiline case (which is the most common), we keep the original indentation of each constructor + -- and field. + -- + -- For the inline case, we use the first construcotr/field as the base, and align all following items + -- to them. + let sameLineAsPrev = prevNode >>= ( + \prevNode' -> if notSeperatedByLineEnding prevNode' node + then pure prevNode' + else Nothing + ) + -- For the inline case, we need to move the seperator to the next line. + -- For constructors, it's vertical bar; for fields, it's comma. + -- The seperator is passed in as function argument. + when (isJust sameLineAsPrev) $ modifyAnnsT $ \anns -> + let newSepCol :: Annotation -> Int + newSepCol ann = + if usePrevNodeAsAnchor then 0 else deltaColumn (annEntryDelta ann) + updateSepAnn :: Annotation -> Annotation updateSepAnn ann = ann {annsDP = - Map.toList . Map.adjust (const (DP (1,0))) (G AnnVbar) . Map.fromList $ annsDP ann} + Map.toList . Map.adjust (const $ DP (1, newSepCol ann)) seperator . Map.fromList $ annsDP ann} in flip (maybe anns) prevNode $ \prevNode' -> Map.adjust updateSepAnn (mkAnnKey prevNode') anns + -- Calculate the real column of the anchor let anchorCol = maybe 0 srcSpanStartCol . realSpan . maybe outerLoc getLoc $ if usePrevNodeAsAnchor then prevNode else Nothing + -- 'dpCol' is what we will use for the current node's entry delta's column + dpCol <- flip fmap getAnnsT $ \anns -> + case sameLineAsPrev of + Just prevNode' -> + -- If the previous node is the anchor, using 0 as column will make current code align with + -- the previous one. + -- Otherwise, use the column of entry delta of the previous node. + -- The map lookup should not fail. '2' is used as a fallback value to make sure the syntax + -- is correct after the changes. + if usePrevNodeAsAnchor then 0 else maybe 2 (deltaColumn . annEntryDelta) + $ anns Map.!? mkAnnKey prevNode' + -- We subtract the real column to get dp column. + Nothing -> (maybe 2 srcSpanStartCol . realSpan $ getLoc node) - anchorCol + -- Modify the current node modifyAnnsT $ let updateCurrent :: Annotation -> Annotation updateCurrent ann = ann { - annPriorComments = - case annPriorComments ann of - (c, dp) : rem -> (emptyPriorHaddockComment, dp) : (c, DP (2,0)) : rem - _ -> [(emptyPriorHaddockComment, annEntryDelta ann)], + -- If there exists non-haddock comments, we simply inherit it's delta pos, and move existing + -- comments two lines below (to seperate them from our newly added haddock comments) + -- Otherwise, inherit the node's entry delta pos. + annPriorComments = case annPriorComments ann of + (c, dp) : rem -> (emptyPriorHaddockComment, dp) : (c, DP (2,0)) : rem + _ -> [(emptyPriorHaddockComment, annEntryDelta ann)], annEntryDelta = DP (1, dpCol) } - dpCol = if sameLineAsPrev then 0 - else (maybe 2 srcSpanStartCol . realSpan $ getLoc node) - anchorCol in Map.adjust updateCurrent (mkAnnKey node) +-- | Determine if a list of constructor declarations is missing some haddock comments. missingSomeHaddock :: Anns -> [LConDecl GhcPs] -> Bool missingSomeHaddock anns = any $ \lcon@(L _ conDecl) -> case conDecl of ConDeclH98 { con_args = RecCon (L _ fields) } -> elem (Just False) $ hasHaddock anns lcon : fmap (hasHaddock anns) fields _ -> False -- GADT is not supported yet +-- | Returns 'True' if the end of the first node and the start of the second node are on the same line. notSeperatedByLineEnding :: Located a -> Located a -> Bool @@ -82,6 +131,7 @@ notSeperatedByLineEnding (L (RealSrcSpan x _) _) (L (RealSrcSpan y _) _) = srcLocLine (realSrcSpanEnd x) == srcLocLine (realSrcSpanStart y) notSeperatedByLineEnding _ _ = False +-- | Empty haddock, suitable for being added to 'annPriorComments' emptyPriorHaddockComment :: Comment emptyPriorHaddockComment = mkComment "-- |" #if MIN_VERSION_ghc(9,0,0) @@ -90,6 +140,7 @@ emptyPriorHaddockComment = mkComment "-- |" noSrcSpan #endif +-- | Determines the given node has haddock comments attached to it. hasHaddock :: Data a => Anns -> Located a -> Maybe Bool hasHaddock anns node = fmap annHasHaddock (anns Map.!? key) where @@ -99,6 +150,7 @@ hasHaddock anns node = fmap annHasHaddock (anns Map.!? key) || any (matchCommentPrefix followingCommentPrefix . fst) (annFollowingComments ann) || any (keywordIdIsHaddockComment . fst) (annsDP ann) +-- | Checks if the given 'KeywordId' is a comment, and specifically, a haddock comment. keywordIdIsHaddockComment :: KeywordId -> Bool keywordIdIsHaddockComment (AnnComment comment) = any (`isPrefixOf` commentContents comment) (priorCommentPrefix ++ followingCommentPrefix) keywordIdIsHaddockComment _ = False diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs index 44eb1527e1..3bf56e2b61 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs @@ -7,12 +7,17 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint (AnnKey, Annotation) +-- | A more generic comments generator data GenComments = GenComments { title :: T.Text, + -- | Use 'Maybe' monad to exit early. 'Nothing' means a code action for haddock comments + -- in the given context is not possible. updateAnns :: LHsDecl GhcPs -> TransformT Maybe () } -- | Defines how to generate haddock comments by tweaking annotations of AST +-- +-- This is left here for compatibility reason, so that we don't break the existing code. data GenCommentsSimple = forall a. GenCommentsSimple { title :: T.Text, diff --git a/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs b/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs index 6f60a758d1..cff893ddcb 100644 --- a/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs +++ b/plugins/hls-haddock-comments-plugin/test/testdata/InlineRecord.expected.hs @@ -3,8 +3,9 @@ module Record2 where -- | A record data Record = -- | A { -- | - a :: Int , -- | - b :: String } + a :: Int + , -- | + b :: String } | -- | B { -- | bb :: Double } From 87403ea63836d1d5f385112def05ab0ed80edc48 Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 22 Sep 2022 11:49:32 +0000 Subject: [PATCH 11/13] add kokobd to codeowners of haddock-comments plugin --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 27cc7e20d4..61dfd9a206 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -16,7 +16,7 @@ /plugins/hls-floskell-plugin @Ailrun /plugins/hls-fourmolu-plugin @georgefst /plugins/hls-gadt-plugin @July541 -/plugins/hls-haddock-comments-plugin @berberman +/plugins/hls-haddock-comments-plugin @berberman @kokobd /plugins/hls-hlint-plugin @jneira @eddiemundo /plugins/hls-module-name-plugin /plugins/hls-ormolu-plugin @georgefst From 4fee7f50b39b730b11f4255ae4c2f04d6cc7fc74 Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 24 Sep 2022 15:11:56 +0000 Subject: [PATCH 12/13] fix a comment --- .../src/Ide/Plugin/HaddockComments/Data.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs index 8f6fa4b510..a8c3ec016c 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs @@ -55,7 +55,10 @@ addHaddockCommentsToList usePrevNodeAsAnchor outerLoc seperator nodes = -- https://hackage.haskell.org/package/ghc-exactprint-0.6.4/docs/Language-Haskell-GHC-ExactPrint-Delta.html -- The important part is that for DP(r,c), if r is zero, c is the offset start from the end of the previous node. -- However, if r is greater than zero, c is the offset start from the 'anchor'. - -- Generally speaking, the 'anchor' is the node that "enclose" + -- Generally speaking, the 'anchor' is the node that "enclose" the current node. But it's not always the case. + -- Sometimes 'anchor' is just the previous node. It depends on the the syntactic structure. + -- For constructors, the anchor is the previous node (if there is any). + -- For record fields, the anchor is always the constructor they belong to. for_ (zip nodes (Nothing: fmap Just nodes)) $ \(node, prevNode) -> do addHaddockCommentToCurrentNode <- fmap (not . fromMaybe True . flip hasHaddock node) getAnnsT -- We don't add new haddock comments to nodes with existing ones. From 1803c5ee921fc13efa43d1362db8f655fa7db334 Mon Sep 17 00:00:00 2001 From: kokobd Date: Sat, 24 Sep 2022 15:14:37 +0000 Subject: [PATCH 13/13] rephrase some comments to make them clearer --- .../src/Ide/Plugin/HaddockComments/Data.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs index a8c3ec016c..3c37556841 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs @@ -109,8 +109,8 @@ addHaddockCommentsToList usePrevNodeAsAnchor outerLoc seperator nodes = modifyAnnsT $ let updateCurrent :: Annotation -> Annotation updateCurrent ann = ann { - -- If there exists non-haddock comments, we simply inherit it's delta pos, and move existing - -- comments two lines below (to seperate them from our newly added haddock comments) + -- If there exist non-haddock comments, we simply inherit the first one's delta pos, + -- and move them two lines below, to seperate them from our newly added haddock comments -- Otherwise, inherit the node's entry delta pos. annPriorComments = case annPriorComments ann of (c, dp) : rem -> (emptyPriorHaddockComment, dp) : (c, DP (2,0)) : rem