-
-
Notifications
You must be signed in to change notification settings - Fork 367
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
* remove 'buildable: False' in cabal * remove constraint on ghc-exactprint * wip * revert HaddockComments.hs * generate haddock comments for constructors * fix tests * restore constraints * make it compatible with ghc 9.0 * add more tests * add comments & fix dp calculation for inline case * add kokobd to codeowners of haddock-comments plugin * fix a comment * rephrase some comments to make them clearer Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
- Loading branch information
1 parent
6f9b435
commit 217573f
Showing
12 changed files
with
294 additions
and
74 deletions.
There are no files selected for viewing
Validating CODEOWNERS rules …
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
168 changes: 168 additions & 0 deletions
168
plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Data.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,168 @@ | ||
| {-# LANGUAGE CPP #-} | ||
| {-# LANGUAGE DuplicateRecordFields #-} | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# 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 Data.Maybe (fromMaybe, isJust) | ||
| 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 haddock comments", | ||
| updateAnns = updateDataAnns | ||
| } | ||
|
|
||
| updateDataAnns :: LHsDecl GhcPs -> TransformT Maybe () | ||
| 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 | ||
| addHaddockCommentsToList True declLoc (G AnnVbar) cons | ||
| for_ cons $ \case | ||
| L conLoc ConDeclH98 { con_args = RecCon (L _ fields) } -> addHaddockCommentsToList False conLoc (G AnnComma) fields | ||
| _ -> pure () | ||
| modifyAnnsT $ Map.adjust (\ann -> ann {annPriorComments = []}) (mkAnnKey decl) | ||
| updateDataAnns _ = lift Nothing | ||
|
|
||
| -- | 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" 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. | ||
| when addHaddockCommentToCurrentNode $ do | ||
| -- '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, 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 { | ||
| -- 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 | ||
| _ -> [(emptyPriorHaddockComment, annEntryDelta ann)], | ||
| annEntryDelta = DP (1, dpCol) | ||
| } | ||
| 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 | ||
| 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) | ||
| badRealSrcSpan | ||
| #else | ||
| 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 | ||
| key = mkAnnKey node | ||
| annHasHaddock ann = | ||
| any (matchCommentPrefix priorCommentPrefix . fst) (annPriorComments ann) | ||
| || 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 | ||
|
|
||
| priorCommentPrefix :: [String] | ||
| priorCommentPrefix = ["-- |", "{-|", "{- |"] | ||
|
|
||
| followingCommentPrefix :: [String] | ||
| followingCommentPrefix = ["-- ^", "{-^", "{- ^"] | ||
|
|
||
| matchCommentPrefix :: [String] -> Comment -> Bool | ||
| matchCommentPrefix prefix comment = any (`isPrefixOf` commentContents comment) prefix |
29 changes: 29 additions & 0 deletions
29
plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments/Prelude.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,29 @@ | ||
| {-# 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) | ||
|
|
||
| -- | 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, | ||
| fromDecl :: HsDecl GhcPs -> Maybe a, | ||
| collectKeys :: a -> [AnnKey], | ||
| isFresh :: Annotation -> Bool, | ||
| updateAnn :: Annotation -> Annotation, | ||
| updateDeclAnn :: Annotation -> Annotation | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.