hls-notes-plugin: Find notes at index time and cache

plugins/hls-notes-plugin/hls-notes-plugin.cabal

@@ -23,11 +23,9 @@ common warnings
 
 library
   import:           warnings
-  other-modules:
-    Ide.Plugin.Notes.Internal
   exposed-modules:  Ide.Plugin.Notes
   build-depends:
-    , base                  >=4.16 && <5
+    , base                  >=4.12 && <5
     , array
     , bytestring
     , ghcide
@@ -37,13 +35,17 @@ library
     , hls-graph
     , regex-tdfa ^>= 1.3.1
     , text
+    , text-rope
+    , transformers
+    , unordered-containers
   hs-source-dirs:   src
   default-language: GHC2021
   default-extensions:
     DataKinds
+    ExplicitNamespaces
     LambdaCase
     OverloadedStrings
-    ExplicitNamespaces
+    TypeFamilies
 
 test-suite tests
   import:           warnings

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

@@ -1,12 +1,104 @@
-module Ide.Plugin.Notes (descriptor) where
+module Ide.Plugin.Notes (descriptor, Log) where
 
-import           Development.IDE
-import qualified Ide.Plugin.Notes.Internal as X
+import           Control.Lens                  (ix, (^.), (^?))
+import           Control.Monad.IO.Class        (liftIO)
+import           Control.Monad.Trans.Class     (lift)
+import qualified Data.Array                    as A
+import           Data.HashMap.Strict           (HashMap)
+import qualified Data.HashMap.Strict           as HM
+import           Data.Maybe                    (listToMaybe, mapMaybe)
+import           Data.Text                     (Text, intercalate)
+import qualified Data.Text                     as T
+import qualified Data.Text.Utf16.Rope          as Rope
+import           Data.Typeable                 (Typeable)
+import           Development.IDE               hiding (line)
+import qualified Development.IDE.Core.Shake    as Shake
+import           Development.IDE.Graph.Classes (Hashable, NFData)
+import           GHC.Generics                  (Generic)
+import           Ide.PluginUtils               (getNormalizedFilePath,
+                                                pluginResponse,
+                                                throwPluginError)
 import           Ide.Types
+import qualified Language.LSP.Server           as LSP
 import           Language.LSP.Types
+import qualified Language.LSP.Types.Lens       as L
+import           Language.LSP.VFS              (VirtualFile (..))
+import           Text.Regex.TDFA               (Regex, caseSensitive,
+                                                defaultCompOpt, defaultExecOpt,
+                                                makeRegexOpts, matchAllText)
 
