Add throwPluginError to Plugin Utilities (#2924)

* Add new PluginUtility function.

Add the function `throwPluginError`. This function is intended to
provide a common `ResponseError` message for use in logging.

Renamed `response` to `pluginResponse` for more clarity.

* Call hierarchy clean up

* Make Descriptor usable as String/Text or PluginID

* Update reference to ChangeTypeSignature descriptor

* Use unpack rather than show

* Import cleanup

* Merge cleanup

* Fix test suites for effected plugins

* forgot to change the CodeAction kind in the test suite...

* Update new plugin

Author: drsooch

exe/Plugins.hs

@@ -157,7 +157,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
       Brittany.descriptor "brittany" :
 #endif
 #if callHierarchy
-      CallHierarchy.descriptor "callHierarchy":
+      CallHierarchy.descriptor :
 #endif
 #if class
       Class.descriptor "class" :
@@ -187,13 +187,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
 #if gadt
       GADT.descriptor "gadt" :

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

@@ -28,14 +28,14 @@ module Ide.PluginUtils
     positionInRange,
     usePropertyLsp,
     getNormalizedFilePath,
-    response,
+    pluginResponse,
     handleMaybe,
     handleMaybeM,
+    throwPluginError
     )
 where
 
 
-import           Control.Lens                    ((^.))
 import           Control.Monad.Extra             (maybeM)
 import           Control.Monad.Trans.Class       (lift)
 import           Control.Monad.Trans.Except      (ExceptT, runExceptT, throwE)
@@ -253,13 +253,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

@@ -8,6 +8,7 @@ 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 +32,22 @@ 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)
+import qualified Language.LSP.Types.Lens         as L
 
 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,8 +87,8 @@ 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
-    nfp <- getNormalizedFilePath plId (docId ^. uri)
+codeActionHandler state plId (CodeActionParams _ _ docId currRange _) = pluginResponse $ do
+    nfp <- getNormalizedFilePath plId (docId ^. L.uri)
     CLR{..} <- requestLiterals state nfp
     pragma <- getFirstPragma state nfp
         -- remove any invalid literals (see validTarget comment)
@@ -144,14 +148,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
+        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-alternate-number-format-plugin/test/Main.hs

@@ -21,7 +21,7 @@ main :: IO ()
 main = defaultTestRunner test
 
 alternateNumberFormatPlugin :: PluginDescriptor IdeState
-alternateNumberFormatPlugin = AlternateNumberFormat.descriptor mempty "alternateNumberFormat"
+alternateNumberFormatPlugin = AlternateNumberFormat.descriptor mempty
 
 -- NOTE: For whatever reason, this plugin does not play nice with creating Code Actions on time.
 -- As a result tests will mostly pass if `import Prelude` is added at the top. We (mostly fendor) surmise this has something

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 ^. L.uri)
+    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-call-hierarchy-plugin/test/Main.hs

@@ -22,7 +22,7 @@ import           Test.Hls
 import           Test.Hls.Util            (withCanonicalTempDir)
 
 plugin :: PluginDescriptor IdeState
-plugin = descriptor "callHierarchy"
+plugin = descriptor
 
 main :: IO ()
 main = defaultTestRunner $

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-change-type-signature-plugin/test/Main.hs

@@ -32,7 +32,7 @@ main :: IO ()
 main = defaultTestRunner test
 
 changeTypeSignaturePlugin :: PluginDescriptor IdeState
-changeTypeSignaturePlugin = ChangeTypeSignature.descriptor "changeTypeSignature"
+changeTypeSignaturePlugin = ChangeTypeSignature.descriptor
 
 test :: TestTree
 test = testGroup "changeTypeSignature" [
@@ -112,8 +112,8 @@ findChangeTypeActions = pure . filter isChangeTypeAction . rights . map toEither
         isChangeTypeAction CodeAction{_kind} = case _kind of
           Nothing -> False
           Just kind -> case kind of
-            "quickfix.changeSignature" -> True
-            _                          -> False
+            "quickfix.changeTypeSignature" -> True
+            _                              -> False
 
 
 regexTest :: FilePath -> Text -> Bool -> TestTree

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