diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/hls-plugin-api.cabal b/hls-plugin-api.cabal new file mode 100644 --- /dev/null +++ b/hls-plugin-api.cabal @@ -0,0 +1,53 @@ +cabal-version: 2.2 +name: hls-plugin-api +version: 0.4.0.0 +synopsis: Haskell Language Server API for plugin communication +description: Please see README.md +license: Apache-2.0 +license-file: LICENSE +author: Many,TBD when we release +maintainer: alan.zimm@gmail.com (for now) +copyright: Alan Zimmerman +category: Web +build-type: Simple + +flag pedantic + description: Enable -Werror + default: False + manual: True + +library + exposed-modules: + Ide.Logger + Ide.Plugin + Ide.Plugin.Config + Ide.Plugin.Formatter + Ide.Plugin.GhcIde + Ide.PluginUtils + Ide.Types + + hs-source-dirs: src + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , data-default + , Diff + , ghc + , ghc-boot-th + , ghcide >=0.1 + , haskell-lsp ^>=0.22 + , hslogger + , lens + , process + , regex-tdfa >=1.3.1.0 + , shake >=0.17.5 + , text + , unordered-containers + + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 diff --git a/src/Ide/Logger.hs b/src/Ide/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Logger.hs @@ -0,0 +1,43 @@ +{- | Provides an implementation of the ghcide @Logger@ which uses + @System.Log.Logger@ under the hood. +-} +module Ide.Logger + ( + hlsLogger + , logm + , debugm + , warningm + , errorm + ) where + +import Control.Monad.IO.Class +import qualified Data.Text as T +import qualified Development.IDE.Types.Logger as L +import System.Log.Logger + +-- --------------------------------------------------------------------- + +hlsLogger :: L.Logger +hlsLogger = L.Logger $ \pri txt -> + case pri of + L.Telemetry -> logm (T.unpack txt) + L.Debug -> debugm (T.unpack txt) + L.Info -> logm (T.unpack txt) + L.Warning -> warningm (T.unpack txt) + L.Error -> errorm (T.unpack txt) + +-- --------------------------------------------------------------------- + +logm :: MonadIO m => String -> m () +logm s = liftIO $ infoM "hls" s + +debugm :: MonadIO m => String -> m () +debugm s = liftIO $ debugM "hls" s + +warningm :: MonadIO m => String -> m () +warningm s = liftIO $ warningM "hls" s + +errorm :: MonadIO m => String -> m () +errorm s = liftIO $ errorM "hls" s + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ide.Plugin + ( + asGhcIdePlugin + , pluginDescToIdePlugins + , mkLspCommand + , allLspCmdIds + , allLspCmdIds' + , getPid + , responseError + ) where + +import Control.Exception(SomeException, catch) +import Control.Lens ( (^.) ) +import Control.Monad +import qualified Data.Aeson as J +import qualified Data.Default +import Data.Either +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Development.IDE hiding (pluginRules) +import Development.IDE.LSP.Server +import GHC.Generics +import Ide.Plugin.Config +import Ide.Plugin.Formatter +import Ide.Types +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Capabilities as C +import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) +import qualified Language.Haskell.LSP.VFS as VFS +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +-- | Map a set of plugins to the underlying ghcide engine. Main point is +-- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message +-- category ('Notifaction', 'Request' etc). +asGhcIdePlugin :: IdePlugins -> Plugin Config +asGhcIdePlugin mp = + mkPlugin rulesPlugins (Just . pluginRules) <> + mkPlugin executeCommandPlugins (Just . pluginCommands) <> + mkPlugin codeActionPlugins pluginCodeActionProvider <> + mkPlugin codeLensPlugins pluginCodeLensProvider <> + -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider + mkPlugin hoverPlugins pluginHoverProvider <> + mkPlugin symbolsPlugins pluginSymbolsProvider <> + mkPlugin formatterPlugins pluginFormattingProvider <> + mkPlugin completionsPlugins pluginCompletionProvider <> + mkPlugin renamePlugins pluginRenameProvider + where + justs (p, Just x) = [(p, x)] + justs (_, Nothing) = [] + + ls = Map.toList (ipMap mp) + + mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> Maybe b) -> Plugin Config + mkPlugin maker selector = + case concatMap (\(pid, p) -> justs (pid, selector p)) ls of + -- If there are no plugins that provide a descriptor, use mempty to + -- create the plugin – otherwise we we end up declaring handlers for + -- capabilities that there are no plugins for + [] -> mempty + xs -> maker xs + + +pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins +pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins + +allLspCmdIds' :: T.Text -> IdePlugins -> [T.Text] +allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) + where + justs (p, Just x) = [(p, x)] + justs (_, Nothing) = [] + + ls = Map.toList (ipMap mp) + + mkPlugin maker selector + = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls + +-- --------------------------------------------------------------------- + +rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config +rulesPlugins rs = Plugin rules mempty + where + rules = mconcat $ map snd rs + +codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config +codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) + +codeActionRules :: Rules () +codeActionRules = mempty + +codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config +codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.codeActionHandler + = withResponse RspCodeAction (makeCodeAction cas) + } + +makeCodeAction :: [(PluginId, CodeActionProvider)] + -> LSP.LspFuncs Config -> IdeState + -> CodeActionParams + -> IO (Either ResponseError (List CAResult)) +makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do + let caps = LSP.clientCapabilities lf + unL (List ls) = ls + r <- mapM (\(pid,provider) -> provider lf ideState pid docId range context) cas + let actions = filter wasRequested . concat $ map unL $ rights r + res <- send caps actions + return $ Right res + where + wasRequested :: CAResult -> Bool + wasRequested (CACommand _) = True + wasRequested (CACodeAction ca) + | Nothing <- only context = True + | Just (List allowed) <- only context + , Just caKind <- ca ^. kind = caKind `elem` allowed + | otherwise = False + + wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult) + wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd) + wrapCodeAction caps (CACodeAction action) = do + + let (C.ClientCapabilities _ textDocCaps _ _) = caps + let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport + + case literalSupport of + Nothing -> do + let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] + cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) + return $ Just (CACommand cmd) + Just _ -> return $ Just (CACodeAction action) + + send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult) + send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions + +data FallbackCodeActionParams = + FallbackCodeActionParams + { fallbackWorkspaceEdit :: Maybe WorkspaceEdit + , fallbackCommand :: Maybe Command + } + deriving (Generic, J.ToJSON, J.FromJSON) + +-- ----------------------------------------------------------- + +codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config +codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) + +codeLensRules :: Rules () +codeLensRules = mempty + +codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config +codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.codeLensHandler + = withResponse RspCodeLens (makeCodeLens cas) + } + +makeCodeLens :: [(PluginId, CodeLensProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> CodeLensParams + -> IO (Either ResponseError (List CodeLens)) +makeCodeLens cas lf ideState params = do + logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ + let + makeLens (pid, provider) = do + r <- provider lf ideState pid params + return (pid, r) + breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) + breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) + where + doOneLeft (pid, Left err) = [(pid,err)] + doOneLeft (_, Right _) = [] + + doOneRight (pid, Right a) = [(pid,a)] + doOneRight (_, Left _) = [] + + r <- mapM makeLens cas + case breakdown r of + ([],[]) -> return $ Right $ List [] + (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing + (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs) + +-- ----------------------------------------------------------- + +executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config +executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) + +executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config +executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ + LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs) + } + +-- type ExecuteCommandProvider = IdeState +-- -> ExecuteCommandParams +-- -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +makeExecuteCommands :: [(PluginId, [PluginCommand])] -> LSP.LspFuncs Config -> ExecuteCommandProvider +makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do + let + pluginMap = Map.fromList ecs + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing + + execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + execCmd (ExecuteCommandParams cmdId args _) = do + -- The parameters to the HIE command are always the first element + let cmdParams :: J.Value + cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> J.Null + + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hls", "fallbackCodeAction") -> + case J.fromJSON cmdParams of + J.Success (FallbackCodeActionParams mEdit mCmd) -> do + + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> do + let eParams = J.ApplyWorkspaceEditParams edit + -- TODO: Use lspfuncs to send an applyedit message. Or change + -- the API to allow a list of messages to be returned. + return (Right J.Null, Just(J.WorkspaceApplyEdit, eParams)) + + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) + -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing) + Nothing -> return (Right J.Null, Nothing) + + J.Error _str -> return (Right J.Null, Nothing) + -- Couldn't parse the fallback command params + -- _ -> liftIO $ + -- LSP.sendErrorResponseS (LSP.sendFunc lf) + -- (J.responseId (req ^. J.id)) + -- J.InvalidParams + -- "Invalid fallbackCodeAction params" + + -- Just an ordinary HIE command + Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams + + -- Couldn't parse the command identifier + _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing) + + execCmd + +{- + ReqExecuteCommand req -> do + liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req + lf <- asks lspFuncs + + let params = req ^. J.params + + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing + + callback obj = do + liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show obj + case fromDynJSON obj :: Maybe J.WorkspaceEdit of + Just v -> do + lid <- nextLspReqId + reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) + let msg = fmServerApplyWorkspaceEditRequest lid $ J.ApplyWorkspaceEditParams v + liftIO $ U.logs $ "ExecuteCommand sending edit: " ++ show msg + reactorSend $ ReqApplyWorkspaceEdit msg + Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req $ dynToJSON obj + + execCmd cmdId args = do + -- The parameters to the HIE command are always the first element + let cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> A.Null + + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hls", "fallbackCodeAction") -> do + case A.fromJSON cmdParams of + A.Success (FallbackCodeActionParams mEdit mCmd) -> do + + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> do + lid <- nextLspReqId + let eParams = J.ApplyWorkspaceEditParams edit + eReq = fmServerApplyWorkspaceEditRequest lid eParams + reactorSend $ ReqApplyWorkspaceEdit eReq + + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) -> execCmd innerCmdId innerArgs + + -- Otherwise we need to send back a response oureslves + Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) + + -- Couldn't parse the fallback command params + _ -> liftIO $ + Core.sendErrorResponseS (Core.sendFunc lf) + (J.responseId (req ^. J.id)) + J.InvalidParams + "Invalid fallbackCodeAction params" + -- Just an ordinary HIE command + Just (plugin, cmd) -> + let preq = GReq tn "plugin" Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit)) + $ runPluginCommand plugin cmd cmdParams + in makeRequest preq + + -- Couldn't parse the command identifier + _ -> liftIO $ + Core.sendErrorResponseS (Core.sendFunc lf) + (J.responseId (req ^. J.id)) + J.InvalidParams + "Invalid command identifier" + + execCmd (params ^. J.command) (params ^. J.arguments) +-} + +-- ----------------------------------------------------------- +wrapUnhandledExceptions :: + (a -> IO (Either ResponseError J.Value, Maybe b)) -> + a -> IO (Either ResponseError J.Value, Maybe b) +wrapUnhandledExceptions action input = + catch (action input) $ \(e::SomeException) -> do + let resp = ResponseError InternalError (T.pack $ show e) Nothing + return (Left resp, Nothing) + + +-- | Runs a plugin command given a PluginId, CommandId and +-- arguments in the form of a JSON object. +runPluginCommand :: Map.Map PluginId [PluginCommand] + -> LSP.LspFuncs Config + -> IdeState + -> PluginId + -> CommandId + -> J.Value + -> IO (Either ResponseError J.Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) +runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg = + case Map.lookup p m of + Nothing -> return + (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing) + Just xs -> case List.find ((com ==) . commandId) xs of + Nothing -> return (Left $ + ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' + <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing) + Just (PluginCommand _ _ f) -> case J.fromJSON arg of + J.Error err -> return (Left $ + ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' + <> ": " <> T.pack err + <> "\narg = " <> T.pack (show arg)) Nothing, Nothing) + J.Success a -> f lf ide a + +-- lsp-request: error while parsing args for typesignature.add in plugin ghcide: +-- When parsing the record ExecuteCommandParams of type +-- Language.Haskell.LSP.Types.DataTypesJSON.ExecuteCommandParams the key command +-- was not present. + +-- ----------------------------------------------------------- + +mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command +mkLspCommand plid cn title args' = do + pid <- getPid + let cmdId = mkLspCmdId pid plid cn + let args = List <$> args' + return $ Command title cmdId args + +mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text +mkLspCmdId pid (PluginId plid) (CommandId cid) + = pid <> ":" <> plid <> ":" <> cid + +allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand])] -> [T.Text] +allLspCmdIds pid commands = concat $ map go commands + where + go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds + +-- --------------------------------------------------------------------- + +hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config +hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) + +hoverRules :: Rules () +hoverRules = mempty + +hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config +hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} + +makeHover :: [(PluginId, HoverProvider)] + -> LSP.LspFuncs Config -> IdeState + -> TextDocumentPositionParams + -> IO (Either ResponseError (Maybe Hover)) +makeHover hps _lf ideState params + = do + mhs <- mapM (\(_,p) -> p ideState params) hps + -- TODO: We should support ServerCapabilities and declare that + -- we don't support hover requests during initialization if we + -- don't have any hover providers + -- TODO: maybe only have provider give MarkedString and + -- work out range here? + let hs = catMaybes (rights mhs) + r = listToMaybe $ mapMaybe (^. range) hs + h = case mconcat ((map (^. contents) hs) :: [HoverContents]) of + HoverContentsMS (List []) -> Nothing + hh -> Just $ Hover hh r + return $ Right h + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config +symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) + +symbolsRules :: Rules () +symbolsRules = mempty + +symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config +symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> + return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} + +makeSymbols :: [(PluginId, SymbolsProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> DocumentSymbolParams + -> IO (Either ResponseError DSResult) +makeSymbols sps lf ideState params + = do + let uri' = params ^. textDocument . uri + (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf + supportsHierarchy = fromMaybe False $ tdc >>= C._documentSymbol + >>= C._hierarchicalDocumentSymbolSupport + convertSymbols :: [DocumentSymbol] -> DSResult + convertSymbols symbs + | supportsHierarchy = DSDocumentSymbols $ List symbs + | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs) + where + go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] + go parent ds = + let children' :: [SymbolInformation] + children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) + loc = Location uri' (ds ^. range) + name' = ds ^. name + si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent + in [si] <> children' + + mhs <- mapM (\(_,p) -> p lf ideState params) sps + case rights mhs of + [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs + hs -> return $ Right $ convertSymbols $ concat hs + + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +renamePlugins :: [(PluginId, RenameProvider)] -> Plugin Config +renamePlugins providers = Plugin rules handlers + where + rules = mempty + handlers = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.renameHandler = withResponse RspRename (renameWith providers)} + +renameWith :: + [(PluginId, RenameProvider)] -> + LSP.LspFuncs Config -> + IdeState -> + RenameParams -> + IO (Either ResponseError WorkspaceEdit) +renameWith providers lspFuncs state params = do + results <- mapM (\(_,p) -> p lspFuncs state params) providers + case partitionEithers results of + (errors, []) -> return $ Left $ responseError $ T.pack $ show $ errors + (_, edits) -> return $ Right $ mconcat edits + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config +formatterPlugins providers + = Plugin formatterRules + (formatterHandlers (Map.fromList (("none",noneProvider):providers))) + +formatterRules :: Rules () +formatterRules = mempty + +formatterHandlers :: Map.Map PluginId (FormattingProvider IO) -> PartialHandlers Config +formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.documentFormattingHandler + = withResponse RspDocumentFormatting (formatting providers) + , LSP.documentRangeFormattingHandler + = withResponse RspDocumentRangeFormatting (rangeFormatting providers) + } + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config +completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) + +completionsRules :: Rules () +completionsRules = mempty + +completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config +completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> + return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} + +makeCompletions :: [(PluginId, CompletionProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> CompletionParams + -> IO (Either ResponseError CompletionResponseResult) +makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) + = do + mprefix <- getPrefixAtPos lf doc pos + _snippets <- WithSnippets <$> completionSnippetsOn <$> (getClientConfig lf) + + let + combine :: [CompletionResponseResult] -> CompletionResponseResult + combine cs = go (Completions $ List []) cs + where + go acc [] = acc + go (Completions (List ls)) (Completions (List ls2):rest) + = go (Completions (List (ls <> ls2))) rest + go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest) + = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest + go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest) + = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest + go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest) + = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest + + case mprefix of + Nothing -> return $ Right $ Completions $ List [] + Just _prefix -> do + mhs <- mapM (\(_,p) -> p lf ideState params) sps + case rights mhs of + [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs + hs -> return $ Right $ combine hs + +{- + ReqCompletion req -> do + liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req + let (_, doc, pos) = reqParams req + + mprefix <- getPrefixAtPos doc pos + + let callback compls = do + let rspMsg = Core.makeResponseMessage req + $ J.Completions $ J.List compls + reactorSend $ RspCompletion rspMsg + case mprefix of + Nothing -> callback [] + Just prefix -> do + snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn + let hreq = IReq tn "completion" (req ^. J.id) callback + $ lift $ Completions.getCompletions doc prefix snippets + makeRequest hreq +-} + +getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo) +getPrefixAtPos lf uri pos = do + mvf <- (LSP.getVirtualFileFunc lf) (J.toNormalizedUri uri) + case mvf of + Just vf -> VFS.getCompletionPrefix pos vf + Nothing -> return Nothing + +-- --------------------------------------------------------------------- +-- | Returns the current client configuration. It is not wise to permanently +-- cache the returned value of this function, as clients can at runitime change +-- their configuration. +-- +-- If no custom configuration has been set by the client, this function returns +-- our own defaults. +getClientConfig :: LSP.LspFuncs Config -> IO Config +getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Config.hs b/src/Ide/Plugin/Config.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Config.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Ide.Plugin.Config + ( + getInitialConfig + , getConfigFromNotification + , Config(..) + ) where + +import Control.Applicative +import qualified Data.Aeson as A +import Data.Aeson hiding ( Error ) +import Data.Default +import qualified Data.Text as T +import Language.Haskell.LSP.Types + +-- --------------------------------------------------------------------- + +-- | Given a DidChangeConfigurationNotification message, this function returns the parsed +-- Config object if possible. +getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config +getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) = + case fromJSON p of + A.Success c -> Right c + A.Error err -> Left $ T.pack err + +-- | Given an InitializeRequest message, this function returns the parsed +-- Config object if possible. Otherwise, it returns the default configuration +getInitialConfig :: InitializeRequest -> Either T.Text Config +getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right def +getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) = + case fromJSON opts of + A.Success c -> Right c + A.Error err -> Left $ T.pack err + +-- --------------------------------------------------------------------- + +-- | We (initially anyway) mirror the hie configuration, so that existing +-- clients can simply switch executable and not have any nasty surprises. There +-- will be surprises relating to config options being ignored, initially though. +data Config = + Config + { hlintOn :: Bool + , diagnosticsOnChange :: Bool + , maxNumberOfProblems :: Int + , diagnosticsDebounceDuration :: Int + , liquidOn :: Bool + , completionSnippetsOn :: Bool + , formatOnImportOn :: Bool + , formattingProvider :: T.Text + } deriving (Show,Eq) + +instance Default Config where + def = Config + { hlintOn = True + , diagnosticsOnChange = True + , maxNumberOfProblems = 100 + , diagnosticsDebounceDuration = 350000 + , liquidOn = False + , completionSnippetsOn = True + , formatOnImportOn = True + -- , formattingProvider = "brittany" + , formattingProvider = "ormolu" + -- , formattingProvider = "floskell" + -- , formattingProvider = "stylish-haskell" + } + +-- TODO: Add API for plugins to expose their own LSP config options +instance A.FromJSON Config where + parseJSON = A.withObject "Config" $ \v -> do + -- Officially, we use "haskell" as the section name but for + -- backwards compatibility we also accept "languageServerHaskell" + s <- v .: "haskell" <|> v .: "languageServerHaskell" + flip (A.withObject "Config.settings") s $ \o -> Config + <$> o .:? "hlintOn" .!= hlintOn def + <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def + <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def + <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def + <*> o .:? "liquidOn" .!= liquidOn def + <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def + <*> o .:? "formatOnImportOn" .!= formatOnImportOn def + <*> o .:? "formattingProvider" .!= formattingProvider def + +-- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"haskell":{"maxNumberOfProblems":100,"hlintOn":true}}}} +-- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification: +-- NotificationMessage +-- {_jsonrpc = "2.0" +-- , _method = WorkspaceDidChangeConfiguration +-- , _params = DidChangeConfigurationParams +-- {_settings = Object (fromList [("haskell",Object (fromList [("hlintOn",Bool True) +-- ,("maxNumberOfProblems",Number 100.0)]))])}} + +instance A.ToJSON Config where + toJSON (Config h diag m d l c f fp) = object [ "haskell" .= r ] + where + r = object [ "hlintOn" .= h + , "diagnosticsOnChange" .= diag + , "maxNumberOfProblems" .= m + , "diagnosticsDebounceDuration" .= d + , "liquidOn" .= l + , "completionSnippetsOn" .= c + , "formatOnImportOn" .= f + , "formattingProvider" .= fp + ] diff --git a/src/Ide/Plugin/Formatter.hs b/src/Ide/Plugin/Formatter.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Formatter.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Formatter + ( + formatting + , rangeFormatting + , noneProvider + , responseError + , extractRange + , fullRange + ) +where + +import qualified Data.Map as Map +import qualified Data.Text as T +import Development.IDE +import Ide.Types +import Ide.Plugin.Config +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +formatting :: Map.Map PluginId (FormattingProvider IO) + -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams + -> IO (Either ResponseError (List TextEdit)) +formatting providers lf ideState + (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) + = doFormatting lf providers ideState FormatText uri params + +-- --------------------------------------------------------------------- + +rangeFormatting :: Map.Map PluginId (FormattingProvider IO) + -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams + -> IO (Either ResponseError (List TextEdit)) +rangeFormatting providers lf ideState + (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) + = doFormatting lf providers ideState (FormatRange range) uri params + +-- --------------------------------------------------------------------- + +doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IO) + -> IdeState -> FormattingType -> Uri -> FormattingOptions + -> IO (Either ResponseError (List TextEdit)) +doFormatting lf providers ideState ft uri params = do + mc <- LSP.config lf + let mf = maybe "none" formattingProvider mc + case Map.lookup (PluginId mf) providers of + Just provider -> + case uriToFilePath uri of + Just (toNormalizedFilePath -> fp) -> do + (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp + case mb_contents of + Just contents -> do + logDebug (ideLogger ideState) $ T.pack $ + "Formatter.doFormatting: contents=" ++ show contents -- AZ + provider lf ideState ft contents fp params + Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: no formatter found for:[" ++ T.unpack mf ++ "]" + +-- --------------------------------------------------------------------- + +noneProvider :: FormattingProvider IO +noneProvider _ _ _ _ _ _ = return $ Right (List []) + +-- --------------------------------------------------------------------- + +responseError :: T.Text -> ResponseError +responseError txt = ResponseError InvalidParams txt Nothing + +-- --------------------------------------------------------------------- + +extractRange :: Range -> T.Text -> T.Text +extractRange (Range (Position sl _) (Position el _)) s = newS + where focusLines = take (el-sl+1) $ drop sl $ T.lines s + newS = T.unlines focusLines + +-- | Gets the range that covers the entire text +fullRange :: T.Text -> Range +fullRange s = Range startPos endPos + where startPos = Position 0 0 + endPos = Position lastLine 0 + {- + In order to replace everything including newline characters, + the end range should extend below the last line. From the specification: + "If you want to specify a range that contains a line including + the line ending character(s) then use an end position denoting + the start of the next line" + -} + lastLine = length $ T.lines s + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/GhcIde.hs b/src/Ide/Plugin/GhcIde.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/GhcIde.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.GhcIde + ( + descriptor + ) where + +import Data.Aeson +import Development.IDE +import Development.IDE.Plugin.Completions +import Development.IDE.Plugin.CodeAction +import Development.IDE.LSP.HoverDefinition +import Development.IDE.LSP.Outline +import Ide.Plugin +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = (defaultPluginDescriptor plId) + { pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature] + , pluginCodeActionProvider = Just codeAction' + , pluginCodeLensProvider = Just codeLens' + , pluginHoverProvider = Just hover' + , pluginSymbolsProvider = Just symbolsProvider + , pluginCompletionProvider = Just getCompletionsLSP + } + +-- --------------------------------------------------------------------- + +hover' :: HoverProvider +hover' ideState params = do + logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ + hover ideState params + +-- --------------------------------------------------------------------- + +commandAddSignature :: CommandFunction WorkspaceEdit +commandAddSignature lf ide params + = executeAddSignatureCommand lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing) + +-- --------------------------------------------------------------------- + +codeAction' :: CodeActionProvider +codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context + +-- --------------------------------------------------------------------- + +codeLens' :: CodeLensProvider +codeLens' lf ide _ params = codeLens lf ide params + +-- --------------------------------------------------------------------- + +symbolsProvider :: SymbolsProvider +symbolsProvider ls ide params = do + ds <- moduleOutline ls ide params + case ds of + Right (DSDocumentSymbols (List ls)) -> return $ Right ls + Right (DSSymbolInformation (List _si)) -> + return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated" + Left err -> return $ Left err + +-- --------------------------------------------------------------------- diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs new file mode 100644 --- /dev/null +++ b/src/Ide/PluginUtils.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +module Ide.PluginUtils where + +import qualified Data.Text as T +import Data.Maybe +import Data.Algorithm.DiffOutput +import Data.Algorithm.Diff +import qualified Data.HashMap.Strict as H +import Language.Haskell.LSP.Types.Capabilities +import qualified Language.Haskell.LSP.Types as J +import Language.Haskell.LSP.Types + +-- --------------------------------------------------------------------- + +-- | Extend to the line below and above to replace newline character. +normalize :: Range -> Range +normalize (Range (Position sl _) (Position el _)) = + Range (Position sl 0) (Position (el + 1) 0) + +-- --------------------------------------------------------------------- + +data WithDeletions = IncludeDeletions | SkipDeletions + deriving Eq + +-- | Generate a 'WorkspaceEdit' value from a pair of source Text +diffText :: ClientCapabilities -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit +diffText clientCaps old new withDeletions = + let + supports = clientSupportsDocumentChanges clientCaps + in diffText' supports old new withDeletions + +makeDiffTextEdit :: T.Text -> T.Text -> List TextEdit +makeDiffTextEdit f1 f2 = diffTextEdit f1 f2 IncludeDeletions + +makeDiffTextEditAdditive :: T.Text -> T.Text -> List TextEdit +makeDiffTextEditAdditive f1 f2 = diffTextEdit f1 f2 SkipDeletions + +diffTextEdit :: T.Text -> T.Text -> WithDeletions -> List TextEdit +diffTextEdit fText f2Text withDeletions = J.List r + where + r = map diffOperationToTextEdit diffOps + d = getGroupedDiff (lines $ T.unpack fText) (lines $ T.unpack f2Text) + + diffOps = filter (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x)) + (diffToLineRanges d) + + isDeletion (Deletion _ _) = True + isDeletion _ = False + + + diffOperationToTextEdit :: DiffOperation LineRange -> J.TextEdit + diffOperationToTextEdit (Change fm to) = J.TextEdit range nt + where + range = calcRange fm + nt = T.pack $ init $ unlines $ lrContents to + + {- + In order to replace everything including newline characters, + the end range should extend below the last line. From the specification: + "If you want to specify a range that contains a line including + the line ending character(s) then use an end position denoting + the start of the next line" + -} + diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = J.TextEdit range "" + where + range = J.Range (J.Position (sl - 1) 0) + (J.Position el 0) + + diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt + -- fm has a range wrt to the changed file, which starts in the current file at l + 1 + -- So the range has to be shifted to start at l + 1 + where + range = J.Range (J.Position l 0) + (J.Position l 0) + nt = T.pack $ unlines $ lrContents fm + + + calcRange fm = J.Range s e + where + sl = fst $ lrNumbers fm + sc = 0 + s = J.Position (sl - 1) sc -- Note: zero-based lines + el = snd $ lrNumbers fm + ec = length $ last $ lrContents fm + e = J.Position (el - 1) ec -- Note: zero-based lines + + +-- | A pure version of 'diffText' for testing +diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit +diffText' supports (f,fText) f2Text withDeletions = + if supports + then WorkspaceEdit Nothing (Just docChanges) + else WorkspaceEdit (Just h) Nothing + where + diff = diffTextEdit fText f2Text withDeletions + h = H.singleton f diff + docChanges = J.List [docEdit] + docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) diff + +-- --------------------------------------------------------------------- + +clientSupportsDocumentChanges :: ClientCapabilities -> Bool +clientSupportsDocumentChanges caps = + let ClientCapabilities mwCaps _ _ _ = caps + supports = do + wCaps <- mwCaps + WorkspaceEditClientCapabilities mDc <- _workspaceEdit wCaps + mDc + in + fromMaybe False supports diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Types.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ide.Types + ( + IdePlugins(..) + , PluginDescriptor(..) + , defaultPluginDescriptor + , PluginCommand(..) + , PluginId(..) + , CommandId(..) + , DiagnosticProvider(..) + , DiagnosticProviderFunc(..) + , SymbolsProvider + , FormattingType(..) + , FormattingProvider + , HoverProvider + , CodeActionProvider + , CodeLensProvider + , CommandFunction + , ExecuteCommandProvider + , CompletionProvider + , RenameProvider + , WithSnippets(..) + ) where + +import Data.Aeson hiding (defaultOptions) +import qualified Data.Map as Map +import qualified Data.Set as S +import Data.String +import qualified Data.Text as T +import Development.IDE +import Ide.Plugin.Config +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +newtype IdePlugins = IdePlugins + { ipMap :: Map.Map PluginId PluginDescriptor + } + +-- --------------------------------------------------------------------- + +data PluginDescriptor = + PluginDescriptor { pluginId :: !PluginId + , pluginRules :: !(Rules ()) + , pluginCommands :: ![PluginCommand] + , pluginCodeActionProvider :: !(Maybe CodeActionProvider) + , pluginCodeLensProvider :: !(Maybe CodeLensProvider) + , pluginDiagnosticProvider :: !(Maybe DiagnosticProvider) + -- ^ TODO: diagnostics are generally provided via rules, + -- this is probably redundant. + , pluginHoverProvider :: !(Maybe HoverProvider) + , pluginSymbolsProvider :: !(Maybe SymbolsProvider) + , pluginFormattingProvider :: !(Maybe (FormattingProvider IO)) + , pluginCompletionProvider :: !(Maybe CompletionProvider) + , pluginRenameProvider :: !(Maybe RenameProvider) + } + +defaultPluginDescriptor :: PluginId -> PluginDescriptor +defaultPluginDescriptor plId = + PluginDescriptor + plId + mempty + mempty + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +-- instance Show PluginCommand where +-- show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }" + +-- newtype CommandId = CommandId T.Text +-- deriving (Show, Read, Eq, Ord) +-- instance IsString CommandId where +-- fromString = CommandId . T.pack + +-- data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => +-- PluginCommand { commandId :: CommandId +-- , commandDesc :: T.Text +-- , commandFunc :: a -> IO (Either ResponseError b) +-- } + +newtype CommandId = CommandId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString CommandId where + fromString = CommandId . T.pack + +data PluginCommand = forall a. (FromJSON a) => + PluginCommand { commandId :: CommandId + , commandDesc :: T.Text + , commandFunc :: CommandFunction a + } + +-- --------------------------------------------------------------------- + +type CommandFunction a = LSP.LspFuncs Config + -> IdeState + -> a + -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + +type CodeActionProvider = LSP.LspFuncs Config + -> IdeState + -> PluginId + -> TextDocumentIdentifier + -> Range + -> CodeActionContext + -> IO (Either ResponseError (List CAResult)) + +type CompletionProvider = LSP.LspFuncs Config + -> IdeState + -> CompletionParams + -> IO (Either ResponseError CompletionResponseResult) + + + +type CodeLensProvider = LSP.LspFuncs Config + -> IdeState + -> PluginId + -> CodeLensParams + -> IO (Either ResponseError (List CodeLens)) + +type RenameProvider = LSP.LspFuncs Config + -> IdeState + -> RenameParams + -> IO (Either ResponseError WorkspaceEdit) + +type DiagnosticProviderFuncSync + = DiagnosticTrigger -> Uri + -> IO (Either ResponseError (Map.Map Uri (S.Set Diagnostic))) + +type DiagnosticProviderFuncAsync + = DiagnosticTrigger -> Uri + -> (Map.Map Uri (S.Set Diagnostic) -> IO ()) + -> IO (Either ResponseError ()) + +data DiagnosticProviderFunc + = DiagnosticProviderSync DiagnosticProviderFuncSync + | DiagnosticProviderAsync DiagnosticProviderFuncAsync + + +data DiagnosticProvider = DiagnosticProvider + { dpTrigger :: S.Set DiagnosticTrigger -- AZ:should this be a NonEmptyList? + , dpFunc :: DiagnosticProviderFunc + } + +data DiagnosticTrigger = DiagnosticOnOpen + | DiagnosticOnChange + | DiagnosticOnSave + deriving (Show,Ord,Eq) + +-- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) +type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) + +type SymbolsProvider = LSP.LspFuncs Config + -> IdeState + -> DocumentSymbolParams + -> IO (Either ResponseError [DocumentSymbol]) + +type ExecuteCommandProvider = IdeState + -> ExecuteCommandParams + -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + +newtype WithSnippets = WithSnippets Bool + +-- --------------------------------------------------------------------- + +newtype PluginId = PluginId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString PluginId where + fromString = PluginId . T.pack + +-- --------------------------------------------------------------------- + + +-- | Format the given Text as a whole or only a @Range@ of it. +-- Range must be relative to the text to format. +-- To format the whole document, read the Text from the file and use 'FormatText' +-- as the FormattingType. +data FormattingType = FormatText + | FormatRange Range + + +-- | To format a whole document, the 'FormatText' @FormattingType@ can be used. +-- It is required to pass in the whole Document Text for that to happen, an empty text +-- and file uri, does not suffice. +type FormattingProvider m + = LSP.LspFuncs Config + -> IdeState + -> FormattingType -- ^ How much to format + -> T.Text -- ^ Text to format + -> NormalizedFilePath -- ^ location of the file being formatted + -> FormattingOptions -- ^ Options for the formatter + -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting + +-- ---------------------------------------------------------------------