simplify plugin api

Author: wz1000

ghcide/src/Development/IDE/Plugin/HLS.hs

@@ -155,29 +155,24 @@ extensiblePlugins xs = Plugin mempty handlers
             ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs))
             Nothing
           Just fs -> do
-            ex <- getExtraParams m params
-            case ex of
-              Left err -> pure $ Left err
-              Right ex -> do
-                let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)
-                es <- runConcurrently msg fs ide ex params
-                let (errs,succs) = partitionEithers $ toList es
-                case nonEmpty succs of
-                  Nothing -> pure $ Left $ combineErrors errs
-                  Just xs -> do
-                    caps <- LSP.getClientCapabilities
-                    pure $ Right $ combineResponses m pid config caps params xs
+            let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)
+            es <- runConcurrently msg fs ide params
+            let (errs,succs) = partitionEithers $ toList es
+            case nonEmpty succs of
+              Nothing -> pure $ Left $ combineErrors errs
+              Just xs -> do
+                caps <- LSP.getClientCapabilities
+                pure $ Right $ combineResponses m pid config caps params xs
 
 runConcurrently
   :: MonadUnliftIO m
   => (SomeException -> PluginId -> T.Text)
-  -> NonEmpty (PluginId, a -> b -> c -> m (NonEmpty (Either ResponseError d)))
+  -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
   -> a
   -> b
-  -> c
   -> m (NonEmpty (Either ResponseError d))
