Code lens for missing signatures

ghcide.cabal

@@ -48,6 +48,7 @@ library
         prettyprinter-ansi-terminal,
         prettyprinter-ansi-terminal,
         prettyprinter,
+        random,
         rope-utf16-splay,
         safe-exceptions,
         shake >= 0.17.5,

src/Development/IDE/LSP/CodeAction.hs

@@ -8,18 +8,22 @@
 -- | Go to the definition of a variable.
 module Development.IDE.LSP.CodeAction
     ( setHandlersCodeAction
+    , setHandlersCodeLens
     ) where
 
 import           Language.Haskell.LSP.Types
 import Development.IDE.GHC.Compat
 import Development.IDE.Core.Rules
+import Development.IDE.Core.Shake
 import Development.IDE.LSP.Server
+import Development.IDE.Types.Location
 import qualified Data.HashMap.Strict as Map
 import qualified Data.HashSet as Set
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.VFS
 import Language.Haskell.LSP.Messages
 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
@@ -42,9 +46,41 @@ codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_cont
         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
         ]
 
+-- | Generate code lenses.
+codeLens
+    :: LSP.LspFuncs ()
+    -> IdeState
+    -> CodeLensParams
+    -> IO (List CodeLens)
+codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
+    diag <- getDiagnostics ideState
+    case uriToFilePath' uri of
+      Just (toNormalizedFilePath -> filePath) -> do
+        pure $ List
+          [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
+          | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag
+          , dFile == filePath
+          , (title, tedit) <- suggestTopLevelBinding dDiag
+          , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
+          ]
+      Nothing -> pure $ List []
+
+-- | Generate code lenses.
+executeAddSignatureCommand
+    :: LSP.LspFuncs ()
+    -> IdeState
+    -> ExecuteCommandParams
+    -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
+executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
+    | _command == "typesignature.add"
+    , Just (List [edit]) <- _arguments
+    , Success wedit <- fromJSON edit 
+    = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
+    | otherwise
+    = return (Null, Nothing)
 
 suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestAction contents Diagnostic{_range=_range@Range{..},..}
+suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}
 
 -- File.hs:16:1: warning:
 --     The import of `Data.List' is redundant
@@ -141,6 +177,12 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..}
       extractFitNames     = map (T.strip . head . T.splitOn " :: ")
       in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
 
+    | tlb@[_] <- suggestTopLevelBinding diag = tlb
+
+suggestAction _ _ = []
+
+suggestTopLevelBinding :: Diagnostic -> [(T.Text, [TextEdit])]
+suggestTopLevelBinding Diagnostic{_range=_range@Range{..},..}
     | "Top-level binding with no type signature" `T.isInfixOf` _message = let
       filterNewlines = T.concat  . T.lines
       unifySpaces    = T.unwords . T.words
@@ -150,8 +192,7 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..}
       title          = "add signature: " <> signature
       action         = TextEdit beforeLine $ signature <> "\n"
       in [(title, [action])]
-
-suggestAction _ _ = []
+suggestTopLevelBinding _ = []
 
 topOfHoleFitsMarker :: T.Text
 topOfHoleFitsMarker =
@@ -236,3 +277,9 @@ setHandlersCodeAction :: PartialHandlers
 setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.codeActionHandler = withResponse RspCodeAction codeAction
     }
+
+setHandlersCodeLens :: PartialHandlers
+setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
+    LSP.codeLensHandler = withResponse RspCodeLens codeLens,
+    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
+    }

src/Development/IDE/LSP/LanguageServer.hs

@@ -25,6 +25,7 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 import           GHC.IO.Handle                    (hDuplicate, hDuplicateTo)
 import System.IO
+import System.Random
 import Control.Monad.Extra
 
 import Development.IDE.LSP.Definition
@@ -76,6 +77,9 @@ runLanguageServer options userHandlers getIdeState = do
             atomically $ modifyTVar pendingRequests (Set.insert _id)
             writeChan clientMsgChan $ Response r wrap f
     let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))
+    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
+            atomically $ modifyTVar pendingRequests (Set.insert _id)
+            writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
     let cancelRequest reqId = atomically $ do
             queued <- readTVar pendingRequests
             -- We want to avoid that the list of cancelled requests
@@ -93,13 +97,14 @@ runLanguageServer options userHandlers getIdeState = do
             unless (reqId `Set.member` cancelled) retry
     let PartialHandlers parts =
             setHandlersIgnore <> -- least important
-            setHandlersDefinition <> setHandlersHover <> setHandlersCodeAction <> -- useful features someone may override
+            setHandlersDefinition <> setHandlersHover <>
+            setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
             userHandlers <>
             setHandlersNotifications <> -- absolutely critical, join them with user notifications
             cancelHandler cancelRequest
             -- Cancel requests are special since they need to be handled
             -- out of order to be useful. Existing handlers are run afterwards.
-    handlers <- parts WithMessage{withResponse, withNotification} def
+    handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
 
     let initializeCallbacks = LSP.InitializeCallbacks
             { LSP.onInitialConfiguration = const $ Right ()
@@ -153,6 +158,34 @@ runLanguageServer options userHandlers getIdeState = do
                                 "Exception: " ++ show e
                             sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
                                 Just $ ResponseError InternalError (T.pack $ show e) Nothing
+                    ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
+                        flip finally (clearReqId _id) $
+                        catch (do
+                            -- We could optimize this by first checking if the id
+                            -- is in the cancelled set. However, this is unlikely to be a
+                            -- bottleneck and the additional check might hide
+                            -- issues with async exceptions that need to be fixed.
+                            cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params
+                            case cancelOrRes of
+                                Left () -> do
+                                    logDebug (ideLogger ide) $ T.pack $
+                                        "Cancelled request " <> show _id
+                                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
+                                        Just $ ResponseError RequestCancelled "" Nothing
+                                Right (res, newReq) -> do
+                                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
+                                    case newReq of
+                                        Nothing -> return ()
+                                        Just (rm, newReqParams) -> do
+                                            reqId <- IdInt <$> randomIO
+                                            sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
+                        ) $ \(e :: SomeException) -> do
+                            logError (ideLogger ide) $ T.pack $
+                                "Unexpected exception on request, please report!\n" ++
+                                "Message: " ++ show x ++ "\n" ++
+                                "Exception: " ++ show e
+                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
+                                Just $ ResponseError InternalError (T.pack $ show e) Nothing
             pure Nothing
 
 
@@ -177,11 +210,13 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
 --   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
 data Message
     = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
+    | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
     | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
 
 
 modifyOptions :: LSP.Options -> LSP.Options
 modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS
+                   , LSP.executeCommandCommands = Just ["typesignature.add"]
                    }
     where
         tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

src/Development/IDE/LSP/Server.hs

@@ -26,6 +26,12 @@ data WithMessage = WithMessage
         Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
         (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work
         Maybe (LSP.Handler (NotificationMessage m req))
+    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody. 
+        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
+        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
+        (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
+        (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
+        Maybe (LSP.Handler (RequestMessage m req resp))
     }
 
 newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)

test/exe/Main.hs

@@ -66,7 +66,7 @@ initializeResponseTests = withResource acquire release tests where
     , chk "NO doc symbol"           _documentSymbolProvider  Nothing
     , chk "NO workspace symbol"    _workspaceSymbolProvider  Nothing
     , chk "   code action"             _codeActionProvider $ Just $ CodeActionOptionsStatic True
-    , chk "NO code lens"                  _codeLensProvider  Nothing
+    , chk "   code lens"                 _codeLensProvider $ Just $ CodeLensOptions Nothing
     , chk "NO doc formatting"   _documentFormattingProvider  Nothing
     , chk "NO doc range formatting"
                            _documentRangeFormattingProvider  Nothing
@@ -76,7 +76,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)
-    , chk "NO execute command"      _executeCommandProvider  Nothing
+    , chk "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
     , chk "NO workspace"                         _workspace  nothingWorkspace
     , chk "NO experimental"                   _experimental  Nothing
     ] where