Add throwPluginError to Plugin Utilities

exe/Plugins.hs

@@ -153,7 +153,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
       Brittany.descriptor "brittany" :
 #endif
 #if callHierarchy
-      CallHierarchy.descriptor "callHierarchy":
+      CallHierarchy.descriptor :
 #endif
 #if class
       Class.descriptor "class" :
@@ -183,13 +183,13 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
       Splice.descriptor "splice" :
 #endif
 #if alternateNumberFormat
-      AlternateNumberFormat.descriptor pluginRecorder "alternateNumberFormat" :
+      AlternateNumberFormat.descriptor pluginRecorder :
 #endif
 #if selectionRange
       SelectionRange.descriptor "selectionRange" :
 #endif
 #if changeTypeSignature
-      ChangeTypeSignature.descriptor "changeTypeSignature" :
+      ChangeTypeSignature.descriptor :
 #endif
     -- The ghcide descriptors should come last so that the notification handlers
     -- (which restart the Shake build) run after everything else

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

@@ -28,9 +28,10 @@ module Ide.PluginUtils
     positionInRange,
     usePropertyLsp,
     getNormalizedFilePath,
-    response,
+    pluginResponse,
     handleMaybe,
     handleMaybeM,
+    throwPluginError
     )
 where
 
@@ -254,13 +255,18 @@ getNormalizedFilePath (PluginId plId) uri = handleMaybe errMsg
         errMsg = T.unpack $ "Error(" <> plId <> "): converting " <> getUri uri <> " to NormalizedFilePath"
 
 -- ---------------------------------------------------------------------
+throwPluginError :: Monad m => PluginId -> String -> String -> ExceptT String m b
+throwPluginError (PluginId who) what where' = throwE msg
+    where
+        msg = (T.unpack who) <> " failed with " <> what <> " at " <> where'
+
 handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b
 handleMaybe msg = maybe (throwE msg) return
 
 handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b
 handleMaybeM msg act = maybeM (throwE msg) return $ lift act
 
-response :: Monad m => ExceptT String m a -> m (Either ResponseError a)
-response =
+pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a)
+pluginResponse =
   fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))
     . runExceptT

plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs

