Skip to content
This repository has been archived by the owner on Jan 2, 2021. It is now read-only.

Commit

Permalink
Code lens for missing signatures (#224)
Browse files Browse the repository at this point in the history 
* Code lens for missing signatures

* Fix tests

* Implement suggestions by @cocreature
  • Loading branch information
@serras @cocreature
serras authored and cocreature committed Dec 9, 2019
1 parent 5091a1d commit 7f3b0f6
Show file tree
Hide file tree
Showing 4 changed files with 104 additions and 30 deletions.
55 changes: 51 additions & 4 deletions src/Development/IDE/LSP/CodeAction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 False 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
Expand Down Expand Up @@ -141,17 +177,22 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..}
extractFitNames = map (T.strip . head . T.splitOn " :: ")
in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message

| tlb@[_] <- suggestTopLevelBinding True diag = tlb

suggestAction _ _ = []

suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
suggestTopLevelBinding isQuickFix 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
signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
startOfLine = Position (_line _start) 0
beforeLine = Range startOfLine startOfLine
title = "add signature: " <> signature
title = if isQuickFix then "add signature: " <> signature else signature
action = TextEdit beforeLine $ signature <> "\n"
in [(title, [action])]

suggestAction _ _ = []
suggestTopLevelBinding _ _ = []

topOfHoleFitsMarker :: T.Text
topOfHoleFitsMarker =
Expand Down Expand Up @@ -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
}
69 changes: 45 additions & 24 deletions src/Development/IDE/LSP/LanguageServer.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -76,6 +76,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
Expand All @@ -93,13 +96,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 ()
Expand Down Expand Up @@ -131,30 +135,42 @@ runLanguageServer options userHandlers getIdeState = do
"Message: " ++ show x ++ "\n" ++
"Exception: " ++ show e
Response x@RequestMessage{_id, _params} wrap 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 ->
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
) $ \(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
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
\res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
\(res, newReq) -> do
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
case newReq of
Nothing -> return ()
Just (rm, newReqParams) -> do
reqId <- getNextReqId
sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
pure Nothing

checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
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 -> k res
) $ \(e :: SomeException) -> do
logError (ideLogger ide) $ T.pack $
"Unexpected exception on request, please report!\n" ++
"Message: " ++ show msg ++ "\n" ++
"Exception: " ++ show e
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
Just $ ResponseError InternalError (T.pack $ show e) Nothing


-- | Things that get sent to us, but we don't deal with.
-- Set them to avoid a warning in VS Code output.
Expand All @@ -177,11 +193,16 @@ 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)
-- | Used for cases in which we need to send not only a response,
-- but also an additional request to the client.
-- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
| 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}
Expand Down
6 changes: 6 additions & 0 deletions src/Development/IDE/LSP/Server.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
4 changes: 2 additions & 2 deletions test/exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down

0 comments on commit 7f3b0f6

Please sign in to comment.