Skip to content

Commit 08bdb65

Browse files
jvanbrueggejvanbruegge
committed
hls-notes-plugin: Initial implementation
1 parent 41de40e commit 08bdb65

File tree

8 files changed

+286
-0
lines changed

8 files changed

+286
-0
lines changed

‎haskell-language-server.cabal

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1607,6 +1607,61 @@ test-suite hls-semantic-tokens-plugin-tests
16071607
, data-default
16081608
, row-types
16091609

1610+
-----------------------------
1611+
-- notes plugin
1612+
-----------------------------
1613+
1614+
flag notes
1615+
description: Enable notes plugin
1616+
default: True
1617+
manual: True
1618+
1619+
common notes
1620+
if flag(notes)
1621+
build-depends: haskell-language-server:hls-notes-plugin
1622+
cpp-options: -Dhls_notes
1623+
1624+
library hls-notes-plugin
1625+
import: defaults, pedantic, warnings
1626+
buildable: True
1627+
exposed-modules:
1628+
Ide.Plugin.Notes
1629+
hs-source-dirs: plugins/hls-notes-plugin/src
1630+
build-depends:
1631+
, base >=4.12 && <5
1632+
, array
1633+
, ghcide == 2.7.0.0
1634+
, hls-graph == 2.7.0.0
1635+
, hls-plugin-api == 2.7.0.0
1636+
, lens
1637+
, lsp >=2.4
1638+
, mtl >= 2.2
1639+
, regex-tdfa >= 1.3.1
1640+
, text
1641+
, text-rope
1642+
, unordered-containers
1643+
default-extensions:
1644+
DataKinds
1645+
, DeriveAnyClass
1646+
, DerivingStrategies
1647+
, OverloadedStrings
1648+
, LambdaCase
1649+
, TypeFamilies
1650+
1651+
test-suite hls-notes-plugin-tests
1652+
import: defaults, pedantic, test-defaults, warnings
1653+
type: exitcode-stdio-1.0
1654+
hs-source-dirs: plugins/hls-notes-plugin/test
1655+
main-is: NotesTest.hs
1656+
build-depends:
1657+
, base
1658+
, directory
1659+
, filepath
1660+
, ghcide:ghcide-test-utils
1661+
, haskell-language-server:hls-notes-plugin
1662+
, hls-test-utils == 2.7.0.0
1663+
default-extensions: OverloadedStrings
1664+
16101665
----------------------------
16111666
----------------------------
16121667
-- HLS
@@ -1645,6 +1700,7 @@ library
16451700
, refactor
16461701
, overloadedRecordDot
16471702
, semanticTokens
1703+
, notes
16481704

16491705
exposed-modules:
16501706
Ide.Arguments