@@ -5,9 +5,9 @@
 {-# LANGUAGE ViewPatterns  #-}
 module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where
 
-import           Control.Lens                    ((^.))
 import           Control.Monad.Except            (ExceptT, MonadIO, liftIO)
 import qualified Data.HashMap.Strict             as HashMap
+import           Data.String                     (IsString)
 import           Data.Text                       (Text)
 import qualified Data.Text                       as T
 import           Development.IDE                 (GetParsedModule (GetParsedModule),
@@ -31,19 +31,21 @@ import           Ide.Plugin.Conversion           (AlternateFormat,
                                                   alternateFormat)
 import           Ide.Plugin.Literals
 import           Ide.PluginUtils                 (getNormalizedFilePath,
-                                                  handleMaybeM, response)
+                                                  handleMaybeM, pluginResponse)
 import           Ide.Types
 import           Language.LSP.Types
-import           Language.LSP.Types.Lens         (uri)
 
 newtype Log = LogShake Shake.Log deriving Show
 
 instance Pretty Log where
   pretty = \case
     LogShake log -> pretty log
 
-descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
-descriptor recorder plId = (defaultPluginDescriptor plId)
+alternateNumberFormatId :: IsString a => a
+alternateNumberFormatId = "alternateNumberFormat"
+
+descriptor :: Recorder (WithPriority Log) -> PluginDescriptor IdeState
+descriptor recorder = (defaultPluginDescriptor alternateNumberFormatId)
     { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler
     , pluginRules = collectLiteralsRule recorder
     }
@@ -83,7 +85,7 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec
         getExtensions = map GhcExtension . toList . extensionFlags . ms_hspp_opts . pm_mod_summary
 
 codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
-codeActionHandler state plId (CodeActionParams _ _ docId currRange _) = response $ do
+codeActionHandler state _ (CodeActionParams _ _ docId currRange _) = pluginResponse $ do
     nfp <- getNormalizedFilePath plId (docId ^. uri)
     CLR{..} <- requestLiterals state nfp
     pragma <- getFirstPragma state nfp
@@ -144,14 +146,14 @@ p `isInsideRealSrcSpan` r = let (Range sp ep) = realSrcSpanToRange r in sp <= p
 
 getFirstPragma :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo
 getFirstPragma state nfp = handleMaybeM "Error: Could not get NextPragmaInfo" $ do
-      ghcSession <- liftIO $ runAction "AlternateNumberFormat.GhcSession" state $ useWithStale GhcSession nfp
-      (_, fileContents) <- liftIO $ runAction "AlternateNumberFormat.GetFileContents" state $ getFileContents nfp
+      ghcSession <- liftIO $ runAction (alternateNumberFormatId <> ".GhcSession") state $ useWithStale GhcSession nfp
+      (_, fileContents) <- liftIO $ runAction (alternateNumberFormatId <> ".GetFileContents") state $ getFileContents nfp
       case ghcSession of
         Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents
         Nothing -> pure Nothing
 
 requestLiterals :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult
 requestLiterals state = handleMaybeM "Error: Could not Collect Literals"
                 . liftIO
-                . runAction "AlternateNumberFormat.CollectLiterals" state
+                . runAction (alternateNumberFormatId <> ".CollectLiterals") state
                 . use CollectLiterals

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs

@@ -5,8 +5,8 @@ import qualified Ide.Plugin.CallHierarchy.Internal as X
 import           Ide.Types
 import           Language.LSP.Types
 
-descriptor :: PluginId -> PluginDescriptor IdeState
-descriptor plId = (defaultPluginDescriptor plId)
+descriptor :: PluginDescriptor IdeState
+descriptor = (defaultPluginDescriptor X.callHierarchyId)
   { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentPrepareCallHierarchy X.prepareCallHierarchy
                             <> mkPluginHandler SCallHierarchyIncomingCalls X.incomingCalls
                             <> mkPluginHandler SCallHierarchyOutgoingCalls X.outgoingCalls

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs

@@ -11,6 +11,7 @@ module Ide.Plugin.CallHierarchy.Internal (
   prepareCallHierarchy
 , incomingCalls
 , outgoingCalls
+, callHierarchyId
 ) where
 
 import           Control.Lens                   ((^.))
@@ -35,23 +36,23 @@ import           GHC.Conc.Sync
 import           HieDb                          (Symbol (Symbol))
 import qualified Ide.Plugin.CallHierarchy.Query as Q
 import           Ide.Plugin.CallHierarchy.Types
+import           Ide.PluginUtils                (getNormalizedFilePath,
+                                                 handleMaybe, pluginResponse,
+                                                 throwPluginError)
 import           Ide.Types
 import           Language.LSP.Types
 import qualified Language.LSP.Types.Lens        as L
 import           Text.Read                      (readMaybe)
 
+callHierarchyId :: PluginId
+callHierarchyId = PluginId "callHierarchy"
+
 -- | Render prepare call hierarchy request.
 prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy
-prepareCallHierarchy state pluginId param
-  | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri =
-    liftIO (runAction "CallHierarchy.prepareHierarchy" state (prepareCallHierarchyItem nfp pos)) >>=
-      \case
-        Just items -> pure $ Right $ Just $ List items
-        Nothing    -> pure $ Right Nothing
-  | otherwise = pure $ Left $ responseError $ T.pack $ "Call Hierarchy: uriToNormalizedFilePath failed for: " <> show uri
-  where
-    uri = param ^. (L.textDocument . L.uri)
-    pos = param ^. L.position
+prepareCallHierarchy state pluginId param = pluginResponse $ do
+    nfp <- getNormalizedFilePath pluginId (param ^. L.textDocument)
+    items <- liftIO (runAction "CallHierarchy.prepareHierarchy" state (prepareCallHierarchyItem nfp (param ^. L.position)))
+    pure (List <$> items)
 
 prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem])
 prepareCallHierarchyItem = constructFromAst
@@ -196,13 +197,13 @@ deriving instance Ord Value
 
 -- | Render incoming calls request.
 incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls
-incomingCalls state pluginId param = do
-  liftIO $ runAction "CallHierarchy.incomingCalls" state $
+incomingCalls state pluginId param = pluginResponse $ do
+  calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state $
       queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall
-        mergeIncomingCalls >>=
-    \case
-      Just x  -> pure $ Right $ Just $ List x
-      Nothing -> pure $ Left $ responseError "CallHierarchy: IncomingCalls internal error"
+        mergeIncomingCalls
+  case calls of
+    Just x  -> pure $ Just $ List x
+    Nothing -> throwPluginError callHierarchyId "Internal Error" "incomingCalls"
   where
     mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
     mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall
@@ -217,13 +218,13 @@ incomingCalls state pluginId param = do
 
 -- Render outgoing calls request.
 outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls
-outgoingCalls state pluginId param = do
-  liftIO $ runAction "CallHierarchy.outgoingCalls" state $
+outgoingCalls state pluginId param = pluginResponse $ do
+  calls <- liftIO $ runAction "CallHierarchy.outgoingCalls" state $
       queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall
-        mergeOutgoingCalls >>=
-    \case
-      Just x  -> pure $ Right $ Just $ List x
-      Nothing -> pure $ Left $ responseError "CallHierarchy: OutgoingCalls internal error"
+        mergeOutgoingCalls
+  case calls of
+      Just x  -> pure $ Just $ List x
+      Nothing -> throwPluginError callHierarchyId "Internal Error" "outgoingCalls"
   where
     mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
     mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall

plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs

@@ -12,6 +12,7 @@ import           Control.Monad.Trans.Except     (ExceptT)
 import           Data.Foldable                  (asum)
 import qualified Data.HashMap.Strict            as Map
 import           Data.Maybe                     (mapMaybe)
+import           Data.String                    (IsString)
 import           Data.Text                      (Text)
 import qualified Data.Text                      as T
 import           Development.IDE                (realSrcSpanToRange)
@@ -22,19 +23,22 @@ import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Util       (printOutputable)
 import           Generics.SYB                   (extQ, something)
 import           Ide.PluginUtils                (getNormalizedFilePath,
-                                                 handleMaybeM, response)
+                                                 handleMaybeM, pluginResponse)
 import           Ide.Types                      (PluginDescriptor (..),
-                                                 PluginId, PluginMethodHandler,
+                                                 PluginMethodHandler,
                                                  defaultPluginDescriptor,
                                                  mkPluginHandler)
 import           Language.LSP.Types
 import           Text.Regex.TDFA                ((=~))
 
-descriptor :: PluginId -> PluginDescriptor IdeState
-descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler }
+changeTypeSignatureId :: IsString a => a
+changeTypeSignatureId = "changeTypeSignature"
+
+descriptor :: PluginDescriptor IdeState
+descriptor = (defaultPluginDescriptor changeTypeSignatureId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler }
 
 codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
-codeActionHandler ideState plId CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = response $ do
+codeActionHandler ideState plId CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = pluginResponse $ do
       nfp <- getNormalizedFilePath plId uri
       decls <- getDecls ideState nfp
       let actions = mapMaybe (generateAction uri decls) diags
