More plugin refactoring, add codelens support

Starting to look pretty solid.

Author: alanz

exe/Main.hs

@@ -69,38 +69,15 @@ import Ide.Plugin.Pragmas                 as Pragmas
 
 -- ---------------------------------------------------------------------
 
--- | TODO: these should come out of something like asGhcIdePlugin
-commandIds :: T.Text -> [T.Text]
-commandIds pid = "typesignature.add" : allLspCmdIds pid [("pragmas", Pragmas.commands)]
-
--- | The plugins configured for use in this instance of the language
--- server.
--- These can be freely added or removed to tailor the available
--- features of the server.
-_idePlugins :: Bool -> Plugin Config
-_idePlugins includeExample
-  = Completions.plugin <>
-    CodeAction.plugin <>
-    formatterPlugins [("ormolu",   Ormolu.provider)
-                     ,("floskell", Floskell.provider)] <>
-    codeActionPlugins [("eg",      Example.codeAction)
-                      ,("eg2",     Example2.codeAction)
-                      ,("pragmas", Pragmas.codeAction)] <>
-    executeCommandPlugins [("pragmas", Pragmas.commands)] <>
-    hoverPlugins [("eg", Example.hover)
-                 ,("eg2", Example2.hover)] <>
-    if includeExample then Example.plugin <> Example2.plugin
-                      else mempty
-
-
 -- | The plugins configured for use in this instance of the language
 -- server.
 -- These can be freely added or removed to tailor the available
 -- features of the server.
-idePlugins :: Bool -> Plugin Config
-idePlugins includeExamples
-    = asGhcIdePlugin $ pluginDescToIdePlugins allPlugins
+idePlugins :: T.Text -> Bool -> (Plugin Config, [T.Text])
+idePlugins pid includeExamples
+    = (asGhcIdePlugin ps, allLspCmdIds' pid ps)
   where
+    ps = pluginDescToIdePlugins allPlugins
     allPlugins = if includeExamples
                    then basePlugins ++ examplePlugins
                    else basePlugins
@@ -164,9 +141,12 @@ main = do
     dir <- IO.getCurrentDirectory
 
     pid <- getPid
-    -- let plugins = idePlugins argsExamplePlugin
-    let plugins = idePlugins True
-        options = def { LSP.executeCommandCommands = Just (commandIds pid)
+    let
+        -- (ps, commandIds) = idePlugins pid argsExamplePlugin
+        (ps, commandIds) = idePlugins pid True
+        plugins = Completions.plugin <> CodeAction.plugin <>
+                  ps
+        options = def { LSP.executeCommandCommands = Just commandIds
                       , LSP.completionTriggerCharacters = Just "."
                       }
 

src/Ide/Logger.hs

@@ -1,3 +1,6 @@
+{- | Provides an implementation of the ghcide @Logger@ which uses
+   @System.Log.Logger@ under the hood.
+-}
 module Ide.Logger
   (
     hlsLogger
@@ -13,7 +16,7 @@ import qualified Development.IDE.Types.Logger as L
 import           System.Log.Logger
 
 -- ---------------------------------------------------------------------
--- data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}
+
 hlsLogger :: L.Logger
 hlsLogger = L.Logger $ \pri txt ->
     case pri of

src/Ide/Plugin.hs

@@ -11,12 +11,9 @@ module Ide.Plugin
     (
       asGhcIdePlugin
     , pluginDescToIdePlugins
-    , formatterPlugins
-    , hoverPlugins
-    , codeActionPlugins
-    , executeCommandPlugins
     , mkLspCommand
     , allLspCmdIds
+    , allLspCmdIds'
     , getPid
     ) where
 
@@ -29,9 +26,11 @@ import qualified Data.Map  as Map
 import           Data.Maybe
 import qualified Data.Text                     as T
 import           Development.IDE.Core.Rules
+import           Development.IDE.Core.Shake
 import           Development.IDE.LSP.Server
 import           Development.IDE.Plugin hiding (pluginCommands, pluginRules)
 import           Development.IDE.Types.Diagnostics as D
+import           Development.IDE.Types.Logger
 import           Development.Shake hiding ( Diagnostic, command )
 import           GHC.Generics
 import           Ide.Compat
@@ -56,11 +55,12 @@ asGhcIdePlugin mp =
     mkPlugin rulesPlugins (Just . pluginRules) <>
     mkPlugin executeCommandPlugins (Just . pluginCommands) <>
     mkPlugin codeActionPlugins     pluginCodeActionProvider <>
-    -- diagnostics from pluginDiagnosticProvider
+    mkPlugin codeLensPlugins       pluginCodeLensProvider <>
+    -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider
     mkPlugin hoverPlugins          pluginHoverProvider <>
-    -- symbols via pluginSymbolProvider
+    -- TODO: symbols via pluginSymbolProvider
     mkPlugin formatterPlugins      pluginFormattingProvider
-    -- completions
+    -- TODO: completions
     where
         justs (p, Just x)  = [(p, x)]
         justs (_, Nothing) = []
@@ -75,6 +75,17 @@ asGhcIdePlugin mp =
 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
@@ -140,6 +151,46 @@ data FallbackCodeActionParams =
 
 -- -----------------------------------------------------------
 
+codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config
+codeLensPlugins cas = Plugin mempty 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 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 mempty (executeCommandHandlers ecs)
 
@@ -275,6 +326,9 @@ makeExecuteCommands ecs _lf _params = do
 
           execCmd (params ^. J.command) (params ^. J.arguments)
 -}
+
+-- -----------------------------------------------------------
+
 -- | Runs a plugin command given a PluginId, CommandId and
 -- arguments in the form of a JSON object.
 runPluginCommand :: Map.Map PluginId [PluginCommand] -> PluginId -> CommandId -> J.Value
@@ -290,14 +344,7 @@ runPluginCommand m p@(PluginId p') com@(CommandId com') arg =
       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) Nothing, Nothing)
