Extract type signature code lenses to an HLS plugin

This was worth doing to clean up the messy command handlers

exe/Plugins.hs

@@ -10,6 +10,7 @@ import           Ide.Plugin.Example        as Example
 import           Ide.Plugin.Example2       as Example2
 import           Development.IDE           (IdeState)
 import           Development.IDE.Plugin.HLS.GhcIde as GhcIde
+import           Development.IDE.Plugin.TypeLenses as TypeLenses
 
 -- haskell-language-server optional plugins
 
@@ -90,6 +91,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
                    else basePlugins
     basePlugins =
       [ GhcIde.descriptor  "ghcide"
+      , TypeLenses.descriptor "type-lenses"
 #if pragmas
       , Pragmas.descriptor  "pragmas"
 #endif

ghcide/exe/Main.hs

@@ -28,6 +28,7 @@ import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Options
 import Development.IDE.Types.Logger
 import Development.IDE.Plugin
+import Development.IDE.Plugin.TypeLenses as TypeLenses
 import Development.IDE.Plugin.Test as Test
 import Development.IDE.Session (loadSession)
 import Development.Shake (ShakeOptions (shakeThreads))
@@ -87,7 +88,9 @@ main = do
 
     dir <- IO.getCurrentDirectory
 
-    let hlsPlugins = pluginDescToIdePlugins [GhcIde.descriptor "ghcide"]
+    let hlsPlugins = pluginDescToIdePlugins
+            [ GhcIde.descriptor "ghcide"
+            , TypeLenses.descriptor "type-lenses" ]
 
     pid <- T.pack . show <$> getProcessID
     let hlsPlugin = asGhcIdePlugin hlsPlugins

ghcide/ghcide.cabal

@@ -173,6 +173,7 @@ library
         Development.IDE.Plugin.HLS
         Development.IDE.Plugin.HLS.GhcIde
         Development.IDE.Plugin.Test
+        Development.IDE.Plugin.TypeLenses
 
     -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
     -- the real GHC library and the types are incompatible. Furthermore, when

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

@@ -10,13 +10,10 @@ module Development.IDE.Plugin.CodeAction
     (
     -- * For haskell-language-server
       codeAction
-    , codeLens
     , rulePackageExports
-    , commandHandler
 
     -- * For testing
     , blockCommandId
-    , typeSignatureCommandId
     , matchRegExMultipleImports
     ) where
 
@@ -28,21 +25,19 @@ import Development.IDE.Core.Service
 import Development.IDE.Core.Shake
 import Development.IDE.GHC.Error
 import Development.IDE.GHC.ExactPrint
-import Development.IDE.LSP.Server
 import Development.IDE.Plugin.CodeAction.ExactPrint
 import Development.IDE.Plugin.CodeAction.PositionIndexed
 import Development.IDE.Plugin.CodeAction.RuleTypes
 import Development.IDE.Plugin.CodeAction.Rules
+import Development.IDE.Plugin.TypeLenses (suggestSignature)
 import Development.IDE.Types.Exports
 import Development.IDE.Types.Location
 import Development.IDE.Types.Options
 import qualified Data.HashMap.Strict as Map
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.VFS
-import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
 import qualified Data.Rope.UTF16 as Rope
-import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
 import Data.Char
 import Data.Maybe
 import Data.List.Extra
@@ -58,17 +53,13 @@ import Control.Applicative ((<|>))
 import Safe (atMay)
 import Bag (isEmptyBag)
 import qualified Data.HashSet as Set
-import Control.Concurrent.Extra (threadDelay, readVar)
+import Control.Concurrent.Extra (readVar)
 import Development.IDE.GHC.Util (printRdrName)
 import Ide.PluginUtils (subRange)
 
 -- | a command that blocks forever. Used for testing
 blockCommandId :: T.Text
 blockCommandId = "ghcide.command.block"
-
-typeSignatureCommandId :: T.Text
-typeSignatureCommandId = "typesignature.add"
-
 -- | Generate code actions.
 codeAction
     :: LSP.LspFuncs c
@@ -117,52 +108,6 @@ mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> CAResult
 mkCA title diags edit =
   CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) (Just edit) Nothing
 
