Skip to content

Commit 704b21d

Browse files
pepeiborrapepeiborra
committed
Extract type signature code lenses to an HLS plugin
This was worth doing to clean up the messy command handlers
1 parent c125ddb commit 704b21d

File tree

7 files changed

+129
-109
lines changed

7 files changed

+129
-109
lines changed

‎exe/Plugins.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ import Ide.Plugin.Example as Example
1010
import Ide.Plugin.Example2 as Example2
1111
import Development.IDE (IdeState)
1212
import Development.IDE.Plugin.HLS.GhcIde as GhcIde
13+
import Development.IDE.Plugin.TypeLenses as TypeLenses
1314

1415
-- haskell-language-server optional plugins
1516

@@ -90,6 +91,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
9091
else basePlugins
9192
basePlugins =
9293
[ GhcIde.descriptor "ghcide"
94+
, TypeLenses.descriptor "type-lenses"
9395
#if pragmas
9496
, Pragmas.descriptor "pragmas"
9597
#endif

‎ghcide/exe/Main.hs

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import Development.IDE.Types.Diagnostics
2828
import Development.IDE.Types.Options
2929
import Development.IDE.Types.Logger
3030
import Development.IDE.Plugin
31+
import Development.IDE.Plugin.TypeLenses as TypeLenses
3132
import Development.IDE.Plugin.Test as Test
3233
import Development.IDE.Session (loadSession)
3334
import Development.Shake (ShakeOptions (shakeThreads))
@@ -87,7 +88,9 @@ main = do
8788

8889
dir <- IO.getCurrentDirectory
8990

90-
let hlsPlugins = pluginDescToIdePlugins [GhcIde.descriptor "ghcide"]
91+
let hlsPlugins = pluginDescToIdePlugins
92+
[ GhcIde.descriptor "ghcide"
93+
, TypeLenses.descriptor "type-lenses" ]
9194

9295
pid <- T.pack . show <$> getProcessID
9396
let hlsPlugin = asGhcIdePlugin hlsPlugins

‎ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -173,6 +173,7 @@ library
173173
Development.IDE.Plugin.HLS
174174
Development.IDE.Plugin.HLS.GhcIde
175175
Development.IDE.Plugin.Test
176+
Development.IDE.Plugin.TypeLenses
176177

177178
-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
178179
-- the real GHC library and the types are incompatible. Furthermore, when

‎ghcide/src/Development/IDE/Plugin/CodeAction.hs

Lines changed: 2 additions & 86 deletions
Original file line numberDiff line numberDiff line change
@@ -10,13 +10,10 @@ module Development.IDE.Plugin.CodeAction
1010
(
1111
-- * For haskell-language-server
1212
codeAction
13-
, codeLens
1413
, rulePackageExports
15-
, commandHandler
1614

1715
-- * For testing
1816
, blockCommandId
19-
, typeSignatureCommandId
2017
, matchRegExMultipleImports
2118
) where
2219

@@ -28,21 +25,19 @@ import Development.IDE.Core.Service
2825
import Development.IDE.Core.Shake
2926
import Development.IDE.GHC.Error
3027
import Development.IDE.GHC.ExactPrint
31-
import Development.IDE.LSP.Server
3228
import Development.IDE.Plugin.CodeAction.ExactPrint
3329
import Development.IDE.Plugin.CodeAction.PositionIndexed
3430
import Development.IDE.Plugin.CodeAction.RuleTypes
3531
import Development.IDE.Plugin.CodeAction.Rules
32+
import Development.IDE.Plugin.TypeLenses (suggestSignature)
3633
import Development.IDE.Types.Exports
3734
import Development.IDE.Types.Location
3835
import Development.IDE.Types.Options
3936
import qualified Data.HashMap.Strict as Map
4037
import qualified Language.Haskell.LSP.Core as LSP
4138
import Language.Haskell.LSP.VFS
42-
import Language.Haskell.LSP.Messages
4339
import Language.Haskell.LSP.Types
4440
import qualified Data.Rope.UTF16 as Rope
45-
import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
4641
import Data.Char
4742
import Data.Maybe
4843
import Data.List.Extra
@@ -58,17 +53,13 @@ import Control.Applicative ((<|>))
5853
import Safe (atMay)
5954
import Bag (isEmptyBag)
6055
import qualified Data.HashSet as Set
61-
import Control.Concurrent.Extra (threadDelay, readVar)
56+
import Control.Concurrent.Extra (readVar)
6257
import Development.IDE.GHC.Util (printRdrName)
6358
import Ide.PluginUtils (subRange)
6459

6560
-- | a command that blocks forever. Used for testing
6661
blockCommandId :: T.Text
6762
blockCommandId = "ghcide.command.block"
68-
69-
typeSignatureCommandId :: T.Text
70-
typeSignatureCommandId = "typesignature.add"
71-
7263
-- | Generate code actions.
7364
codeAction
7465
:: LSP.LspFuncs c
@@ -117,52 +108,6 @@ mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> CAResult
117108
mkCA title diags edit =
118109
CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) (Just edit) Nothing
119110