-        J.Success a -> do
-            res <- f a
-            return res
-            -- case res of
-            --     Left e ->  return (Left e,             Nothing)
-            --     -- Right r -> return (Right $ J.toJSON r, Nothing)
-            --     Right r -> return r
-            --         -- return (Right J.Null, Just(WorkspaceApplyEdit, _ r))
+        J.Success a -> f a
 
 -- -----------------------------------------------------------
 

src/Ide/Plugin/Example.hs

@@ -1,24 +1,21 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TupleSections     #-}
 {-# LANGUAGE TypeFamilies      #-}
 
 module Ide.Plugin.Example
   (
     descriptor
-  , plugin
-  , hover
-  , codeAction
   ) where
 
 import Control.DeepSeq ( NFData )
 import Control.Monad.Trans.Maybe
-import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
+import Data.Aeson
 import Data.Binary
 import Data.Functor
 import qualified Data.HashMap.Strict as Map
@@ -31,16 +28,13 @@ import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Rules
 import Development.IDE.Core.Service
 import Development.IDE.Core.Shake
-import Development.IDE.LSP.Server
-import Development.IDE.Plugin
 import Development.IDE.Types.Diagnostics as D
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.Shake hiding ( Diagnostic )
 import GHC.Generics
+import Ide.Plugin
 import Ide.Types
-import qualified Language.Haskell.LSP.Core as LSP
-import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
 import Text.Regex.TDFA.Text()
 
@@ -50,8 +44,9 @@ descriptor :: PluginId -> PluginDescriptor
 descriptor plId = PluginDescriptor
   { pluginId = plId
   , pluginRules = exampleRules
-  , pluginCommands = []
+  , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd]
   , pluginCodeActionProvider = Just codeAction
+  , pluginCodeLensProvider   = Just codeLens
   , pluginDiagnosticProvider = Nothing
   , pluginHoverProvider = Just hover
   , pluginSymbolProvider = Nothing
@@ -61,23 +56,15 @@ descriptor plId = PluginDescriptor
 
 -- ---------------------------------------------------------------------
 
-plugin :: Plugin c
-plugin = Plugin mempty exampleRules handlersExample
-         -- <> codeActionPlugin codeAction
-         <> Plugin mempty mempty handlersCodeLens
-
 hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
 hover = request "Hover" blah (Right Nothing) foundHover
 
 blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
 blah _ (Position line col)
   = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 1\n"])
 
-handlersExample :: PartialHandlers c
-handlersExample = mempty
--- handlersExample = PartialHandlers $ \WithMessage{..} x ->
---   return x{LSP.hoverHandler = withResponse RspHover $ const hover}
-
+-- ---------------------------------------------------------------------
+-- Generating Diagnostics via rules
 -- ---------------------------------------------------------------------
 
 data Example = Example
@@ -116,6 +103,8 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,)
     }
 
 -- ---------------------------------------------------------------------