‎plugins/hls-notes-plugin/README.md

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
# Note plugin
2+
3+
The [Note convention](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/coding-style#2-using-notes) is a nice way to hoist and share big chunks of documentation out of the body of functions. This is done by referencing a long form note from within the function. This plugin extends goto-definition to jump from the reference to the note.
4+
5+
# Example
6+
7+
Main.hs
8+
```haskell
9+
module Main where
10+
11+
main :: IO
12+
main = do
13+
doSomething -- We need this here, see Note [Do Something] in Foo
14+
```
15+
16+
Foo.hs
17+
```
18+
module Foo where
19+
20+
doSomething :: IO ()
21+
doSomething = undefined
22+
23+
{-
24+
Note [Do Something]
25+
~~~~~~~~~~~~~~~~~~~
26+
Some very important explanation
27+
-}
28+
```
29+
30+
Using "Go-to-definition on the Note reference in `Main.hs` will jump to the beginning of the note in `Foo.hs`.

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

Lines changed: 125 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,125 @@
1+
module Ide.Plugin.Notes (descriptor, Log) where
2+
3+
import Control.Lens (ix, (^.), (^?))
4+
import Control.Monad.Except (throwError)
5+
import Control.Monad.IO.Class (liftIO)
6+
import Control.Monad.Trans (lift)
7+
import qualified Data.Array as A
8+
import Data.HashMap.Strict (HashMap)
9+
import qualified Data.HashMap.Strict as HM
10+
import qualified Data.HashSet as HS
11+
import Data.Maybe (catMaybes, listToMaybe,
12+
mapMaybe)
13+
import Data.Text (Text, intercalate)
14+
import qualified Data.Text as T
15+
import qualified Data.Text.Utf16.Rope.Mixed as Rope
16+
import Development.IDE hiding (line)
17+
import Development.IDE.Core.PluginUtils (runActionE, useE)
18+
import Development.IDE.Core.Shake (toKnownFiles)
19+
import qualified Development.IDE.Core.Shake as Shake
20+
import Development.IDE.Graph.Classes (Hashable, NFData)
21+
import GHC.Generics (Generic)
22+
import Ide.Plugin.Error (PluginError (..))
23+
import Ide.Types
24+
import qualified Language.LSP.Protocol.Lens as L
25+
import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition),
26+
SMethod (SMethod_TextDocumentDefinition))
27+
import Language.LSP.Protocol.Types
28+
import qualified Language.LSP.Server as LSP
29+
import Language.LSP.VFS (VirtualFile (..))
30+
import Text.Regex.TDFA (Regex, caseSensitive,
31+
defaultCompOpt,
32+
defaultExecOpt,
33+
makeRegexOpts, matchAllText)
34+
35+
data Log
36+
= LogShake Shake.Log
37+
| LogNotesFound NormalizedFilePath [(Text, Position)]
38+
deriving Show
39+
40+
data GetNotesInFile = MkGetNotesInFile
41+
deriving (Show, Generic, Eq, Ord)
42+
deriving anyclass (Hashable, NFData)
43+
type instance RuleResult GetNotesInFile = HM.HashMap Text Position
44+
45+
data GetNotes = MkGetNotes
46+
deriving (Show, Generic, Eq, Ord)
47+
deriving anyclass (Hashable, NFData)
48+
type instance RuleResult GetNotes = HashMap Text (NormalizedFilePath, Position)
49+
50+
instance Pretty Log where
51+
pretty = \case
52+
LogShake l -> pretty l
53+
LogNotesFound file notes ->
54+
"Found notes in " <> pretty (show file) <> ": ["
55+
<> pretty (intercalate ", " (fmap (\(s, p) -> "\"" <> s <> "\" at " <> T.pack (show p)) notes)) <> "]"
56+
57+
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
58+
descriptor recorder plId = (defaultPluginDescriptor plId "Provides goto definition support for GHC-style notes")
59+
{ Ide.Types.pluginRules = findNotesRules recorder
60+
, Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentDefinition jumpToNote
61+
}
62+
63+
findNotesRules :: Recorder (WithPriority Log) -> Rules ()
64+
findNotesRules recorder = do
65+
defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNotesInFile nfp -> do
66+
findNotesInFile nfp recorder
67+
68+
defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNotes _ -> do
69+
targets <- toKnownFiles <$> useNoFile_ GetKnownTargets
70+
definedNotes <- catMaybes <$> mapM (\nfp -> fmap (HM.map (nfp,)) <$> use MkGetNotesInFile nfp) (HS.toList targets)
71+
pure $ Just $ HM.unions definedNotes
72+
73+
jumpToNote :: PluginMethodHandler IdeState Method_TextDocumentDefinition
74+
jumpToNote state _ param
75+
| Just nfp <- uriToNormalizedFilePath uriOrig
76+
= do
77+
let Position l c = param ^. L.position
78+
contents <- fmap _file_text . err "Error getting file contents"
79+
=<< lift (LSP.getVirtualFile uriOrig)
80+
line <- err "Line not found in file" (Rope.lines contents ^? ix (fromIntegral l))
81+
note <- err "No note at this position" $ listToMaybe $
82+
mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line
83+
notes <- runActionE "notes.definedNotes" state $ useE MkGetNotes nfp
84+
(noteFp, pos) <- err "Note not found" (HM.lookup note notes)
85+
pure $ InL (Definition (InL
86+
(Location (fromNormalizedUri $ normalizedFilePathToUri noteFp) (Range pos pos))
87+
))
88+
where
89+
uriOrig = toNormalizedUri $ param ^. (L.textDocument . L.uri)
90+
err s = maybe (throwError $ PluginInternalError s) pure
91+
atPos c arr = case arr A.! 0 of
92+
(_, (c', len)) -> if c' <= c && c <= c' + len
93+
then Just (fst (arr A.! 1)) else Nothing
94+
jumpToNote _ _ _ = throwError $ PluginInternalError "conversion to normalized file path failed"
95+
96+
findNotesInFile :: NormalizedFilePath -> Recorder (WithPriority Log) -> Action (Maybe (HM.HashMap Text Position))
97+
findNotesInFile file recorder = do
98+
contentOpt <- (snd =<<) <$> use GetFileContents file
99+
content <- case contentOpt of
100+
Just x -> pure x
101+
Nothing -> liftIO $ readFileUtf8 $ fromNormalizedFilePath file
102+
let matches = (A.! 1) <$> matchAllText noteRegex content
103+
m = toPositions matches content
104+
logWith recorder Debug $ LogNotesFound file (HM.toList m)
105+
pure $ Just m
106+
where
107+
uint = fromIntegral . toInteger
108+
toPositions matches = snd . fst . T.foldl' (\case
109+
(([], m), _) -> const (([], m), (0, 0, 0))
110+
((x@(name, (char, _)):xs, m), (n, nc, c)) -> \char' ->
111+
let !c' = c + 1
112+
(!n', !nc') = if char' == '\n' then (n + 1, c') else (n, nc)
113+
p = if char == c then
114+
(xs, HM.insert name (Position (uint n') (uint (char - nc'))) m)
115+
else (x:xs, m)
116+
in (p, (n', nc', c'))
117+
) ((matches, HM.empty), (0, 0, 0))
118+
119+
noteRefRegex, noteRegex :: Regex
120+
(noteRefRegex, noteRegex) =
121+
( mkReg ("note \\[(.+)\\]" :: String)
122+
, mkReg ("note \\[([[:print:]]+)\\][[:blank:]]*[[:space:]][[:space:]]?~~~" :: String)
123+
)
124+
where
125+
mkReg = makeRegexOpts (defaultCompOpt { caseSensitive = False }) defaultExecOpt

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

Lines changed: 43 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
module Main (main) where
2+
3+
import Development.IDE.Test
4+
import Ide.Plugin.Notes (Log, descriptor)
5+
import System.Directory (canonicalizePath)
6+
import System.FilePath ((</>))
7+
import Test.Hls
8+
9+
plugin :: PluginTestDescriptor Log
10+
plugin = mkPluginTestDescriptor descriptor "notes"
11+
12+
main :: IO ()
13+
main = defaultTestRunner $
14+
testGroup "Notes"
15+
[ gotoNoteTests
16+
]
17+
18+
gotoNoteTests :: TestTree
19+
gotoNoteTests = testGroup "Goto Note Definition"
20+
[ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do
21+
doc <- openDoc "NoteDef.hs" "haskell"
22+
_ <- waitForAllProgressDone
23+
defs <- getDefinitions doc (Position 3 41)
24+
liftIO $ do
25+
fp <- canonicalizePath "NoteDef.hs"
26+
defs @?= InL (Definition (InL (Location (filePathToUri fp) (Range (Position 5 9) (Position 5 9)))))
27+
, testCase "no_note" $ runSessionWithServer def plugin testDataDir $ do
28+
doc <- openDoc "NoteDef.hs" "haskell"
29+
defs <- getDefinitions doc (Position 1 0)
30+
liftIO $ defs @?= InL (Definition (InR []))
31+
32+
, testCase "unopened_file" $ runSessionWithServer def plugin testDataDir $ do
33+
doc <- openDoc "Other.hs" "haskell"
34+
waitForCustomMessage "ghcide/cradle/loaded" (const $ Just ())
35+
waitForAllProgressDone
36+
defs <- getDefinitions doc (Position 5 20)
37+
liftIO $ do
38+
fp <- canonicalizePath "NoteDef.hs"
39+
defs @?= InL (Definition (InL (Location (filePathToUri fp) (Range (Position 9 6) (Position 9 6)))))
40+
]
41+
42+
testDataDir :: FilePath
43+
testDataDir = "plugins" </> "hls-notes-plugin" </> "test" </> "testdata"

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

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
module NoteDef (foo) where
2+
3+
foo :: Int -> Int
4+
foo _ = 0 -- We always return zero, see Note [Returning zero from foo]
5+
6+
{- Note [Returning zero from foo]
7+
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8+
This is a big long form note, with very important info
9+
10+
Note [Multiple notes in comment]
11+
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
12+
This is also a very common thing to do for GHC
13+
14+
-}

‎plugins/hls-notes-plugin/test/testdata/Other.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
module Other where
2+
3+
import NoteDef
4+
5+
bar :: Int
6+
bar = 4 -- See @Note [Multiple notes in comment]@ in NoteDef

‎plugins/hls-notes-plugin/test/testdata/hie.yaml

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
cradle:
2+
direct:
3+
arguments:
4+
- Other
5+
- NoteDef

‎src/HlsPlugins.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -93,6 +93,10 @@ import qualified Ide.Plugin.ExplicitFields as ExplicitFields
9393
import qualified Ide.Plugin.OverloadedRecordDot as OverloadedRecordDot
9494
#endif
9595

96+
#if hls_notes
97+
import qualified Ide.Plugin.Notes as Notes
98+
#endif
99+
96100
-- formatters
97101

98102
#if hls_floskell
@@ -230,6 +234,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins
230234
#endif
231235
#if hls_overloaded_record_dot
232236
let pId = "overloaded-record-dot" in OverloadedRecordDot.descriptor (pluginRecorder pId) pId :
237+
#endif
238+
#if hls_notes
239+
let pId = "notes" in Notes.descriptor (pluginRecorder pId) pId :
233240
#endif
234241
GhcIde.descriptors (pluginRecorder "ghcide")
235242

0 commit comments

Comments
 (0)