120-
-- | Generate code lenses.
121-
codeLens
122-
:: LSP.LspFuncs c
123-
-> IdeState
124-
-> CodeLensParams
125-
-> IO (Either ResponseError (List CodeLens))
126-
codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
127-
let commandId = "typesignature.add"
128-
fmap (Right . List) $ case uriToFilePath' uri of
129-
Just (toNormalizedFilePath' -> filePath) -> do
130-
_ <- runAction "codeLens" ideState (use TypeCheck filePath)
131-
diag <- getDiagnostics ideState
132-
hDiag <- getHiddenDiagnostics ideState
133-
pure
134-
[ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
135-
| (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
136-
, dFile == filePath
137-
, (title, tedit) <- suggestSignature False dDiag
138-
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
139-
]
140-
Nothing -> pure []
141-
142-
-- | Execute the "typesignature.add" command.
143-
commandHandler
144-
:: LSP.LspFuncs c
145-
-> IdeState
146-
-> ExecuteCommandParams
147-
-> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
148-
commandHandler lsp _ideState ExecuteCommandParams{..}
149-
-- _command is prefixed with a process ID, because certain clients
150-
-- have a global command registry, and all commands must be
151-
-- unique. And there can be more than one ghcide instance running
152-
-- at a time against the same client.
153-
| T.isSuffixOf blockCommandId _command
154-
= do
155-
LSP.sendFunc lsp $ NotCustomServer $
156-
NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null
157-
threadDelay maxBound
158-
return (Right Null, Nothing)
159-
| T.isSuffixOf typeSignatureCommandId _command
160-
, Just (List [edit]) <- _arguments
161-
, Success wedit <- fromJSON edit
162-
= return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
163-
| otherwise
164-
= return (Right Null, Nothing)
165-
166111
suggestExactAction ::
167112
ExportsMap ->
168113
DynFlags ->
@@ -772,31 +717,6 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}
772717
= let fixedImport = typ <> "(" <> constructor <> ")"
773718
in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
774719
| otherwise = []
775-
776-
suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
777-
suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
778-
| _message =~
779-
("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let
780-
signature = removeInitialForAll
781-
$ T.takeWhile (\x -> x/='*' && x/='•')
782-
$ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
783-
startOfLine = Position (_line _start) startCharacter
784-
beforeLine = Range startOfLine startOfLine
785-
title = if isQuickFix then "add signature: " <> signature else signature
786-
action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
787-
in [(title, [action])]
788-
where removeInitialForAll :: T.Text -> T.Text
789-
removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
790-
| "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
791-
| otherwise = nm <> ty
792-
startCharacter
793-
| "Polymorphic local binding" `T.isPrefixOf` _message
794-
= _character _start
795-
| otherwise
796-
= 0
797-
798-
suggestSignature _ _ = []
799-
800720
-- | Suggests a constraint for a declaration for which a constraint is missing.
801721
suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
802722
suggestConstraint df parsedModule diag@Diagnostic {..}
@@ -1190,10 +1110,6 @@ matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
11901110
matchRegex message regex = case message =~~ regex of
11911111
Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
11921112
Nothing -> Nothing
1193-
1194-
filterNewlines :: T.Text -> T.Text
1195-
filterNewlines = T.concat . T.lines
1196-
11971113
unifySpaces :: T.Text -> T.Text
11981114
unifySpaces = T.unwords . T.words
11991115

‎ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs

Lines changed: 1 addition & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -6,8 +6,6 @@ module Development.IDE.Plugin.HLS.GhcIde
66
(
77
descriptor
88
) where
9-
10-
import Data.Aeson
119
import Development.IDE
1210
import Development.IDE.Plugin.Completions as Completions
1311
import Development.IDE.Plugin.CodeAction as CodeAction
@@ -22,9 +20,7 @@ import Text.Regex.TDFA.Text()
2220

2321
descriptor :: PluginId -> PluginDescriptor IdeState
2422
descriptor plId = (defaultPluginDescriptor plId)
25-
{ pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature]
26-
, pluginCodeActionProvider = Just codeAction'
27-
, pluginCodeLensProvider = Just codeLens'
23+
{ pluginCodeActionProvider = Just codeAction'
2824
, pluginHoverProvider = Just hover'
2925
, pluginSymbolsProvider = Just symbolsProvider
3026
, pluginCompletionProvider = Just getCompletionsLSP
@@ -38,24 +34,10 @@ hover' ideState params = do
3834
logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ
3935
hover ideState params
4036

41-
-- ---------------------------------------------------------------------
42-
43-
commandAddSignature :: CommandFunction IdeState WorkspaceEdit
44-
commandAddSignature lf ide params
45-
= commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing)
46-
47-
-- ---------------------------------------------------------------------
48-
4937
codeAction' :: CodeActionProvider IdeState
5038
codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context
5139

5240
-- ---------------------------------------------------------------------
53-
54-
codeLens' :: CodeLensProvider IdeState
55-
codeLens' lf ide _ params = codeLens lf ide params
56-
57-
-- ---------------------------------------------------------------------
58-
5941
symbolsProvider :: SymbolsProvider IdeState
6042
symbolsProvider ls ide params = do
6143
ds <- moduleOutline ls ide params

‎ghcide/src/Development/IDE/Plugin/TypeLenses.hs

Lines changed: 115 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,115 @@
1+
-- | An HLS plugin to provide code lenses for type signatures
2+
module Development.IDE.Plugin.TypeLenses
3+
( descriptor,
4+
suggestSignature,
5+
typeLensCommandId,
6+
)
7+
where
8+
9+
import Data.Aeson.Types (Value (..), toJSON)
10+
import qualified Data.HashMap.Strict as Map
11+
import qualified Data.Text as T
12+
import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck))
13+
import Development.IDE.Core.Rules (IdeState, runAction)
14+
import Development.IDE.Core.Service (getDiagnostics)
15+
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
16+
import Development.IDE.Types.Location
17+
( Position (Position, _character, _line),
18+
Range (Range, _end, _start),
19+
toNormalizedFilePath',
20+
uriToFilePath',
21+
)
22+
import Ide.PluginUtils (mkLspCommand)
23+
import Ide.Types
24+
( CommandFunction,
25+
CommandId (CommandId),
26+
PluginCommand (PluginCommand),
27+
PluginDescriptor (pluginCodeLensProvider, pluginCommands),
28+
PluginId,
29+
defaultPluginDescriptor,
30+
)
31+
import qualified Language.Haskell.LSP.Core as LSP
32+
import Language.Haskell.LSP.Types
33+
( ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
34+
CodeLens (CodeLens),
35+
CodeLensParams (CodeLensParams, _textDocument),
36+
Diagnostic (..),
37+
List (..),
38+
ResponseError,
39+
ServerMethod (WorkspaceApplyEdit),
40+
TextDocumentIdentifier (TextDocumentIdentifier),
41+
TextEdit (TextEdit),
42+
WorkspaceEdit (WorkspaceEdit),
43+
)
44+
import Text.Regex.TDFA ((=~))
45+
46+
typeLensCommandId :: T.Text
47+
typeLensCommandId = "typesignature.add"
48+
49+
descriptor :: PluginId -> PluginDescriptor IdeState
50+
descriptor plId =
51+
(defaultPluginDescriptor plId)
52+
{ pluginCodeLensProvider = Just codeLensProvider,
53+
pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
54+
}
55+
56+
codeLensProvider ::
57+
LSP.LspFuncs c ->
58+
IdeState ->
59+
PluginId ->
60+
CodeLensParams ->
61+
IO (Either ResponseError (List CodeLens))
62+
codeLensProvider _lsp ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do
63+
fmap (Right . List) $ case uriToFilePath' uri of
64+
Just (toNormalizedFilePath' -> filePath) -> do
65+
_ <- runAction "codeLens" ideState (use TypeCheck filePath)
66+
diag <- getDiagnostics ideState
67+
hDiag <- getHiddenDiagnostics ideState
68+
sequence
69+
[ generateLens pId _range title edit
70+
| (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag,
71+
dFile == filePath,
72+
(title, tedit) <- suggestSignature False dDiag,
73+
let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
74+
]
75+
Nothing -> pure []
76+
77+
generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens
78+
generateLens pId _range title edit = do
79+
cId <- mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])
80+
return $ CodeLens _range (Just cId) Nothing
81+
82+
commandHandler :: CommandFunction IdeState WorkspaceEdit
83+
commandHandler _lsp _ideState wedit =
84+
return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
85+
86+
suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
87+
suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..}
88+
| _message
89+
=~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) =
90+
let signature =
91+
removeInitialForAll $
92+
T.takeWhile (\x -> x /= '*' && x /= '•') $
93+
T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
94+
startOfLine = Position (_line _start) startCharacter
95+
beforeLine = Range startOfLine startOfLine
96+
title = if isQuickFix then "add signature: " <> signature else signature
97+
action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
98+
in [(title, [action])]
99+
where
100+
removeInitialForAll :: T.Text -> T.Text
101+
removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
102+
| "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
103+
| otherwise = nm <> ty
104+
startCharacter
105+
| "Polymorphic local binding" `T.isPrefixOf` _message =
106+
_character _start
107+
| otherwise =
108+
0
109+
suggestSignature _ _ = []
110+
111+
unifySpaces :: T.Text -> T.Text
112+
unifySpaces = T.unwords . T.words
113+
114+
filterNewlines :: T.Text -> T.Text
115+
filterNewlines = T.concat . T.lines