+-- code actions
+-- ---------------------------------------------------------------------
 
 -- | Generate code actions.
 codeAction
@@ -136,49 +125,50 @@ codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_di
 
 -- ---------------------------------------------------------------------
 
--- | Generate code lenses.
-handlersCodeLens :: PartialHandlers c
-handlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
-    LSP.codeLensHandler = withResponse RspCodeLens codeLens,
-    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
-    }
-
 codeLens
-    :: LSP.LspFuncs c
-    -> IdeState
+    :: IdeState
+    -> PluginId
     -> CodeLensParams
     -> IO (Either ResponseError (List CodeLens))
-codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
+codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
+    logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ
     case uriToFilePath' uri of
       Just (toNormalizedFilePath -> filePath) -> do
         _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
         _diag <- getDiagnostics ideState
         _hDiag <- getHiddenDiagnostics ideState
         let
           title = "Add TODO Item via Code Lens"
-          tedit = [TextEdit (Range (Position 3 0) (Position 3 0))
-               "-- TODO added by Example Plugin via code lens action\n"]
-          edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
-          range = (Range (Position 3 0) (Position 4 0))
-        pure $ Right $ List
-          -- [ CodeLens range (Just (Command title "codelens.do" (Just $ List [toJSON edit]))) Nothing
-          [ CodeLens range (Just (Command title "codelens.todo" (Just $ List [toJSON edit]))) Nothing
-          ]
+          -- tedit = [TextEdit (Range (Position 3 0) (Position 3 0))
+          --      "-- TODO added by Example Plugin via code lens action\n"]
+          -- edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
+          range = Range (Position 3 0) (Position 4 0)
+        let cmdParams = AddTodoParams uri "do abc"
+        cmd <- mkLspCommand plId "codelens.todo" title (Just [(toJSON cmdParams)])
+        pure $ Right $ List [ CodeLens range (Just cmd) Nothing ]
       Nothing -> pure $ Right $ List []
 
--- | Execute the "codelens.todo" command.
-executeAddSignatureCommand
-    :: LSP.LspFuncs c
-    -> IdeState
-    -> ExecuteCommandParams
-    -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
-executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
-    | _command == "codelens.todo"
-    , Just (List [edit]) <- _arguments
-    , Success wedit <- fromJSON edit
-    = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
-    | otherwise
-    = return (Right Null, Nothing)
+-- ---------------------------------------------------------------------
+-- | Parameters for the addTodo PluginCommand.
+data AddTodoParams = AddTodoParams
+  { file   :: Uri  -- ^ Uri of the file to add the pragma to
+  , todoText :: T.Text
+  }
+  deriving (Show, Eq, Generic, ToJSON, FromJSON)
+
+addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value,
+                           Maybe (ServerMethod, ApplyWorkspaceEditParams))
+addTodoCmd (AddTodoParams uri todoText) = do
+  let
+    pos = Position 0 0
+    textEdits = List
+      [TextEdit (Range pos pos)
+                  ("-- TODO:" <> todoText)
+      ]
+    res = WorkspaceEdit
+      (Just $ Map.singleton uri textEdits)
+      Nothing
+  return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res))
 
 -- ---------------------------------------------------------------------
 
@@ -203,7 +193,8 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc
         Nothing   -> pure Nothing
     pure $ maybe notFound found mbResult
 
-logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b
+logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b)
+                  -> IdeState -> Position -> String -> IO b
 logAndRunRequest label getResults ide pos path = do
   let filePath = toNormalizedFilePath path
   logInfo (ideLogger ide) $