diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 3999846837..0ff759597b 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -153,6 +153,7 @@ library Development.IDE.Core.FileUtils Development.IDE.Core.IdeConfiguration Development.IDE.Core.OfInterest + Development.IDE.Core.PluginUtils Development.IDE.Core.PositionMapping Development.IDE.Core.Preprocessor Development.IDE.Core.ProgressReporting diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs new file mode 100644 index 0000000000..32a82d6b1a --- /dev/null +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE GADTs #-} +module Development.IDE.Core.PluginUtils where + +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Reader (runReaderT) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Either.Extra (maybeToEither) +import Data.Functor.Identity +import qualified Data.Text as T +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Shake (IdeAction, IdeRule, + IdeState (shakeExtras), + mkDelayedAction, + shakeEnqueue) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Orphans () +import Development.IDE.Graph hiding (ShakeValue) +import Development.IDE.Types.Location (NormalizedFilePath) +import qualified Development.IDE.Types.Location as Location +import qualified Development.IDE.Types.Logger as Logger +import qualified Ide.PluginUtils as PluginUtils +import qualified Language.LSP.Types as LSP +import Prettyprinter +import Prettyprinter.Render.Text (renderStrict) + +-- ---------------------------------------------------------------------------- +-- Plugin Error wrapping +-- ---------------------------------------------------------------------------- + +data GhcidePluginError + = forall a . Show a => FastRuleNotReady a + | forall a . Show a => RuleFailed a + | CoreError PluginUtils.PluginError + +instance Pretty GhcidePluginError where + pretty = \case + FastRuleNotReady rule -> "FastRuleNotReady:" <+> viaShow rule + RuleFailed rule -> "RuleFailed:" <+> viaShow rule + CoreError perror -> pretty $ PluginUtils.prettyPluginError perror + +pluginResponse :: + Monad m => + ExceptT GhcidePluginError m a -> + m (Either LSP.ResponseError a) +pluginResponse = PluginUtils.pluginResponse' handlePluginError + +withPluginError :: Functor m => ExceptT PluginUtils.PluginError m a -> ExceptT GhcidePluginError m a +withPluginError = PluginUtils.withError CoreError + +mkPluginErrorMessage :: T.Text -> GhcidePluginError +mkPluginErrorMessage = CoreError . PluginUtils.mkPluginErrorMessage + +handlePluginError :: GhcidePluginError -> LSP.ResponseError +handlePluginError msg = PluginUtils.mkSimpleResponseError $ renderStrict simpleDoc + where + simpleDoc = layoutPretty defaultLayoutOptions $ pretty msg + +-- ---------------------------------------------------------------------------- +-- Action wrappers +-- ---------------------------------------------------------------------------- + +runAction :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a +runAction herald ide act = + PluginUtils.hoistExceptT . ExceptT $ + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act) + +-- | Request a Rule result, it not available return the last computed result which may be stale. +-- Errors out if none available. +useWithStale_ ::(IdeRule k v) + => k -> NormalizedFilePath -> ExceptT e Action (v, PositionMapping) +useWithStale_ key file = ExceptT $ fmap Right $ Shake.useWithStale_ key file + +useWithStale :: IdeRule k v + => k -> NormalizedFilePath -> ExceptT GhcidePluginError Action (v, PositionMapping) +useWithStale key file = maybeToExceptT (FastRuleNotReady key) $ useWithStaleMaybeT key file + +-- | useE is useful to implement functions that aren’t rules but need shortcircuiting +-- e.g. getDefinition. +use :: IdeRule k v => k -> NormalizedFilePath -> ExceptT GhcidePluginError Action v +use k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.use k + +useWithStaleMaybeT :: IdeRule k v + => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping) +useWithStaleMaybeT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) + +-- ---------------------------------------------------------------------------- +-- IdeAction wrappers +-- ---------------------------------------------------------------------------- + +runIdeAction :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a +runIdeAction _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ runExceptT i) s + +-- | useE is useful to implement functions that aren’t rules but need shortcircuiting +-- e.g. getDefinition. +useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> ExceptT GhcidePluginError IdeAction (v, PositionMapping) +useWithStaleFast k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.useWithStaleFast k + +uriToFilePath' :: Monad m => LSP.Uri -> ExceptT GhcidePluginError m FilePath +uriToFilePath' uri = ExceptT . pure . maybeToEither (CoreError $ PluginUtils.PluginUriToFilePath uri) $ Location.uriToFilePath' uri + +-- ---------------------------------------------------------------------------- +-- Internal Helper function, not exported +-- ---------------------------------------------------------------------------- + +hoistAction :: Action a -> ExceptT e Action a +hoistAction = ExceptT . fmap Right diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 9118dc68d7..66b8189c33 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -35,6 +35,8 @@ import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP import Control.Monad +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) import qualified Development.IDE.Core.FileExists as FileExists import qualified Development.IDE.Core.OfInterest as OfInterest import Development.IDE.Core.Shake hiding (Log) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 18152a5421..1f9c554ea0 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -77,7 +77,7 @@ module Development.IDE.Core.Shake( garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, Log(..), - VFSModified(..), getClientConfigAction + VFSModified(..), getClientConfigAction, ) where import Control.Concurrent.Async @@ -964,11 +964,15 @@ useWithStale key file = runIdentity <$> usesWithStale key (Identity file) -- | Request a Rule result, it not available return the last computed result which may be stale. -- Errors out if none available. +-- +-- The thrown error is a 'BadDependency' error which is caught by the rule system. useWithStale_ :: IdeRule k v => k -> NormalizedFilePath -> Action (v, PositionMapping) useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) -- | Plural version of 'useWithStale_' +-- +-- The thrown error is a 'BadDependency' error which is caught by the rule system. usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do res <- usesWithStale key files diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 609134c5ab..1a0d16d733 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -2,6 +2,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# HLINT ignore #-} + module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 806dca3969..06ba065751 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -28,9 +28,9 @@ import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, define, srcSpanToRange, - usePropertyAction, - useWithStale) + usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.Core.Rules (IdeState, runAction) @@ -51,7 +51,8 @@ import Development.IDE.Types.Logger (Pretty (pretty), cmapWithPrio) import GHC.Generics (Generic) import Ide.Plugin.Properties -import Ide.PluginUtils +import Ide.PluginUtils (getNormalizedFilePath, + mkLspCommand) import Ide.Types (CommandFunction, CommandId (CommandId), PluginCommand (PluginCommand), @@ -103,28 +104,22 @@ properties = emptyProperties ] Always codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens -codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do +codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = PluginUtils.pluginResponse $ do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties - nfp <- getNormalizedFilePath uri - env <- hscEnv . fst - <$> (handleMaybeM "Unable to get GhcSession" - $ liftIO - $ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp) - ) - tmr <- fst <$> ( - handleMaybeM "Unable to TypeCheck" - $ liftIO - $ runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck nfp) - ) - bindings <- fst <$> ( - handleMaybeM "Unable to GetBindings" - $ liftIO - $ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp) - ) + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + env <- hscEnv . fst <$> + PluginUtils.runAction "codeLens.GhcSession" ideState + (PluginUtils.useWithStale GhcSession nfp) + + (tmr, _) <- PluginUtils.runAction "codeLens.TypeCheck" ideState + (PluginUtils.useWithStale TypeCheck nfp) + + (bindings, _) <- PluginUtils.runAction "codeLens.GetBindings" ideState + (PluginUtils.useWithStale GetBindings nfp) + (gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <- - handleMaybeM "Unable to GetGlobalBindingTypeSigs" - $ liftIO - $ runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs nfp) + PluginUtils.runAction "codeLens.GetGlobalBindingTypeSigs" ideState + (PluginUtils.useWithStale GetGlobalBindingTypeSigs nfp) diag <- liftIO $ atomically $ getDiagnostics ideState hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index 6e00769922..dae94d42fc 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -15,7 +15,7 @@ import qualified Data.List as List import qualified Data.Maybe as Maybe import Data.Text (Text, pack) import qualified Data.Text as Text -import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv) +import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import qualified Language.LSP.Types as LSP @@ -23,7 +23,8 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT) import Ide.Types (PluginId(..)) import qualified Data.Text as T -import Ide.PluginUtils (handleMaybeM) +import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils (GhcidePluginError) getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo getNextPragmaInfo dynFlags sourceText = @@ -51,13 +52,13 @@ insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit prag pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0 pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition -getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo -getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do - ghcSession <- liftIO $ runAction (T.unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp - (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp +getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT GhcidePluginError m NextPragmaInfo +getFirstPragma (PluginId pId) state nfp = do + ghcSession <- PluginUtils.runAction (T.unpack pId <> ".GhcSession") state $ PluginUtils.useWithStale GhcSession nfp + (_, fileContents) <- PluginUtils.runAction (T.unpack pId <> ".GetFileContents") state $ PluginUtils.hoistAction $ getFileContents nfp case ghcSession of - Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents - Nothing -> pure Nothing + (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> + pure $ getNextPragmaInfo sessionDynFlags fileContents -- Pre-declaration comments parser ----------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 14da81039a..017f7e2acd 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Ide.PluginUtils @@ -30,11 +31,22 @@ module Ide.PluginUtils subRange, positionInRange, usePropertyLsp, - getNormalizedFilePath, + -- * Plugin Error Handling API + PluginError(..), pluginResponse, + pluginResponse', + pluginResponseM, + prettyPluginError, + handlePluginError, + mkPluginErrorMessage, + hoistExceptT, handleMaybe, handleMaybeM, - throwPluginError, + mkSimpleResponseError, + withError, + -- * Batteries-included plugin error API + getNormalizedFilePath, + -- * Escape unescape, ) where @@ -43,15 +55,17 @@ where import Control.Arrow ((&&&)) import Control.Lens ((^.)) import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, + runExceptT, throwE, + withExceptT) import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Bifunctor (Bifunctor (first)) import Data.Char (isPrint, showLitChar) import Data.Functor (void) import qualified Data.HashMap.Strict as H -import Data.String (IsString (fromString)) import qualified Data.Text as T import Data.Void (Void) import Ide.Plugin.Config @@ -263,16 +277,52 @@ allLspCmdIds pid commands = concatMap go commands -- --------------------------------------------------------------------- -getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath -getNormalizedFilePath uri = handleMaybe errMsg +getNormalizedFilePath :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath +getNormalizedFilePath uri = handleMaybe (PluginUriToNormalizedFilePath uri) $ uriToNormalizedFilePath $ toNormalizedUri uri - where - errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath" -- --------------------------------------------------------------------- -throwPluginError :: Monad m => String -> ExceptT String m b -throwPluginError = throwE + +type PluginHandler e m a = ExceptT e m a + +pluginResponse :: Monad m => ExceptT PluginError m a -> m (Either ResponseError a) +pluginResponse = + fmap (first handlePluginError) + . runExceptT + +pluginResponse' :: Monad m => (e -> ResponseError) -> ExceptT e m a -> m (Either ResponseError a) +pluginResponse' handleError = + fmap (first handleError) + . runExceptT + +pluginResponseM :: Monad m => (t -> m (Either a b)) -> ExceptT t m b -> m (Either a b) +pluginResponseM handler act = + runExceptT act >>= \case + Right r -> pure $ Right r + Left err -> handler err + +handlePluginError :: PluginError -> ResponseError +handlePluginError msg = ResponseError InternalError (prettyPluginError msg) Nothing + +data PluginError + = PluginInternalError + | PluginUriToFilePath J.Uri + | PluginUriToNormalizedFilePath J.Uri + | PluginErrorMessage T.Text + +prettyPluginError :: PluginError -> T.Text +prettyPluginError = \case + PluginInternalError -> "Internal Plugin Error" + PluginUriToFilePath uri -> "Failed to translate URI " <> T.pack (show uri) + PluginUriToNormalizedFilePath uri -> "Failed converting " <> getUri uri <> " to NormalizedFilePath" + PluginErrorMessage msg -> "Plugin failed: " <> msg + +mkPluginErrorMessage :: T.Text -> PluginError +mkPluginErrorMessage = PluginErrorMessage + +mkSimpleResponseError :: T.Text -> ResponseError +mkSimpleResponseError err = ResponseError InternalError err Nothing handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return @@ -280,10 +330,11 @@ 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 -pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a) -pluginResponse = - fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) - . runExceptT +withError :: Functor m => (e' -> e) -> ExceptT e' m a -> ExceptT e m a +withError = withExceptT + +hoistExceptT :: MonadIO m => ExceptT e IO a -> ExceptT e m a +hoistExceptT = mapExceptT liftIO -- --------------------------------------------------------------------- diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index 3b90cec4fb..fb558d40ec 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -4,35 +4,36 @@ {-# LANGUAGE TypeOperators #-} module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where -import Control.Lens ((^.)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Except (ExceptT) -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text, unpack) -import qualified Data.Text as T -import Development.IDE (GetParsedModule (GetParsedModule), - IdeState, RuleResult, Rules, - define, realSrcSpanToRange, - runAction, use) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat hiding (getSrcSpan) -import Development.IDE.GHC.Util (getExtensions) -import Development.IDE.Graph.Classes (Hashable, NFData, rnf) -import Development.IDE.Spans.Pragmas (NextPragmaInfo, getFirstPragma, - insertNewPragma) -import Development.IDE.Types.Logger as Logger -import GHC.Generics (Generic) -import Ide.Plugin.Conversion (AlternateFormat, - ExtensionNeeded (NeedsExtension, NoExtension), - alternateFormat) +import Control.Lens ((^.)) +import Control.Monad.Except (ExceptT) +import Control.Monad.IO.Class (MonadIO) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text, unpack) +import qualified Data.Text as T +import Development.IDE (GetParsedModule (GetParsedModule), + IdeState, RuleResult, Rules, + define, realSrcSpanToRange, + use) +import qualified Development.IDE.Core.PluginUtils as PluginUtils +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (getSrcSpan) +import Development.IDE.GHC.Util (getExtensions) +import Development.IDE.Graph.Classes (Hashable, NFData, rnf) +import Development.IDE.Spans.Pragmas (NextPragmaInfo, + getFirstPragma, + insertNewPragma) +import Development.IDE.Types.Logger as Logger +import GHC.Generics (Generic) +import Ide.Plugin.Conversion (AlternateFormat, + ExtensionNeeded (NeedsExtension, NoExtension), + alternateFormat) import Ide.Plugin.Literals -import Ide.Plugin.RangeMap (RangeMap) -import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybeM, pluginResponse) +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.PluginUtils (getNormalizedFilePath) import Ide.Types import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Lens as L newtype Log = LogShake Shake.Log deriving Show @@ -80,8 +81,8 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec pure ([], CLR <$> litMap <*> exts) codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction -codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginResponse $ do - nfp <- getNormalizedFilePath (docId ^. L.uri) +codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (docId ^. L.uri) CLR{..} <- requestLiterals pId state nfp pragma <- getFirstPragma pId state nfp -- remove any invalid literals (see validTarget comment) @@ -127,8 +128,7 @@ mkCodeActionTitle lit (alt, ext) ghcExts needsExtension :: Extension -> [GhcExtension] -> Bool needsExtension ext ghcExts = ext `notElem` map unExt ghcExts -requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult -requestLiterals (PluginId pId) state = handleMaybeM "Could not Collect Literals" - . liftIO - . runAction (unpack pId <> ".CollectLiterals") state - . use CollectLiterals +requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError m CollectLiteralsResult +requestLiterals (PluginId pId) state = + PluginUtils.runAction (unpack pId <> ".CollectLiterals") state + . PluginUtils.use CollectLiterals diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 2b23688fd3..cfaabad108 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -13,34 +13,34 @@ module Ide.Plugin.CallHierarchy.Internal ( , outgoingCalls ) where -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.IO.Class -import Data.Aeson as A -import Data.List (groupBy, sortBy) -import qualified Data.Map as M +import Data.Aeson as A +import Data.List (groupBy, sortBy) +import qualified Data.Map as M import Data.Maybe -import qualified Data.Set as S -import qualified Data.Text as T +import qualified Data.Set as S +import qualified Data.Text as T import Data.Tuple.Extra import Development.IDE +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat as Compat import Development.IDE.Spans.AtPoint -import HieDb (Symbol (Symbol)) -import qualified Ide.Plugin.CallHierarchy.Query as Q +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.PluginUtils (getNormalizedFilePath, + handleMaybe) import Ide.Types import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L -import Text.Read (readMaybe) +import qualified Language.LSP.Types.Lens as L +import Text.Read (readMaybe) -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy -prepareCallHierarchy state _ param = pluginResponse $ do - nfp <- getNormalizedFilePath (param ^. L.textDocument ^. L.uri) +prepareCallHierarchy state _ param = PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (param ^. L.textDocument ^. L.uri) items <- liftIO $ runAction "CallHierarchy.prepareHierarchy" state $ prepareCallHierarchyItem nfp (param ^. L.position) @@ -174,7 +174,7 @@ deriving instance Ord Value -- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls -incomingCalls state pluginId param = pluginResponse $ do +incomingCalls state pluginId param = PluginUtils.pluginResponse $ do calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls @@ -189,7 +189,7 @@ incomingCalls state pluginId param = pluginResponse $ do -- | Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls -outgoingCalls state pluginId param = pluginResponse $ do +outgoingCalls state pluginId param = PluginUtils.pluginResponse $ do calls <- liftIO $ runAction "CallHierarchy.outgoingCalls" state $ queryCalls diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index 5374761a14..5871bae193 100644 --- a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -6,47 +6,45 @@ module Ide.Plugin.ChangeTypeSignature (descriptor , errorMessageRegexes ) where -import Control.Monad (guard) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except (ExceptT) -import Data.Foldable (asum) -import qualified Data.HashMap.Strict as Map -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE (realSrcSpanToRange) -import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule)) -import Development.IDE.Core.Service (IdeState, runAction) -import Development.IDE.Core.Shake (use) +import Control.Monad (guard) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Except (ExceptT) +import Data.Foldable (asum) +import qualified Data.HashMap.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (realSrcSpanToRange) +import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule)) +import Development.IDE.Core.Service (IdeState) import Development.IDE.GHC.Compat -import Development.IDE.GHC.Util (printOutputable) -import Generics.SYB (extQ, something) -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybeM, pluginResponse) -import Ide.Types (PluginDescriptor (..), - PluginId (PluginId), - PluginMethodHandler, - defaultPluginDescriptor, - mkPluginHandler) +import Development.IDE.GHC.Util (printOutputable) +import Generics.SYB (extQ, something) +import Ide.PluginUtils (getNormalizedFilePath) +import Ide.Types (PluginDescriptor (..), + PluginId (PluginId), + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) import Language.LSP.Types -import Text.Regex.TDFA ((=~)) +import Text.Regex.TDFA ((=~)) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeActionHandler plId) } codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'TextDocumentCodeAction -codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = pluginResponse $ do - nfp <- getNormalizedFilePath uri +codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri decls <- getDecls plId ideState nfp let actions = mapMaybe (generateAction plId uri decls) diags pure $ List actions -getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs] -getDecls (PluginId changeTypeSignatureId) state = handleMaybeM "Could not get Parsed Module" - . liftIO - . fmap (fmap (hsmodDecls . unLoc . pm_parsed_source)) - . runAction (T.unpack changeTypeSignatureId <> ".GetParsedModule") state - . use GetParsedModule +getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError m [LHsDecl GhcPs] +getDecls (PluginId changeTypeSignatureId) state = + PluginUtils.runAction (T.unpack changeTypeSignatureId <> ".GetParsedModule") state + . (fmap (hsmodDecls . unLoc . pm_parsed_source)) + . PluginUtils.use GetParsedModule -- | Text representing a Declaration's Name type DeclName = Text diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 3af9ae8ce2..fbe666a86f 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -5,7 +5,6 @@ module Ide.Plugin.Class.CodeAction where -import Control.Applicative (liftA2) import Control.Lens hiding (List, use) import Control.Monad.Extra import Control.Monad.IO.Class (liftIO) @@ -23,11 +22,11 @@ import Data.Maybe (isNothing, listToMaybe, import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.PositionMapping (fromCurrentRange) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.AtPoint (pointCommand) -import GHC.LanguageExtensions.Type import Ide.Plugin.Class.ExactPrint import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils @@ -41,17 +40,13 @@ import qualified Language.LSP.Types.Lens as J addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do caps <- getClientCapabilities - pluginResponse $ do - nfp <- getNormalizedFilePath (verTxtDocId ^. J.uri) - pm <- handleMaybeM "Unable to GetParsedModule" - $ liftIO - $ runAction "classplugin.addMethodPlaceholders.GetParsedModule" state - $ use GetParsedModule nfp - (hsc_dflags . hscEnv -> df) <- handleMaybeM "Unable to GhcSessionDeps" - $ liftIO - $ runAction "classplugin.addMethodPlaceholders.GhcSessionDeps" state - $ use GhcSessionDeps nfp - (old, new) <- handleMaybeM "Unable to makeEditText" + PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (verTxtDocId ^. J.uri) + pm <- PluginUtils.runAction "classplugin.addMethodPlaceholders.GetParsedModule" state + $ PluginUtils.use GetParsedModule nfp + (hsc_dflags . hscEnv -> df) <- PluginUtils.runAction "classplugin.addMethodPlaceholders.GhcSessionDeps" state + $ PluginUtils.use GhcSessionDeps nfp + (old, new) <- handleMaybeM (PluginUtils.mkPluginErrorMessage "Unable to makeEditText") $ liftIO $ runMaybeT $ makeEditText pm df param pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs @@ -82,9 +77,9 @@ addMethodPlaceholders _ state param@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 :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction -codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginResponse $ do +codeAction recorder state plId (CodeActionParams _ _ docId _ context) = PluginUtils.pluginResponse $ do verTxtDocId <- lift $ getVersionedTextDoc docId - nfp <- getNormalizedFilePath (verTxtDocId ^. J.uri) + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (verTxtDocId ^. J.uri) actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags pure $ List actions where @@ -97,21 +92,17 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe :: NormalizedFilePath -> VersionedTextDocumentIdentifier -> Diagnostic - -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] + -> ExceptT PluginUtils.GhcidePluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] mkActions docPath verTxtDocId diag = do - (HAR {hieAst = ast}, pmap) <- handleMaybeM "Unable to GetHieAst" - . liftIO - . runAction "classplugin.findClassIdentifier.GetHieAst" state - $ useWithStale GetHieAst docPath - instancePosition <- handleMaybe "No range" $ + (HAR {hieAst = ast}, pmap) <- PluginUtils.runAction "classplugin.findClassIdentifier.GetHieAst" state + $ PluginUtils.useWithStale GetHieAst docPath + instancePosition <- handleMaybe (PluginUtils.mkPluginErrorMessage "No range") $ fromCurrentRange pmap range ^? _Just . J.start & fmap (J.character -~ 1) ident <- findClassIdentifier ast instancePosition cls <- findClassFromIdentifier docPath ident - InstanceBindTypeSigsResult sigs <- handleMaybeM "Unable to GetInstanceBindTypeSigs" - $ liftIO - $ runAction "classplugin.codeAction.GetInstanceBindTypeSigs" state - $ use GetInstanceBindTypeSigs docPath + InstanceBindTypeSigsResult sigs <- PluginUtils.runAction "classplugin.codeAction.GetInstanceBindTypeSigs" state + $ PluginUtils.use GetInstanceBindTypeSigs docPath implemented <- findImplementedMethods ast instancePosition logWith recorder Info (LogImplementedMethods cls implemented) pure @@ -158,7 +149,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe Nothing findClassIdentifier hf instancePosition = - handleMaybe "No Identifier found" + handleMaybe (PluginUtils.mkPluginErrorMessage "No Identifier found") $ listToMaybe $ mapMaybe listToMaybe $ pointCommand hf instancePosition @@ -169,7 +160,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe findImplementedMethods :: HieASTs a -> Position - -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [T.Text] + -> ExceptT PluginUtils.GhcidePluginError (LspT Ide.Plugin.Config.Config IO) [T.Text] findImplementedMethods asts instancePosition = do pure $ concat @@ -186,15 +177,11 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren ast) findClassFromIdentifier docPath (Right name) = do - (hscEnv -> hscenv, _) <- handleMaybeM "Unable to GhcSessionDeps" - . liftIO - . runAction "classplugin.findClassFromIdentifier.GhcSessionDeps" state - $ useWithStale GhcSessionDeps docPath - (tmrTypechecked -> thisMod, _) <- handleMaybeM "Unable to TypeCheck" - . liftIO - . runAction "classplugin.findClassFromIdentifier.TypeCheck" state - $ useWithStale TypeCheck docPath - handleMaybeM "TcEnv" + (hscEnv -> hscenv, _) <- PluginUtils.runAction "classplugin.findClassFromIdentifier.GhcSessionDeps" state + $ PluginUtils.useWithStale GhcSessionDeps docPath + (tmrTypechecked -> thisMod, _) <- PluginUtils.runAction "classplugin.findClassFromIdentifier.TypeCheck" state + $ PluginUtils.useWithStale TypeCheck docPath + handleMaybeM (PluginUtils.CoreError PluginInternalError) . liftIO . fmap snd . initTcWithGbl hscenv thisMod ghostSpan $ do @@ -203,7 +190,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe AGlobal (AConLike (RealDataCon con)) | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls _ -> fail "Ide.Plugin.Class.findClassFromIdentifier" - findClassFromIdentifier _ (Left _) = throwE "Ide.Plugin.Class.findClassIdentifier" + findClassFromIdentifier _ (Left _) = throwE (PluginUtils.mkPluginErrorMessage "Ide.Plugin.Class.findClassIdentifier") isClassNodeIdentifier :: IdentifierDetails a -> Bool isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` identInfo ident diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs index 1b3b4f10f3..66a1a5685e 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -6,15 +6,14 @@ module Ide.Plugin.Class.CodeLens where import Control.Lens ((^.)) -import Control.Monad.IO.Class (liftIO) import Data.Aeson import Data.Maybe (mapMaybe, maybeToList) import qualified Data.Text as T import Development.IDE +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import GHC.LanguageExtensions.Type import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils import Ide.PluginUtils @@ -24,23 +23,18 @@ import Language.LSP.Types import qualified Language.LSP.Types.Lens as J codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens -codeLens state plId CodeLensParams{..} = pluginResponse $ do - nfp <- getNormalizedFilePath uri - (tmr, _) <- handleMaybeM "Unable to typecheck" - $ liftIO - $ runAction "classplugin.TypeCheck" state +codeLens state plId CodeLensParams{..} = PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + (tmr, _) <- PluginUtils.runAction "classplugin.TypeCheck" state -- Using stale results means that we can almost always return a value. In practice -- this means the lenses don't 'flicker' - $ useWithStale TypeCheck nfp + $ PluginUtils.useWithStale TypeCheck nfp -- All instance binds - (InstanceBindTypeSigsResult allBinds, mp) <- - handleMaybeM "Unable to get InstanceBindTypeSigsResult" - $ liftIO - $ runAction "classplugin.GetInstanceBindTypeSigs" state + (InstanceBindTypeSigsResult allBinds, mp) <- PluginUtils.runAction "classplugin.GetInstanceBindTypeSigs" state -- Using stale results means that we can almost always return a value. In practice -- this means the lenses don't 'flicker' - $ useWithStale GetInstanceBindTypeSigs nfp + $ PluginUtils.useWithStale GetInstanceBindTypeSigs nfp pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs index 31dbd021a2..caadd3211a 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -2,17 +2,18 @@ module Ide.Plugin.Class.Utils where -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except -import Data.Char (isAlpha) -import Data.List (isPrefixOf) -import Data.String (IsString) -import qualified Data.Text as T +import Data.Char (isAlpha) +import Data.List (isPrefixOf) +import Data.String (IsString) +import qualified Data.Text as T import Development.IDE +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import Development.IDE.Spans.Pragmas (getNextPragmaInfo, - insertNewPragma) +import Development.IDE.Spans.Pragmas (getNextPragmaInfo, + insertNewPragma) import Ide.PluginUtils import Language.LSP.Types @@ -54,19 +55,15 @@ insertPragmaIfNotPresent :: (MonadIO m) => IdeState -> NormalizedFilePath -> Extension - -> ExceptT String m [TextEdit] + -> ExceptT PluginUtils.GhcidePluginError m [TextEdit] insertPragmaIfNotPresent state nfp pragma = do - (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- handleMaybeM "Unable to get GhcSession" - $ liftIO - $ runAction "classplugin.insertPragmaIfNotPresent.GhcSession" state - $ useWithStale GhcSession nfp - (_, fileContents) <- liftIO - $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- PluginUtils.runAction "classplugin.insertPragmaIfNotPresent.GhcSession" state + $ PluginUtils.useWithStale GhcSession nfp + (_, fileContents) <- PluginUtils.runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state + $ PluginUtils.hoistAction $ getFileContents nfp - (pm, _) <- handleMaybeM "Unable to GetParsedModuleWithComments" - $ liftIO - $ runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state - $ useWithStale GetParsedModuleWithComments nfp + (pm, _) <- PluginUtils.runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state + $ PluginUtils.useWithStale GetParsedModuleWithComments nfp let exts = getExtensions pm info = getNextPragmaInfo sessionDynFlags fileContents pure [insertNewPragma info pragma | pragma `notElem` exts] diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs index d6dfd2820a..5f8c6f5636 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,12 +14,10 @@ module Ide.Plugin.CodeRange ( , createFoldingRange ) where -import Control.Monad.Except (ExceptT (ExceptT), - mapExceptT) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) -import Data.Either.Extra (maybeToEither) import Data.List.Extra (drop1) import Data.Maybe (fromMaybe) import Data.Vector (Vector) @@ -27,11 +26,8 @@ import Development.IDE (Action, IdeAction, IdeState (shakeExtras), Range (Range), Recorder, WithPriority, - cmapWithPrio, runAction, - runIdeAction, - toNormalizedFilePath', - uriToFilePath', use, - useWithStaleFast) + cmapWithPrio) +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) @@ -42,13 +38,16 @@ import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), codeRangeRule, crkToFrk) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) -import Ide.PluginUtils (pluginResponse, - positionInRange) +import Ide.PluginUtils (getNormalizedFilePath, + mkSimpleResponseError, + pluginResponseM, + positionInRange, + withError) import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), PluginId, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Server (LspM, LspT) +import Language.LSP.Server (LspM) import Language.LSP.Types (FoldingRange (..), FoldingRangeParams (..), List (List), @@ -79,40 +78,31 @@ instance Pretty Log where LogBadDependency rule -> pretty $ "bad dependency: " <> show rule foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) -foldingRangeHandler recorder ide _ FoldingRangeParams{..} = do - pluginResponse $ do - filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ - toNormalizedFilePath' <$> uriToFilePath' uri - foldingRanges <- mapExceptT runAction' $ - getFoldingRanges filePath +foldingRangeHandler recorder ide _ FoldingRangeParams{..} = + pluginResponseM handleErrors $ do + filePath <- withError PluginUtils.CoreError $ getNormalizedFilePath uri + foldingRanges <- PluginUtils.runAction "FoldingRange" ide $ getFoldingRanges filePath pure . List $ foldingRanges where uri :: Uri TextDocumentIdentifier uri = _textDocument - runAction' :: Action (Either FoldingRangeError [FoldingRange]) -> LspT c IO (Either String [FoldingRange]) - runAction' action = do - result <- liftIO $ runAction "FoldingRange" ide action - case result of - Left err -> case err of - FoldingRangeBadDependency rule -> do - logWith recorder Warning $ LogBadDependency rule - pure $ Right [] - Right list -> pure $ Right list + handleErrors = \case + PluginUtils.RuleFailed rule -> do + logWith recorder Warning $ LogBadDependency rule + pure $ Right $ List [] + errs -> pure $ Left $ PluginUtils.handlePluginError errs -data FoldingRangeError = forall rule. Show rule => FoldingRangeBadDependency rule - -getFoldingRanges :: NormalizedFilePath -> ExceptT FoldingRangeError Action [FoldingRange] +getFoldingRanges :: NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError Action [FoldingRange] getFoldingRanges file = do - codeRange <- maybeToExceptT (FoldingRangeBadDependency GetCodeRange) . MaybeT $ use GetCodeRange file + codeRange <- PluginUtils.use GetCodeRange file pure $ findFoldingRanges codeRange selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do - pluginResponse $ do - filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ - toNormalizedFilePath' <$> uriToFilePath' uri - fmap List . mapExceptT runIdeAction' . getSelectionRanges filePath $ positions + pluginResponseM handleErrors $ do + filePath <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath uri + fmap List . runIdeAction' $ getSelectionRanges filePath positions where uri :: Uri TextDocumentIdentifier uri = _textDocument @@ -120,30 +110,36 @@ selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do positions :: [Position] List positions = _positions - runIdeAction' :: IdeAction (Either SelectionRangeError [SelectionRange]) -> LspT c IO (Either String [SelectionRange]) - runIdeAction' action = do - result <- liftIO $ runIdeAction "SelectionRange" (shakeExtras ide) action - case result of - Left err -> case err of - SelectionRangeBadDependency rule -> do - logWith recorder Warning $ LogBadDependency rule - -- This might happen if the HieAst is not ready, - -- so we give it a default value instead of throwing an error - pure $ Right [] - SelectionRangeInputPositionMappingFailure -> pure $ - Left "failed to apply position mapping to input positions" - SelectionRangeOutputPositionMappingFailure -> pure $ - Left "failed to apply position mapping to output positions" - Right list -> pure $ Right list + runIdeAction' :: MonadIO m => ExceptT SelectionRangeError IdeAction [SelectionRange] -> ExceptT SelectionRangeError m [SelectionRange] + runIdeAction' action = PluginUtils.runIdeAction "SelectionRange" (shakeExtras ide) action + + handleErrors :: + MonadIO m => + SelectionRangeError -> + m (Either ResponseError (List a)) + handleErrors err = case err of + SelectionRangeBadDependency rule -> do + logWith recorder Warning $ LogBadDependency rule + -- This might happen if the HieAst is not ready, + -- so we give it a default value instead of throwing an error + pure $ Right $ List [] + SelectionRangeInputPositionMappingFailure -> + pure $ Left $ mkSimpleResponseError "failed to apply position mapping to input positions" + SelectionRangeOutputPositionMappingFailure -> + pure $ Left $ mkSimpleResponseError "failed to apply position mapping to output positions" + GhcidePluginErrors ghcidePluginError -> + pure $ Left $ PluginUtils.handlePluginError ghcidePluginError + data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency rule | SelectionRangeInputPositionMappingFailure | SelectionRangeOutputPositionMappingFailure + | GhcidePluginErrors PluginUtils.GhcidePluginError getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction [SelectionRange] getSelectionRanges file positions = do - (codeRange, positionMapping) <- maybeToExceptT (SelectionRangeBadDependency GetCodeRange) . MaybeT $ - useWithStaleFast GetCodeRange file + (codeRange, positionMapping) <- withError (\_ -> SelectionRangeBadDependency GetCodeRange) $ + PluginUtils.useWithStaleFast GetCodeRange file -- 'positionMapping' should be applied to the input before using them positions' <- maybeToExceptT SelectionRangeInputPositionMappingFailure . MaybeT . pure $ traverse (fromCurrentPosition positionMapping) positions diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 32fe788701..0d7bedf9f5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -29,8 +29,8 @@ import Control.Exception (try) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) -import Control.Monad (guard, - void, when) +import Control.Monad (guard, void, + when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..)) import Data.Aeson (toJSON) @@ -46,25 +46,24 @@ import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) -import Development.IDE.Core.RuleTypes - ( NeedsCompilation(NeedsCompilation), - LinkableResult(linkableHomeMod), - tmrTypechecked, - TypeCheck(..)) -import Development.IDE.Core.Rules ( runAction, IdeState ) -import Development.IDE.Core.Shake - ( useWithStale_, - use_, - uses_ ) -import Development.IDE.GHC.Util - ( printOutputable, evalGhcEnv, modifyDynFlags ) -import Development.IDE.Types.Location - ( toNormalizedFilePath', uriToFilePath' ) +import Development.IDE.Core.Rules (IdeState, + runAction) +import Development.IDE.Core.RuleTypes (LinkableResult (linkableHomeMod), + NeedsCompilation (NeedsCompilation), + TypeCheck (..), + tmrTypechecked) +import Development.IDE.Core.Shake (useWithStale_, + use_, uses_) import Development.IDE.GHC.Compat hiding (typeKind, unitState) import Development.IDE.GHC.Compat.Util (GhcException, OverridingBool (..)) +import Development.IDE.GHC.Util (evalGhcEnv, + modifyDynFlags, + printOutputable) import Development.IDE.Import.DependencyInformation (reachableModules) +import Development.IDE.Types.Location (toNormalizedFilePath', + uriToFilePath') import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), FamInst, @@ -75,33 +74,34 @@ import GHC (ClsInst, exprType, getInfo, getInteractiveDynFlags, - isImport, isStmt, parseName, + isImport, isStmt, + parseName, pprFamInst, pprInstance, typeKind) -import Development.IDE.Core.RuleTypes - ( ModSummaryResult(msrModSummary), - GetModSummary(GetModSummary), - GhcSessionDeps(GhcSessionDeps), - GetDependencyInformation(GetDependencyInformation), - GetLinkable(GetLinkable) ) -import Development.IDE.Core.Shake ( VFSModified(VFSUnmodified) ) -import Development.IDE.Types.HscEnvEq ( HscEnvEq(hscEnv) ) -import qualified Development.IDE.GHC.Compat.Core as Compat - ( InteractiveImport(IIModule) ) -import qualified Development.IDE.GHC.Compat.Core as SrcLoc - ( unLoc, HasSrcSpan(getLoc) ) +import Development.IDE.Core.RuleTypes (GetDependencyInformation (GetDependencyInformation), + GetLinkable (GetLinkable), + GetModSummary (GetModSummary), + GhcSessionDeps (GhcSessionDeps), + ModSummaryResult (msrModSummary)) +import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) +import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) +import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc), + unLoc) +import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) #if MIN_VERSION_ghc(9,2,0) #endif import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) import Development.IDE.Core.FileStore (setSomethingModified) +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Types.Shake (toKey) #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #endif +import Development.IDE.Core.PluginUtils (GhcidePluginError) import Ide.Plugin.Eval.Code (Statement, asStatements, myExecStmt, @@ -124,8 +124,7 @@ import Ide.Plugin.Eval.Util (gStrictTry, logWith, response', timed) import Ide.PluginUtils (handleMaybe, - handleMaybeM, - pluginResponse) + handleMaybeM) import Ide.Types import Language.LSP.Server import Language.LSP.Types hiding @@ -142,14 +141,14 @@ codeLens st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg in perf "codeLens" $ - pluginResponse $ do + PluginUtils.pluginResponse $ do let TextDocumentIdentifier uri = _textDocument - fp <- handleMaybe "uri" $ uriToFilePath' uri + fp <- PluginUtils.uriToFilePath' uri let nfp = toNormalizedFilePath' fp isLHS = isLiterate fp dbg "fp" fp - (comments, _) <- liftIO $ - runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetEvalComments nfp + (comments, _) <- + PluginUtils.runAction "eval.GetParsedModuleWithComments" st $ PluginUtils.useWithStale_ GetEvalComments nfp -- dbg "excluded comments" $ show $ DL.toList $ -- foldMap (\(L a b) -> -- case b of @@ -208,12 +207,12 @@ runEvalCmd :: PluginId -> CommandFunction IdeState EvalParams runEvalCmd plId st EvalParams{..} = let dbg = logWith st perf = timed dbg - cmd :: ExceptT String (LspM Config) WorkspaceEdit + cmd :: ExceptT GhcidePluginError (LspM Config) WorkspaceEdit cmd = do let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections let TextDocumentIdentifier{_uri} = module_ - fp <- handleMaybe "uri" $ uriToFilePath' _uri + fp <- PluginUtils.uriToFilePath' _uri let nfp = toNormalizedFilePath' fp mdlText <- moduleText _uri @@ -300,9 +299,9 @@ finalReturn txt = p = Position l c in TextEdit (Range p p) "\n" -moduleText :: (IsString e, MonadLsp c m) => Uri -> ExceptT e m Text +moduleText :: MonadLsp c m => Uri -> ExceptT GhcidePluginError m Text moduleText uri = - handleMaybeM "mdlText" $ + handleMaybeM (PluginUtils.mkPluginErrorMessage "mdlText") $ (virtualFileText <$>) <$> getVirtualFile (toNormalizedUri uri) @@ -366,7 +365,7 @@ asEdit (MultiLine commRange) test resultLines asEdit _ test resultLines = TextEdit (resultRange test) (T.unlines resultLines) -{- +{- | The result of evaluating a test line can be: * a value * nothing diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs index 2b8c41ec2e..9d5e07a850 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} -- |Debug utilities @@ -13,25 +13,32 @@ module Ide.Plugin.Eval.Util ( logWith, ) where -import Control.Exception (SomeException, evaluate, fromException) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Aeson (Value (Null)) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Development.IDE (IdeState, Priority (..), - ideLogger, logPriority) -import Development.IDE.GHC.Compat.Util (MonadCatch, catch, bagToList) +import Control.Exception (SomeException, evaluate, + fromException) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) +import Data.Aeson (Value (Null)) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Development.IDE (IdeState, Priority (..), + ideLogger, logPriority) +import Development.IDE.Core.PluginUtils (GhcidePluginError) +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.GHC.Compat.Outputable -import GHC.Exts (toList) -import GHC.Stack (HasCallStack, callStack, - srcLocFile, srcLocStartCol, - srcLocStartLine) +import Development.IDE.GHC.Compat.Util (MonadCatch, bagToList, + catch) +import GHC.Exts (toList) +import GHC.Stack (HasCallStack, callStack, + srcLocFile, + srcLocStartCol, + srcLocStartLine) +import Ide.PluginUtils (prettyPluginError) import Language.LSP.Server import Language.LSP.Types -import System.FilePath (takeExtension) -import System.Time.Extra (duration, showDuration) -import UnliftIO.Exception (catchAny) +import System.FilePath (takeExtension) +import System.Time.Extra (duration, showDuration) +import UnliftIO.Exception (catchAny) timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b timed out name op = do @@ -61,13 +68,15 @@ logLevel = Debug -- Info isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value) +response' :: ExceptT GhcidePluginError (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value) response' act = do res <- runExceptT act - `catchAny` showErr + `catchAny` \e -> do + res <- showErr e + pure . Left . PluginUtils.mkPluginErrorMessage $ fromString res case res of Left e -> - return $ Left (ResponseError InternalError (fromString e) Nothing) + return $ Left $ PluginUtils.handlePluginError e Right a -> do _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) return $ Right Null @@ -76,28 +85,28 @@ gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) gStrictTry op = catch (op >>= fmap Right . gevaluate) - showErr + (fmap Left . showErr) gevaluate :: MonadIO m => a -> m a gevaluate = liftIO . evaluate -showErr :: Monad m => SomeException -> m (Either String b) +showErr :: Monad m => SomeException -> m String showErr e = #if MIN_VERSION_ghc(9,3,0) case fromException e of -- On GHC 9.4+, the show instance adds the error message span -- We don't want this for the plugin -- So render without the span. - Just (SourceError msgs) -> return $ Left $ renderWithContext defaultSDocContext - $ vcat - $ bagToList - $ fmap (vcat . unDecorated - . diagnosticMessage + Just (SourceError msgs) -> return $ renderWithContext defaultSDocContext + $ vcat + $ bagToList + $ fmap (vcat . unDecorated + . diagnosticMessage #if MIN_VERSION_ghc(9,5,0) - (defaultDiagnosticOpts @GhcMessage) + (defaultDiagnosticOpts @GhcMessage) #endif - . errMsgDiagnostic) - $ getMessages msgs + . errMsgDiagnostic) + $ getMessages msgs _ -> #endif - return . Left . show $ e + return . show $ e diff --git a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs index 29b30a94c2..bae8a79998 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -11,7 +11,6 @@ module Ide.Plugin.ExplicitFixity(descriptor, Log) where import Control.DeepSeq import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Maybe import Data.Either.Extra import Data.Hashable import qualified Data.Map.Strict as M @@ -20,6 +19,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Development.IDE hiding (pluginHandlers, pluginRules) +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.Shake (addPersistentRule) import qualified Development.IDE.Core.Shake as Shake @@ -28,9 +28,7 @@ import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.LSP.Notifications (ghcideNotificationsPluginPriority) import Development.IDE.Spans.AtPoint import GHC.Generics (Generic) -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybeM, - pluginResponse) +import Ide.PluginUtils (getNormalizedFilePath) import Ide.Types hiding (pluginId) import Language.LSP.Types @@ -44,14 +42,14 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId) } hover :: PluginMethodHandler IdeState TextDocumentHover -hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse $ do - nfp <- getNormalizedFilePath uri - handleMaybeM "ExplicitFixity: Unable to get fixity" $ liftIO $ runIdeAction "ExplicitFixity" (shakeExtras state) $ runMaybeT $ do - (FixityMap fixmap, _) <- useE GetFixity nfp - (HAR{hieAst}, mapping) <- useE GetHieAst nfp +hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + PluginUtils.runIdeAction "ExplicitFixity" (shakeExtras state) $ do + (FixityMap fixmap, _) <- PluginUtils.useE GetFixity nfp + (HAR{hieAst}, mapping) <- PluginUtils.useE GetHieAst nfp let ns = getNamesAtPoint hieAst pos mapping fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns - pure $ toHover $ fs + pure $ toHover fs where toHover :: [(Name, Fixity)] -> Maybe Hover toHover [] = Nothing diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 7600daa671..086979f28f 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -15,71 +15,71 @@ module Ide.Plugin.ExplicitFields , Log ) where -import Control.Lens ((^.)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Except (ExceptT) -import Data.Functor ((<&>)) -import Data.Generics (GenericQ, everything, extQ, - mkQ) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (fromMaybe, isJust, - listToMaybe, maybeToList) -import Data.Text (Text) -import Development.IDE (IdeState, NormalizedFilePath, - Pretty (..), Recorder (..), - Rules, WithPriority (..), - realSrcSpanToRange) -import Development.IDE.Core.Rules (runAction) -import Development.IDE.Core.RuleTypes (TcModuleResult (..), - TypeCheck (..)) -import Development.IDE.Core.Shake (define, use) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsRecFields (..), LPat, - Outputable, getLoc, recDotDot, - unLoc) -import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - GhcPass, - HsExpr (RecordCon, rcon_flds), - HsRecField, LHsExpr, LocatedA, - Name, Pass (..), Pat (..), - RealSrcSpan, UniqFM, - conPatDetails, emptyUFM, - hfbPun, hfbRHS, hs_valds, - lookupUFM, mapConPatDetail, - mapLoc, pattern RealSrcSpan, - plusUFM_C, ufmToIntMap, - unitUFM) -import Development.IDE.GHC.Util (getExtensions, - printOutputable) -import Development.IDE.Graph (RuleResult) -import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) -import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), - getFirstPragma, - insertNewPragma) -import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, - logWith, (<+>)) -import GHC.Generics (Generic) -import Ide.Plugin.RangeMap (RangeMap) -import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybeM, pluginResponse) -import Ide.Types (PluginDescriptor (..), - PluginId (..), - PluginMethodHandler, - defaultPluginDescriptor, - mkPluginHandler) -import Language.LSP.Types (CodeAction (..), - CodeActionKind (CodeActionRefactorRewrite), - CodeActionParams (..), - Command, List (..), - Method (..), SMethod (..), - TextEdit (..), - WorkspaceEdit (WorkspaceEdit), - fromNormalizedUri, - normalizedFilePathToUri, - type (|?) (InR)) -import qualified Language.LSP.Types.Lens as L +import Control.Lens ((^.)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Except (ExceptT) +import Data.Functor ((<&>)) +import Data.Generics (GenericQ, everything, extQ, + mkQ) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (fromMaybe, isJust, + listToMaybe, maybeToList) +import Data.Text (Text) +import Development.IDE (IdeState, NormalizedFilePath, + Pretty (..), Recorder (..), + Rules, WithPriority (..), + realSrcSpanToRange) +import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import Development.IDE.Core.Shake (define, use) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (HsConDetails (RecCon), + HsRecFields (..), LPat, + Outputable, getLoc, + recDotDot, unLoc) +import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + GhcPass, + HsExpr (RecordCon, rcon_flds), + HsRecField, LHsExpr, + LocatedA, Name, Pass (..), + Pat (..), RealSrcSpan, + UniqFM, conPatDetails, + emptyUFM, hfbPun, hfbRHS, + hs_valds, lookupUFM, + mapConPatDetail, mapLoc, + pattern RealSrcSpan, + plusUFM_C, ufmToIntMap, + unitUFM) +import Development.IDE.GHC.Util (getExtensions, + printOutputable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), + getFirstPragma, + insertNewPragma) +import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, + logWith, (<+>)) +import GHC.Generics (Generic) +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.PluginUtils (getNormalizedFilePath) +import Ide.Types (PluginDescriptor (..), + PluginId (..), + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Types (CodeAction (..), + CodeActionKind (CodeActionRefactorRewrite), + CodeActionParams (..), + Command, List (..), + Method (..), SMethod (..), + TextEdit (..), + WorkspaceEdit (WorkspaceEdit), + fromNormalizedUri, + normalizedFilePathToUri, + type (|?) (InR)) +import qualified Language.LSP.Types.Lens as L data Log @@ -100,8 +100,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId) } codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction -codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse $ do - nfp <- getNormalizedFilePath (docId ^. L.uri) +codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (docId ^. L.uri) pragma <- getFirstPragma pId ideState nfp CRR recMap exts <- collectRecords' ideState nfp let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange range recMap) @@ -358,10 +358,7 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] getRecPatterns _ = Nothing -collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectRecordsResult -collectRecords' ideState = - handleMaybeM "Unable to TypeCheck" - . liftIO - . runAction "ExplicitFields" ideState - . use CollectRecords +collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError m CollectRecordsResult +collectRecords' ideState = PluginUtils.runAction "ExplicitFields" ideState + . PluginUtils.use CollectRecords diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 150094bd07..917813b866 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -8,28 +9,30 @@ {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.GADT (descriptor) where -import Control.Monad.Trans.Class -import Control.Monad.IO.Class -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.Except -import Data.Aeson (FromJSON, ToJSON, Value (Null), - toJSON) -import Data.Either.Extra (maybeToEither) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Text as T +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Aeson (FromJSON, ToJSON, + Value (Null), toJSON) +import Data.Either.Extra (maybeToEither) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat -import Control.Monad.Trans.Except (throwE) -import Data.Maybe (mapMaybe) -import Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma) -import GHC.Generics (Generic) +import Control.Monad.Trans.Except (throwE) +import Data.Maybe (mapMaybe) +import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Spans.Pragmas (getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) import Ide.Plugin.GHC import Ide.PluginUtils import Ide.Types -import Language.LSP.Server (sendRequest) +import Language.LSP.Server (sendRequest) import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Lens as L descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) @@ -50,20 +53,21 @@ toGADTSyntaxCommandId = "GADT.toGADT" -- | A command replaces H98 data decl with GADT decl in place toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams -toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponse $ do - nfp <- getNormalizedFilePath uri +toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponseM handleGhcidePluginError $ do + nfp <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d - _ -> throwE $ "Expected 1 declaration, but got " <> show (Prelude.length decls) - deps <- liftIO $ runAction (T.unpack pId' <> ".GhcSessionDeps") state $ use GhcSessionDeps nfp - (hsc_dflags . hscEnv -> df) <- liftEither - $ maybeToEither "Get GhcSessionDeps failed" deps - txt <- liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl + _ -> throwE $ UnexpectedNumberOfDeclarations (Prelude.length decls) + deps <- withError GhcidePluginErrors + $ PluginUtils.runAction (T.unpack pId' <> ".GhcSessionDeps") state + $ PluginUtils.use GhcSessionDeps nfp + (hsc_dflags . hscEnv -> df) <- pure deps + txt <- withError (PrettyGadtError . T.pack) $ liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl range <- liftEither - $ maybeToEither "Unable to get data decl range" + $ maybeToEither FailedToFindDataDeclRange $ srcSpanToRange $ locA ann - pragma <- getFirstPragma pId state nfp + pragma <- withError GhcidePluginErrors $ getFirstPragma pId state nfp let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] _ <- lift $ sendRequest @@ -80,8 +84,8 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponse $ do Nothing Nothing codeActionHandler :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponse $ do - nfp <- getNormalizedFilePath (doc ^. L.uri) +codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponseM handleGhcidePluginError $ do + nfp <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath (doc ^. L.uri) (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls pure $ List actions @@ -106,15 +110,34 @@ getInRangeH98DeclsAndExts :: (MonadIO m) => IdeState -> Range -> NormalizedFilePath - -> ExceptT String m ([LTyClDecl GP], [Extension]) + -> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension]) getInRangeH98DeclsAndExts state range nfp = do - pm <- handleMaybeM "Unable to get ParsedModuleWithComments" - $ liftIO - $ runAction "GADT.GetParsedModuleWithComments" state - $ use GetParsedModuleWithComments nfp + pm <- withError GhcidePluginErrors + $ PluginUtils.runAction "GADT.GetParsedModuleWithComments" state + $ PluginUtils.use GetParsedModuleWithComments nfp let (L _ hsDecls) = hsmodDecls <$> pm_parsed_source pm decls = filter isH98DataDecl $ mapMaybe getDataDecl $ filter (inRange range) hsDecls exts = getExtensions pm pure (decls, exts) + +data GadtPluginError + = UnexpectedNumberOfDeclarations Int + | FailedToFindDataDeclRange + | PrettyGadtError T.Text + | GhcidePluginErrors PluginUtils.GhcidePluginError + +handleGhcidePluginError :: + Monad m => + GadtPluginError -> + m (Either ResponseError a) +handleGhcidePluginError = \case + UnexpectedNumberOfDeclarations nums -> do + pure $ Left $ mkSimpleResponseError $ "Expected one declaration but found: " <> T.pack (show nums) + FailedToFindDataDeclRange -> + pure $ Left $ mkSimpleResponseError $ "Unable to get data decl range" + PrettyGadtError errMsg -> + pure $ Left $ mkSimpleResponseError $ errMsg + GhcidePluginErrors errors -> + pure $ Left $ PluginUtils.handlePluginError errors diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index 0fa03b7b31..a51f27a319 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -41,6 +41,7 @@ import Development.IDE.GHC.Compat (HsExpr (HsRecFld)) #endif import Control.DeepSeq (rwhnf) +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping (PositionMapping), toCurrentRange) import Development.IDE.GHC.Compat (Extension (OverloadedRecordDot), @@ -68,7 +69,8 @@ import Development.IDE.Types.Logger (Priority (..), import GHC.Generics (Generic) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath, +import Ide.PluginUtils (PluginError, + getNormalizedFilePath, handleMaybeM, pluginResponse) import Ide.Types (PluginDescriptor (..), @@ -88,6 +90,7 @@ import Language.LSP.Types (CodeAction (..), normalizedFilePathToUri, type (|?) (InR)) import qualified Language.LSP.Types.Lens as L + data Log = LogShake Shake.Log | LogCollectedRecordSelectors [RecordSelectorExpr] @@ -146,8 +149,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId) codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = - pluginResponse $ do - nfp <- getNormalizedFilePath (caDocId ^. L.uri) + PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (caDocId ^. L.uri) pragma <- getFirstPragma pId ideState nfp CRSR crsMap exts <- collectRecSelResult ideState nfp let pragmaEdit = @@ -271,10 +274,8 @@ getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecFld _ _) getRecSels _ = ([], False) collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath - -> ExceptT String m CollectRecordSelectorsResult + -> ExceptT PluginUtils.GhcidePluginError m CollectRecordSelectorsResult collectRecSelResult ideState = - handleMaybeM "Unable to TypeCheck" - . liftIO - . runAction "overloadedRecordDot.collectRecordSelectors" ideState - . use CollectRecordSelectors + PluginUtils.runAction "overloadedRecordDot.collectRecordSelectors" ideState + . PluginUtils.use CollectRecordSelectors diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 8506bb4b2c..16f7d0ae16 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -19,6 +19,7 @@ import GHC.Parser.Annotation (AnnContext, AnnList, import Compat.HieTypes import Control.Lens ((^.)) +import Compat.HieTypes import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -36,6 +37,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Development.IDE (Recorder, WithPriority, usePropertyAction) +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -57,6 +59,7 @@ import Ide.Types import Language.LSP.Server import Language.LSP.Types import qualified Language.LSP.Types.Lens as LSP +import Compat.HieTypes instance Hashable (Mod a) where hash n = hash (unMod n) @@ -69,7 +72,7 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultP renameProvider :: PluginMethodHandler IdeState TextDocumentRename renameProvider state pluginId (RenameParams docId@(TextDocumentIdentifier uri) pos _prog newNameText) = - pluginResponse $ do + PluginUtils.pluginResponse $ do nfp <- handleUriToNfp uri directOldNames <- getNamesAtPos state nfp pos directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames @@ -89,7 +92,7 @@ renameProvider state pluginId (RenameParams docId@(TextDocumentIdentifier uri) p -- Validate rename crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames - when (any isBuiltInSyntax oldNames) $ throwE "Invalid rename of built-in syntax" + when (any isBuiltInSyntax oldNames) $ throwE $ PluginUtils.mkPluginErrorMessage "Invalid rename of built-in syntax" -- Perform rename let newName = mkTcOcc $ T.unpack newNameText @@ -107,19 +110,17 @@ failWhenImportOrExport :: NormalizedFilePath -> HashSet Location -> [Name] -> - ExceptT String m () + ExceptT PluginUtils.GhcidePluginError m () failWhenImportOrExport state nfp refLocs names = do - pm <- handleMaybeM ("No parsed module for: " ++ show nfp) $ liftIO $ runAction - "Rename.GetParsedModule" - state - (use GetParsedModule nfp) + pm <- PluginUtils.runAction "Rename.GetParsedModule" state + (PluginUtils.use GetParsedModule nfp) let hsMod = unLoc $ pm_parsed_source pm case (unLoc <$> hsmodName hsMod, hsmodExports hsMod) of (mbModName, _) | not $ any (\n -> nameIsLocalOrFrom (replaceModName n mbModName) n) names - -> throwE "Renaming of an imported name is unsupported" + -> throwE $ PluginUtils.mkPluginErrorMessage "Renaming of an imported name is unsupported" (_, Just (L _ exports)) | any ((`HS.member` refLocs) . unsafeSrcSpanToLoc . getLoc) exports - -> throwE "Renaming of an exported name is unsupported" - (Just _, Nothing) -> throwE "Explicit export list required for renaming" + -> throwE $ PluginUtils.mkPluginErrorMessage "Renaming of an exported name is unsupported" + (Just _, Nothing) -> throwE $ PluginUtils.mkPluginErrorMessage "Explicit export list required for renaming" _ -> pure () --------------------------------------------------------------------------------------------------- @@ -131,14 +132,12 @@ getSrcEdit :: IdeState -> VersionedTextDocumentIdentifier -> (ParsedSource -> ParsedSource) -> - ExceptT String m WorkspaceEdit + ExceptT PluginUtils.GhcidePluginError m WorkspaceEdit getSrcEdit state verTxtDocId updatePs = do ccs <- lift getClientCapabilities nfp <- handleUriToNfp (verTxtDocId ^. LSP.uri) - annAst <- handleMaybeM ("No parsed source for: " ++ show nfp) $ liftIO $ runAction - "Rename.GetAnnotatedParsedSource" - state - (use GetAnnotatedParsedSource nfp) + annAst <- PluginUtils.runAction "Rename.GetAnnotatedParsedSource" state + (PluginUtils.use GetAnnotatedParsedSource nfp) let (ps, anns) = (astA annAst, annsA annAst) #if !MIN_VERSION_ghc(9,2,1) let src = T.pack $ exactPrint ps anns @@ -194,7 +193,7 @@ refsAtName :: IdeState -> NormalizedFilePath -> Name -> - ExceptT String m [Location] + ExceptT PluginUtils.GhcidePluginError m [Location] refsAtName state nfp name = do ShakeExtras{withHieDb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras ast <- handleGetHieAst state nfp @@ -219,7 +218,7 @@ nameLocs name (HAR _ _ rm _ _, pm) = --------------------------------------------------------------------------------------------------- -- Util -getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT String m [Name] +getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginUtils.GhcidePluginError m [Name] getNamesAtPos state nfp pos = do (HAR{hieAst}, pm) <- handleGetHieAst state nfp pure $ getNamesAtPoint hieAst pos pm @@ -228,10 +227,9 @@ handleGetHieAst :: MonadIO m => IdeState -> NormalizedFilePath -> - ExceptT String m (HieAstResult, PositionMapping) -handleGetHieAst state nfp = handleMaybeM - ("No AST for file: " ++ show nfp) - (liftIO $ fmap (fmap (first removeGenerated)) $ runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp) + ExceptT PluginUtils.GhcidePluginError m (HieAstResult, PositionMapping) +handleGetHieAst state nfp = + fmap (first removeGenerated) $ PluginUtils.runAction "Rename.GetHieAst" state $ PluginUtils.useWithStale GetHieAst nfp -- | We don't want to rename in code generated by GHC as this gives false positives. -- So we restrict the HIE file to remove all the generated code. @@ -247,10 +245,8 @@ removeGenerated HAR{..} = HAR{hieAst = go hieAst,..} hf #endif -handleUriToNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath -handleUriToNfp uri = handleMaybe - ("No filepath for uri: " ++ show uri) - (toNormalizedFilePath <$> uriToFilePath uri) +handleUriToNfp :: (Monad m) => Uri -> ExceptT PluginUtils.GhcidePluginError m NormalizedFilePath +handleUriToNfp uri = PluginUtils.withPluginError $ getNormalizedFilePath uri -- head is safe since groups are non-empty collectWith :: (Hashable a, Eq a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)] diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index e5127c9567..23dc166556 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -170,6 +170,7 @@ import Retrie.ExactPrint (relativiseApiAnns) #endif import Control.Arrow ((&&&)) import Development.IDE.Core.Actions (lookupMod) +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Spans.AtPoint (LookupModule, getNamesAtPoint, nameToLocation) @@ -211,14 +212,13 @@ runRetrieCmd :: LspM c (Either ResponseError Value) runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = withIndefiniteProgress description Cancellable $ do - runMaybeT $ do - nfp <- MaybeT $ return $ uriToNormalizedFilePath $ toNormalizedUri uri - (session, _) <- MaybeT $ liftIO $ - runAction "Retrie.GhcSessionDeps" state $ - useWithStale GhcSessionDeps + PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + (session, _) <- + PluginUtils.runAction "Retrie.GhcSessionDeps" state $ + PluginUtils.useWithStale GhcSessionDeps nfp - (ms, binds, _, _, _) <- MaybeT $ liftIO $ - runAction "Retrie.getBinds" state $ getBinds nfp + (ms, binds, _, _, _) <- PluginUtils.runAction "Retrie.getBinds" state $ getBinds nfp let importRewrites = concatMap (extractImports ms binds) rewrites (errors, edits) <- liftIO $ callRetrie @@ -246,38 +246,39 @@ data RunRetrieInlineThisParams = RunRetrieInlineThisParams runRetrieInlineThisCmd :: IdeState -> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value) -runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do - nfp <- handleMaybe "uri" $ uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineIntoThisLocation - nfpSource <- handleMaybe "sourceUri" $ - uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineFromThisLocation +runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = PluginUtils.pluginResponse $ do + nfp <- PluginUtils.withPluginError $ + getNormalizedFilePath $ getLocationUri inlineIntoThisLocation + nfpSource <- PluginUtils.withPluginError $ + getNormalizedFilePath $ getLocationUri inlineFromThisLocation -- What we do here: -- Find the identifier in the given position -- Construct an inline rewrite for it -- Run retrie to get a list of changes -- Select the change that inlines the identifier in the given position -- Apply the edit - ast <- handleMaybeM "ast" $ liftIO $ runAction "retrie" state $ - use GetAnnotatedParsedSource nfp - astSrc <- handleMaybeM "ast" $ liftIO $ runAction "retrie" state $ - use GetAnnotatedParsedSource nfpSource - msr <- handleMaybeM "modSummary" $ liftIO $ runAction "retrie" state $ - use GetModSummaryWithoutTimestamps nfp - hiFileRes <- handleMaybeM "modIface" $ liftIO $ runAction "retrie" state $ - use GetModIface nfpSource + ast <- PluginUtils.runAction "retrie" state $ + PluginUtils.use GetAnnotatedParsedSource nfp + astSrc <- PluginUtils.runAction "retrie" state $ + PluginUtils.use GetAnnotatedParsedSource nfpSource + msr <- PluginUtils.runAction "retrie" state $ + PluginUtils.use GetModSummaryWithoutTimestamps nfp + hiFileRes <- PluginUtils.runAction "retrie" state $ + PluginUtils.use GetModIface nfpSource let fixityEnv = fixityEnvFromModIface (hirModIface hiFileRes) fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange - when (null inlineRewrite) $ throwE "Empty rewrite" - let ShakeExtras{..}= shakeExtras state - (session, _) <- handleMaybeM "GHCSession" $ liftIO $ runAction "retrie" state $ - useWithStale GhcSessionDeps nfp + when (null inlineRewrite) $ throwE $ PluginUtils.mkPluginErrorMessage "Empty rewrite" + let ShakeExtras{..} = shakeExtras state + (session, _) <- PluginUtils.runAction "retrie" state $ + PluginUtils.useWithStale GhcSessionDeps nfp (fixityEnv, cpp) <- liftIO $ getCPPmodule state (hscEnv session) $ fromNormalizedFilePath nfp result <- liftIO $ try @_ @SomeException $ runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp case result of - Left err -> throwE $ "Retrie - crashed with: " <> show err - Right (_,_,NoChange) -> throwE "Retrie - inline produced no changes" + Left err -> throwE $ PluginUtils.mkPluginErrorMessage $ "Retrie - crashed with: " <> T.pack (show err) + Right (_,_,NoChange) -> throwE $ PluginUtils.mkPluginErrorMessage "Retrie - inline produced no changes" Right (_,_,Change replacements imports) -> do let edits = asEditMap $ asTextEdits $ Change ourReplacement imports wedit = WorkspaceEdit (Just edits) Nothing Nothing @@ -338,18 +339,17 @@ extractImports _ _ _ = [] ------------------------------------------------------------------------------- provider :: PluginMethodHandler IdeState TextDocumentCodeAction -provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = pluginResponse $ do +provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = PluginUtils.pluginResponse $ do let (J.CodeActionContext _diags _monly) = ca - nuri = toNormalizedUri uri - nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) - <- handleMaybeM "typecheck" $ liftIO $ runAction "retrie" state $ + <- PluginUtils.runAction "retrie" state $ getBinds nfp extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras - range <- handleMaybe "range" $ fromCurrentRange posMapping range + range <- handleMaybe (PluginUtils.mkPluginErrorMessage "range") $ fromCurrentRange posMapping range let pos = _start range let rewrites = concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds @@ -380,9 +380,9 @@ getLocationUri Location{_uri} = _uri getLocationRange Location{_range} = _range -getBinds :: NormalizedFilePath -> Action (Maybe (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn])) -getBinds nfp = runMaybeT $ do - (tm, posMapping) <- MaybeT $ useWithStale TypeCheck nfp +getBinds :: NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError Action (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn]) +getBinds nfp = do + (tm, posMapping) <- PluginUtils.useWithStale TypeCheck nfp -- we use the typechecked source instead of the parsed source -- to be able to extract module names from the Ids, -- so that we can include adding the required imports in the retrie command