-descriptor :: PluginId -> PluginDescriptor IdeState
-descriptor plId = (defaultPluginDescriptor plId)
-    { Ide.Types.pluginHandlers =
-        mkPluginHandler STextDocumentDefinition X.jumpToNote
+data Log
+    = LogShake Shake.Log
+    | LogNotesFound [Text]
+    deriving Show
+
+instance Pretty Log where
+    pretty = \case
+        LogShake l -> pretty l
+        LogNotesFound notes ->
+            "Found notes: ["
+            <> pretty (intercalate ", " (fmap (\s -> "\"" <> s <> "\"") notes)) <> "]"
+
+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder plId = (defaultPluginDescriptor plId)
+    { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentDefinition jumpToNote
+    , Ide.Types.pluginRules = findNotesRules recorder
     }
+
+jumpToNote :: PluginMethodHandler IdeState TextDocumentDefinition
+jumpToNote state _ param = pluginResponse $ do
+    let uriOrig = param ^. (L.textDocument . L.uri)
+        Position l c = param ^. L.position
+    nfp <- getNormalizedFilePath uriOrig
+    contents <- fmap _file_text . err "Error getting file contents"
+        =<< lift (LSP.getVirtualFile (toNormalizedUri uriOrig))
+    line <- err "Line not found in file" (Rope.lines contents ^? ix (fromIntegral l))
+    note <- err "No note at this position" $ listToMaybe $
+        mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line
+    allNotes <- err "No notes found in file" =<<
+        liftIO (runAction "Notes.getNotes" state $ use MkNoteDefinitions nfp)
+    pos <- err "Note not found" (HM.lookup note allNotes)
+    pure $ InL (Location uriOrig (Range pos pos))
+    where
+        err s = maybe (throwPluginError s) pure
+        atPos c arr = case arr A.! 0 of
+            (_, (c', len)) -> if c' <= c && c <= c' + len
+                then Just (fst (arr A.! 1)) else Nothing
+
+data NoteDefinitions = MkNoteDefinitions
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable NoteDefinitions
+instance NFData NoteDefinitions
+
+type instance RuleResult NoteDefinitions = HashMap Text Position
+
+findNotesRules :: Recorder (WithPriority Log) -> Rules ()
+findNotesRules recorder = do
+    defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkNoteDefinitions file -> do
+        content <- snd <$> use_ GetFileContents file
+        let m = do
+                c <- content
+                let matches = (A.! 1) <$> matchAllText noteRegex c
+                pure $ toPositions matches c
+        logWith recorder Debug $ LogNotesFound (maybe [] HM.keys m)
+        pure m
+    where
+        uint = fromIntegral . toInteger
+        toPositions matches = snd . fst . T.foldl' (\case
+            (([], m), _) -> const (([], m), (0, 0, 0))
+            ((x@(name, (char, _)):xs, m), (n, nc, c)) -> \char' ->
+                let !c' = c + 1
+                    (!n', !nc') = if char' == '\n' then (n + 1, c') else (n, nc)
+                    p = if char == c then
+                            (xs, HM.insert name (Position (uint n') (uint (char - nc'))) m)
+                        else (x:xs, m)
+                in (p, (n', nc', c'))
+            ) ((matches, HM.empty), (0, 0, 0))
+
+noteRefRegex, noteRegex :: Regex
+(noteRefRegex, noteRegex) =
+    ( mkReg ("note \\[(.+)\\]( in (([A-Za-z0-9]+\\.)*[A-Za-z0-9]+))?" :: String)
+    , mkReg ("note \\[([[:print:]]+)\\][[:blank:]]*[[:space:]][[:space:]]?~~~" :: String)
+    )
+    where
+        mkReg = makeRegexOpts (defaultCompOpt { caseSensitive = False }) defaultExecOpt

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

@@ -1,12 +1,12 @@
 module Main (main) where
 
-import           Ide.Plugin.Notes (descriptor)
+import           Ide.Plugin.Notes (Log, descriptor)
 import           System.Directory (canonicalizePath)
 import           System.FilePath  ((</>))
 import           Test.Hls
 
-plugin :: PluginTestDescriptor ()
-plugin = mkPluginTestDescriptor' descriptor "notes"
+plugin :: PluginTestDescriptor Log
+plugin = mkPluginTestDescriptor descriptor "notes"
 
 main :: IO ()
 main = defaultTestRunner $
@@ -21,7 +21,7 @@ gotoNoteTests = testGroup "Goto Note Definition"
         defs <- getDefinitions doc (Position 3 41)
         liftIO $ do
           fp <- canonicalizePath "NoteDef.hs"
-          defs @?= InL [Location (filePathToUri fp) (Range (Position 7 0) (Position 7 0))]
+          defs @?= InL [Location (filePathToUri fp) (Range (Position 5 9) (Position 5 9))]
     , testCase "no_note" $ runSessionWithServer plugin testDataDir $ do
         doc <- openDoc "NoteDef.hs" "haskell"
         defs <- getDefinitions doc (Position 1 0)

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

@@ -3,10 +3,12 @@ module NoteDef (foo) where
 foo :: Int -> Int
 foo _ = 0 -- We always return zero, see Note [Returning zero from foo]
 
-{-
-
-Note [Returning zero from foo]
+{- Note [Returning zero from foo]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 This is a big long form note, with very important info
 
+Note [Multiple notes in comment]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This is also a very common thing to do for GHC
+
 -}

src/HlsPlugins.hs

@@ -243,7 +243,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins
       let pId = "overloaded-record-dot" in OverloadedRecordDot.descriptor (pluginRecorder pId) pId :
 #endif
 #if hls_notes
-      Notes.descriptor "notes" :
+      let pId = "notes" in Notes.descriptor (pluginRecorder pId) pId :
 #endif
       GhcIde.descriptors (pluginRecorder "ghcide")