--- | Generate code lenses.
-codeLens
-    :: LSP.LspFuncs c
-    -> IdeState
-    -> CodeLensParams
-    -> IO (Either ResponseError (List CodeLens))
-codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
-    let commandId = "typesignature.add"
-    fmap (Right . List) $ case uriToFilePath' uri of
-      Just (toNormalizedFilePath' -> filePath) -> do
-        _ <- runAction "codeLens" ideState (use TypeCheck filePath)
-        diag <- getDiagnostics ideState
-        hDiag <- getHiddenDiagnostics ideState
-        pure
-          [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
-          | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
-          , dFile == filePath
-          , (title, tedit) <- suggestSignature False dDiag
-          , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
-          ]
-      Nothing -> pure []
-
--- | Execute the "typesignature.add" command.
-commandHandler
-    :: LSP.LspFuncs c
-    -> IdeState
-    -> ExecuteCommandParams
-    -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
-commandHandler lsp _ideState ExecuteCommandParams{..}
-    -- _command is prefixed with a process ID, because certain clients
-    -- have a global command registry, and all commands must be
-    -- unique. And there can be more than one ghcide instance running
-    -- at a time against the same client.
-    | T.isSuffixOf blockCommandId _command
-    = do
-        LSP.sendFunc lsp $ NotCustomServer $
-            NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null
-        threadDelay maxBound
-        return (Right Null, Nothing)
-    | T.isSuffixOf typeSignatureCommandId _command
-    , Just (List [edit]) <- _arguments
-    , Success wedit <- fromJSON edit
-    = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
-    | otherwise
-    = return (Right Null, Nothing)
-
 suggestExactAction ::
   ExportsMap ->
   DynFlags ->
@@ -772,31 +717,6 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}
   = let fixedImport = typ <> "(" <> constructor <> ")"
     in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
   | otherwise = []
-
-suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
-    | _message =~
-      ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let
-      signature      = removeInitialForAll
-                     $ T.takeWhile (\x -> x/='*' && x/='•')
-                     $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
-      startOfLine    = Position (_line _start) startCharacter
-      beforeLine     = Range startOfLine startOfLine
-      title          = if isQuickFix then "add signature: " <> signature else signature
-      action         = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
-      in [(title, [action])]
-    where removeInitialForAll :: T.Text -> T.Text
-          removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
-              | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
-              | otherwise                  = nm <> ty
-          startCharacter
-            | "Polymorphic local binding" `T.isPrefixOf` _message
-            = _character _start
-            | otherwise
-            = 0
-
-suggestSignature _ _ = []
-
 -- | Suggests a constraint for a declaration for which a constraint is missing.
 suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
 suggestConstraint df parsedModule diag@Diagnostic {..}
@@ -1190,10 +1110,6 @@ matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
 matchRegex message regex = case message =~~ regex of
     Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
     Nothing -> Nothing
-
-filterNewlines :: T.Text -> T.Text
-filterNewlines = T.concat  . T.lines
-
 unifySpaces :: T.Text -> T.Text
 unifySpaces    = T.unwords . T.words
 

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

@@ -6,8 +6,6 @@ module Development.IDE.Plugin.HLS.GhcIde
   (
     descriptor
   ) where
-
-import Data.Aeson
 import Development.IDE
 import Development.IDE.Plugin.Completions as Completions
 import Development.IDE.Plugin.CodeAction as CodeAction
@@ -22,9 +20,7 @@ import Text.Regex.TDFA.Text()
 
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId = (defaultPluginDescriptor plId)
-  { pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature]
-  , pluginCodeActionProvider = Just codeAction'
-  , pluginCodeLensProvider   = Just codeLens'
+  { pluginCodeActionProvider = Just codeAction'
   , pluginHoverProvider      = Just hover'
   , pluginSymbolsProvider    = Just symbolsProvider
   , pluginCompletionProvider = Just getCompletionsLSP
@@ -38,24 +34,10 @@ hover' ideState params = do
     logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ
     hover ideState params
 
--- ---------------------------------------------------------------------
-
-commandAddSignature :: CommandFunction IdeState WorkspaceEdit
-commandAddSignature lf ide params
-    = commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing)
-
--- ---------------------------------------------------------------------
-
 codeAction' :: CodeActionProvider IdeState
 codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context
 
 -- ---------------------------------------------------------------------
-
-codeLens' :: CodeLensProvider IdeState
-codeLens' lf ide _ params = codeLens lf ide params
-
--- ---------------------------------------------------------------------
-
 symbolsProvider :: SymbolsProvider IdeState
 symbolsProvider ls ide params = do
     ds <- moduleOutline ls ide params

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