‎ghcide/test/exe/Main.hs

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import Development.IDE.Core.Shake (Q(..))
2828
import Development.IDE.GHC.Util
2929
import qualified Data.Text as T
3030
import Data.Typeable
31+
import Development.IDE.Plugin.TypeLenses (typeLensCommandId)
3132
import Development.IDE.Spans.Common
3233
import Development.IDE.Test
3334
import Development.IDE.Test.Runfiles
@@ -59,8 +60,8 @@ import Test.Tasty.Ingredients.Rerun
5960
import Test.Tasty.HUnit
6061
import Test.Tasty.QuickCheck
6162
import System.Time.Extra
62-
import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId, matchRegExMultipleImports)
6363
import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(BlockSeconds,GetInterfaceFilesDir))
64+
import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports)
6465
import Control.Monad.Extra (whenJust)
6566
import qualified Language.Haskell.LSP.Types.Lens as L
6667
import Control.Lens ((^.))
@@ -141,7 +142,7 @@ initializeResponseTests = withResource acquire release tests where
141142
, chk "NO doc link" _documentLinkProvider Nothing
142143
, chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
143144
, chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
144-
, che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeSignatureCommandId, blockCommandId])
145+
, che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeLensCommandId, blockCommandId])
145146
, chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
146147
, chk "NO experimental" _experimental Nothing
147148
] where
@@ -1171,7 +1172,7 @@ extendImportTests = testGroup "extend import actions"
11711172
, "import ModuleA (A (Constructor))"
11721173
, "b :: A"
11731174
, "b = Constructor"
1174-
])
1175+
])
11751176
, testSession "extend single line import with constructor (with comments)" $ template
11761177
[("ModuleA.hs", T.unlines
11771178
[ "module ModuleA where"

0 commit comments

Comments
 (0)