diff --git a/src/Development/IDE/LSP/CodeAction.hs b/src/Development/IDE/LSP/CodeAction.hs index 9f4bef13..808ea4d1 100644 --- a/src/Development/IDE/LSP/CodeAction.hs +++ b/src/Development/IDE/LSP/CodeAction.hs @@ -10,40 +10,88 @@ module Development.IDE.LSP.CodeAction ) where import Language.Haskell.LSP.Types - +import GHC.LanguageExtensions.Type import Development.IDE.Core.Rules import Development.IDE.LSP.Server import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.Types as LSP +import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Messages - +import qualified Data.Rope.UTF16 as Rope +import Data.Char import qualified Data.Text as T -- | Generate code actions. codeAction - :: IdeState + :: LSP.LspFuncs () + -> IdeState -> CodeActionParams -> IO (List CAResult) -codeAction _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do +codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do -- disable logging as its quite verbose -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg + contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri + let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents pure $ List [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing - | x <- xs, (title, edit) <- suggestAction uri x] + | x <- xs, (title, tedit) <- suggestAction text x + , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + ] -suggestAction :: Uri -> Diagnostic -> [(T.Text, LSP.WorkspaceEdit)] -suggestAction uri Diagnostic{..} +suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestAction contents Diagnostic{_range=_range@Range{..},..} + -- File.hs:16:1: warning: -- The import of `Data.List' is redundant -- except perhaps to import instances from `Data.List' -- To import instances alone, use: import Data.List() | "The import of " `T.isInfixOf` _message , " is redundant" `T.isInfixOf` _message - = [("Remove import", WorkspaceEdit (Just $ Map.singleton uri $ List [TextEdit _range ""]) Nothing)] + , let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . textAtPosition _end) contents + , let extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line + = [("Remove import", [TextEdit (if extend then Range _start (Position (_line _end + 1) 0) else _range) ""])] + +-- File.hs:22:8: error: +-- Illegal lambda-case (use -XLambdaCase) +-- File.hs:22:6: error: +-- Illegal view pattern: x -> foo +-- Use ViewPatterns to enable view patterns +-- File.hs:26:8: error: +-- Illegal `..' in record pattern +-- Use RecordWildCards to permit this +-- File.hs:53:28: error: +-- Illegal tuple section: use TupleSections +-- File.hs:238:29: error: +-- * Can't make a derived instance of `Data FSATrace': +-- You need DeriveDataTypeable to derive an instance for this class +-- * In the data declaration for `FSATrace' +-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error: +-- * Illegal equational constraint a ~ () +-- (Use GADTs or TypeFamilies to permit this) +-- * In the context: a ~ () +-- While checking an instance declaration +-- In the instance declaration for `Unit (m a)' + | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message + = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts] + suggestAction _ _ = [] + +-- | All the GHC extensions +ghcExtensions :: Set.HashSet T.Text +ghcExtensions = Set.fromList $ map (T.pack . show) [Cpp .. StarIsType] -- use enumerate from GHC 8.8 and beyond + + +textAtPosition :: Position -> T.Text -> (T.Text, T.Text) +textAtPosition (Position row col) x + | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x + , (preCol, postCol) <- T.splitAt col mid + = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) + | otherwise = (x, T.empty) + + setHandlersCodeAction :: PartialHandlers setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.codeActionHandler = withResponse RspCodeAction codeAction diff --git a/src/Development/IDE/LSP/Definition.hs b/src/Development/IDE/LSP/Definition.hs index 5996241d..7b40fcdd 100644 --- a/src/Development/IDE/LSP/Definition.hs +++ b/src/Development/IDE/LSP/Definition.hs @@ -40,5 +40,5 @@ gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) setHandlersDefinition :: PartialHandlers setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.definitionHandler = withResponse RspDefinition gotoDefinition + LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition } diff --git a/src/Development/IDE/LSP/Hover.hs b/src/Development/IDE/LSP/Hover.hs index d2f323be..504f1b08 100644 --- a/src/Development/IDE/LSP/Hover.hs +++ b/src/Development/IDE/LSP/Hover.hs @@ -44,5 +44,5 @@ onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do setHandlersHover :: PartialHandlers setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.hoverHandler = withResponse RspHover onHover + LSP.hoverHandler = withResponse RspHover $ const onHover } diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs index 72bc3000..540b49cb 100644 --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -66,7 +66,7 @@ runLanguageServer options userHandlers getIdeState = do clientMsgBarrier <- newBarrier let withResponse wrap f = Just $ \r -> writeChan clientMsgChan $ Response r wrap f - let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\ide x -> f ide x >> whenJust old ($ r)) + let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r)) let PartialHandlers parts = setHandlersIgnore <> -- least important setHandlersDefinition <> setHandlersHover <> setHandlersCodeAction <> -- useful features someone may override @@ -94,14 +94,14 @@ runLanguageServer options userHandlers getIdeState = do msg <- readChan clientMsgChan case msg of Notification x@NotificationMessage{_params} act -> do - catch (act ide _params) $ \(e :: SomeException) -> + catch (act lspFuncs ide _params) $ \(e :: SomeException) -> logError (ideLogger ide) $ T.pack $ "Unexpected exception on notification, please report!\n" ++ "Message: " ++ show x ++ "\n" ++ "Exception: " ++ show e Response x@RequestMessage{_id, _params} wrap act -> catch (do - res <- act ide _params + res <- act lspFuncs ide _params sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing ) $ \(e :: SomeException) -> do logError (ideLogger ide) $ T.pack $ @@ -126,8 +126,8 @@ setHandlersIgnore = PartialHandlers $ \_ x -> return x -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety -- 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) (IdeState -> req -> IO resp) - | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (IdeState -> req -> IO ()) + = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp) + | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ()) modifyOptions :: LSP.Options -> LSP.Options diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs index aebd6bc6..66c07862 100644 --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -32,24 +32,24 @@ whenUriFile ide uri act = case LSP.uriToFilePath uri of setHandlersNotifications :: PartialHandlers setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $ - \ide (DidOpenTextDocumentParams TextDocumentItem{_uri}) -> do + \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri}) -> do setSomethingModified ide whenUriFile ide _uri $ \file -> modifyFilesOfInterest ide (S.insert file) logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $ - \ide (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> do + \_ ide (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> do setSomethingModified ide logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $ - \ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do + \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do setSomethingModified ide logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $ - \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do + \_ ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do setSomethingModified ide whenUriFile ide _uri $ \file -> modifyFilesOfInterest ide (S.delete file) diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs index 4b7fe22f..b7362d1a 100644 --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -20,11 +20,11 @@ import Development.IDE.Core.Service data WithMessage = WithMessage {withResponse :: forall m req resp . (Show m, Show req) => (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response - (IdeState -> req -> IO resp) -> -- actual work + (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work Maybe (LSP.Handler (RequestMessage m req resp)) ,withNotification :: forall m req . (Show m, Show req) => Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler - (IdeState -> req -> IO ()) -> -- actual work + (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work Maybe (LSP.Handler (NotificationMessage m req)) }