@@ -0,0 +1,115 @@
+-- | An HLS plugin to provide code lenses for type signatures
+module Development.IDE.Plugin.TypeLenses
+  ( descriptor,
+    suggestSignature,
+    typeLensCommandId,
+  )
+where
+
+import Data.Aeson.Types (Value (..), toJSON)
+import qualified Data.HashMap.Strict as Map
+import qualified Data.Text as T
+import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck))
+import Development.IDE.Core.Rules (IdeState, runAction)
+import Development.IDE.Core.Service (getDiagnostics)
+import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
+import Development.IDE.Types.Location
+  ( Position (Position, _character, _line),
+    Range (Range, _end, _start),
+    toNormalizedFilePath',
+    uriToFilePath',
+  )
+import Ide.PluginUtils (mkLspCommand)
+import Ide.Types
+  ( CommandFunction,
+    CommandId (CommandId),
+    PluginCommand (PluginCommand),
+    PluginDescriptor (pluginCodeLensProvider, pluginCommands),
+    PluginId,
+    defaultPluginDescriptor,
+  )
+import qualified Language.Haskell.LSP.Core as LSP
+import Language.Haskell.LSP.Types
+  ( ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
+    CodeLens (CodeLens),
+    CodeLensParams (CodeLensParams, _textDocument),
+    Diagnostic (..),
+    List (..),
+    ResponseError,
+    ServerMethod (WorkspaceApplyEdit),
+    TextDocumentIdentifier (TextDocumentIdentifier),
+    TextEdit (TextEdit),
+    WorkspaceEdit (WorkspaceEdit),
+  )
+import Text.Regex.TDFA ((=~))
+
+typeLensCommandId :: T.Text
+typeLensCommandId = "typesignature.add"
+
+descriptor :: PluginId -> PluginDescriptor IdeState
+descriptor plId =
+  (defaultPluginDescriptor plId)
+    { pluginCodeLensProvider = Just codeLensProvider,
+      pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
+    }
+
+codeLensProvider ::
+  LSP.LspFuncs c ->
+  IdeState ->
+  PluginId ->
+  CodeLensParams ->
+  IO (Either ResponseError (List CodeLens))
+codeLensProvider _lsp ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do
+  fmap (Right . List) $ case uriToFilePath' uri of
+    Just (toNormalizedFilePath' -> filePath) -> do
+      _ <- runAction "codeLens" ideState (use TypeCheck filePath)
+      diag <- getDiagnostics ideState
+      hDiag <- getHiddenDiagnostics ideState
+      sequence
+        [ generateLens pId _range title edit
+          | (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag,
+            dFile == filePath,
+            (title, tedit) <- suggestSignature False dDiag,
+            let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
+        ]
+    Nothing -> pure []
+
+generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens
+generateLens pId _range title edit = do
+  cId <- mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])
+  return $ CodeLens _range (Just cId) Nothing
+
+commandHandler :: CommandFunction IdeState WorkspaceEdit
+commandHandler _lsp _ideState wedit =
+    return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
+
+suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..}
+  | _message
+      =~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) =
+    let signature =
+          removeInitialForAll $
+            T.takeWhile (\x -> x /= '*' && x /= '•') $
+              T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
+        startOfLine = Position (_line _start) startCharacter
+        beforeLine = Range startOfLine startOfLine
+        title = if isQuickFix then "add signature: " <> signature else signature
+        action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
+     in [(title, [action])]
+  where
+    removeInitialForAll :: T.Text -> T.Text
+    removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
+      | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
+      | otherwise = nm <> ty
+    startCharacter
+      | "Polymorphic local binding" `T.isPrefixOf` _message =
+        _character _start
+      | otherwise =
+        0
+suggestSignature _ _ = []
+
+unifySpaces :: T.Text -> T.Text
+unifySpaces = T.unwords . T.words
+
+filterNewlines :: T.Text -> T.Text
+filterNewlines = T.concat . T.lines

ghcide/test/exe/Main.hs

@@ -28,6 +28,7 @@ import Development.IDE.Core.Shake (Q(..))
 import Development.IDE.GHC.Util
 import qualified Data.Text as T
 import Data.Typeable
+import Development.IDE.Plugin.TypeLenses (typeLensCommandId)
 import Development.IDE.Spans.Common
 import Development.IDE.Test
 import Development.IDE.Test.Runfiles
@@ -59,8 +60,8 @@ import Test.Tasty.Ingredients.Rerun
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 import System.Time.Extra
-import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId, matchRegExMultipleImports)
 import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(BlockSeconds,GetInterfaceFilesDir))
+import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports)
 import Control.Monad.Extra (whenJust)
 import qualified Language.Haskell.LSP.Types.Lens as L
 import Control.Lens ((^.))
@@ -141,7 +142,7 @@ initializeResponseTests = withResource acquire release tests where
     , chk "NO doc link"               _documentLinkProvider  Nothing
     , chk "NO color"                         _colorProvider (Just $ ColorOptionsStatic False)
     , chk "NO folding range"          _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
-    , che "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeSignatureCommandId, blockCommandId])
+    , che "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeLensCommandId, blockCommandId])
     , chk "   workspace"                         _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
     , chk "NO experimental"                   _experimental  Nothing
     ] where
@@ -1171,7 +1172,7 @@ extendImportTests = testGroup "extend import actions"
                     , "import ModuleA (A (Constructor))"
                     , "b :: A"
                     , "b = Constructor"
-                    ])        
+                    ])
         , testSession "extend single line import with constructor (with comments)" $ template
             [("ModuleA.hs", T.unlines
                     [ "module ModuleA where"