-runConcurrently msg fs a b c = fmap join $ forConcurrently fs $ \(pid,f) ->
-  f a b c
+runConcurrently msg fs a b = fmap join $ forConcurrently fs $ \(pid,f) ->
+  f a b
     `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)
 
 combineErrors :: [ResponseError] -> ResponseError
@@ -186,7 +181,7 @@ combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing
 
 -- | Combine the 'PluginHandler' for all plugins
 newtype IdeHandler (m :: J.Method FromClient Request)
-  = IdeHandler [(PluginId,(IdeState -> ExtraParams m -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))))]
+  = IdeHandler [(PluginId,(IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))))]
 
 -- | Combine the 'PluginHandlers' for all plugins
 newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler)

hls-plugin-api/src/Ide/Types.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ConstraintKinds #-}
 
 module Ide.Types
     where
@@ -26,7 +27,7 @@ import           Development.Shake hiding (command)
 import           Ide.Plugin.Config
 import           Language.LSP.Types
 import           Language.LSP.VFS
-import           Language.LSP.Types.Lens hiding (id)
+import           Language.LSP.Types.Lens as J hiding (id)
 import           Language.LSP.Types.Capabilities
 import           Language.LSP.Server (LspM, getVirtualFile)
 import           Text.Regex.TDFA.Text()
@@ -60,16 +61,6 @@ data PluginDescriptor ideState =
 -- Only methods for which we know how to combine responses can be instances of 'PluginMethod'
 class PluginMethod m where
 
-  -- | Extra data associated with requests of this type, to be passed to the handler
-  type ExtraParams m :: *
-  type ExtraParams m = () -- no extra data by default
-
-  -- | How to generate the extra data
-  getExtraParams :: SMethod m -> MessageParams m -> LspM Config (Either ResponseError (ExtraParams m))
-
-  default getExtraParams :: (ExtraParams m ~ ()) => SMethod m -> MessageParams m -> LspM Config (Either ResponseError (ExtraParams m))
-  getExtraParams _ _ = pure $ Right ()
-
   -- | Parse the configuration to check if this plugin is enabled
   pluginEnabled :: SMethod m -> PluginId -> Config -> Bool
 
@@ -88,7 +79,7 @@ class PluginMethod m where
 
 instance PluginMethod TextDocumentCodeAction where
   pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn
-  combineResponses _method pid _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ docId range context) resps =
+  combineResponses _method pid _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ _ _ context) resps =
       fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps
     where
 
@@ -175,24 +166,10 @@ instance PluginMethod TextDocumentCompletion where
           consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx)))
 
 instance PluginMethod TextDocumentFormatting where
-  type ExtraParams TextDocumentFormatting = (FormattingType, T.Text)
-  getExtraParams _ (DocumentFormattingParams _ (TextDocumentIdentifier uri) params) = do
-    mf <- getVirtualFile $ toNormalizedUri uri
-    case mf of
-      Just vf -> pure $ Right (FormatText, virtualFileText vf)
-      Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
-
   pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
   combineResponses _ _ _ _ _ (x :| _) = x
 
 instance PluginMethod TextDocumentRangeFormatting where
-  type ExtraParams TextDocumentRangeFormatting = (FormattingType, T.Text)
-  getExtraParams _ (DocumentRangeFormattingParams _ (TextDocumentIdentifier uri) range params) = do
-    mf <- getVirtualFile $ toNormalizedUri uri
-    case mf of
-      Just vf -> pure $ Right (FormatRange range, virtualFileText vf)
-      Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
-
   pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
   combineResponses _ _ _ _ _ (x :| _) = x
 
@@ -205,39 +182,30 @@ instance GCompare IdeMethod where
 
 -- | Combine handlers for the
 newtype PluginHandler a (m :: Method FromClient Request)
-  = PluginHandler (PluginId -> a -> ExtraParams m -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))
+  = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))
 
 newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a))
 
 instance Semigroup (PluginHandlers a) where
   (PluginHandlers a) <> (PluginHandlers b) = PluginHandlers $ DMap.unionWithKey go a b
     where
-      go _ (PluginHandler f) (PluginHandler g) = PluginHandler $ \pid ide extra params ->
-        (<>) <$> f pid ide extra params <*> g pid ide extra params
+      go _ (PluginHandler f) (PluginHandler g) = PluginHandler $ \pid ide params ->
+        (<>) <$> f pid ide params <*> g pid ide params
 
 instance Monoid (PluginHandlers a) where
   mempty = PluginHandlers mempty
 
-type SimpleHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))
+type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))
 
 -- | Make a handler for plugins with no extra data
 mkPluginHandler
   :: PluginMethod m
   => SClientMethod m
-  -> SimpleHandler ideState m
+  -> PluginMethodHandler ideState m
   -> PluginHandlers ideState
 mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f')
   where
-    f' pid ide _ params = pure <$> f ide pid params
-
-mkPluginHandlerExtra
-  :: PluginMethod m
-  => SClientMethod m
-  -> (ideState -> PluginId -> ExtraParams m -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m)))
-  -> PluginHandlers ideState
-mkPluginHandlerExtra m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f')
-  where
-    f' pid ide extra params = pure <$> f ide pid extra params
+    f' pid ide params = pure <$> f ide pid params
 
 defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState
 defaultPluginDescriptor plId =
@@ -294,6 +262,45 @@ pluginEnabledConfig f pid config = plcGlobalOn pluginConfig && f pluginConfig
 data FormattingType = FormatText
                     | FormatRange Range
 
+
+type FormattingMethod m =
+  ( J.HasOptions (MessageParams m) FormattingOptions
+  , J.HasTextDocument (MessageParams m) TextDocumentIdentifier
+  , ResponseResult m ~ List TextEdit
+  )
+
+type FormattingHandler a
+  =  a
+  -> FormattingType
+  -> T.Text
+  -> NormalizedFilePath
+  -> FormattingOptions
+  -> LspM Config (Either ResponseError (List TextEdit))
+
+mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a
+mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting)
+                      <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting)
+  where
+    provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m
+    provider m ide _pid params
+      | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
+        mf <- getVirtualFile $ toNormalizedUri uri
+        case mf of
+          Just vf -> do
+            let typ = case m of
+                  STextDocumentFormatting -> FormatText
+                  STextDocumentRangeFormatting -> FormatRange (params ^. J.range)
+                  _ -> error "mkFormattingHandlers: impossible"
+            f ide typ (virtualFileText vf) nfp opts
+          Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
+
+      | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri
+      where
+        uri = params ^. J.textDocument . J.uri
+        opts = params ^. J.options
+
+-- ---------------------------------------------------------------------
+
 responseError :: T.Text -> ResponseError
 responseError txt = ResponseError InvalidParams txt Nothing
 

plugins/default/src/Ide/Plugin/Brittany.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Ide.Plugin.Brittany where
-
+  
 import           Control.Exception (bracket_)
 import           Control.Lens
 import           Control.Monad.IO.Class
@@ -9,7 +11,7 @@ import           Data.Maybe (maybeToList)
 import           Data.Semigroup
 import           Data.Text                             (Text)
 import qualified Data.Text                             as T
-import           Development.IDE
+import           Development.IDE hiding (pluginHandlers)
 import           Development.IDE.GHC.Compat (topDir, ModSummary(ms_hspp_opts))
 import           Language.Haskell.Brittany
 import           Language.LSP.Types            as J
@@ -22,28 +24,26 @@ import           System.Environment (setEnv, unsetEnv)
 
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId = (defaultPluginDescriptor plId)
-  { pluginFormattingProvider = Just provider
+  { pluginHandlers = mkFormattingHandlers provider
   }
 
 -- | Formatter provider of Brittany.
 -- Formats the given source in either a given Range or the whole Document.
 -- If the provider fails an error is returned that can be displayed to the user.
-provider
-  :: FormattingProvider IdeState IO
-provider _lf ide typ contents nfp opts = do
--- text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do
-  confFile <- liftIO $ getConfFile nfp
-  let (range, selectedContents) = case typ of
-        FormatText    -> (fullRange contents, contents)
-        FormatRange r -> (normalize r, extractRange r contents)
-  (modsum, _) <- runAction "brittany" ide $ use_ GetModSummary nfp
-  let dflags = ms_hspp_opts modsum
-  let withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key)
-        where key = "GHC_EXACTPRINT_GHC_LIBDIR"
-  res <- withRuntimeLibdir $ formatText confFile opts selectedContents
-  case res of
-    Left err -> return $ Left $ responseError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err))
-    Right newText -> return $ Right $ J.List [TextEdit range newText]
+provider :: FormattingHandler IdeState
+provider ide typ contents nfp opts = liftIO $ do
+    confFile <- getConfFile nfp
+    let (range, selectedContents) = case typ of
+          FormatText    -> (fullRange contents, contents)
+          FormatRange r -> (normalize r, extractRange r contents)
+    (modsum, _) <- runAction "brittany" ide $ use_ GetModSummary nfp
+    let dflags = ms_hspp_opts modsum
+    let withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key)
+          where key = "GHC_EXACTPRINT_GHC_LIBDIR"
+    res <- withRuntimeLibdir $ formatText confFile opts selectedContents
+    case res of
+      Left err -> return $ Left $ responseError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err))
+      Right newText -> return $ Right $ J.List [TextEdit range newText]
 
 -- | Primitive to format text with the given option.
 -- May not throw exceptions but return a Left value.

plugins/hls-class-plugin/src/Ide/Plugin/Class.hs

@@ -131,7 +131,7 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do
 -- |
 -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
 -- sensitive to the format of diagnostic messages from GHC.
-codeAction :: SimpleHandler IdeState TextDocumentCodeAction
+codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction
 codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do
   docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri
   actions <- join <$> mapM (mkActions docPath) methodDiags

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

@@ -194,7 +194,7 @@ import Language.LSP.Types.Lens (line, end)
 {- | Code Lens provider
  NOTE: Invoked every time the document is modified, not just when the document is saved.
 -}
-codeLens :: SimpleHandler IdeState TextDocumentCodeLens
+codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens
 codeLens st plId CodeLensParams{_textDocument} =
     let dbg = logWith st
         perf = timed dbg

plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs

@@ -87,7 +87,7 @@ runImportCommand _state (ImportCommandParams edit) = do
 -- the provider should produce one code lens associated to the import statement:
 --
 -- > import Data.List (intercalate, sortBy)
-lensProvider :: SimpleHandler IdeState TextDocumentCodeLens
+lensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
 lensProvider
   state -- ghcide state, used to retrieve typechecking artifacts
   pId -- plugin Id
@@ -115,7 +115,7 @@ lensProvider
 
 -- | If there are any implicit imports, provide one code action to turn them all
 --   into explicit imports.
-codeActionProvider :: SimpleHandler IdeState TextDocumentCodeAction
+codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
 codeActionProvider ideState _pId (CodeActionParams _ _ docId range _context)
   | TextDocumentIdentifier {_uri} <- docId,
     Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $

plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs

@@ -29,7 +29,7 @@ descriptor plId =
     { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider
     }
 
-codeActionProvider :: SimpleHandler IdeState TextDocumentCodeAction
+codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
 codeActionProvider ideState _pId (CodeActionParams _ _ (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = List diags}) =
   do
     let noErr = and $ (/= Just DsError) . _severity <$> diags

plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs

@@ -252,7 +252,7 @@ getHlintSettingsRule usage =
 
 -- ---------------------------------------------------------------------
 
-codeActionProvider :: SimpleHandler IdeState TextDocumentCodeAction
+codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
 codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right . LSP.List . map InR <$> liftIO getCodeActions
   where
 

plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs

@@ -163,7 +163,7 @@ extractImports _ _ _ = []
 
 -------------------------------------------------------------------------------
 
-provider :: SimpleHandler IdeState TextDocumentCodeAction
+provider :: PluginMethodHandler IdeState TextDocumentCodeAction
 provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = response $ do
   let (J.CodeActionContext _diags _monly) = ca
       nuri = toNormalizedUri uri

plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs

@@ -388,7 +388,7 @@ fromSearchResult _ = Nothing
 
 -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors)
 -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs?
-codeAction :: SimpleHandler IdeState TextDocumentCodeAction
+codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction
 codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $
     fmap (maybe (Right $ List []) Right) $
         runMaybeT $ do