@@ -44,7 +48,7 @@ getDecls :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m [LHs
 getDecls state = handleMaybeM "Error: Could not get Parsed Module"
     . liftIO
     . fmap (fmap (hsmodDecls . unLoc . pm_parsed_source))
-    . runAction "changeSignature.GetParsedModule" state
+    . runAction (changeTypeSignatureId <> ".GetParsedModule") state
     . use GetParsedModule
 
 -- | Text representing a Declaration's Name
@@ -146,7 +150,7 @@ stripSignature (T.filter (/= '\n') -> sig) = if T.isInfixOf " => " sig
 
 changeSigToCodeAction :: Uri -> ChangeSignature -> Command |? CodeAction
 changeSigToCodeAction uri ChangeSignature{..} = InR CodeAction { _title       = mkChangeSigTitle declName actualType
-                                                               , _kind        = Just (CodeActionUnknown "quickfix.changeSignature")
+                                                               , _kind        = Just (CodeActionUnknown ("quickfix." <> changeTypeSignatureId))
                                                                , _diagnostics = Just $ List [diagnostic]
                                                                , _isPreferred = Nothing
                                                                , _disabled    = Nothing

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

@@ -48,14 +48,13 @@ import           Development.IDE                 (GetModSummary (..),
                                                   GhcSessionIO (..), IdeState,
                                                   ModSummaryResult (..),
                                                   NeedsCompilation (NeedsCompilation),
-                                                  evalGhcEnv,
+                                                  VFSModified (..), evalGhcEnv,
                                                   hscEnvWithImportPaths,
                                                   printOutputable, runAction,
                                                   textToStringBuffer,
                                                   toNormalizedFilePath',
                                                   uriToFilePath', useNoFile_,
-                                                  useWithStale_, use_,
-                                                  VFSModified(..))
+                                                  useWithStale_, use_)
 import           Development.IDE.Core.Rules      (GhcSessionDepsConfig (..),
                                                   ghcSessionDepsDefinition)
 import           Development.IDE.GHC.Compat      hiding (typeKind, unitState)
@@ -91,7 +90,8 @@ import           Ide.Plugin.Eval.Code            (Statement, asStatements,
                                                   evalSetup, myExecStmt,
                                                   propSetup, resultRange,
                                                   testCheck, testRanges)
-import           Ide.Plugin.Eval.Config          (getEvalConfig, EvalConfig(..))
+import           Ide.Plugin.Eval.Config          (EvalConfig (..),
+                                                  getEvalConfig)
 import           Ide.Plugin.Eval.GHC             (addImport, addPackages,
                                                   hasPackage, showDynFlags)
 import           Ide.Plugin.Eval.Parse.Comments  (commentsToSections)
@@ -101,7 +101,7 @@ import           Ide.Plugin.Eval.Types
 import           Ide.Plugin.Eval.Util            (gStrictTry, isLiterate,
                                                   logWith, response', timed)
 import           Ide.PluginUtils                 (handleMaybe, handleMaybeM,
-                                                  response)
+                                                  pluginResponse)
 import           Ide.Types
 import           Language.LSP.Server
 import           Language.LSP.Types              hiding
@@ -127,7 +127,7 @@ codeLens st plId CodeLensParams{_textDocument} =
     let dbg = logWith st
         perf = timed dbg
      in perf "codeLens" $
-            response $ do
+            pluginResponse $ do
                 let TextDocumentIdentifier uri = _textDocument
                 fp <- handleMaybe "uri" $ uriToFilePath' uri
                 let nfp = toNormalizedFilePath' fp

plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs

@@ -12,17 +12,18 @@
 module Ide.Plugin.Rename (descriptor) where
 
 #if MIN_VERSION_ghc(9,2,1)
-import           GHC.Parser.Annotation                 (AnnContext, AnnList, AnnParen, AnnPragma)
+import           GHC.Parser.Annotation                 (AnnContext, AnnList,
+                                                        AnnParen, AnnPragma)
 #endif
 
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Except
 import           Data.Generics
+import           Data.Hashable
 import           Data.HashSet                          (HashSet)
 import qualified Data.HashSet                          as HS
-import           Data.Hashable
 import           Data.List.Extra
 import qualified Data.Map                              as M
 import           Data.Maybe
@@ -63,7 +64,7 @@ descriptor pluginId = (defaultPluginDescriptor pluginId)
 
 renameProvider :: PluginMethodHandler IdeState TextDocumentRename
 renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) =
-    response $ do
+    pluginResponse $ do
         nfp <- safeUriToNfp uri
         oldName <- getNameAtPos state nfp pos
         refLocs <- refsAtName state nfp oldName

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

@@ -37,9 +37,9 @@ import           Data.Bifunctor                       (Bifunctor (first),
 import qualified Data.ByteString                      as BS
 import           Data.Coerce
 import           Data.Either                          (partitionEithers)
+import           Data.Hashable                        (unhashed)
 import qualified Data.HashMap.Strict                  as HM
 import qualified Data.HashSet                         as Set
-import           Data.Hashable                        (unhashed)
 import           Data.IORef.Extra                     (atomicModifyIORef'_,
                                                        newIORef, readIORef)
 import           Data.List.Extra                      (find, nubOrdOn)
@@ -101,9 +101,9 @@ import qualified Retrie.GHC                           as GHC
 import           Retrie.Monad                         (addImports, apply,
                                                        getGroundTerms,
                                                        runRetrie)
+import qualified Retrie.Options                       as Retrie
 import           Retrie.Options                       (defaultOptions,
                                                        getTargetFiles)
-import qualified Retrie.Options                       as Retrie
 import           Retrie.Replace                       (Change (..),
                                                        Replacement (..))
 import           Retrie.Rewrites
@@ -188,7 +188,7 @@ extractImports _ _ _ = []
 -------------------------------------------------------------------------------
 
 provider :: PluginMethodHandler IdeState TextDocumentCodeAction
-provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = response $ do
+provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = pluginResponse $ do
   let (J.CodeActionContext _diags _monly) = ca
       nuri = toNormalizedUri uri
   nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri