Improving Notes Plugin (#4791)

* hover Note References to get declaration info

* Note Declaration snippet

* Note References

* update config and format code

* Implement Reviews

Author: vidit-od

plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs

@@ -10,8 +10,8 @@ import           Data.HashMap.Strict              (HashMap)
 import qualified Data.HashMap.Strict              as HM
 import qualified Data.HashSet                     as HS
 import           Data.List                        (uncons)
-import           Data.Maybe                       (catMaybes, listToMaybe,
-                                                   mapMaybe)
+import           Data.Maybe                       (catMaybes, fromMaybe,
+                                                   listToMaybe, mapMaybe)
 import           Data.Text                        (Text, intercalate)
 import qualified Data.Text                        as T
 import qualified Data.Text.Utf16.Rope.Mixed       as Rope
@@ -25,8 +25,8 @@ import           GHC.Generics                     (Generic)
 import           Ide.Plugin.Error                 (PluginError (..))
 import           Ide.Types
 import qualified Language.LSP.Protocol.Lens       as L
-import           Language.LSP.Protocol.Message    (Method (Method_TextDocumentDefinition, Method_TextDocumentReferences),
-                                                   SMethod (SMethod_TextDocumentDefinition, SMethod_TextDocumentReferences))
+import           Language.LSP.Protocol.Message    (Method (Method_TextDocumentCompletion, Method_TextDocumentDefinition, Method_TextDocumentHover, Method_TextDocumentReferences),
+                                                   SMethod (SMethod_TextDocumentCompletion, SMethod_TextDocumentDefinition, SMethod_TextDocumentHover, SMethod_TextDocumentReferences))
 import           Language.LSP.Protocol.Types
 import           Text.Regex.TDFA                  (Regex, caseSensitive,
                                                    defaultCompOpt,
@@ -80,6 +80,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId "Provides goto definiti
     , Ide.Types.pluginHandlers =
         mkPluginHandler SMethod_TextDocumentDefinition jumpToNote
         <> mkPluginHandler SMethod_TextDocumentReferences listReferences
+        <> mkPluginHandler SMethod_TextDocumentHover hoverNote
+        <> mkPluginHandler SMethod_TextDocumentCompletion autocomplete
     }
 
 findNotesRules :: Recorder (WithPriority Log) -> Rules ()
@@ -190,8 +192,199 @@ findNotesInFile file recorder = do
 
 noteRefRegex, noteRegex :: Regex
 (noteRefRegex, noteRegex) =
-    ( mkReg ("note \\[(.+)\\]" :: String)
-    , mkReg ("note \\[([[:print:]]+)\\][[:blank:]]*\r?\n[[:blank:]]*(--)?[[:blank:]]*~~~" :: String)
+    ( mkReg ("note[[:blank:]]?\\[(.+)\\]" :: String)
+    , mkReg ("note[[:blank:]]?\\[([[:print:]]+)\\][[:blank:]]*\r?\n[[:blank:]]*(--)?[[:blank:]]*~~~" :: String)
     )
     where
         mkReg = makeRegexOpts (defaultCompOpt { caseSensitive = False }) defaultExecOpt
+
+-- | Find the precise range of `note[...]` or `note [...]` on a line.
+findNoteRange
+  :: Text   -- ^ Full line text
+  -> Text   -- ^ Note title
+  -> UInt   -- ^ Line number
+  -> Maybe Range
+findNoteRange line _note lineNo =
+  case matchAllText noteRefRegex line of
+    [] -> Nothing
+    (arr:_) ->
+      case arr A.! 0 of
+        (_, (start, len)) ->
+          let startCol = fromIntegral start
+              endCol   = startCol + fromIntegral len
+          in Just $
+               Range
+                 (Position lineNo startCol)
+                 (Position lineNo endCol)
+
+-- Given the path and position of a Note Declaration, finds Content in it.
+-- ignores ~ as a seprator
+extractNoteContent
+  :: NormalizedFilePath
+  -> Position
+  -> IO (Maybe Text)
+extractNoteContent nfp (Position startLine _) = do
+  fileText <- readFileUtf8 $ fromNormalizedFilePath nfp
+
+  let allLines = T.lines fileText
+      afterDecl = drop (fromIntegral startLine + 1) allLines
+      afterSeparator =
+        case dropWhile (not . isSeparatorLine) afterDecl of
+          []     -> []
+          (_:xs) -> xs
+
+      bodyLines = takeWhile (not . isStopLine) afterSeparator
+
+  if null afterSeparator
+     then pure Nothing
+     else pure $ Just (T.unlines (map stripCommentPrefix bodyLines))
+
+  where
+    isSeparatorLine :: Text -> Bool
+    isSeparatorLine t = "~~~" `T.isInfixOf` t
+
+    isNoteHeader :: Text -> Bool
+    isNoteHeader t =
+      let stripped = T.toLower (T.stripStart (stripCommentPrefix t))
+      in "note [" `T.isPrefixOf` stripped
+
+    isEndMarker :: Text -> Bool
+    isEndMarker t = "-}" `T.isInfixOf` t
+
+    isStopLine :: Text -> Bool
+    isStopLine t = isSeparatorLine t || isNoteHeader t || isEndMarker t
+
+    stripCommentPrefix :: Text -> Text
+    stripCommentPrefix t =
+      let s = T.stripStart t
+      in if "--" `T.isPrefixOf` s
+            then T.stripStart (T.drop 2 s)
+            else s
+
+normalizeNewlines :: Text -> Text
+normalizeNewlines = T.replace "\r\n" "\n"
+
+-- on hovering Note References, shows corresponding Declaration if it Exists
+-- ignores Note Declaration
+hoverNote :: PluginMethodHandler IdeState Method_TextDocumentHover
+hoverNote state _ params
+  | Just nfp <- uriToNormalizedFilePath uriOrig
+  = do
+      let pos@(Position line _) = params ^. L.position
+      noteOpt <- getNote nfp state pos
+      case noteOpt of
+        Nothing -> pure (InR Null)
+
+        Just note -> do
+          mbRope <- liftIO $ runAction "notes.hoverLine" state (getFileContents nfp)
+
+          -- compute precise hover range for highlighting corresponding Note Reference on Hover
+          let lineText =
+                case mbRope of
+                  Nothing   -> ""
+                  Just rope -> fromMaybe "" $ listToMaybe $ drop (fromIntegral line) $ Rope.lines rope
+
+              mbRange = findNoteRange lineText note line
+
+          notes <- runActionE "notes.hover" state $ useE MkGetNotes nfp
+          case HM.lookup note notes of
+            Nothing -> pure $ InL $ Hover (InL $ MarkupContent MarkupKind_Markdown "_No declaration available_") mbRange
+
+            Just (defFile, defPos) ->
+              if nfp == defFile && pos ^. L.line == defPos ^. L.line
+                then pure (InR Null)
+                else do
+                  mbContent <- liftIO $ extractNoteContent defFile defPos
+
+                  let contents =
+                        case mbContent of
+                          Nothing   -> "_No declaration available_"
+                          Just body -> T.unlines [note, "", body]
+                      normalizedContents = normalizeNewlines contents
+
+                  pure $ InL $ Hover (InL $ MarkupContent MarkupKind_Markdown normalizedContents) mbRange
+  where
+    uriOrig = toNormalizedUri $ params ^. (L.textDocument . L.uri)
+
+hoverNote _ _ _ = pure (InR Null)
+
+-- Gives an autocomplete suggestion when 'note' prefix is detected
+autocomplete :: PluginMethodHandler IdeState Method_TextDocumentCompletion
+autocomplete state _ params = do
+  let uri = params ^. (L.textDocument . L.uri)
+      pos = params ^. L.position
+      nuri = toNormalizedUri uri
+
+  contents <-
+    liftIO $
+      runAction "Notes.GetUriContents" state $
+        getUriContents nuri
+
+  fmap InL $
+    case contents of
+      Nothing -> pure []
+
+      Just rope -> do
+        let linePrefix =  T.toLower $  T.stripEnd $  getLinePrefix rope pos
+
+        -- Suggest NOTE DECLARATION snippit if "note" prefix detected
+        if T.strip linePrefix == "note"
+        then
+          pure [CompletionItem "Note" Nothing (Just CompletionItemKind_Keyword) Nothing
+              (Just "Note Declaration") Nothing Nothing Nothing Nothing
+              Nothing (Just noteSnippet) (Just InsertTextFormat_Snippet) Nothing
+              Nothing Nothing Nothing Nothing Nothing Nothing
+          ]
+
+        -- Suggest list of all NOTE DECLARATION if "note [" infix detected
+        else if "note[" `T.isInfixOf` linePrefix || "note [" `T.isInfixOf` linePrefix
+        then
+          case uriToNormalizedFilePath nuri of
+            Nothing -> pure []
+
+            Just nfp -> do
+              let typed =
+                   case T.breakOnEnd "[" linePrefix of
+                    (_, "")   -> ""
+                    (_, rest)-> T.strip rest
+
+              notesMap <-
+                runActionE "notes.completion.notes" state $
+                  useE MkGetNotes nfp
+
+              let allNotes = HM.keys notesMap
+                  matches =
+                    filter
+                      (\n -> T.toLower typed `T.isPrefixOf` T.toLower n)
+                      allNotes
+
+                  finalNotes =
+                    if null matches then allNotes else matches
+              pure $
+                map
+                  (\n ->
+                     CompletionItem n Nothing (Just CompletionItemKind_Reference) Nothing (Just "Note reference")
+                       Nothing Nothing (Just True) (Just "0") (Just n)
+                       Nothing Nothing Nothing Nothing Nothing
+                       Nothing Nothing Nothing Nothing
+                  )
+                  finalNotes
+        else
+          pure []
+
+noteSnippet :: Text
+noteSnippet =
+  T.unlines
+    [ "{- Note [${1:Declaration title}]"
+    , "~~~"
+    , "${2:Content}"
+    , "-}"
+    ]
+
+getLinePrefix :: Rope.Rope -> Position -> Text
+getLinePrefix rope (Position line col) =
+  case Rope.splitAtLine (fromIntegral line) rope of
+    (_, rest) ->
+      case Rope.lines rest of
+        (l:_) -> T.take (fromIntegral col) l
+        _     -> ""

plugins/hls-notes-plugin/test/NotesTest.hs

@@ -1,5 +1,6 @@
 module Main (main) where
 
+import           Data.List        (sort)
 import           Ide.Plugin.Notes (Log, descriptor)
 import           System.FilePath  ((</>))
 import           Test.Hls
@@ -12,6 +13,7 @@ main = defaultTestRunner $
   testGroup "Notes"
     [ gotoNoteTests
     , noteReferenceTests
+    , hoverNoteTests
     ]
 
 runSessionWithServer' :: FilePath -> (FilePath -> Session a) -> IO a
@@ -28,13 +30,15 @@ noteReferenceTests = testGroup "Note References"
       testCase "multi_file" $ runSessionWithServer' testDataDir $ \dir -> do
         doc <- openDoc "NoteDef.hs" "haskell"
         waitForKickDone
-        refs <- getReferences doc (Position 21 15) False
-        let fp = dir </> "NoteDef.hs"
-        liftIO $ refs @?= [
-            Location (filePathToUri (dir </> "Other.hs")) (Range (Position 6 13) (Position 6 13)),
-            Location (filePathToUri fp) (Range (Position 9 9) (Position 9 9)),
-            Location (filePathToUri fp) (Range (Position 5 67) (Position 5 67))
-          ]
+        refs0 <- getReferences doc (Position 21 15) False
+        let refs = sort refs0
+            fp = dir </> "NoteDef.hs"
+
+        liftIO $ sort refs @?= sort
+            [ Location (filePathToUri (dir </> "Other.hs")) (Range (Position 6 13) (Position 6 13))
+            , Location (filePathToUri fp) (Range (Position 9 9) (Position 9 9))
+            , Location (filePathToUri fp) (Range (Position 5 67) (Position 5 67))
+            ]
     ]
 
 gotoNoteTests :: TestTree
@@ -75,3 +79,69 @@ gotoNoteTests = testGroup "Goto Note Definition"
 
 testDataDir :: FilePath
 testDataDir = "plugins" </> "hls-notes-plugin" </> "test" </> "testdata"
+
+hoverNoteTests :: TestTree
+hoverNoteTests = testGroup "Hover Notes"
+  [ testCase "hover normal-notes" $
+      runSessionWithServer' testDataDir $ \_dir -> do
+        let file = "HoverNote.hs"
+            pos  = Position 24 10
+        doc <- openDoc file "haskell"
+        waitForKickDone
+        hover <- getHover doc pos
+
+        let expected =
+              Just $ Hover (InL $ MarkupContent MarkupKind_Markdown
+              "Normal-Notes\n\nContent of Normal Notes\n\n")
+              (Just (Range (Position 24 3) (Position 24 22)))
+
+        liftIO $ hover @?= expected
+
+
+  , testCase "hover multi-notes-one" $
+      runSessionWithServer' testDataDir $ \_dir -> do
+        let file = "HoverNote.hs"
+            pos  = Position 25 10
+        doc <- openDoc file "haskell"
+        waitForKickDone
+        hover <- getHover doc pos
+
+        let expected =
+              Just $ Hover (InL $ MarkupContent MarkupKind_Markdown
+              "Multi-Notes-one\n\nContent of Multi-Notes-one\n\n\n")
+              (Just (Range (Position 25 3) (Position 25 25)))
+
+        liftIO $ hover @?= expected
+
+
+  , testCase "hover multi-notes-two" $
+      runSessionWithServer' testDataDir $ \_dir -> do
+        let file = "HoverNote.hs"
+            pos  = Position 26 10
+        doc <- openDoc file "haskell"
+        waitForKickDone
+        hover <- getHover doc pos
+
+        let expected =
+              Just $ Hover (InL $ MarkupContent MarkupKind_Markdown
+              "Multi-Notes-two\n\nContent of Multi-Notes-two\n\n")
+              (Just (Range (Position 26 3) (Position 26 25)))
+
+        liftIO $ hover @?= expected
+
+
+  , testCase "hover single-comment-declaration" $
+      runSessionWithServer' testDataDir $ \_dir -> do
+        let file = "HoverNote.hs"
+            pos  = Position 27 10
+        doc <- openDoc file "haskell"
+        waitForKickDone
+        hover <- getHover doc pos
+
+        let expected =
+              Just $ Hover (InL $ MarkupContent MarkupKind_Markdown
+              "Single Comment Declaration\n\nContent of Single Comment Declaration\n\n")
+              (Just (Range (Position 27 3) (Position 27 36)))
+
+        liftIO $ hover @?= expected
+  ]

plugins/hls-notes-plugin/test/testdata/HoverNote.hs

@@ -0,0 +1,28 @@
+module HoverNotes where
+
+{- Note [Normal-Notes]
+~~~
+Content of Normal Notes
+-}
+
+{- Note [Multi-Notes-one]
+~~~
+Content of Multi-Notes-one
+
+Note [Multi-Notes-two]
+~~~
+Content of Multi-Notes-two
+-}
+
+-- Note [Single Comment Declaration]
+-- ~~~
+-- Content of Single Comment Declaration
+-- -}
+
+foo :: Int
+foo = 42
+
+-- Note [Normal-Notes]
+-- Note [Multi-Notes-one]
+-- Note [Multi-Notes-two]
+-- Note [Single Comment Declaration]

test/testdata/schema/ghc910/default-config.golden.json

@@ -99,6 +99,10 @@
         "moduleName": {
             "globalOn": true
         },
+        "notes": {
+            "completionOn": true,
+            "hoverOn": true
+        },
         "ormolu": {
             "config": {
                 "external": false

test/testdata/schema/ghc910/vscode-extension-schema.golden.json

@@ -237,6 +237,18 @@
         "scope": "resource",
         "type": "boolean"
     },
+    "haskell.plugin.notes.completionOn": {
+        "default": true,
+        "description": "Enables notes completions",
+        "scope": "resource",
+        "type": "boolean"
+    },
+    "haskell.plugin.notes.hoverOn": {
+        "default": true,
+        "description": "Enables notes hover",
+        "scope": "resource",
+        "type": "boolean"
+    },
     "haskell.plugin.ormolu.config.external": {
         "default": false,
         "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library",