add comments & fix dp calculation for inline case

Author: kokobd

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
   ]
 

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,53 +35,103 @@ 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
 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

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,

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 }