From 8adb03e7d6b8dc44256f70e90408fe407da5d1c5 Mon Sep 17 00:00:00 2001 From: Fendor Date: Thu, 15 Jun 2023 21:38:05 +0200 Subject: [PATCH 01/28] WIP --- ghcide/ghcide.cabal | 1 + .../src/Development/IDE/Core/PluginUtils.hs | 108 +++++++++++++ ghcide/src/Development/IDE/Core/Service.hs | 2 + ghcide/src/Development/IDE/Core/Shake.hs | 6 +- ghcide/src/Development/IDE/Core/Tracing.hs | 1 + .../src/Development/IDE/Plugin/TypeLenses.hs | 41 +++-- ghcide/src/Development/IDE/Spans/Pragmas.hs | 17 ++- hls-plugin-api/src/Ide/PluginUtils.hs | 79 ++++++++-- .../src/Ide/Plugin/AlternateNumberFormat.hs | 66 ++++---- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 36 ++--- .../src/Ide/Plugin/ChangeTypeSignature.hs | 58 ++++--- .../src/Ide/Plugin/Class/CodeAction.hs | 61 +++----- .../src/Ide/Plugin/Class/CodeLens.hs | 20 +-- .../src/Ide/Plugin/Class/Utils.hs | 33 ++-- .../src/Ide/Plugin/CodeRange.hs | 100 ++++++------ .../src/Ide/Plugin/Eval/CodeLens.hs | 79 +++++----- .../src/Ide/Plugin/Eval/Util.hs | 71 +++++---- .../src/Ide/Plugin/ExplicitFixity.hs | 18 +-- .../src/Ide/Plugin/ExplicitFields.hs | 143 +++++++++--------- .../hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 83 ++++++---- .../src/Ide/Plugin/OverloadedRecordDot.hs | 17 ++- .../src/Ide/Plugin/Rename.hs | 46 +++--- .../src/Ide/Plugin/Retrie.hs | 66 ++++---- 23 files changed, 655 insertions(+), 497 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/PluginUtils.hs 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 From d4a9d4e9e77e29743981690040472cc111f8208d Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 14 Jul 2023 13:25:10 +0300 Subject: [PATCH 02/28] Make compilable --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 4 ++-- hls-plugin-api/src/Ide/PluginUtils.hs | 17 +++++++++++++++-- .../src/Ide/Plugin/AlternateNumberFormat.hs | 4 ++-- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 4 ++-- .../src/Ide/Plugin/ChangeTypeSignature.hs | 4 ++-- .../src/Ide/Plugin/Class/CodeAction.hs | 4 ++-- .../src/Ide/Plugin/Class/CodeLens.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 6 +++--- .../src/Ide/Plugin/ExplicitFixity.hs | 8 ++++---- .../src/Ide/Plugin/ExplicitFields.hs | 4 ++-- plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 4 ++-- .../src/Ide/Plugin/OverloadedRecordDot.hs | 4 ++-- .../hls-rename-plugin/src/Ide/Plugin/Rename.hs | 4 +--- .../hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 8 ++++---- 14 files changed, 44 insertions(+), 33 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 06ba065751..9ee687e490 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -51,7 +51,7 @@ import Development.IDE.Types.Logger (Pretty (pretty), cmapWithPrio) import GHC.Generics (Generic) import Ide.Plugin.Properties -import Ide.PluginUtils (getNormalizedFilePath, +import Ide.PluginUtils (getNormalizedFilePath', mkLspCommand) import Ide.Types (CommandFunction, CommandId (CommandId), @@ -106,7 +106,7 @@ properties = emptyProperties codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = PluginUtils.pluginResponse $ do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri env <- hscEnv . fst <$> PluginUtils.runAction "codeLens.GhcSession" ideState (PluginUtils.useWithStale GhcSession nfp) diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 017f7e2acd..9daa8f8754 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -46,6 +46,8 @@ module Ide.PluginUtils withError, -- * Batteries-included plugin error API getNormalizedFilePath, + getNormalizedFilePath', + throwPluginError, -- * Escape unescape, ) @@ -277,8 +279,8 @@ allLspCmdIds pid commands = concatMap go commands -- --------------------------------------------------------------------- -getNormalizedFilePath :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath -getNormalizedFilePath uri = handleMaybe (PluginUriToNormalizedFilePath uri) +getNormalizedFilePath' :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath +getNormalizedFilePath' uri = handleMaybe (PluginUriToNormalizedFilePath uri) $ uriToNormalizedFilePath $ toNormalizedUri uri @@ -366,3 +368,14 @@ escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) inside' = concatMap f inside pure $ "\"" <> inside' <> "\"" + +getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath +getNormalizedFilePath uri = handleMaybe errMsg + $ uriToNormalizedFilePath + $ toNormalizedUri uri + where + errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath" + +-- --------------------------------------------------------------------- +throwPluginError :: Monad m => String -> ExceptT String m b +throwPluginError = throwE 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 fb558d40ec..33b58b911d 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 @@ -30,7 +30,7 @@ import Ide.Plugin.Conversion (AlternateFormat, import Ide.Plugin.Literals import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath) +import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types import Language.LSP.Types import qualified Language.LSP.Types.Lens as L @@ -82,7 +82,7 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (docId ^. L.uri) + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (docId ^. L.uri) CLR{..} <- requestLiterals pId state nfp pragma <- getFirstPragma pId state nfp -- remove any invalid literals (see validTarget comment) 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 cfaabad108..34dd16793f 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 @@ -30,7 +30,7 @@ import Development.IDE.Spans.AtPoint import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types -import Ide.PluginUtils (getNormalizedFilePath, +import Ide.PluginUtils (getNormalizedFilePath', handleMaybe) import Ide.Types import Language.LSP.Types @@ -40,7 +40,7 @@ import Text.Read (readMaybe) -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy prepareCallHierarchy state _ param = PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (param ^. L.textDocument ^. L.uri) + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (param ^. L.textDocument ^. L.uri) items <- liftIO $ runAction "CallHierarchy.prepareHierarchy" state $ prepareCallHierarchyItem nfp (param ^. L.position) 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 5871bae193..46c0c54957 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 @@ -21,7 +21,7 @@ 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) +import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types (PluginDescriptor (..), PluginId (PluginId), PluginMethodHandler, @@ -35,7 +35,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHand codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'TextDocumentCodeAction codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri decls <- getDecls plId ideState nfp let actions = mapMaybe (generateAction plId uri decls) diags pure $ List actions 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 fbe666a86f..1ff2463c62 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -41,7 +41,7 @@ addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsP addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do caps <- getClientCapabilities PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (verTxtDocId ^. J.uri) + 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 @@ -79,7 +79,7 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction codeAction recorder state plId (CodeActionParams _ _ docId _ context) = PluginUtils.pluginResponse $ do verTxtDocId <- lift $ getVersionedTextDoc docId - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (verTxtDocId ^. J.uri) + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (verTxtDocId ^. J.uri) actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags pure $ List actions where 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 66a1a5685e..1f6b487f5d 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -24,7 +24,7 @@ import qualified Language.LSP.Types.Lens as J codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens codeLens state plId CodeLensParams{..} = PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + 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' 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 5f8c6f5636..ff421a7568 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -38,7 +38,7 @@ import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), codeRangeRule, crkToFrk) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) -import Ide.PluginUtils (getNormalizedFilePath, +import Ide.PluginUtils (getNormalizedFilePath', mkSimpleResponseError, pluginResponseM, positionInRange, @@ -80,7 +80,7 @@ instance Pretty Log where foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) foldingRangeHandler recorder ide _ FoldingRangeParams{..} = pluginResponseM handleErrors $ do - filePath <- withError PluginUtils.CoreError $ getNormalizedFilePath uri + filePath <- withError PluginUtils.CoreError $ getNormalizedFilePath' uri foldingRanges <- PluginUtils.runAction "FoldingRange" ide $ getFoldingRanges filePath pure . List $ foldingRanges where @@ -101,7 +101,7 @@ getFoldingRanges file = do selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do pluginResponseM handleErrors $ do - filePath <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath uri + filePath <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath' uri fmap List . runIdeAction' $ getSelectionRanges filePath positions where uri :: Uri 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 bae8a79998..74f59b3c8f 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -28,7 +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) +import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types hiding (pluginId) import Language.LSP.Types @@ -43,10 +43,10 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId) hover :: PluginMethodHandler IdeState TextDocumentHover hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri PluginUtils.runIdeAction "ExplicitFixity" (shakeExtras state) $ do - (FixityMap fixmap, _) <- PluginUtils.useE GetFixity nfp - (HAR{hieAst}, mapping) <- PluginUtils.useE GetHieAst nfp + (FixityMap fixmap, _) <- PluginUtils.useWithStaleFast GetFixity nfp + (HAR{hieAst}, mapping) <- PluginUtils.useWithStaleFast GetHieAst nfp let ns = getNamesAtPoint hieAst pos mapping fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns pure $ toHover fs 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 086979f28f..fb0c858591 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 @@ -63,7 +63,7 @@ import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, import GHC.Generics (Generic) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath) +import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, @@ -101,7 +101,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (docId ^. L.uri) + 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) diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 917813b866..e9b6a2935a 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -54,7 +54,7 @@ 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{..} = pluginResponseM handleGhcidePluginError $ do - nfp <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath uri + nfp <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath' uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d @@ -85,7 +85,7 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponseM handl codeActionHandler :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponseM handleGhcidePluginError $ do - nfp <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath (doc ^. L.uri) + 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 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 a51f27a319..5449c766d8 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 @@ -70,7 +70,7 @@ import GHC.Generics (Generic) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.PluginUtils (PluginError, - getNormalizedFilePath, + getNormalizedFilePath', handleMaybeM, pluginResponse) import Ide.Types (PluginDescriptor (..), @@ -150,7 +150,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath (caDocId ^. L.uri) + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (caDocId ^. L.uri) pragma <- getFirstPragma pId ideState nfp CRSR crsMap exts <- collectRecSelResult ideState nfp let pragmaEdit = diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 16f7d0ae16..adcb4a5419 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -19,7 +19,6 @@ 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 @@ -59,7 +58,6 @@ 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) @@ -246,7 +244,7 @@ removeGenerated HAR{..} = HAR{hieAst = go hieAst,..} #endif handleUriToNfp :: (Monad m) => Uri -> ExceptT PluginUtils.GhcidePluginError m NormalizedFilePath -handleUriToNfp uri = PluginUtils.withPluginError $ getNormalizedFilePath uri +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 23dc166556..3d5fb01f31 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -213,7 +213,7 @@ runRetrieCmd :: runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = withIndefiniteProgress description Cancellable $ do PluginUtils.pluginResponse $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri (session, _) <- PluginUtils.runAction "Retrie.GhcSessionDeps" state $ PluginUtils.useWithStale GhcSessionDeps @@ -248,9 +248,9 @@ runRetrieInlineThisCmd :: IdeState -> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value) runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = PluginUtils.pluginResponse $ do nfp <- PluginUtils.withPluginError $ - getNormalizedFilePath $ getLocationUri inlineIntoThisLocation + getNormalizedFilePath' $ getLocationUri inlineIntoThisLocation nfpSource <- PluginUtils.withPluginError $ - getNormalizedFilePath $ getLocationUri inlineFromThisLocation + getNormalizedFilePath' $ getLocationUri inlineFromThisLocation -- What we do here: -- Find the identifier in the given position -- Construct an inline rewrite for it @@ -341,7 +341,7 @@ extractImports _ _ _ = [] provider :: PluginMethodHandler IdeState TextDocumentCodeAction provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = PluginUtils.pluginResponse $ do let (J.CodeActionContext _diags _monly) = ca - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath uri + nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) <- PluginUtils.runAction "retrie" state $ From e34da52d9cf14ba678163e47ac9add98c71986c2 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 18 Jul 2023 16:27:53 +0300 Subject: [PATCH 03/28] Flatten error hierarchy and avoid name clashes --- .../src/Development/IDE/Core/PluginUtils.hs | 53 ++--------- .../src/Development/IDE/Plugin/TypeLenses.hs | 5 +- ghcide/src/Development/IDE/Spans/Pragmas.hs | 4 +- hls-plugin-api/hls-plugin-api.cabal | 2 + hls-plugin-api/src/Ide/Plugin/Error.hs | 93 +++++++++++++++++++ hls-plugin-api/src/Ide/PluginUtils.hs | 68 +------------- .../src/Ide/Plugin/AlternateNumberFormat.hs | 7 +- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 12 +-- .../src/Ide/Plugin/ChangeTypeSignature.hs | 10 +- .../src/Ide/Plugin/Class/CodeAction.hs | 23 ++--- .../src/Ide/Plugin/Class/CodeLens.hs | 5 +- .../src/Ide/Plugin/Class/Utils.hs | 3 +- .../src/Ide/Plugin/CodeRange.hs | 20 ++-- .../src/Ide/Plugin/Eval/CodeLens.hs | 16 ++-- .../src/Ide/Plugin/Eval/Util.hs | 9 +- .../src/Ide/Plugin/ExplicitFixity.hs | 5 +- .../src/Ide/Plugin/ExplicitImports.hs | 19 ++-- .../src/Ide/Plugin/ExplicitFields.hs | 11 +-- .../hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 9 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 6 +- .../src/Ide/Plugin/OverloadedRecordDot.hs | 23 ++--- .../src/Ide/Plugin/Rename.hs | 25 ++--- .../src/Ide/Plugin/Retrie.hs | 27 +++--- 23 files changed, 223 insertions(+), 232 deletions(-) create mode 100644 hls-plugin-api/src/Ide/Plugin/Error.hs diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index 76a0d67a5b..b6799c6c4e 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -10,7 +10,6 @@ import Data.Bifunctor (first) import Data.Either.Extra (maybeToEither) import Data.Functor.Identity import Data.String (IsString (fromString)) -import qualified Data.Text as T import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake (IdeAction, IdeRule, IdeState (shakeExtras), @@ -22,47 +21,9 @@ 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 Ide.Plugin.Error import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.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 String m a -> m (Either LSP.ResponseError a) -pluginResponse = - fmap (first (\msg -> LSP.ResponseError (LSP.InR LSP.ErrorCodes_InternalError) (fromString msg) Nothing)) - . runExceptT - -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 @@ -70,7 +31,7 @@ handlePluginError msg = PluginUtils.mkSimpleResponseError $ renderStrict simpleD runAction :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a runAction herald ide act = - PluginUtils.hoistExceptT . ExceptT $ + 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. @@ -80,12 +41,12 @@ useWithStale_ ::(IdeRule k v) useWithStale_ key file = ExceptT $ fmap Right $ Shake.useWithStale_ key file useWithStale :: IdeRule k v - => k -> NormalizedFilePath -> ExceptT GhcidePluginError Action (v, PositionMapping) + => k -> NormalizedFilePath -> ExceptT PluginError 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 :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v use k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.use k useWithStaleMaybeT :: IdeRule k v @@ -101,11 +62,11 @@ runIdeAction _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ -- | 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 :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError 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 +uriToFilePath' :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath +uriToFilePath' uri = ExceptT . pure . maybeToEither (PluginUriToFilePath uri) $ Location.uriToFilePath' uri -- ---------------------------------------------------------------------------- -- Internal Helper function, not exported diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index d60b894bfa..20b4eefdb8 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -50,6 +50,7 @@ import Development.IDE.Types.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) import GHC.Generics (Generic) +import Ide.Plugin.Error import Ide.Plugin.Properties import Ide.PluginUtils (getNormalizedFilePath', mkLspCommand) @@ -105,9 +106,9 @@ properties = emptyProperties ] Always codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = PluginUtils.pluginResponse' $ do +codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse' $ do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri + nfp <- getNormalizedFilePath' uri env <- hscEnv . fst <$> PluginUtils.runAction "codeLens.GhcSession" ideState (PluginUtils.useWithStale GhcSession nfp) diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index 905e76fdc4..f5de5ba2f6 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -21,10 +21,10 @@ import Development.IDE.GHC.Compat.Util import qualified Language.LSP.Protocol.Types as LSP import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT) +import Ide.Plugin.Error (PluginError) import Ide.Types (PluginId(..)) import qualified Data.Text as T import qualified Development.IDE.Core.PluginUtils as PluginUtils -import Development.IDE.Core.PluginUtils (GhcidePluginError) getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo getNextPragmaInfo dynFlags sourceText = @@ -52,7 +52,7 @@ 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 GhcidePluginError m NextPragmaInfo +getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError 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 diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 64d1aa8263..479a225734 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -34,6 +34,7 @@ source-repository head library exposed-modules: + Ide.Plugin.Error Ide.Plugin.Config Ide.Plugin.ConfigUtils Ide.Plugin.Properties @@ -61,6 +62,7 @@ library , lsp ^>=2.0.0.0 , opentelemetry >=0.4 , optparse-applicative + , prettyprinter , regex-tdfa >=1.3.1.0 , row-types , text diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs new file mode 100644 index 0000000000..9f58959fbc --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.Error ( + -- * Plugin Error Handling API + PluginError(..), + pluginResponse, + pluginResponse', + pluginResponseM, + handlePluginError, + mkPluginErrorMessage, + hoistExceptT, + handleMaybe, + handleMaybeM, + mkSimpleResponseError, + withError, +) where + + +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, + runExceptT, throwE, withExceptT) +import Data.Bifunctor (Bifunctor (first)) + +import qualified Data.Text as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Prettyprinter +import Prettyprinter.Render.Text (renderStrict) + +type PluginHandler e m a = ExceptT e m a + +-- ---------------------------------------------------------------------------- +-- Plugin Error wrapping +-- ---------------------------------------------------------------------------- + + +pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a) +pluginResponse = + fmap (first (\msg -> ResponseError (InR ErrorCodes_InternalError) (T.pack msg) Nothing)) + . runExceptT + +pluginResponse' :: Monad m => ExceptT PluginError m a -> m (Either ResponseError a) +pluginResponse' = + fmap (first handlePluginError) + . 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 (InR ErrorCodes_InternalError) (renderStrict simpleDoc) Nothing + where simpleDoc = layoutPretty defaultLayoutOptions $ pretty msg + +data PluginError + = PluginInternalError + | PluginUriToFilePath Uri + | PluginUriToNormalizedFilePath Uri + | PluginErrorMessage T.Text + | forall a . Show a => FastRuleNotReady a + | forall a . Show a => RuleFailed a + +instance Pretty PluginError where + pretty = \case + PluginInternalError -> "Internal Plugin Error" + PluginUriToFilePath uri -> "Failed to translate URI " <+> viaShow uri + PluginUriToNormalizedFilePath uri -> "Failed converting " <+> viaShow uri <+> " to NormalizedFilePath" + PluginErrorMessage msg -> "Plugin failed: " <+> viaShow msg + FastRuleNotReady rule -> "FastRuleNotReady:" <+> viaShow rule + RuleFailed rule -> "RuleFailed:" <+> viaShow rule + +mkPluginErrorMessage :: T.Text -> PluginError +mkPluginErrorMessage = PluginErrorMessage + +mkSimpleResponseError :: T.Text -> ResponseError +mkSimpleResponseError err = ResponseError (InR ErrorCodes_InternalError) err Nothing + +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 + +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/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 9d8e261626..4898a6f342 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -31,19 +31,6 @@ module Ide.PluginUtils subRange, positionInRange, usePropertyLsp, - -- * Plugin Error Handling API - PluginError(..), - pluginResponse, - pluginResponse', - pluginResponseM, - prettyPluginError, - handlePluginError, - mkPluginErrorMessage, - hoistExceptT, - handleMaybe, - handleMaybeM, - mkSimpleResponseError, - withError, -- * Batteries-included plugin error API getNormalizedFilePath, getNormalizedFilePath', @@ -71,6 +58,7 @@ import Data.String (IsString (fromString)) import qualified Data.Text as T import Data.Void (Void) import Ide.Plugin.Config +import Ide.Plugin.Error import Ide.Plugin.Properties import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -282,60 +270,6 @@ getNormalizedFilePath' uri = handleMaybe (PluginUriToNormalizedFilePath uri) -- --------------------------------------------------------------------- -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 (InR ErrorCodes_InternalError) (prettyPluginError msg) Nothing - -data PluginError - = PluginInternalError - | PluginUriToFilePath Uri - | PluginUriToNormalizedFilePath 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 (InR ErrorCodes_InternalError) err Nothing - -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 - -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 - --- --------------------------------------------------------------------- - type TextParser = P.Parsec Void T.Text -- | Unescape printable escape sequences within double quotes. 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 ee3020f576..6da7a8161d 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 @@ -27,6 +27,7 @@ import GHC.Generics (Generic) import Ide.Plugin.Conversion (AlternateFormat, ExtensionNeeded (NeedsExtension, NoExtension), alternateFormat) +import Ide.Plugin.Error import Ide.Plugin.Literals import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap @@ -83,8 +84,8 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec pure ([], CLR <$> litMap <*> exts) codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (docId ^. L.uri) +codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginResponse' $ do + nfp <- getNormalizedFilePath' (docId ^. L.uri) CLR{..} <- requestLiterals pId state nfp pragma <- getFirstPragma pId state nfp -- remove any invalid literals (see validTarget comment) @@ -130,7 +131,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 PluginUtils.GhcidePluginError m CollectLiteralsResult +requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError 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 c2f0351448..d6ad5016f0 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 @@ -30,8 +30,8 @@ import Development.IDE.Spans.AtPoint import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types -import Ide.PluginUtils (getNormalizedFilePath', - handleMaybe) +import Ide.Plugin.Error +import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -40,8 +40,8 @@ import Text.Read (readMaybe) -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy -prepareCallHierarchy state _ param = PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (param ^. L.textDocument ^. L.uri) +prepareCallHierarchy state _ param = pluginResponse' $ do + nfp <- 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 Method_CallHierarchyIncomingCalls -incomingCalls state pluginId param = PluginUtils.pluginResponse $ do +incomingCalls state pluginId param = pluginResponse $ do calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls @@ -189,7 +189,7 @@ incomingCalls state pluginId param = PluginUtils.pluginResponse $ do -- | Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls -outgoingCalls state pluginId param = PluginUtils.pluginResponse $ do +outgoingCalls state pluginId param = 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 d31d634766..6e5fc6d184 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 @@ -21,8 +21,8 @@ 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.Plugin.Error (PluginError, pluginResponse') +import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types (PluginDescriptor (..), PluginId (PluginId), PluginMethodHandler, @@ -36,13 +36,13 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) } codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri +codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = pluginResponse' $ do + nfp <- getNormalizedFilePath' uri decls <- getDecls plId ideState nfp let actions = mapMaybe (generateAction plId uri decls) diags pure $ InL actions -getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError m [LHsDecl GhcPs] +getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs] getDecls (PluginId changeTypeSignatureId) state = PluginUtils.runAction (T.unpack changeTypeSignatureId <> ".GetParsedModule") state . (fmap (hsmodDecls . unLoc . pm_parsed_source)) 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 7936b8ffa5..3e406cd2e5 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -32,6 +32,7 @@ import Ide.Plugin.Class.ExactPrint import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils import qualified Ide.Plugin.Config +import Ide.Plugin.Error import Ide.PluginUtils import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -42,13 +43,13 @@ import Language.LSP.Server addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do caps <- getClientCapabilities - PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (verTxtDocId ^. L.uri) + pluginResponse' $ do + nfp <- getNormalizedFilePath' (verTxtDocId ^. L.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") + (old, new) <- handleMaybeM (mkPluginErrorMessage "Unable to makeEditText") $ liftIO $ runMaybeT $ makeEditText pm df param pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs @@ -79,9 +80,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 Method_TextDocumentCodeAction -codeAction recorder state plId (CodeActionParams _ _ docId _ context) = PluginUtils.pluginResponse' $ do +codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginResponse' $ do verTxtDocId <- lift $ getVersionedTextDoc docId - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (verTxtDocId ^. L.uri) + nfp <- getNormalizedFilePath' (verTxtDocId ^. L.uri) actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags pure $ InL actions where @@ -94,11 +95,11 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = PluginUt :: NormalizedFilePath -> VersionedTextDocumentIdentifier -> Diagnostic - -> ExceptT PluginUtils.GhcidePluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] + -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] mkActions docPath verTxtDocId diag = do (HAR {hieAst = ast}, pmap) <- PluginUtils.runAction "classplugin.findClassIdentifier.GetHieAst" state $ PluginUtils.useWithStale GetHieAst docPath - instancePosition <- handleMaybe (PluginUtils.mkPluginErrorMessage "No range") $ + instancePosition <- handleMaybe (mkPluginErrorMessage "No range") $ fromCurrentRange pmap range ^? _Just . L.start & fmap (L.character -~ 1) ident <- findClassIdentifier ast instancePosition @@ -152,7 +153,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = PluginUt Nothing findClassIdentifier hf instancePosition = - handleMaybe (PluginUtils.mkPluginErrorMessage "No Identifier found") + handleMaybe (mkPluginErrorMessage "No Identifier found") $ listToMaybe $ mapMaybe listToMaybe $ pointCommand hf instancePosition @@ -163,7 +164,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = PluginUt findImplementedMethods :: HieASTs a -> Position - -> ExceptT PluginUtils.GhcidePluginError (LspT Ide.Plugin.Config.Config IO) [T.Text] + -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [T.Text] findImplementedMethods asts instancePosition = do pure $ concat @@ -184,7 +185,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = PluginUt $ PluginUtils.useWithStale GhcSessionDeps docPath (tmrTypechecked -> thisMod, _) <- PluginUtils.runAction "classplugin.findClassFromIdentifier.TypeCheck" state $ PluginUtils.useWithStale TypeCheck docPath - handleMaybeM (PluginUtils.CoreError PluginInternalError) + handleMaybeM (PluginInternalError) . liftIO . fmap snd . initTcWithGbl hscenv thisMod ghostSpan $ do @@ -193,7 +194,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = PluginUt AGlobal (AConLike (RealDataCon con)) | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls _ -> fail "Ide.Plugin.Class.findClassFromIdentifier" - findClassFromIdentifier _ (Left _) = throwE (PluginUtils.mkPluginErrorMessage "Ide.Plugin.Class.findClassIdentifier") + findClassFromIdentifier _ (Left _) = throwE (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 574cb33081..35d7a4a710 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -16,6 +16,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils +import Ide.Plugin.Error import Ide.PluginUtils import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -24,8 +25,8 @@ import Language.LSP.Protocol.Types import Language.LSP.Server (sendRequest) codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLens state plId CodeLensParams{..} = PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri +codeLens state plId CodeLensParams{..} = pluginResponse' $ do + nfp <- 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' 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 46e475231c..cd624e2b00 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -14,6 +14,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.Pragmas (getNextPragmaInfo, insertNewPragma) +import Ide.Plugin.Error import Ide.PluginUtils import Language.LSP.Protocol.Types @@ -55,7 +56,7 @@ insertPragmaIfNotPresent :: (MonadIO m) => IdeState -> NormalizedFilePath -> Extension - -> ExceptT PluginUtils.GhcidePluginError m [TextEdit] + -> ExceptT PluginError m [TextEdit] insertPragmaIfNotPresent state nfp pragma = do (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- PluginUtils.runAction "classplugin.insertPragmaIfNotPresent.GhcSession" state $ PluginUtils.useWithStale GhcSession nfp 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 4d9ab26ecd..5628370fdb 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -38,11 +38,9 @@ import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), codeRangeRule, crkToFrk) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) +import Ide.Plugin.Error import Ide.PluginUtils (getNormalizedFilePath', - mkSimpleResponseError, - pluginResponseM, - positionInRange, - withError) + positionInRange) import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), PluginId, defaultPluginDescriptor, @@ -79,7 +77,7 @@ instance Pretty Log where foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError ([FoldingRange] |? Null)) foldingRangeHandler recorder ide _ FoldingRangeParams{..} = pluginResponseM handleErrors $ do - filePath <- withError PluginUtils.CoreError $ getNormalizedFilePath' uri + filePath <- getNormalizedFilePath' uri foldingRanges <- PluginUtils.runAction "FoldingRange" ide $ getFoldingRanges filePath pure . InL $ foldingRanges where @@ -87,12 +85,12 @@ foldingRangeHandler recorder ide _ FoldingRangeParams{..} = TextDocumentIdentifier uri = _textDocument handleErrors = \case - PluginUtils.RuleFailed rule -> do + RuleFailed rule -> do logWith recorder Warning $ LogBadDependency rule pure $ Right $ InL [] - errs -> pure $ Left $ PluginUtils.handlePluginError errs + errs -> pure $ Left $ handlePluginError errs -getFoldingRanges :: NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError Action [FoldingRange] +getFoldingRanges :: NormalizedFilePath -> ExceptT PluginError Action [FoldingRange] getFoldingRanges file = do codeRange <- PluginUtils.use GetCodeRange file pure $ findFoldingRanges codeRange @@ -100,7 +98,7 @@ getFoldingRanges file = do selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError ([SelectionRange] |? Null)) selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do pluginResponseM handleErrors $ do - filePath <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath' uri + filePath <- withError GhcidePluginErrors $ getNormalizedFilePath' uri fmap id . runIdeAction' $ getSelectionRanges filePath positions where uri :: Uri @@ -127,13 +125,13 @@ selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do SelectionRangeOutputPositionMappingFailure -> pure $ Left $ mkSimpleResponseError "failed to apply position mapping to output positions" GhcidePluginErrors ghcidePluginError -> - pure $ Left $ PluginUtils.handlePluginError ghcidePluginError + pure $ Left $ handlePluginError ghcidePluginError data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency rule | SelectionRangeInputPositionMappingFailure | SelectionRangeOutputPositionMappingFailure - | GhcidePluginErrors PluginUtils.GhcidePluginError + | GhcidePluginErrors PluginError getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction ([SelectionRange] |? Null) getSelectionRanges file positions = do 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 7eb2332a5c..d44d1911e4 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -101,7 +101,11 @@ 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.Error (PluginError, + handleMaybe, + handleMaybeM, + mkPluginErrorMessage, + pluginResponse') import Ide.Plugin.Eval.Code (Statement, asStatements, myExecStmt, @@ -123,8 +127,6 @@ import Ide.Plugin.Eval.Util (gStrictTry, isLiterate, logWith, response', timed) -import Ide.PluginUtils (handleMaybe, - handleMaybeM) import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -140,7 +142,7 @@ codeLens st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg in perf "codeLens" $ - PluginUtils.pluginResponse' $ do + pluginResponse' $ do let TextDocumentIdentifier uri = _textDocument fp <- PluginUtils.uriToFilePath' uri let nfp = toNormalizedFilePath' fp @@ -206,7 +208,7 @@ runEvalCmd :: PluginId -> CommandFunction IdeState EvalParams runEvalCmd plId st EvalParams{..} = let dbg = logWith st perf = timed dbg - cmd :: ExceptT GhcidePluginError (LspM Config) WorkspaceEdit + cmd :: ExceptT PluginError (LspM Config) WorkspaceEdit cmd = do let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections @@ -298,9 +300,9 @@ finalReturn txt = p = Position l c in TextEdit (Range p p) "\n" -moduleText :: MonadLsp c m => Uri -> ExceptT GhcidePluginError m Text +moduleText :: MonadLsp c m => Uri -> ExceptT PluginError m Text moduleText uri = - handleMaybeM (PluginUtils.mkPluginErrorMessage "mdlText") $ + handleMaybeM (mkPluginErrorMessage "mdlText") $ (virtualFileText <$>) <$> getVirtualFile (toNormalizedUri uri) 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 ff2324e4ea..c765121bdd 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -23,7 +23,6 @@ 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 Development.IDE.GHC.Compat.Util (MonadCatch, bagToList, @@ -33,7 +32,7 @@ import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, srcLocStartLine) -import Ide.PluginUtils (prettyPluginError) +import Ide.Plugin.Error import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server @@ -69,15 +68,15 @@ logLevel = Debug -- Info isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT GhcidePluginError (LspM c) WorkspaceEdit -> LspM c (Either ResponseError (Value |? Null)) +response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> LspM c (Either ResponseError (Value |? Null)) response' act = do res <- runExceptT act `catchAny` \e -> do res <- showErr e - pure . Left . PluginUtils.mkPluginErrorMessage $ fromString res + pure . Left . mkPluginErrorMessage $ fromString res case res of Left e -> - return $ Left $ PluginUtils.handlePluginError e + return $ Left $ handlePluginError e Right a -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) return $ Right $ InR Null 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 d481d33043..e16e8bf30b 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -28,6 +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.Plugin.Error import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types hiding (pluginId) import Language.LSP.Protocol.Message @@ -43,8 +44,8 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId) } hover :: PluginMethodHandler IdeState Method_TextDocumentHover -hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri +hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse' $ do + nfp <- getNormalizedFilePath' uri PluginUtils.runIdeAction "ExplicitFixity" (shakeExtras state) $ do (FixityMap fixmap, _) <- PluginUtils.useWithStaleFast GetFixity nfp (HAR{hieAst}, mapping) <- PluginUtils.useWithStaleFast GetHieAst nfp diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index c2e5d73682..d68639cdb9 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -40,18 +40,17 @@ import qualified Data.Unique as U (hashUnique, newUnique) import Development.IDE hiding (pluginHandlers, pluginRules) -import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding ((<+>)) import Development.IDE.Graph.Classes import GHC.Generics (Generic) -import Ide.Plugin.RangeMap (filterByRange) -import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybe, +import Ide.Plugin.Error (handleMaybe, handleMaybeM, pluginResponse) +import Ide.Plugin.RangeMap (filterByRange) +import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) +import Ide.PluginUtils (getNormalizedFilePath) import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -101,7 +100,7 @@ descriptorForModules recorder modFilter plId = -- | The actual command handler runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState EIResolveData -runImportCommand recorder ideState eird@(ResolveOne _ _) = PluginUtils.pluginResponse $ do +runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do wedit <- resolveWTextEdit ideState eird _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors return $ InR Null @@ -124,7 +123,7 @@ runImportCommand _ _ (ResolveAll _) = do -- > import Data.List (intercalate, sortBy) lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} - = PluginUtils.pluginResponse $ do + = pluginResponse $ do nfp <- getNormalizedFilePath _uri mbMinImports <- liftIO $ runAction "MinimalImports" state $ use MinimalImports nfp case mbMinImports of @@ -142,7 +141,7 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier { lensResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_CodeLensResolve lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = Just data_@(A.fromJSON -> A.Success (ResolveOne uri uid))}) - = PluginUtils.pluginResponse $ do + = pluginResponse $ do nfp <- getNormalizedFilePath uri (MinimalImportsResult{forResolve}) <- handleMaybeM "Unable to run Minimal Imports" @@ -168,7 +167,7 @@ lensResolveProvider _ _ _ (CodeLens {_data_ = v}) = do -- into explicit imports. codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) - = PluginUtils.pluginResponse $ do + = pluginResponse $ do nfp <- getNormalizedFilePath _uri (MinimalImportsResult{forCodeActions}) <- handleMaybeM "Unable to run Minimal Imports" @@ -194,7 +193,7 @@ codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier codeActionResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_CodeActionResolve codeActionResolveProvider _ ideState _ ca@(CodeAction{_data_= Just (A.fromJSON -> A.Success rd)}) = - PluginUtils.pluginResponse $ do + pluginResponse $ do wedit <- resolveWTextEdit ideState rd pure $ ca & L.edit ?~ wedit codeActionResolveProvider _ _ _ (CodeAction{_data_= Just (A.fromJSON @EIResolveData -> A.Error (T.pack -> str))}) = 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 b7480b2e5e..b1f043880a 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 @@ -62,11 +62,10 @@ import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError, pluginResponse') import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath, - getNormalizedFilePath', - handleMaybeM, pluginResponse) +import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, @@ -102,8 +101,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId) } codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (docId ^. L.uri) +codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse' $ do + nfp <- 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) @@ -360,7 +359,7 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] getRecPatterns _ = Nothing -collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError m CollectRecordsResult +collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT PluginError 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 dcf828b448..f0c9d443fb 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -27,6 +27,7 @@ import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma) import GHC.Generics (Generic) +import Ide.Plugin.Error import Ide.Plugin.GHC import Ide.PluginUtils import Ide.Types @@ -55,7 +56,7 @@ 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{..} = pluginResponseM handleGhcidePluginError $ do - nfp <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath' uri + nfp <- withError (GhcidePluginErrors) $ getNormalizedFilePath' uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d @@ -86,7 +87,7 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponseM handl codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponseM handleGhcidePluginError $ do - nfp <- withError (GhcidePluginErrors . PluginUtils.CoreError) $ getNormalizedFilePath' (doc ^. L.uri) + nfp <- withError (GhcidePluginErrors) $ getNormalizedFilePath' (doc ^. L.uri) (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls pure $ InL actions @@ -127,7 +128,7 @@ data GadtPluginError = UnexpectedNumberOfDeclarations Int | FailedToFindDataDeclRange | PrettyGadtError T.Text - | GhcidePluginErrors PluginUtils.GhcidePluginError + | GhcidePluginErrors PluginError handleGhcidePluginError :: Monad m => @@ -141,4 +142,4 @@ handleGhcidePluginError = \case PrettyGadtError errMsg -> pure $ Left $ mkSimpleResponseError $ errMsg GhcidePluginErrors errors -> - pure $ Left $ PluginUtils.handlePluginError errors + pure $ Left $ handlePluginError errors diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 911dfdca9e..a72e5da890 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -113,9 +113,9 @@ import Language.Haskell.GHC.ExactPrint.Types (Rigidity (. import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities) import qualified Refact.Fixity as Refact #endif - import Ide.Plugin.Config hiding (Config) +import Ide.Plugin.Error import Ide.Plugin.Properties import Ide.PluginUtils import Ide.Types hiding @@ -437,12 +437,12 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context resolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_CodeActionResolve resolveProvider recorder ideState _ - ca@CodeAction {_data_ = Just (fromJSON -> (Success (ApplyHint verTxtDocId oneHint)))} = PluginUtils.pluginResponse $ do + ca@CodeAction {_data_ = Just (fromJSON -> (Success (ApplyHint verTxtDocId oneHint)))} = pluginResponse $ do file <- getNormalizedFilePath (verTxtDocId ^. LSP.uri) edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId pure $ ca & LSP.edit ?~ edit resolveProvider recorder ideState _ - ca@CodeAction {_data_ = Just (fromJSON -> (Success (IgnoreHint verTxtDocId hintTitle)))} = PluginUtils.pluginResponse $ do + ca@CodeAction {_data_ = Just (fromJSON -> (Success (IgnoreHint verTxtDocId hintTitle)))} = pluginResponse $ do file <- getNormalizedFilePath (verTxtDocId ^. LSP.uri) edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle pure $ ca & LSP.edit ?~ edit 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 6b9499111e..5b6dd20219 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 @@ -75,20 +75,17 @@ import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError (..), + pluginResponse') import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (PluginError, - getNormalizedFilePath, - getNormalizedFilePath', - handleMaybeM, - pluginResponse) +import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, defaultPluginDescriptor, mkCodeActionHandlerWithResolve, mkPluginHandler) -import Language.LSP.Protocol.Lens (HasChanges (changes)) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message (Method (..), SMethod (..)) @@ -179,10 +176,10 @@ descriptor recorder plId = (defaultPluginDescriptor plId) resolveProvider :: PluginMethodHandler IdeState 'Method_CodeActionResolve resolveProvider ideState pId ca@(CodeAction _ _ _ _ _ _ _ (Just resData)) = - PluginUtils.pluginResponse' $ do + pluginResponse' $ do case fromJSON resData of Success (ORDRD uri int) -> do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri + nfp <- getNormalizedFilePath' uri CRSR _ crsDetails exts <- collectRecSelResult ideState nfp pragma <- getFirstPragma pId ideState nfp case IntMap.lookup int crsDetails of @@ -191,13 +188,13 @@ resolveProvider ideState pId ca@(CodeAction _ _ _ _ _ _ _ (Just resData)) = -- https://github.com/microsoft/language-server-protocol/issues/1738 -- but we need fendor's plugin error response pr to make it -- convenient to use here, so we will wait to do that till that's merged - _ -> throwE $ PluginUtils.mkPluginErrorMessage "Content Modified Error" - _ -> throwE $ PluginUtils.mkPluginErrorMessage "Unable to deserialize the data" + _ -> throwE $ PluginErrorMessage "Content Modified Error" + _ -> throwE $ PluginErrorMessage "Unable to deserialize the data" codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = - PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' (caDocId ^. L.uri) + pluginResponse' $ do + nfp <- getNormalizedFilePath' (caDocId ^. L.uri) CRSR crsMap crsDetails exts <- collectRecSelResult ideState nfp let mkCodeAction (crsM, nse) = InR CodeAction { -- We pass the record selector to the title function, so that @@ -329,7 +326,7 @@ getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecFld _ _) getRecSels _ = ([], False) collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath - -> ExceptT PluginUtils.GhcidePluginError m CollectRecordSelectorsResult + -> ExceptT PluginError m CollectRecordSelectorsResult collectRecSelResult ideState = 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 31fdeab699..1211f14df2 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -52,6 +52,7 @@ import Development.IDE.Plugin.CodeAction import Development.IDE.Spans.AtPoint import Development.IDE.Types.Location import HieDb.Query +import Ide.Plugin.Error import Ide.Plugin.Properties import Ide.PluginUtils import Ide.Types @@ -71,7 +72,7 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultP renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier uri) pos newNameText) = - PluginUtils.pluginResponse' $ do + pluginResponse' $ do nfp <- handleUriToNfp uri directOldNames <- getNamesAtPos state nfp pos directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames @@ -91,7 +92,7 @@ renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier -- Validate rename crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames - when (any isBuiltInSyntax oldNames) $ throwE $ PluginUtils.mkPluginErrorMessage "Invalid rename of built-in syntax" + when (any isBuiltInSyntax oldNames) $ throwE $ mkPluginErrorMessage "Invalid rename of built-in syntax" -- Perform rename let newName = mkTcOcc $ T.unpack newNameText @@ -109,17 +110,17 @@ failWhenImportOrExport :: NormalizedFilePath -> HashSet Location -> [Name] -> - ExceptT PluginUtils.GhcidePluginError m () + ExceptT PluginError m () failWhenImportOrExport state nfp refLocs names = do 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 $ PluginUtils.mkPluginErrorMessage "Renaming of an imported name is unsupported" + -> throwE $ mkPluginErrorMessage "Renaming of an imported name is unsupported" (_, Just (L _ exports)) | any ((`HS.member` refLocs) . unsafeSrcSpanToLoc . getLoc) exports - -> throwE $ PluginUtils.mkPluginErrorMessage "Renaming of an exported name is unsupported" - (Just _, Nothing) -> throwE $ PluginUtils.mkPluginErrorMessage "Explicit export list required for renaming" + -> throwE $ mkPluginErrorMessage "Renaming of an exported name is unsupported" + (Just _, Nothing) -> throwE $ mkPluginErrorMessage "Explicit export list required for renaming" _ -> pure () --------------------------------------------------------------------------------------------------- @@ -131,7 +132,7 @@ getSrcEdit :: IdeState -> VersionedTextDocumentIdentifier -> (ParsedSource -> ParsedSource) -> - ExceptT PluginUtils.GhcidePluginError m WorkspaceEdit + ExceptT PluginError m WorkspaceEdit getSrcEdit state verTxtDocId updatePs = do ccs <- lift getClientCapabilities nfp <- handleUriToNfp (verTxtDocId ^. L.uri) @@ -192,7 +193,7 @@ refsAtName :: IdeState -> NormalizedFilePath -> Name -> - ExceptT PluginUtils.GhcidePluginError m [Location] + ExceptT PluginError m [Location] refsAtName state nfp name = do ShakeExtras{withHieDb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras ast <- handleGetHieAst state nfp @@ -217,7 +218,7 @@ nameLocs name (HAR _ _ rm _ _, pm) = --------------------------------------------------------------------------------------------------- -- Util -getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginUtils.GhcidePluginError m [Name] +getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginError m [Name] getNamesAtPos state nfp pos = do (HAR{hieAst}, pm) <- handleGetHieAst state nfp pure $ getNamesAtPoint hieAst pos pm @@ -226,7 +227,7 @@ handleGetHieAst :: MonadIO m => IdeState -> NormalizedFilePath -> - ExceptT PluginUtils.GhcidePluginError m (HieAstResult, PositionMapping) + ExceptT PluginError m (HieAstResult, PositionMapping) handleGetHieAst state nfp = fmap (first removeGenerated) $ PluginUtils.runAction "Rename.GetHieAst" state $ PluginUtils.useWithStale GetHieAst nfp @@ -244,8 +245,8 @@ removeGenerated HAR{..} = HAR{hieAst = go hieAst,..} hf #endif -handleUriToNfp :: (Monad m) => Uri -> ExceptT PluginUtils.GhcidePluginError m NormalizedFilePath -handleUriToNfp uri = PluginUtils.withPluginError $ getNormalizedFilePath' uri +handleUriToNfp :: (Monad m) => Uri -> ExceptT PluginError m NormalizedFilePath +handleUriToNfp uri = 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 4a6a9c188f..33f62a0ab3 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -113,6 +113,7 @@ import qualified GHC (Module, ParsedSource, import qualified GHC as GHCGHC import GHC.Generics (Generic) import GHC.Hs.Dump +import Ide.Plugin.Error import Ide.PluginUtils import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -212,8 +213,8 @@ runRetrieCmd :: LspM c (Either ResponseError (Value |? Null)) runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = withIndefiniteProgress description Cancellable $ do - PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri + pluginResponse' $ do + nfp <- getNormalizedFilePath' uri (session, _) <- PluginUtils.runAction "Retrie.GhcSessionDeps" state $ PluginUtils.useWithStale GhcSessionDeps @@ -246,11 +247,9 @@ data RunRetrieInlineThisParams = RunRetrieInlineThisParams runRetrieInlineThisCmd :: IdeState -> RunRetrieInlineThisParams -> LspM c (Either ResponseError (Value |? Null)) -runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = PluginUtils.pluginResponse' $ do - nfp <- PluginUtils.withPluginError $ - getNormalizedFilePath' $ getLocationUri inlineIntoThisLocation - nfpSource <- PluginUtils.withPluginError $ - getNormalizedFilePath' $ getLocationUri inlineFromThisLocation +runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse' $ do + nfp <- getNormalizedFilePath' $ getLocationUri inlineIntoThisLocation + nfpSource <- getNormalizedFilePath' $ getLocationUri inlineFromThisLocation -- What we do here: -- Find the identifier in the given position -- Construct an inline rewrite for it @@ -269,7 +268,7 @@ runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = PluginUtils.pluginR fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange - when (null inlineRewrite) $ throwE $ PluginUtils.mkPluginErrorMessage "Empty rewrite" + when (null inlineRewrite) $ throwE $ mkPluginErrorMessage "Empty rewrite" let ShakeExtras{..} = shakeExtras state (session, _) <- PluginUtils.runAction "retrie" state $ PluginUtils.useWithStale GhcSessionDeps nfp @@ -277,8 +276,8 @@ runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = PluginUtils.pluginR result <- liftIO $ try @_ @SomeException $ runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp case result of - Left err -> throwE $ PluginUtils.mkPluginErrorMessage $ "Retrie - crashed with: " <> T.pack (show err) - Right (_,_,NoChange) -> throwE $ PluginUtils.mkPluginErrorMessage "Retrie - inline produced no changes" + Left err -> throwE $ mkPluginErrorMessage $ "Retrie - crashed with: " <> T.pack (show err) + Right (_,_,NoChange) -> throwE $ mkPluginErrorMessage "Retrie - inline produced no changes" Right (_,_,Change replacements imports) -> do let edits = asEditMap $ asTextEdits $ Change ourReplacement imports wedit = WorkspaceEdit (Just edits) Nothing Nothing @@ -339,9 +338,9 @@ extractImports _ _ _ = [] ------------------------------------------------------------------------------- provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction -provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = PluginUtils.pluginResponse' $ do +provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = pluginResponse' $ do let (LSP.CodeActionContext _diags _monly _) = ca - nfp <- PluginUtils.withPluginError $ getNormalizedFilePath' uri + nfp <- getNormalizedFilePath' uri (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) <- PluginUtils.runAction "retrie" state $ @@ -349,7 +348,7 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras - range <- handleMaybe (PluginUtils.mkPluginErrorMessage "range") $ fromCurrentRange posMapping range + range <- handleMaybe (mkPluginErrorMessage "range") $ fromCurrentRange posMapping range let pos = range ^. L.start let rewrites = concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds @@ -380,7 +379,7 @@ getLocationUri Location{_uri} = _uri getLocationRange Location{_range} = _range -getBinds :: NormalizedFilePath -> ExceptT PluginUtils.GhcidePluginError Action (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn]) +getBinds :: NormalizedFilePath -> ExceptT PluginError 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 From 1776bd830c44238d930b6b1ff3e0de1d77cd6318 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 20 Jul 2023 19:00:23 +0300 Subject: [PATCH 04/28] Replace ResponseError with PluginError for plugins Additionally further PluginError constructors and helpers refactoring --- ghcide/src/Development/IDE.hs | 3 +- ghcide/src/Development/IDE/Core/Actions.hs | 2 +- .../src/Development/IDE/Core/PluginUtils.hs | 55 +++++++++-------- .../Development/IDE/LSP/HoverDefinition.hs | 28 ++++----- ghcide/src/Development/IDE/LSP/Outline.hs | 4 +- .../src/Development/IDE/Plugin/Completions.hs | 9 +-- ghcide/src/Development/IDE/Plugin/HLS.hs | 43 +++++++++----- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 4 +- ghcide/src/Development/IDE/Plugin/Test.hs | 11 ++-- .../src/Development/IDE/Plugin/TypeLenses.hs | 25 ++++---- ghcide/src/Development/IDE/Spans/Pragmas.hs | 6 +- hls-plugin-api/src/Ide/Plugin/Error.hs | 59 +++++++++---------- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 25 ++++---- hls-plugin-api/src/Ide/PluginUtils.hs | 22 ------- hls-plugin-api/src/Ide/Types.hs | 32 +++++----- .../src/Ide/Plugin/AlternateNumberFormat.hs | 11 ++-- .../src/Ide/Plugin/CabalFmt.hs | 7 ++- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 6 +- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 9 ++- .../src/Ide/Plugin/ChangeTypeSignature.hs | 15 ++--- .../src/Ide/Plugin/Class/CodeAction.hs | 44 +++++++------- .../src/Ide/Plugin/Class/CodeLens.hs | 14 ++--- .../src/Ide/Plugin/Class/Utils.hs | 14 ++--- .../src/Ide/Plugin/CodeRange.hs | 36 +++++------ .../src/Ide/Plugin/Eval/CodeLens.hs | 17 +++--- .../src/Ide/Plugin/Eval/Util.hs | 6 +- .../src/Ide/Plugin/ExplicitFixity.hs | 13 ++-- .../src/Ide/Plugin/ExplicitImports.hs | 56 ++++++++---------- .../src/Ide/Plugin/ExplicitFields.hs | 15 ++--- .../src/Ide/Plugin/Floskell.hs | 3 +- .../src/Ide/Plugin/Fourmolu.hs | 10 ++-- .../hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 24 ++++---- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 25 ++++---- .../src/Ide/Plugin/Ormolu.hs | 5 +- .../src/Ide/Plugin/OverloadedRecordDot.hs | 27 ++++----- .../src/Development/IDE/Plugin/CodeAction.hs | 8 +-- .../Development/IDE/Plugin/CodeAction/Args.hs | 5 +- .../IDE/Plugin/Plugins/AddArgument.hs | 16 ++--- .../src/Ide/Plugin/Rename.hs | 24 ++++---- .../src/Ide/Plugin/Retrie.hs | 58 +++++++++--------- .../src/Ide/Plugin/Splice.hs | 3 +- .../src/Ide/Plugin/StylishHaskell.hs | 3 +- 42 files changed, 385 insertions(+), 417 deletions(-) diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 503f0104f8..2d46f0e458 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -9,8 +9,7 @@ module Development.IDE import Development.IDE.Core.Actions as X (getAtPoint, getDefinition, getTypeDefinition, - useE, useNoFileE, - usesE) + useNoFileE, usesE) import Development.IDE.Core.FileExists as X (getFileExists) import Development.IDE.Core.FileStore as X (getFileContents) import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..), diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index c8e384c1b5..92bafd099c 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -6,7 +6,7 @@ module Development.IDE.Core.Actions , getTypeDefinition , highlightAtPoint , refsAtPoint -, useE +--, useE , useNoFileE , usesE , workspaceSymbols diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index b6799c6c4e..10da1cc932 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -6,10 +6,9 @@ import Control.Monad.IO.Class import Control.Monad.Reader (runReaderT) import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe -import Data.Bifunctor (first) import Data.Either.Extra (maybeToEither) import Data.Functor.Identity -import Data.String (IsString (fromString)) +import qualified Data.Text as T import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake (IdeAction, IdeRule, IdeState (shakeExtras), @@ -29,48 +28,52 @@ import qualified Language.LSP.Protocol.Types as LSP -- Action wrappers -- ---------------------------------------------------------------------------- -runAction :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a -runAction herald ide act = +runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a +runActionE herald ide act = 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 PluginError Action (v, PositionMapping) -useWithStale key file = maybeToExceptT (FastRuleNotReady key) $ useWithStaleMaybeT key file +runActionMaybeT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a +runActionMaybeT herald ide act = + hoistMaybeT . MaybeT $ + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act) -- | useE is useful to implement functions that aren’t rules but need shortcircuiting -- e.g. getDefinition. -use :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v -use k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.use k +useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v +useE k = maybeToExceptT (RuleFailed k) . useMaybeT k + +useMaybeT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v +useMaybeT k = MaybeT . Shake.use k + +useWithStaleE :: IdeRule k v + => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping) +useWithStaleE key = maybeToExceptT (FastRuleNotReady key) . useWithStaleMaybeT key useWithStaleMaybeT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping) useWithStaleMaybeT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) +hoistAction :: Action a -> ExceptT e Action a +hoistAction = ExceptT . fmap Right + -- ---------------------------------------------------------------------------- -- 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 +runIdeActionE :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a +runIdeActionE _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 PluginError IdeAction (v, PositionMapping) -useWithStaleFast k = maybeToExceptT (RuleFailed k) . MaybeT . Shake.useWithStaleFast k +useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping) +useWithStaleFastE k = maybeToExceptT (RuleFailed k) . useWithStaleFastMaybeT k -uriToFilePath' :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath -uriToFilePath' uri = ExceptT . pure . maybeToEither (PluginUriToFilePath uri) $ Location.uriToFilePath' uri +useWithStaleFastMaybeT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) +useWithStaleFastMaybeT k = MaybeT . Shake.useWithStaleFast k --- ---------------------------------------------------------------------------- --- Internal Helper function, not exported --- ---------------------------------------------------------------------------- +uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath +uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <> show uri)) $ uriToFilePathMaybeT uri -hoistAction :: Action a -> ExceptT e Action a -hoistAction = ExceptT . fmap Right +uriToFilePathMaybeT :: Monad m => LSP.Uri -> MaybeT m FilePath +uriToFilePathMaybeT = MaybeT . pure . Location.uriToFilePath' diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index fdd51a9014..3435aaf685 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -22,33 +22,31 @@ import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger +import Ide.Plugin.Error import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (MessageResult Method_TextDocumentDefinition)) -hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Hover |? Null)) -gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (MessageResult Method_TextDocumentTypeDefinition)) -documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError ([DocumentHighlight] |? Null)) +gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either PluginError (MessageResult Method_TextDocumentDefinition)) +hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either PluginError (Hover |? Null)) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either PluginError (MessageResult Method_TextDocumentTypeDefinition)) +documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either PluginError ([DocumentHighlight] |? Null)) gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError ([Location] |? Null)) -references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ - case uriToFilePath' uri of - Just path -> do - let filePath = toNormalizedFilePath' path - logDebug (ideLogger ide) $ +references :: IdeState -> ReferenceParams -> LSP.LspM c (Either PluginError ([Location] |? Null)) +references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = runExceptT $ do + nfp <- getNormalizedFilePathE uri + liftIO $ logDebug (ideLogger ide) $ "References request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path - Right . InL <$> (runAction "references" ide $ refsAtPoint filePath pos) - Nothing -> pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) ("Invalid URI " <> T.pack (show uri)) Nothing + " in file: " <> T.pack (show nfp) + InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError [SymbolInformation]) +wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either PluginError [SymbolInformation]) wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do logDebug (ideLogger ide) $ "Workspace symbols request: " <> query runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . fromMaybe [] <$> workspaceSymbols query @@ -65,7 +63,7 @@ request -> (a -> b) -> IdeState -> TextDocumentPositionParams - -> LSP.LspM c (Either ResponseError b) + -> LSP.LspM c (Either PluginError b) request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest label getResults ide pos path diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 64c7e14bd9..c15278b079 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -22,6 +22,7 @@ import Development.IDE.GHC.Error (rangeToRealSrcSpan, realSrcSpanToRange) import Development.IDE.Types.Location import Development.IDE.GHC.Util (printOutputable) +import Ide.Plugin.Error import Language.LSP.Server (LspM) import Language.LSP.Protocol.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), @@ -29,13 +30,12 @@ import Language.LSP.Protocol.Types (DocumentSymbol (..), SymbolKind (..), TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL, InR), uriToFilePath, Null) -import Language.LSP.Protocol.Message (ResponseError) #if MIN_VERSION_ghc(9,2,0) import Data.List.NonEmpty (nonEmpty) #endif moduleOutline - :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError ([SymbolInformation] |? ([DocumentSymbol] |? Null))) + :: IdeState -> DocumentSymbolParams -> LspM c (Either PluginError ([SymbolInformation] |? ([DocumentSymbol] |? Null))) moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 4f6b8cfa97..20b4d9cd8d 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -40,6 +40,7 @@ import Development.IDE.Types.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) +import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -158,14 +159,10 @@ resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} ur where stripForall ty = case splitForAllTyCoVars ty of (_,res) -> res -resolveCompletion _ _ _ _ _ = pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unable to get normalized file path for url" Nothing +resolveCompletion _ _ _ _ _ = pure $ Left $ PluginInvalidParams "Unable to get normalized file path for url" -- | Generate code actions. -getCompletionsLSP - :: IdeState - -> PluginId - -> CompletionParams - -> LSP.LspM Config (Either ResponseError (MessageResult Method_TextDocumentCompletion)) +getCompletionsLSP :: PluginMethodHandler IdeState 'Method_TextDocumentCompletion getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 5f3ca5882f..dab84da4de 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -34,6 +34,7 @@ import Development.IDE.Plugin import qualified Development.IDE.Plugin as P import Development.IDE.Types.Logger hiding (Error) import Ide.Plugin.Config +import Ide.Plugin.Error import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS import qualified Language.LSP.Protocol.Lens as L @@ -51,14 +52,16 @@ import UnliftIO.Exception (catchAny) -- data Log - = LogPluginError PluginId ResponseError + = LogPluginError PluginId PluginError + | LogResponseError PluginId ResponseError | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier | ExceptionInPlugin PluginId (Some SMethod) SomeException instance Pretty Log where pretty = \case - LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err + LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> pretty err + LogResponseError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err LogNoPluginForMethod (Some method) -> "No plugin enabled for " <> pretty (show method) LogInvalidCommandIdentifier-> "Invalid command identifier" @@ -104,7 +107,7 @@ exceptionInPlugin plId method exception = logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder p errCode msg = do let err = ResponseError errCode msg Nothing - logWith recorder Warning $ LogPluginError p err + logWith recorder Warning $ LogResponseError p err pure $ Left err -- | Logs the provider error before returning it to the caller @@ -213,7 +216,7 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom Just (PluginCommand _ _ f) -> case A.fromJSON arg of A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) A.Success a -> - f ide a `catchAny` -- See Note [Exception handling in plugins] + (first toResponseError <$> f ide a) `catchAny` -- See Note [Exception handling in plugins] (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e)) -- --------------------------------------------------------------------- @@ -246,10 +249,9 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } es <- runConcurrently exceptionInPlugin m handlers ide params let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es - unless (null errs) $ forM_ errs $ \(pId, err) -> - logWith recorder Warning $ LogPluginError pId err + unless (null errs) $ logErrors recorder errs case nonEmpty succs of - Nothing -> pure $ Left $ combineErrors $ map snd errs + Nothing -> pure $ Left $ combineErrors errs Just xs -> do caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs @@ -288,22 +290,35 @@ runConcurrently :: MonadUnliftIO m => (PluginId -> SMethod method -> SomeException -> T.Text) -> SMethod method -- ^ Method (used for errors and tracing) - -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) + -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either PluginError d))) -- ^ Enabled plugin actions that we are allowed to run -> a -> b - -> m (NonEmpty(NonEmpty (Either ResponseError d))) + -> m (NonEmpty(NonEmpty (Either PluginError d))) runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString (show method)) $ do f a b -- See Note [Exception handling in plugins] - `catchAny` (\e -> pure $ pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg pid method e) Nothing) + `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) + +combineErrors :: [(PluginId, PluginError)] -> ResponseError +combineErrors [x] = toResponseError (snd x) +combineErrors xs = ResponseError (InR ErrorCodes_InternalError) (T.pack (show (pretty (snd <$> xs)))) Nothing + +toResponseError :: PluginError -> ResponseError +toResponseError (PluginInternalError msg) = ResponseError (InR ErrorCodes_InternalError) msg Nothing +toResponseError PluginStaleResolve = ResponseError (InL LSPErrorCodes_ContentModified) "" Nothing +toResponseError (PluginInvalidParams msg) = ResponseError (InR ErrorCodes_InvalidParams) msg Nothing +toResponseError (PluginParseError msg) = ResponseError (InR ErrorCodes_ParseError) msg Nothing +toResponseError (FastRuleNotReady a) = ResponseError (InL LSPErrorCodes_ServerCancelled) (T.pack $ "FastRuleNotReady: " <> show a) Nothing +toResponseError (RuleFailed a) = ResponseError (InL LSPErrorCodes_ServerCancelled) (T.pack $ "RuleFailed: " <> show a) Nothing + +logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> LSP.LspT Config IO () +logErrors recorder errs = forM_ errs $ \(pId, err) -> + logWith recorder Warning $ LogPluginError pId err -combineErrors :: [ResponseError] -> ResponseError -combineErrors [x] = x -combineErrors xs = ResponseError (InR ErrorCodes_InternalError) (T.pack (show xs)) Nothing -- | Combine the 'PluginHandler' for all plugins newtype IdeHandler (m :: Method ClientToServer Request) - = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (MessageResult m))))] + = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either PluginError (MessageResult m))))] -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: Method ClientToServer Notification) diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index d419710d51..d0b95c2109 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -60,13 +60,13 @@ descriptor plId = (defaultPluginDescriptor plId) -- --------------------------------------------------------------------- -hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Hover |? Null)) +hover' :: PluginMethodHandler IdeState 'Method_TextDocumentHover hover' ideState _ HoverParams{..} = do liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ hover ideState TextDocumentPositionParams{..} -- --------------------------------------------------------------------- -symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError ([SymbolInformation] |? ([DocumentSymbol] |? Null))) +symbolsProvider :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol symbolsProvider ide _ params = moduleOutline ide params -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 6028d29132..9952f336a1 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -45,6 +45,8 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) import Ide.Plugin.Config (CheckParents) +import Ide.Plugin.Error +import Ide.Plugin.Error (PluginError (PluginInvalidRequest)) import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -85,12 +87,12 @@ plugin = (defaultPluginDescriptor "test") { = testRequestHandler ide customReq | otherwise = return $ Left - $ ResponseError (InR ErrorCodes_InvalidRequest) "Cannot parse request" Nothing + $ PluginInvalidRequest "Cannot parse request" testRequestHandler :: IdeState -> TestRequest - -> LSP.LspM c (Either ResponseError Value) + -> LSP.LspM c (Either PluginError Value) testRequestHandler _ (BlockSeconds secs) = do LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $ toJSON secs @@ -113,7 +115,7 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp let res = WaitForIdeRuleResult <$> success - return $ bimap mkResponseError toJSON res + return $ bimap PluginInvalidRequest toJSON res testRequestHandler s GetBuildKeysBuilt = liftIO $ do keys <- getDatabaseKeys resultBuilt $ shakeDb s return $ Right $ toJSON $ map show keys @@ -147,9 +149,6 @@ getDatabaseKeys field db = do step <- shakeGetBuildStep db return [ k | (k, res) <- keys, field res == Step step] -mkResponseError :: Text -> ResponseError -mkResponseError msg = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing - parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 20b4eefdb8..87cba3bad0 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -30,7 +30,7 @@ import Development.IDE (GhcSession (..), define, srcSpanToRange, usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) -import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.Core.Rules (IdeState, runAction) @@ -52,8 +52,7 @@ import Development.IDE.Types.Logger (Pretty (pretty), import GHC.Generics (Generic) import Ide.Plugin.Error import Ide.Plugin.Properties -import Ide.PluginUtils (getNormalizedFilePath', - mkLspCommand) +import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandFunction, CommandId (CommandId), PluginCommand (PluginCommand), @@ -106,22 +105,22 @@ properties = emptyProperties ] Always codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse' $ do +codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = runExceptT $ do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties - nfp <- getNormalizedFilePath' uri + nfp <- getNormalizedFilePathE uri env <- hscEnv . fst <$> - PluginUtils.runAction "codeLens.GhcSession" ideState - (PluginUtils.useWithStale GhcSession nfp) + runActionE "codeLens.GhcSession" ideState + (useWithStaleE GhcSession nfp) - (tmr, _) <- PluginUtils.runAction "codeLens.TypeCheck" ideState - (PluginUtils.useWithStale TypeCheck nfp) + (tmr, _) <- runActionE "codeLens.TypeCheck" ideState + (useWithStaleE TypeCheck nfp) - (bindings, _) <- PluginUtils.runAction "codeLens.GetBindings" ideState - (PluginUtils.useWithStale GetBindings nfp) + (bindings, _) <- runActionE "codeLens.GetBindings" ideState + (useWithStaleE GetBindings nfp) (gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <- - PluginUtils.runAction "codeLens.GetGlobalBindingTypeSigs" ideState - (PluginUtils.useWithStale GetGlobalBindingTypeSigs nfp) + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + (useWithStaleE 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 f5de5ba2f6..2fea43f018 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -24,7 +24,7 @@ import Control.Monad.Trans.Except (ExceptT) import Ide.Plugin.Error (PluginError) import Ide.Types (PluginId(..)) import qualified Data.Text as T -import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo getNextPragmaInfo dynFlags sourceText = @@ -54,8 +54,8 @@ insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit prag getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError 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 + ghcSession <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp + (_, fileContents) <- runActionE (T.unpack pId <> ".GetFileContents") state $ hoistAction $ getFileContents nfp case ghcSession of (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ getNextPragmaInfo sessionDynFlags fileContents diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index 9f58959fbc..51439cc8d5 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -4,49 +4,37 @@ module Ide.Plugin.Error ( -- * Plugin Error Handling API PluginError(..), - pluginResponse, - pluginResponse', + runExceptT, + runExceptT, pluginResponseM, handlePluginError, - mkPluginErrorMessage, hoistExceptT, + hoistMaybeT, handleMaybe, handleMaybeM, - mkSimpleResponseError, withError, + getNormalizedFilePathE, ) where - import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, runExceptT, throwE, withExceptT) import Data.Bifunctor (Bifunctor (first)) +import Data.String +import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) import qualified Data.Text as T import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Prettyprinter import Prettyprinter.Render.Text (renderStrict) -type PluginHandler e m a = ExceptT e m a - -- ---------------------------------------------------------------------------- -- Plugin Error wrapping -- ---------------------------------------------------------------------------- - -pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a) -pluginResponse = - fmap (first (\msg -> ResponseError (InR ErrorCodes_InternalError) (T.pack msg) Nothing)) - . runExceptT - -pluginResponse' :: Monad m => ExceptT PluginError m a -> m (Either ResponseError a) -pluginResponse' = - fmap (first handlePluginError) - . runExceptT - pluginResponseM :: Monad m => (t -> m (Either a b)) -> ExceptT t m b -> m (Either a b) pluginResponseM handler act = runExceptT act >>= \case @@ -58,27 +46,26 @@ handlePluginError msg = ResponseError (InR ErrorCodes_InternalError) (renderStri where simpleDoc = layoutPretty defaultLayoutOptions $ pretty msg data PluginError - = PluginInternalError - | PluginUriToFilePath Uri - | PluginUriToNormalizedFilePath Uri - | PluginErrorMessage T.Text + = PluginInternalError T.Text + | PluginInvalidParams T.Text + | PluginParseError T.Text + | PluginInvalidRequest T.Text + | PluginStaleResolve + | PluginBadDependency T.Text | forall a . Show a => FastRuleNotReady a | forall a . Show a => RuleFailed a instance Pretty PluginError where pretty = \case - PluginInternalError -> "Internal Plugin Error" - PluginUriToFilePath uri -> "Failed to translate URI " <+> viaShow uri - PluginUriToNormalizedFilePath uri -> "Failed converting " <+> viaShow uri <+> " to NormalizedFilePath" - PluginErrorMessage msg -> "Plugin failed: " <+> viaShow msg + PluginInternalError msg -> "Internal Plugin Error: " <+> viaShow msg + PluginStaleResolve -> "Stale Resolve" FastRuleNotReady rule -> "FastRuleNotReady:" <+> viaShow rule RuleFailed rule -> "RuleFailed:" <+> viaShow rule + PluginInvalidParams text -> "Invalid Params:" <+> viaShow text + PluginParseError text -> "Parse Error:" <+> viaShow text + PluginInvalidRequest text -> "Invalid Request:" <+> viaShow text + PluginBadDependency text -> "Bad dependency" <+> viaShow text -mkPluginErrorMessage :: T.Text -> PluginError -mkPluginErrorMessage = PluginErrorMessage - -mkSimpleResponseError :: T.Text -> ResponseError -mkSimpleResponseError err = ResponseError (InR ErrorCodes_InternalError) err Nothing handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return @@ -91,3 +78,13 @@ withError = withExceptT hoistExceptT :: MonadIO m => ExceptT e IO a -> ExceptT e m a hoistExceptT = mapExceptT liftIO + +hoistMaybeT :: MonadIO m => MaybeT IO a -> MaybeT m a +hoistMaybeT = mapMaybeT liftIO + +getNormalizedFilePathE :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath +getNormalizedFilePathE uri = handleMaybe (PluginInvalidParams (T.pack $ "uriToNormalizedFile failed. Uri:" <> show uri)) + $ uriToNormalizedFilePath + $ toNormalizedUri uri + +-- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 9f5ab76014..23eee0bced 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -19,6 +19,7 @@ import Data.Maybe (catMaybes) import Data.Row ((.!)) import qualified Data.Text as T import GHC.Generics (Generic) +import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -36,8 +37,8 @@ import Language.LSP.Server (LspM, LspT, -- the client supports resolve and act accordingly in your own providers. mkCodeActionHandlerWithResolve :: forall ideState a. (A.FromJSON a) => - (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) - -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) + (ideState -> PluginId -> CodeActionParams -> LspM Config (Either PluginError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either PluginError CodeAction)) -> PluginHandlers ideState mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = runExceptT $ @@ -55,7 +56,7 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = where dropData :: CodeAction -> CodeAction dropData ca = ca & L.data_ .~ Nothing - resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) + resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (LspT Config IO) (Command |? CodeAction) resolveCodeAction _uri _ideState _plId c@(InL _) = pure c resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do case A.fromJSON value of @@ -78,8 +79,8 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = mkCodeActionWithResolveAndCommand :: forall ideState a. (A.FromJSON a) => PluginId - -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) - -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) + -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either PluginError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either PluginError CodeAction)) -> ([PluginCommand ideState], PluginHandlers ideState) mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = runExceptT $ @@ -112,7 +113,7 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = wrapWithURI uri codeAction = codeAction & L.data_ .~ (A.toJSON .WithURI uri <$> data_) where data_ = codeAction ^? L.data_ . _Just - executeResolveCmd :: (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction))-> CommandFunction ideState CodeAction + executeResolveCmd :: (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either PluginError CodeAction))-> CommandFunction ideState CodeAction executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do withIndefiniteProgress "Applying edits for code action..." Cancellable $ do case A.fromJSON value of @@ -169,14 +170,14 @@ supportsCodeActionResolve caps = Just row -> "edit" `elem` row .! #properties _ -> False -internalError :: T.Text -> ResponseError -internalError msg = ResponseError (InR ErrorCodes_InternalError) ("Ide.Plugin.Resolve: Internal Error : " <> msg) Nothing +internalError :: T.Text -> PluginError +internalError msg = PluginInternalError ("Ide.Plugin.Resolve: Internal Error : " <> msg) -invalidParamsError :: T.Text -> ResponseError -invalidParamsError msg = ResponseError (InR ErrorCodes_InvalidParams) ("Ide.Plugin.Resolve: : " <> msg) Nothing +invalidParamsError :: T.Text -> PluginError +invalidParamsError msg = PluginInvalidParams ("Ide.Plugin.Resolve: : " <> msg) -parseError :: Maybe A.Value -> T.Text -> ResponseError -parseError value errMsg = ResponseError (InR ErrorCodes_ParseError) ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) Nothing +parseError :: Maybe A.Value -> T.Text -> PluginError +parseError value errMsg = PluginParseError ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) {- Note [Code action resolve fallback to commands] To make supporting code action resolve easy for plugins, we want to let them diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 4898a6f342..0898288399 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -15,7 +15,6 @@ module Ide.PluginUtils diffText', pluginDescToIdePlugins, idePluginsToPluginDesc, - responseError, getClientConfig, getPluginConfig, configForPlugin, @@ -31,10 +30,6 @@ module Ide.PluginUtils subRange, positionInRange, usePropertyLsp, - -- * Batteries-included plugin error API - getNormalizedFilePath, - getNormalizedFilePath', - throwPluginError, -- * Escape unescape, ) @@ -263,12 +258,6 @@ allLspCmdIds pid commands = concatMap go commands -- --------------------------------------------------------------------- -getNormalizedFilePath' :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath -getNormalizedFilePath' uri = handleMaybe (PluginUriToNormalizedFilePath uri) - $ uriToNormalizedFilePath - $ toNormalizedUri uri - --- --------------------------------------------------------------------- type TextParser = P.Parsec Void T.Text @@ -298,14 +287,3 @@ escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) inside' = concatMap f inside pure $ "\"" <> inside' <> "\"" - -getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath -getNormalizedFilePath uri = handleMaybe errMsg - $ uriToNormalizedFilePath - $ toNormalizedUri uri - where - errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath" - --- --------------------------------------------------------------------- -throwPluginError :: Monad m => String -> ExceptT String m b -throwPluginError = throwE diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index bd35a3312d..57c7c01d6a 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -47,7 +47,6 @@ module Ide.Types , PluginRequestMethod(..) , getProcessID, getPid , installSigUsr1Handler -, responseError , lookupCommandProvider , ResolveFunction , mkResolveHandler @@ -85,6 +84,7 @@ import Data.Text.Encoding (encodeUtf8) import Development.IDE.Graph import GHC (DynFlags) import GHC.Generics +import Ide.Plugin.Error import Ide.Plugin.Properties import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -751,7 +751,7 @@ instance GCompare IdeNotification where -- | Combine handlers for the newtype PluginHandler a (m :: Method ClientToServer Request) - = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (MessageResult m)))) + = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either PluginError (MessageResult m)))) newtype PluginNotificationHandler a (m :: Method ClientToServer Notification) = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ()) @@ -776,7 +776,7 @@ instance Semigroup (PluginNotificationHandlers a) where instance Monoid (PluginNotificationHandlers a) where mempty = PluginNotificationHandlers mempty -type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (MessageResult m)) +type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either PluginError (MessageResult m)) type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () @@ -789,7 +789,7 @@ mkPluginHandler -> PluginHandlers ideState mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m)) where - f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either ResponseError (MessageResult m))) + f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either PluginError (MessageResult m))) -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions -- CodeLens, and Completion methods. f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} = @@ -890,7 +890,7 @@ data PluginCommand ideState = forall a. (FromJSON a) => type CommandFunction ideState a = ideState -> a - -> LspM Config (Either ResponseError (Value |? Null)) + -> LspM Config (Either PluginError (Value |? Null)) -- --------------------------------------------------------------------- @@ -900,7 +900,7 @@ type ResolveFunction ideState a (m :: Method ClientToServer Request) = -> MessageParams m -> Uri -> a - -> LspM Config (Either ResponseError (MessageResult m)) + -> LspM Config (Either PluginError (MessageResult m)) -- | Make a handler for resolve methods. In here we take your provided ResolveFunction -- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers] @@ -912,7 +912,7 @@ mkResolveHandler -> MessageParams m -> Uri -> a - -> LspM Config (Either ResponseError (MessageResult m))) + -> LspM Config (Either PluginError (MessageResult m))) -> PluginHandlers ideState mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do case fromJSON <$> (params ^. L.data_) of @@ -924,10 +924,10 @@ mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do let newParams = params & L.data_ ?~ value in f ideState plId newParams uri decodedValue Error err -> - pure $ Left $ ResponseError (InR ErrorCodes_ParseError) (parseError value err) Nothing - else pure $ Left $ ResponseError (InR ErrorCodes_InternalError) invalidRequest Nothing - (Just (Error err)) -> pure $ Left $ ResponseError (InR ErrorCodes_ParseError) (parseError (params ^. L.data_) err) Nothing - _ -> pure $ Left $ ResponseError (InR ErrorCodes_InternalError) invalidRequest Nothing + pure $ Left $ PluginParseError (parseError value err) + else pure $ Left $ PluginInternalError invalidRequest + (Just (Error err)) -> pure $ Left $ PluginParseError (parseError (params ^. L.data_) err) + _ -> pure $ Left $ PluginInternalError invalidRequest where invalidRequest = "The resolve request incorrectly got routed to the wrong resolve handler!" parseError value err = "Unable to decode: " <> (T.pack $ show value) <> ". Error: " <> (T.pack $ show err) @@ -986,7 +986,7 @@ type FormattingHandler a -> T.Text -> NormalizedFilePath -> FormattingOptions - -> LspM Config (Either ResponseError ([TextEdit] |? Null)) + -> LspM Config (Either PluginError ([TextEdit] |? Null)) mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting) @@ -1003,19 +1003,15 @@ mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provid SMethod_TextDocumentRangeFormatting -> FormatRange (params ^. L.range) _ -> Prelude.error "mkFormattingHandlers: impossible" f ide typ (virtualFileText vf) nfp opts - Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + Nothing -> pure $ Left $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri - | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + | otherwise = pure $ Left $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri where uri = params ^. L.textDocument . L.uri opts = params ^. L.options -- --------------------------------------------------------------------- -responseError :: T.Text -> ResponseError -responseError txt = ResponseError (InR ErrorCodes_InvalidParams) txt Nothing - --- --------------------------------------------------------------------- data FallbackCodeActionParams = FallbackCodeActionParams 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 6da7a8161d..5771c8275b 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 @@ -14,7 +14,7 @@ import Development.IDE (GetParsedModule (GetParsedMod IdeState, RuleResult, Rules, define, realSrcSpanToRange, runAction, use) -import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (getSrcSpan) import Development.IDE.GHC.Util (getExtensions) @@ -31,7 +31,6 @@ import Ide.Plugin.Error import Ide.Plugin.Literals import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -84,8 +83,8 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec pure ([], CLR <$> litMap <*> exts) codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginResponse' $ do - nfp <- getNormalizedFilePath' (docId ^. L.uri) +codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = runExceptT $ do + nfp <- getNormalizedFilePathE (docId ^. L.uri) CLR{..} <- requestLiterals pId state nfp pragma <- getFirstPragma pId state nfp -- remove any invalid literals (see validTarget comment) @@ -133,5 +132,5 @@ needsExtension ext ghcExts = ext `notElem` map unExt ghcExts requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectLiteralsResult requestLiterals (PluginId pId) state = - PluginUtils.runAction (unpack pId <> ".CollectLiterals") state - . PluginUtils.use CollectLiterals + runActionE (unpack pId <> ".CollectLiterals") state + . useE CollectLiterals diff --git a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs index 807179872d..c85df79c92 100644 --- a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs +++ b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs @@ -7,6 +7,7 @@ import Control.Lens import Control.Monad.IO.Class import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginInvalidRequest)) import Ide.PluginUtils import Ide.Types import Language.LSP.Protocol.Lens as L @@ -47,7 +48,7 @@ descriptor recorder plId = provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState provider recorder _ (FormatRange _) _ _ _ = do logWith recorder Info LogInvalidInvocationInfo - pure $ Left (ResponseError (InR ErrorCodes_InvalidRequest) "You cannot format a text-range using cabal-fmt." Nothing) + pure $ Left (PluginInvalidRequest "You cannot format a text-range using cabal-fmt.") provider recorder _ide FormatText contents nfp opts = liftIO $ do let cabalFmtArgs = [fp, "--indent", show tabularSize] x <- findExecutable "cabal-fmt" @@ -64,13 +65,13 @@ provider recorder _ide FormatText contents nfp opts = liftIO $ do case exitCode of ExitFailure code -> do log Error $ LogProcessInvocationFailure code - pure $ Left (ResponseError (InR ErrorCodes_UnknownErrorCode) "Failed to invoke cabal-fmt" Nothing) + pure $ Left (PluginInternalError "Failed to invoke cabal-fmt") ExitSuccess -> do let fmtDiff = makeDiffTextEdit contents (T.pack out) pure $ Right $ InL fmtDiff Nothing -> do log Error LogCabalFmtNotFound - pure $ Left (ResponseError (InR ErrorCodes_InvalidRequest) "No installation of cabal-fmt could be found. Please install it into your global environment." Nothing) + pure $ Left (PluginInternalError "No installation of cabal-fmt could be found. Please install it into your global environment.") where fp = fromNormalizedFilePath nfp tabularSize = opts ^. L.tabSize diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index cfa6190bb5..76f890fcd6 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -178,11 +178,7 @@ kick = do -- Code Actions -- ---------------------------------------------------------------- -licenseSuggestCodeAction - :: IdeState - -> PluginId - -> CodeActionParams - -> LspM Config (Either LSP.ResponseError (LSP.MessageResult 'LSP.Method_TextDocumentCodeAction)) +licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = pure $ Right $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction uri) 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 d6ad5016f0..aae2ae348a 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 @@ -31,7 +31,6 @@ import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types import Ide.Plugin.Error -import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -40,8 +39,8 @@ import Text.Read (readMaybe) -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy -prepareCallHierarchy state _ param = pluginResponse' $ do - nfp <- getNormalizedFilePath' (param ^. L.textDocument ^. L.uri) +prepareCallHierarchy state _ param = runExceptT $ do + nfp <- getNormalizedFilePathE (param ^. L.textDocument ^. L.uri) items <- liftIO $ runAction "CallHierarchy.prepareHierarchy" state $ prepareCallHierarchyItem nfp (param ^. L.position) @@ -174,7 +173,7 @@ deriving instance Ord Value -- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls -incomingCalls state pluginId param = pluginResponse $ do +incomingCalls state pluginId param = runExceptT $ do calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls @@ -189,7 +188,7 @@ incomingCalls state pluginId param = pluginResponse $ do -- | Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls -outgoingCalls state pluginId param = pluginResponse $ do +outgoingCalls state pluginId param = runExceptT $ 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 6e5fc6d184..82d70780eb 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 @@ -15,14 +15,15 @@ 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.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.Plugin.Error (PluginError, pluginResponse') -import Ide.PluginUtils (getNormalizedFilePath') +import Ide.Plugin.Error (PluginError, + getNormalizedFilePathE, + runExceptT) import Ide.Types (PluginDescriptor (..), PluginId (PluginId), PluginMethodHandler, @@ -36,17 +37,17 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) } codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = pluginResponse' $ do - nfp <- getNormalizedFilePath' uri +codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = runExceptT $ do + nfp <- getNormalizedFilePathE uri decls <- getDecls plId ideState nfp let actions = mapMaybe (generateAction plId uri decls) diags pure $ InL actions getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs] getDecls (PluginId changeTypeSignatureId) state = - PluginUtils.runAction (T.unpack changeTypeSignatureId <> ".GetParsedModule") state + runActionE (T.unpack changeTypeSignatureId <> ".GetParsedModule") state . (fmap (hsmodDecls . unLoc . pm_parsed_source)) - . PluginUtils.use GetParsedModule + . useE 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 3e406cd2e5..4a0d108920 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -23,7 +23,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE import Development.IDE.Core.Compile (sourceTypecheck) -import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (fromCurrentRange) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util @@ -43,13 +43,13 @@ import Language.LSP.Server addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do caps <- getClientCapabilities - pluginResponse' $ do - nfp <- getNormalizedFilePath' (verTxtDocId ^. L.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 (mkPluginErrorMessage "Unable to makeEditText") + runExceptT $ do + nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + pm <- runActionE "classplugin.addMethodPlaceholders.GetParsedModule" state + $ useE GetParsedModule nfp + (hsc_dflags . hscEnv -> df) <- runActionE "classplugin.addMethodPlaceholders.GhcSessionDeps" state + $ useE GhcSessionDeps nfp + (old, new) <- handleMaybeM (PluginInternalError "Unable to makeEditText") $ liftIO $ runMaybeT $ makeEditText pm df param pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs @@ -80,9 +80,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 Method_TextDocumentCodeAction -codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginResponse' $ do +codeAction recorder state plId (CodeActionParams _ _ docId _ context) = runExceptT $ do verTxtDocId <- lift $ getVersionedTextDoc docId - nfp <- getNormalizedFilePath' (verTxtDocId ^. L.uri) + nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags pure $ InL actions where @@ -97,15 +97,15 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe -> Diagnostic -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] mkActions docPath verTxtDocId diag = do - (HAR {hieAst = ast}, pmap) <- PluginUtils.runAction "classplugin.findClassIdentifier.GetHieAst" state - $ PluginUtils.useWithStale GetHieAst docPath - instancePosition <- handleMaybe (mkPluginErrorMessage "No range") $ + (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state + $ useWithStaleE GetHieAst docPath + instancePosition <- handleMaybe (PluginBadDependency "GetHieAst.fromCurrentRange") $ fromCurrentRange pmap range ^? _Just . L.start & fmap (L.character -~ 1) ident <- findClassIdentifier ast instancePosition cls <- findClassFromIdentifier docPath ident - InstanceBindTypeSigsResult sigs <- PluginUtils.runAction "classplugin.codeAction.GetInstanceBindTypeSigs" state - $ PluginUtils.use GetInstanceBindTypeSigs docPath + InstanceBindTypeSigsResult sigs <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state + $ useE GetInstanceBindTypeSigs docPath implemented <- findImplementedMethods ast instancePosition logWith recorder Info (LogImplementedMethods cls implemented) pure @@ -153,7 +153,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe Nothing findClassIdentifier hf instancePosition = - handleMaybe (mkPluginErrorMessage "No Identifier found") + handleMaybe (PluginInternalError "No Identifier found") $ listToMaybe $ mapMaybe listToMaybe $ pointCommand hf instancePosition @@ -181,11 +181,11 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren ast) findClassFromIdentifier docPath (Right name) = do - (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 (PluginInternalError) + (hscEnv -> hscenv, _) <- runActionE "classplugin.findClassFromIdentifier.GhcSessionDeps" state + $ useWithStaleE GhcSessionDeps docPath + (tmrTypechecked -> thisMod, _) <- runActionE "classplugin.findClassFromIdentifier.TypeCheck" state + $ useWithStaleE TypeCheck docPath + handleMaybeM (PluginInternalError "initTcWithGbl failed") . liftIO . fmap snd . initTcWithGbl hscenv thisMod ghostSpan $ do @@ -194,7 +194,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 (mkPluginErrorMessage "Ide.Plugin.Class.findClassIdentifier") + findClassFromIdentifier _ (Left _) = throwE (PluginInternalError "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 35d7a4a710..a29c679f0f 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -10,7 +10,7 @@ import Data.Aeson hiding (Null) 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.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util @@ -25,18 +25,18 @@ import Language.LSP.Protocol.Types import Language.LSP.Server (sendRequest) codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLens state plId CodeLensParams{..} = pluginResponse' $ do - nfp <- getNormalizedFilePath' uri - (tmr, _) <- PluginUtils.runAction "classplugin.TypeCheck" state +codeLens state plId CodeLensParams{..} = runExceptT $ do + nfp <- getNormalizedFilePathE uri + (tmr, _) <- runActionE "classplugin.TypeCheck" state -- Using stale results means that we can almost always return a value. In practice -- this means the lenses don't 'flicker' - $ PluginUtils.useWithStale TypeCheck nfp + $ useWithStaleE TypeCheck nfp -- All instance binds - (InstanceBindTypeSigsResult allBinds, mp) <- PluginUtils.runAction "classplugin.GetInstanceBindTypeSigs" state + (InstanceBindTypeSigsResult allBinds, mp) <- runActionE "classplugin.GetInstanceBindTypeSigs" state -- Using stale results means that we can almost always return a value. In practice -- this means the lenses don't 'flicker' - $ PluginUtils.useWithStale GetInstanceBindTypeSigs nfp + $ useWithStaleE 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 cd624e2b00..652e02fddb 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -9,7 +9,7 @@ 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.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.Pragmas (getNextPragmaInfo, @@ -58,13 +58,13 @@ insertPragmaIfNotPresent :: (MonadIO m) -> Extension -> ExceptT PluginError m [TextEdit] insertPragmaIfNotPresent state nfp pragma = do - (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- PluginUtils.runAction "classplugin.insertPragmaIfNotPresent.GhcSession" state - $ PluginUtils.useWithStale GhcSession nfp - (_, fileContents) <- PluginUtils.runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state - $ PluginUtils.hoistAction + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GhcSession" state + $ useWithStaleE GhcSession nfp + (_, fileContents) <- runActionE "classplugin.insertPragmaIfNotPresent.GetFileContents" state + $ hoistAction $ getFileContents nfp - (pm, _) <- PluginUtils.runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state - $ PluginUtils.useWithStale GetParsedModuleWithComments nfp + (pm, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state + $ useWithStaleE 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 5628370fdb..4e51db8d13 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -27,7 +28,7 @@ import Development.IDE (Action, IdeAction, Range (Range), Recorder, WithPriority, cmapWithPrio) -import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) @@ -39,13 +40,14 @@ import Ide.Plugin.CodeRange.Rules (CodeRange (..), codeRangeRule, crkToFrk) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) import Ide.Plugin.Error -import Ide.PluginUtils (getNormalizedFilePath', - positionInRange) +import Ide.PluginUtils (positionInRange) import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), PluginId, + PluginMethodHandler, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Protocol.Message (ResponseError, +import Language.LSP.Protocol.Message (Method (Method_TextDocumentFoldingRange, Method_TextDocumentSelectionRange), + ResponseError, SMethod (SMethod_TextDocumentFoldingRange, SMethod_TextDocumentSelectionRange)) import Language.LSP.Protocol.Types (FoldingRange (..), FoldingRangeParams (..), @@ -74,11 +76,11 @@ instance Pretty Log where LogRules codeRangeLog -> pretty codeRangeLog LogBadDependency rule -> pretty $ "bad dependency: " <> show rule -foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError ([FoldingRange] |? Null)) +foldingRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentFoldingRange foldingRangeHandler recorder ide _ FoldingRangeParams{..} = pluginResponseM handleErrors $ do - filePath <- getNormalizedFilePath' uri - foldingRanges <- PluginUtils.runAction "FoldingRange" ide $ getFoldingRanges filePath + filePath <- getNormalizedFilePathE uri + foldingRanges <- runActionE "FoldingRange" ide $ getFoldingRanges filePath pure . InL $ foldingRanges where uri :: Uri @@ -88,17 +90,17 @@ foldingRangeHandler recorder ide _ FoldingRangeParams{..} = RuleFailed rule -> do logWith recorder Warning $ LogBadDependency rule pure $ Right $ InL [] - errs -> pure $ Left $ handlePluginError errs + errs -> pure $ Left errs getFoldingRanges :: NormalizedFilePath -> ExceptT PluginError Action [FoldingRange] getFoldingRanges file = do - codeRange <- PluginUtils.use GetCodeRange file + codeRange <- useE GetCodeRange file pure $ findFoldingRanges codeRange -selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError ([SelectionRange] |? Null)) +selectionRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentSelectionRange selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do pluginResponseM handleErrors $ do - filePath <- withError GhcidePluginErrors $ getNormalizedFilePath' uri + filePath <- withError GhcidePluginErrors $ getNormalizedFilePathE uri fmap id . runIdeAction' $ getSelectionRanges filePath positions where uri :: Uri @@ -108,12 +110,12 @@ selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do positions = _positions runIdeAction' :: MonadIO m => ExceptT SelectionRangeError IdeAction ([SelectionRange] |? Null) -> ExceptT SelectionRangeError m ([SelectionRange] |? Null) - runIdeAction' action = PluginUtils.runIdeAction "SelectionRange" (shakeExtras ide) action + runIdeAction' action = runIdeActionE "SelectionRange" (shakeExtras ide) action handleErrors :: MonadIO m => SelectionRangeError -> - m (Either ResponseError ([a] |? Null)) + m (Either PluginError ([a] |? Null)) handleErrors err = case err of SelectionRangeBadDependency rule -> do logWith recorder Warning $ LogBadDependency rule @@ -121,11 +123,11 @@ selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do -- so we give it a default value instead of throwing an error pure $ Right $ InL [] SelectionRangeInputPositionMappingFailure -> - pure $ Left $ mkSimpleResponseError "failed to apply position mapping to input positions" + pure $ Left $ PluginInternalError "failed to apply position mapping to input positions" SelectionRangeOutputPositionMappingFailure -> - pure $ Left $ mkSimpleResponseError "failed to apply position mapping to output positions" + pure $ Left $ PluginInternalError "failed to apply position mapping to output positions" GhcidePluginErrors ghcidePluginError -> - pure $ Left $ handlePluginError ghcidePluginError + pure $ Left $ ghcidePluginError data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency rule @@ -136,7 +138,7 @@ data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction ([SelectionRange] |? Null) getSelectionRanges file positions = do (codeRange, positionMapping) <- withError (\_ -> SelectionRangeBadDependency GetCodeRange) $ - PluginUtils.useWithStaleFast GetCodeRange file + useWithStaleFastE 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 d44d1911e4..f1abac8bdd 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -96,16 +96,15 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv) 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.Core.PluginUtils import Development.IDE.Types.Shake (toKey) #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #endif -import Ide.Plugin.Error (PluginError, +import Ide.Plugin.Error (PluginError (PluginInternalError), handleMaybe, handleMaybeM, - mkPluginErrorMessage, - pluginResponse') + runExceptT) import Ide.Plugin.Eval.Code (Statement, asStatements, myExecStmt, @@ -142,14 +141,14 @@ codeLens st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg in perf "codeLens" $ - pluginResponse' $ do + runExceptT $ do let TextDocumentIdentifier uri = _textDocument - fp <- PluginUtils.uriToFilePath' uri + fp <- uriToFilePathE uri let nfp = toNormalizedFilePath' fp isLHS = isLiterate fp dbg "fp" fp (comments, _) <- - PluginUtils.runAction "eval.GetParsedModuleWithComments" st $ PluginUtils.useWithStale_ GetEvalComments nfp + runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp -- dbg "excluded comments" $ show $ DL.toList $ -- foldMap (\(L a b) -> -- case b of @@ -213,7 +212,7 @@ runEvalCmd plId st EvalParams{..} = let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections let TextDocumentIdentifier{_uri} = module_ - fp <- PluginUtils.uriToFilePath' _uri + fp <- uriToFilePathE _uri let nfp = toNormalizedFilePath' fp mdlText <- moduleText _uri @@ -302,7 +301,7 @@ finalReturn txt = moduleText :: MonadLsp c m => Uri -> ExceptT PluginError m Text moduleText uri = - handleMaybeM (mkPluginErrorMessage "mdlText") $ + handleMaybeM (PluginInternalError "mdlText") $ (virtualFileText <$>) <$> getVirtualFile (toNormalizedUri uri) 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 c765121bdd..12e01c8ef2 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -68,15 +68,15 @@ logLevel = Debug -- Info isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> LspM c (Either ResponseError (Value |? Null)) +response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> LspM c (Either PluginError (Value |? Null)) response' act = do res <- runExceptT act `catchAny` \e -> do res <- showErr e - pure . Left . mkPluginErrorMessage $ fromString res + pure . Left . PluginInternalError $ fromString res case res of Left e -> - return $ Left $ handlePluginError e + return $ Left e Right a -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) return $ Right $ InR Null 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 e16e8bf30b..24c49ea209 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -19,7 +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.PluginUtils import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.Shake (addPersistentRule) import qualified Development.IDE.Core.Shake as Shake @@ -29,7 +29,6 @@ import Development.IDE.LSP.Notifications (ghcideNotificationsPlugin import Development.IDE.Spans.AtPoint import GHC.Generics (Generic) import Ide.Plugin.Error -import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types hiding (pluginId) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -44,11 +43,11 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId) } hover :: PluginMethodHandler IdeState Method_TextDocumentHover -hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse' $ do - nfp <- getNormalizedFilePath' uri - PluginUtils.runIdeAction "ExplicitFixity" (shakeExtras state) $ do - (FixityMap fixmap, _) <- PluginUtils.useWithStaleFast GetFixity nfp - (HAR{hieAst}, mapping) <- PluginUtils.useWithStaleFast GetHieAst nfp +hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = runExceptT $ do + nfp <- getNormalizedFilePathE uri + runIdeActionE "ExplicitFixity" (shakeExtras state) $ do + (FixityMap fixmap, _) <- useWithStaleFastE GetFixity nfp + (HAR{hieAst}, mapping) <- useWithStaleFastE GetHieAst nfp let ns = getNamesAtPoint hieAst pos mapping fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns pure $ maybeToNull $ toHover fs diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index d09841af90..687e5d4364 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -37,18 +37,19 @@ import qualified Data.Unique as U (hashUnique, newUnique) import Development.IDE hiding (pluginHandlers, pluginRules) +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding ((<+>)) import Development.IDE.Graph.Classes import GHC.Generics (Generic) -import Ide.Plugin.Error (handleMaybe, - handleMaybeM, - pluginResponse) +import Ide.Plugin.Error (PluginError (..), + getNormalizedFilePathE, + handleMaybe, runExceptT) import Ide.Plugin.RangeMap (filterByRange) import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) import Ide.Plugin.Resolve -import Ide.PluginUtils (getNormalizedFilePath) +import Ide.PluginUtils import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -98,7 +99,7 @@ descriptorForModules recorder modFilter plId = -- | The actual command handler runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState EIResolveData -runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do +runImportCommand recorder ideState eird@(ResolveOne _ _) = runExceptT $ do wedit <- resolveWTextEdit ideState eird _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors return $ InR Null @@ -107,7 +108,7 @@ runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do pure () logErrors (Right _) = pure () runImportCommand _ _ (ResolveAll _) = do - pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for command handler: ResolveAll" Nothing + pure $ Left $ PluginInvalidParams "Unexpected argument for command handler: ResolveAll" -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: @@ -121,8 +122,8 @@ runImportCommand _ _ (ResolveAll _) = do -- > import Data.List (intercalate, sortBy) lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} - = pluginResponse $ do - nfp <- getNormalizedFilePath _uri + = runExceptT $ do + nfp <- getNormalizedFilePathE _uri mbMinImports <- liftIO $ runAction "MinimalImports" state $ use MinimalImports nfp case mbMinImports of Just (MinimalImportsResult{forLens}) -> do @@ -139,13 +140,10 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier { lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeLensResolve lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) - = pluginResponse $ do - nfp <- getNormalizedFilePath uri - (MinimalImportsResult{forResolve}) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp - target <- handleMaybe "Unable to resolve lens" $ forResolve IM.!? uid + = runExceptT $ do + nfp <- getNormalizedFilePathE uri + (MinimalImportsResult{forResolve}) <- runActionE "MinimalImports" ideState $ useE MinimalImports nfp + target <- handleMaybe PluginStaleResolve $ forResolve IM.!? uid let updatedCodeLens = cl & L.command ?~ mkCommand plId target pure updatedCodeLens where mkCommand :: PluginId -> TextEdit -> Command @@ -153,19 +151,17 @@ lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) let title = abbreviateImportTitle _newText in mkLspCommand pId importCommandId title (Just $ [A.toJSON rd]) lensResolveProvider _ _ _ _ _ (ResolveAll _) = do - pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for lens resolve handler: ResolveAll" Nothing + pure $ Left $ PluginInvalidParams "Unexpected argument for lens resolve handler: ResolveAll" -- | If there are any implicit imports, provide both one code action per import -- to make that specific import explicit, and one code action to turn them all -- into explicit imports. codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) - = pluginResponse $ do - nfp <- getNormalizedFilePath _uri + = runExceptT $ do + nfp <- getNormalizedFilePathE _uri (MinimalImportsResult{forCodeActions}) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp + runActionE "MinimalImports" ideState $ useE MinimalImports nfp let relevantCodeActions = filterByRange range forCodeActions allExplicit = [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ResolveAll _uri) @@ -186,26 +182,22 @@ codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier codeActionResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeActionResolve codeActionResolveProvider _ ideState _ ca _ rd = - pluginResponse $ do + runExceptT $ do wedit <- resolveWTextEdit ideState rd pure $ ca & L.edit ?~ wedit -------------------------------------------------------------------------------- -resolveWTextEdit :: IdeState -> EIResolveData -> ExceptT String (LspT Config IO) WorkspaceEdit +resolveWTextEdit :: IdeState -> EIResolveData -> ExceptT PluginError (LspT Config IO) WorkspaceEdit resolveWTextEdit ideState (ResolveOne uri int) = do - nfp <- getNormalizedFilePath uri + nfp <- getNormalizedFilePathE uri (MinimalImportsResult{forResolve}) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp - tedit <- handleMaybe "Unable to resolve text edit" $ forResolve IM.!? int + runActionE "MinimalImports" ideState $ useE MinimalImports nfp + tedit <- handleMaybe PluginStaleResolve $ forResolve IM.!? int pure $ mkWorkspaceEdit uri [tedit] resolveWTextEdit ideState (ResolveAll uri) = do - nfp <- getNormalizedFilePath uri + nfp <- getNormalizedFilePathE uri (MinimalImportsResult{forResolve}) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp + runActionE "MinimalImports" ideState $ useE MinimalImports nfp let edits = IM.elems forResolve pure $ mkWorkspaceEdit uri edits 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 b1f043880a..f0cee22d55 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 @@ -29,7 +29,7 @@ import Development.IDE (IdeState, NormalizedFilePath, Pretty (..), Recorder (..), Rules, WithPriority (..), realSrcSpanToRange) -import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) @@ -62,10 +62,11 @@ import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) import GHC.Generics (Generic) -import Ide.Plugin.Error (PluginError, pluginResponse') +import Ide.Plugin.Error (PluginError, + getNormalizedFilePathE, + runExceptT) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, @@ -101,8 +102,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId) } codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse' $ do - nfp <- getNormalizedFilePath' (docId ^. L.uri) +codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = runExceptT $ do + nfp <- getNormalizedFilePathE (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) @@ -360,6 +361,6 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) getRecPatterns _ = Nothing collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectRecordsResult -collectRecords' ideState = PluginUtils.runAction "ExplicitFields" ideState - . PluginUtils.use CollectRecords +collectRecords' ideState = runActionE "ExplicitFields" ideState + . useE CollectRecords diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs index 2c8f6fb92e..735bf35b65 100644 --- a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -11,6 +11,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE hiding (pluginHandlers) import Floskell +import Ide.Plugin.Error import Ide.PluginUtils import Ide.Types import Language.LSP.Protocol.Types @@ -36,7 +37,7 @@ provider _ideState typ contents fp _ = liftIO $ do FormatRange r -> (normalize r, extractRange r contents) result = reformat config (Just file) . TL.encodeUtf8 $ TL.fromStrict selectedContents case result of - Left err -> pure $ Left $ responseError $ T.pack $ "floskellCmd: " ++ err + Left err -> pure $ Left $ PluginInternalError $ T.pack $ "floskellCmd: " ++ err Right new -> pure $ Right $ InL [TextEdit range . TL.toStrict $ TL.decodeUtf8 new] -- | Find Floskell Config, user and system wide or provides a default style. diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index 37288dfc8c..a682f495b4 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -26,6 +26,7 @@ import Development.IDE.GHC.Compat as Compat hiding (Cpp, Warning, hang, vcat) import qualified Development.IDE.GHC.Compat.Util as S import GHC.LanguageExtensions.Type (Extension (Cpp)) +import Ide.Plugin.Error import Ide.Plugin.Fourmolu.Shim import Ide.Plugin.Properties import Ide.PluginUtils (makeDiffTextEdit) @@ -64,7 +65,7 @@ provider recorder plId ideState typ contents fp fo = withIndefiniteProgress titl useCLI <- liftIO $ runAction "Fourmolu" ideState $ usePropertyAction #external plId properties if useCLI then liftIO - . fmap (join . first (mkError . show)) + . fmap (join . first (PluginInternalError . T.pack . show)) . try @IOException $ do CLIVersionInfo{noCabal} <- do -- check Fourmolu version so that we know which flags to use @@ -99,10 +100,10 @@ provider recorder plId ideState typ contents fp fo = withIndefiniteProgress titl pure . Right $ InL $ makeDiffTextEdit contents out ExitFailure n -> do logWith recorder Info $ StdErr err - pure . Left . responseError $ "Fourmolu failed with exit code " <> T.pack (show n) + pure . Left . PluginInternalError $ "Fourmolu failed with exit code " <> T.pack (show n) else do let format fourmoluConfig = - bimap (mkError . show) (InL . makeDiffTextEdit contents) + bimap (PluginInternalError . T.pack . show) (InL . makeDiffTextEdit contents) #if MIN_VERSION_fourmolu(0,11,0) <$> try @OrmoluException (ormolu config fp' contents) #else @@ -134,13 +135,12 @@ provider recorder plId ideState typ contents fp fo = withIndefiniteProgress titl { _type_ = MessageType_Error , _message = errorMessage } - return . Left $ responseError errorMessage + return . Left $ PluginInternalError errorMessage where errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack (showParseError err) where fp' = fromNormalizedFilePath fp title = "Formatting " <> T.pack (takeFileName fp') - mkError = responseError . ("Fourmolu: " <>) . T.pack lspPrinterOpts = mempty{poIndentation = Just $ fromIntegral $ fo ^. tabSize} region = case typ of FormatText -> diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index f0c9d443fb..22baf1c211 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -23,7 +23,7 @@ import Development.IDE.GHC.Compat import Control.Monad.Trans.Except (throwE) import Data.Maybe (mapMaybe) -import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils import Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma) import GHC.Generics (Generic) @@ -56,14 +56,14 @@ 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{..} = pluginResponseM handleGhcidePluginError $ do - nfp <- withError (GhcidePluginErrors) $ getNormalizedFilePath' uri + nfp <- withError (GhcidePluginErrors) $ getNormalizedFilePathE uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d _ -> throwE $ UnexpectedNumberOfDeclarations (Prelude.length decls) deps <- withError GhcidePluginErrors - $ PluginUtils.runAction (T.unpack pId' <> ".GhcSessionDeps") state - $ PluginUtils.use GhcSessionDeps nfp + $ runActionE (T.unpack pId' <> ".GhcSessionDeps") state + $ useE GhcSessionDeps nfp (hsc_dflags . hscEnv -> df) <- pure deps txt <- withError (PrettyGadtError . T.pack) $ liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl range <- liftEither @@ -87,7 +87,7 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponseM handl codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponseM handleGhcidePluginError $ do - nfp <- withError (GhcidePluginErrors) $ getNormalizedFilePath' (doc ^. L.uri) + nfp <- withError (GhcidePluginErrors) $ getNormalizedFilePathE (doc ^. L.uri) (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls pure $ InL actions @@ -115,8 +115,8 @@ getInRangeH98DeclsAndExts :: (MonadIO m) => -> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension]) getInRangeH98DeclsAndExts state range nfp = do pm <- withError GhcidePluginErrors - $ PluginUtils.runAction "GADT.GetParsedModuleWithComments" state - $ PluginUtils.use GetParsedModuleWithComments nfp + $ runActionE "GADT.GetParsedModuleWithComments" state + $ useE GetParsedModuleWithComments nfp let (L _ hsDecls) = hsmodDecls <$> pm_parsed_source pm decls = filter isH98DataDecl $ mapMaybe getDataDecl @@ -133,13 +133,13 @@ data GadtPluginError handleGhcidePluginError :: Monad m => GadtPluginError -> - m (Either ResponseError a) + m (Either PluginError a) handleGhcidePluginError = \case UnexpectedNumberOfDeclarations nums -> do - pure $ Left $ mkSimpleResponseError $ "Expected one declaration but found: " <> T.pack (show nums) + pure $ Left $ PluginInternalError $ "Expected one declaration but found: " <> T.pack (show nums) FailedToFindDataDeclRange -> - pure $ Left $ mkSimpleResponseError $ "Unable to get data decl range" + pure $ Left $ PluginInternalError $ "Unable to get data decl range" PrettyGadtError errMsg -> - pure $ Left $ mkSimpleResponseError $ errMsg + pure $ Left $ PluginInternalError $ errMsg GhcidePluginErrors errors -> - pure $ Left $ handlePluginError errors + pure $ Left $ errors diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 149a0fd628..adec94cd97 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -144,7 +144,8 @@ import GHC.Generics (Generic) import System.Environment (setEnv, unsetEnv) #endif -import qualified Development.IDE.Core.PluginUtils as PluginUtils +import Development.IDE.Core.PluginUtils as PluginUtils +import Ide.Plugin.Error (getNormalizedFilePathE) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -435,8 +436,8 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context diags = context ^. LSP.diagnostics resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve -resolveProvider recorder ideState _plId ca uri resolveValue = pluginResponse $ do - file <- getNormalizedFilePath uri +resolveProvider recorder ideState _plId ca uri resolveValue = runExceptT $ do + file <- getNormalizedFilePathE uri case resolveValue of (ApplyHint verTxtDocId oneHint) -> do edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId @@ -500,10 +501,10 @@ mkSuppressHintTextEdits dynFlags fileContents hint = combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either String WorkspaceEdit) -ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = do - (_, fileContents) <- runAction "Hlint.GetFileContents" ideState $ getFileContents nfp - (msr, _) <- runAction "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStale_ GetModSummaryWithoutTimestamps nfp +ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit) +ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do + (_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents nfp + (msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps nfp case fileContents of Just contents -> do let dynFlags = ms_hspp_opts $ msrModSummary msr @@ -513,8 +514,8 @@ ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = do (Just (M.singleton (verTxtDocId ^. LSP.uri) textEdits)) Nothing Nothing - pure $ Right workspaceEdit - Nothing -> pure $ Left "Unable to get fileContents" + pure workspaceEdit + Nothing -> throwE $ PluginInternalError "Unable to get fileContents" -- --------------------------------------------------------------------- data HlintResolveCommands = @@ -537,7 +538,7 @@ data OneHint = , oneHintTitle :: HintTitle } deriving (Generic, Eq, Show, ToJSON, FromJSON) -applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either String WorkspaceEdit) +applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit) applyHint recorder ide nfp mhint verTxtDocId = runExceptT $ do let runAction' :: Action a -> IO a @@ -545,7 +546,7 @@ applyHint recorder ide nfp mhint verTxtDocId = let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException))) , Handler $ \e -> return (Left (show (e :: ErrorCall))) ] - ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas recorder nfp + ideas <- bimapExceptT (PluginInternalError . T.pack . showParseError) id $ ExceptT $ runAction' $ getIdeas recorder nfp let ideas' = maybe ideas (`filterIdeas` ideas) mhint let commands = map ideaRefactoring ideas' logWith recorder Debug $ LogGeneratedIdeas nfp commands @@ -598,7 +599,7 @@ applyHint recorder ide nfp mhint verTxtDocId = let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions ExceptT $ return (Right wsEdit) Left err -> - throwE err + throwE $ PluginInternalError $ T.pack err where -- | If we are only interested in applying a particular hint then -- let's filter out all the irrelevant ideas diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs index beb878515f..8a9fd22018 100644 --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -19,6 +19,7 @@ import Development.IDE.GHC.Compat (hsc_dflags, moduleNameString) import qualified Development.IDE.GHC.Compat as D import qualified Development.IDE.GHC.Compat.Util as S import GHC.LanguageExtensions.Type +import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.PluginUtils import Ide.Types hiding (Config) import Language.LSP.Protocol.Message @@ -81,8 +82,8 @@ provider ideState typ contents fp _ = withIndefiniteProgress title Cancellable $ where title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) - ret :: Either SomeException T.Text -> Either ResponseError ([TextEdit] |? Null) - ret (Left err) = Left . responseError . T.pack $ "ormoluCmd: " ++ show err + ret :: Either SomeException T.Text -> Either PluginError ([TextEdit] |? Null) + ret (Left err) = Left . PluginInternalError . T.pack $ "ormoluCmd: " ++ show err ret (Right new) = Right $ InL $ makeDiffTextEdit contents new fromDyn :: D.DynFlags -> [DynOption] 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 885770454d..ac2a6cdfbd 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 @@ -49,7 +49,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.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping (PositionMapping), toCurrentRange) import Development.IDE.GHC.Compat (Extension (OverloadedRecordDot), @@ -76,11 +76,11 @@ import Development.IDE.Types.Logger (Priority (..), (<+>)) import GHC.Generics (Generic) import Ide.Plugin.Error (PluginError (..), - pluginResponse') + getNormalizedFilePathE, + handleMaybe, runExceptT) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve) -import Ide.PluginUtils (getNormalizedFilePath') import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, @@ -177,22 +177,17 @@ descriptor recorder plId = let pluginHandler = mkCodeActionHandlerWithResolve co resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve resolveProvider ideState plId ca uri (ORDRD _ int) = - pluginResponse' $ do - nfp <- getNormalizedFilePath' uri + runExceptT $ do + nfp <- getNormalizedFilePathE uri CRSR _ crsDetails exts <- collectRecSelResult ideState nfp pragma <- getFirstPragma plId ideState nfp - case IntMap.lookup int crsDetails of - Just rse -> pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} - -- We need to throw a content modified error here, see - -- https://github.com/microsoft/language-server-protocol/issues/1738 - -- but we need fendor's plugin error response pr to make it - -- convenient to use here, so we will wait to do that till that's merged - _ -> throwE $ PluginErrorMessage "Content Modified Error" + rse <- handleMaybe PluginStaleResolve $ IntMap.lookup int crsDetails + pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = - pluginResponse' $ do - nfp <- getNormalizedFilePath' (caDocId ^. L.uri) + runExceptT $ do + nfp <- getNormalizedFilePathE (caDocId ^. L.uri) CRSR crsMap crsDetails exts <- collectRecSelResult ideState nfp let mkCodeAction (crsM, nse) = InR CodeAction { -- We pass the record selector to the title function, so that @@ -326,6 +321,6 @@ getRecSels _ = ([], False) collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectRecordSelectorsResult collectRecSelResult ideState = - PluginUtils.runAction "overloadedRecordDot.collectRecordSelectors" ideState - . PluginUtils.use CollectRecordSelectors + runActionE "overloadedRecordDot.collectRecordSelectors" ideState + . useE CollectRecordSelectors diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 727a959620..39317458dd 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -74,7 +74,7 @@ import GHC.Parser.Annotation (TokenLocatio #endif import Ide.PluginUtils (subRange) import Ide.Types -import Language.LSP.Protocol.Message (ResponseError, +import Language.LSP.Protocol.Message (Method (..), SMethod (..)) import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (..), CodeAction (..), @@ -118,11 +118,7 @@ import Language.Haskell.GHC.ExactPrint.Types (Annotation ( ------------------------------------------------------------------------------------------------- -- | Generate code actions. -codeAction - :: IdeState - -> PluginId - -> CodeActionParams - -> LSP.LspM c (Either ResponseError ([(Command |? CodeAction)] |? Null)) +codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics= xs}) = do contents <- LSP.getVirtualFile $ toNormalizedUri uri liftIO $ do diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 96cf3dfc04..8fce494cb5 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -37,6 +37,7 @@ import Development.IDE.Spans.LocalBindings (Bindings) import Development.IDE.Types.Exports (ExportsMap) import Development.IDE.Types.Options (IdeOptions) import Ide.Plugin.Config (Config) +import Ide.Plugin.Error (PluginError) import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -48,7 +49,7 @@ type CodeActionPreferred = Bool type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] -type GhcideCodeAction = ExceptT ResponseError (ReaderT CodeActionArgs IO) GhcideCodeActionResult +type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCodeActionResult ------------------------------------------------------------------------------------------------- @@ -190,7 +191,7 @@ instance ToCodeAction a => ToCodeAction [a] where instance ToCodeAction a => ToCodeAction (Maybe a) where toCodeAction = maybe (pure []) toCodeAction -instance ToCodeAction a => ToCodeAction (Either ResponseError a) where +instance ToCodeAction a => ToCodeAction (Either PluginError a) where toCodeAction = either (\err -> ExceptT $ ReaderT $ \_ -> pure $ Left err) toCodeAction instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs index cb71727c9a..ce26d88fab 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -32,8 +32,8 @@ import GHC (EpAnn (..), noAnn) import GHC.Hs (IsUnicodeSyntax (..)) import GHC.Types.SrcLoc (generatedSrcSpan) -import Ide.PluginUtils (makeDiffTextEdit, - responseError) +import Ide.Plugin.Error (PluginError (PluginInternalError)) +import Ide.PluginUtils (makeDiffTextEdit) import Language.Haskell.GHC.ExactPrint (TransformT (..), noAnnSrcSpanDP1, runTransformT) @@ -58,7 +58,7 @@ plugin = [] -- foo :: a -> b -> c -> d -- foo a b = \c -> ... -- In this case a new argument would have to add its type between b and c in the signature. -plugin :: ParsedModule -> Diagnostic -> Either ResponseError [(T.Text, [TextEdit])] +plugin :: ParsedModule -> Diagnostic -> Either PluginError [(T.Text, [TextEdit])] plugin parsedModule Diagnostic {_message, _range} | Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ) @@ -84,11 +84,11 @@ addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) = -- For example: -- insertArg "new_pat" `foo bar baz = 1` -- => (`foo bar baz new_pat = 1`, Just ("foo", 2)) -appendFinalPatToMatches :: T.Text -> LHsDecl GhcPs -> TransformT (Either ResponseError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int)) +appendFinalPatToMatches :: T.Text -> LHsDecl GhcPs -> TransformT (Either PluginError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int)) appendFinalPatToMatches name = \case (L locDecl (ValD xVal fun@FunBind{fun_matches=mg,fun_id = idFunBind})) -> do (mg', numPatsMay) <- modifyMgMatchesT' mg (pure . second Just . addArgToMatch name) Nothing combineMatchNumPats - numPats <- TransformT $ lift $ maybeToEither (responseError "Unexpected empty match group in HsDecl") numPatsMay + numPats <- TransformT $ lift $ maybeToEither (PluginInternalError "Unexpected empty match group in HsDecl") numPatsMay let decl' = L locDecl (ValD xVal fun{fun_matches=mg'}) pure (decl', Just (idFunBind, numPats)) decl -> pure (decl, Nothing) @@ -97,7 +97,7 @@ appendFinalPatToMatches name = \case combineMatchNumPats other Nothing = pure other combineMatchNumPats (Just l) (Just r) | l == r = pure (Just l) - | otherwise = Left $ responseError "Unexpected different numbers of patterns in HsDecl MatchGroup" + | otherwise = Left $ PluginInternalError "Unexpected different numbers of patterns in HsDecl MatchGroup" -- The add argument works as follows: -- 1. Attempt to add the given name as the last pattern of the declaration that contains `range`. @@ -110,7 +110,7 @@ appendFinalPatToMatches name = \case -- foo () = new_def -- -- TODO instead of inserting a typed hole; use GHC's suggested type from the error -addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])] +addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either PluginError [(T.Text, [TextEdit])] addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do (newSource, _, _) <- runTransformT $ do (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl (makeDeltaAst moduleSrc) @@ -123,7 +123,7 @@ addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name - spanContainsRangeOrErr = maybeToEither (responseError "SrcSpan was not valid range") . (`spanContainsRange` range) + spanContainsRangeOrErr = maybeToEither (PluginInternalError "SrcSpan was not valid range") . (`spanContainsRange` range) -- Transform an LHsType into a list of arguments and return type, to make transformations easier. hsTypeToFunTypeAsList :: LHsType GhcPs -> ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 1211f14df2..3cd9ae0ea1 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -36,7 +36,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.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -72,7 +72,7 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultP renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier uri) pos newNameText) = - pluginResponse' $ do + runExceptT $ do nfp <- handleUriToNfp uri directOldNames <- getNamesAtPos state nfp pos directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames @@ -92,7 +92,7 @@ renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier -- Validate rename crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames - when (any isBuiltInSyntax oldNames) $ throwE $ mkPluginErrorMessage "Invalid rename of built-in syntax" + when (any isBuiltInSyntax oldNames) $ throwE $ PluginInternalError "Invalid rename of built-in syntax" -- Perform rename let newName = mkTcOcc $ T.unpack newNameText @@ -112,15 +112,15 @@ failWhenImportOrExport :: [Name] -> ExceptT PluginError m () failWhenImportOrExport state nfp refLocs names = do - pm <- PluginUtils.runAction "Rename.GetParsedModule" state - (PluginUtils.use GetParsedModule nfp) + pm <- runActionE "Rename.GetParsedModule" state + (useE 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 $ mkPluginErrorMessage "Renaming of an imported name is unsupported" + -> throwE $ PluginInternalError "Renaming of an imported name is unsupported" (_, Just (L _ exports)) | any ((`HS.member` refLocs) . unsafeSrcSpanToLoc . getLoc) exports - -> throwE $ mkPluginErrorMessage "Renaming of an exported name is unsupported" - (Just _, Nothing) -> throwE $ mkPluginErrorMessage "Explicit export list required for renaming" + -> throwE $ PluginInternalError "Renaming of an exported name is unsupported" + (Just _, Nothing) -> throwE $ PluginInternalError "Explicit export list required for renaming" _ -> pure () --------------------------------------------------------------------------------------------------- @@ -136,8 +136,8 @@ getSrcEdit :: getSrcEdit state verTxtDocId updatePs = do ccs <- lift getClientCapabilities nfp <- handleUriToNfp (verTxtDocId ^. L.uri) - annAst <- PluginUtils.runAction "Rename.GetAnnotatedParsedSource" state - (PluginUtils.use GetAnnotatedParsedSource nfp) + annAst <- runActionE "Rename.GetAnnotatedParsedSource" state + (useE GetAnnotatedParsedSource nfp) let (ps, anns) = (astA annAst, annsA annAst) #if !MIN_VERSION_ghc(9,2,1) let src = T.pack $ exactPrint ps anns @@ -229,7 +229,7 @@ handleGetHieAst :: NormalizedFilePath -> ExceptT PluginError m (HieAstResult, PositionMapping) handleGetHieAst state nfp = - fmap (first removeGenerated) $ PluginUtils.runAction "Rename.GetHieAst" state $ PluginUtils.useWithStale GetHieAst nfp + fmap (first removeGenerated) $ runActionE "Rename.GetHieAst" state $ useWithStaleE 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. @@ -246,7 +246,7 @@ removeGenerated HAR{..} = HAR{hieAst = go hieAst,..} #endif handleUriToNfp :: (Monad m) => Uri -> ExceptT PluginError m NormalizedFilePath -handleUriToNfp uri = getNormalizedFilePath' uri +handleUriToNfp uri = getNormalizedFilePathE 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 33f62a0ab3..2cd1e36689 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -171,7 +171,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.Core.PluginUtils import Development.IDE.Spans.AtPoint (LookupModule, getNamesAtPoint, nameToLocation) @@ -210,16 +210,16 @@ data RunRetrieParams = RunRetrieParams runRetrieCmd :: IdeState -> RunRetrieParams -> - LspM c (Either ResponseError (Value |? Null)) + LspM c (Either PluginError (Value |? Null)) runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = withIndefiniteProgress description Cancellable $ do - pluginResponse' $ do - nfp <- getNormalizedFilePath' uri + runExceptT $ do + nfp <- getNormalizedFilePathE uri (session, _) <- - PluginUtils.runAction "Retrie.GhcSessionDeps" state $ - PluginUtils.useWithStale GhcSessionDeps + runActionE "Retrie.GhcSessionDeps" state $ + useWithStaleE GhcSessionDeps nfp - (ms, binds, _, _, _) <- PluginUtils.runAction "Retrie.getBinds" state $ getBinds nfp + (ms, binds, _, _, _) <- runActionE "Retrie.getBinds" state $ getBinds nfp let importRewrites = concatMap (extractImports ms binds) rewrites (errors, edits) <- liftIO $ callRetrie @@ -246,38 +246,38 @@ data RunRetrieInlineThisParams = RunRetrieInlineThisParams deriving (Eq, Show, Generic, FromJSON, ToJSON) runRetrieInlineThisCmd :: IdeState - -> RunRetrieInlineThisParams -> LspM c (Either ResponseError (Value |? Null)) -runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse' $ do - nfp <- getNormalizedFilePath' $ getLocationUri inlineIntoThisLocation - nfpSource <- getNormalizedFilePath' $ getLocationUri inlineFromThisLocation + -> RunRetrieInlineThisParams -> LspM c (Either PluginError (Value |? Null)) +runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = runExceptT $ do + nfp <- getNormalizedFilePathE $ getLocationUri inlineIntoThisLocation + nfpSource <- getNormalizedFilePathE $ 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 <- 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 + ast <- runActionE "retrie" state $ + useE GetAnnotatedParsedSource nfp + astSrc <- runActionE "retrie" state $ + useE GetAnnotatedParsedSource nfpSource + msr <- runActionE "retrie" state $ + useE GetModSummaryWithoutTimestamps nfp + hiFileRes <- runActionE "retrie" state $ + useE 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 $ mkPluginErrorMessage "Empty rewrite" + when (null inlineRewrite) $ throwE $ PluginInternalError "Empty rewrite" let ShakeExtras{..} = shakeExtras state - (session, _) <- PluginUtils.runAction "retrie" state $ - PluginUtils.useWithStale GhcSessionDeps nfp + (session, _) <- runActionE "retrie" state $ + useWithStaleE 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 $ mkPluginErrorMessage $ "Retrie - crashed with: " <> T.pack (show err) - Right (_,_,NoChange) -> throwE $ mkPluginErrorMessage "Retrie - inline produced no changes" + Left err -> throwE $ PluginInternalError $ "Retrie - crashed with: " <> T.pack (show err) + Right (_,_,NoChange) -> throwE $ PluginInternalError "Retrie - inline produced no changes" Right (_,_,Change replacements imports) -> do let edits = asEditMap $ asTextEdits $ Change ourReplacement imports wedit = WorkspaceEdit (Just edits) Nothing Nothing @@ -338,17 +338,17 @@ extractImports _ _ _ = [] ------------------------------------------------------------------------------- provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction -provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = pluginResponse' $ do +provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = runExceptT $ do let (LSP.CodeActionContext _diags _monly _) = ca - nfp <- getNormalizedFilePath' uri + nfp <- getNormalizedFilePathE uri (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) - <- PluginUtils.runAction "retrie" state $ + <- runActionE "retrie" state $ getBinds nfp extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras - range <- handleMaybe (mkPluginErrorMessage "range") $ fromCurrentRange posMapping range + range <- handleMaybe (PluginBadDependency "retire:fromCurrentRange") $ fromCurrentRange posMapping range let pos = range ^. L.start let rewrites = concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds @@ -381,7 +381,7 @@ getLocationRange Location{_range} = _range getBinds :: NormalizedFilePath -> ExceptT PluginError Action (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn]) getBinds nfp = do - (tm, posMapping) <- PluginUtils.useWithStale TypeCheck nfp + (tm, posMapping) <- useWithStaleE 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 diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index d4af48ddbc..558c56c4dc 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -67,6 +67,7 @@ import Language.LSP.Server import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message import qualified Language.LSP.Protocol.Lens as J +import Ide.Plugin.Error (PluginError(PluginInternalError)) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -188,7 +189,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do reportEditor MessageType_Error ["Error during expanding splice: " <> T.pack err] - pure (Left $ responseError $ T.pack err) + pure (Left $ PluginInternalError $ T.pack err) Right edits -> pure (Right edits) case res of diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index c68e623401..cd63a0b904 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -13,6 +13,7 @@ import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts), extensionFlags) import qualified Development.IDE.GHC.Compat.Util as Util import GHC.LanguageExtensions.Type +import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.PluginUtils import Ide.Types hiding (Config) import Language.Haskell.Stylish @@ -39,7 +40,7 @@ provider ide typ contents fp _opts = do FormatRange r -> (normalize r, extractRange r contents) result = runStylishHaskell file mergedConfig selectedContents case result of - Left err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err + Left err -> return $ Left $ PluginInternalError $ T.pack $ "stylishHaskellCmd: " ++ err Right new -> return $ Right $ LSP.InL [TextEdit range new] where getMergedConfig dyn config From bc093c242872e193ea01d42523ae7d5d1716ced1 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 21 Jul 2023 20:56:29 +0300 Subject: [PATCH 05/28] Further support for PluginError in HLS.hs among other enhancements --- .../src/Development/IDE/Core/PluginUtils.hs | 56 +++++-- .../src/Development/IDE/Plugin/Completions.hs | 64 ++++---- ghcide/src/Development/IDE/Plugin/HLS.hs | 149 ++++++++++++++---- hls-plugin-api/src/Ide/Plugin/Error.hs | 89 ++++++++--- .../src/Ide/Plugin/Class/CodeAction.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 52 ++---- .../hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 12 +- .../src/Ide/Plugin/Retrie.hs | 2 +- 8 files changed, 281 insertions(+), 145 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index 10da1cc932..630196aedb 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -33,26 +33,26 @@ runActionE herald ide act = hoistExceptT . ExceptT $ join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act) -runActionMaybeT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a -runActionMaybeT herald ide act = +runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a +runActionMT herald ide act = hoistMaybeT . MaybeT $ join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act) -- | useE is useful to implement functions that aren’t rules but need shortcircuiting -- e.g. getDefinition. useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v -useE k = maybeToExceptT (RuleFailed k) . useMaybeT k +useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMaybeT k useMaybeT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v useMaybeT k = MaybeT . Shake.use k useWithStaleE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping) -useWithStaleE key = maybeToExceptT (FastRuleNotReady key) . useWithStaleMaybeT key +useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key -useWithStaleMaybeT :: IdeRule k v +useWithStaleMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping) -useWithStaleMaybeT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) +useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) hoistAction :: Action a -> ExceptT e Action a hoistAction = ExceptT . fmap Right @@ -67,13 +67,45 @@ runIdeActionE _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ -- | useE is useful to implement functions that aren’t rules but need shortcircuiting -- e.g. getDefinition. useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping) -useWithStaleFastE k = maybeToExceptT (RuleFailed k) . useWithStaleFastMaybeT k +useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k -useWithStaleFastMaybeT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) -useWithStaleFastMaybeT k = MaybeT . Shake.useWithStaleFast k +useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) +useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k + +-- ---------------------------------------------------------------------------- +-- Location wrappers +-- ---------------------------------------------------------------------------- uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath -uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <> show uri)) $ uriToFilePathMaybeT uri +uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <> show uri)) $ uriToFilePathMT uri + +uriToFilePathMT :: Monad m => LSP.Uri -> MaybeT m FilePath +uriToFilePathMT = MaybeT . pure . Location.uriToFilePath' + +-- ---------------------------------------------------------------------------- +-- PositionMapping wrappers +-- ---------------------------------------------------------------------------- + +toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position +toCurrentPositionE mapping = maybeToExceptT PluginPositionMappingFailed . toCurrentPositionMT mapping + +toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position +toCurrentPositionMT mapping = MaybeT . pure . toCurrentPosition mapping + +fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position +fromCurrentPositionE mapping = maybeToExceptT PluginPositionMappingFailed . fromCurrentPositionMT mapping + +fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position +fromCurrentPositionMT mapping = MaybeT . pure . fromCurrentPosition mapping + +toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range +toCurrentRangeE mapping = maybeToExceptT PluginPositionMappingFailed . toCurrentRangeMT mapping + +toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range +toCurrentRangeMT mapping = MaybeT . pure . toCurrentRange mapping + +fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range +fromCurrentRangeE mapping = maybeToExceptT PluginPositionMappingFailed . fromCurrentRangeMT mapping -uriToFilePathMaybeT :: Monad m => LSP.Uri -> MaybeT m FilePath -uriToFilePathMaybeT = MaybeT . pure . Location.uriToFilePath' +fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range +fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 20b4d9cd8d..71a04f4f2c 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -19,6 +19,7 @@ import qualified Data.HashSet as Set import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Compile +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake) @@ -121,45 +122,42 @@ dropListFromImportDecl iDecl = let in f <$> iDecl resolveCompletion :: ResolveFunction IdeState CompletionResolveData 'Method_CompletionItemResolve -resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) - | Just file <- uriToNormalizedFilePath $ toNormalizedUri uri - = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do - msess <- useWithStaleFast GhcSessionDeps file - case msess of - Nothing -> pure (Right comp) -- File doesn't compile, return original completion item - Just (sess,_) -> do - let nc = ideNc $ shakeExtras ide +resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) = + runExceptT $ do + file <- getNormalizedFilePathE uri + (sess,_) <- withExceptT (const PluginStaleResolve) + $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide) + $ useWithStaleFastE GhcSessionDeps file + let nc = ideNc $ shakeExtras ide #if MIN_VERSION_ghc(9,3,0) - name <- liftIO $ lookupNameCache nc mod occ + name <- liftIO $ lookupNameCache nc mod occ #else - name <- liftIO $ upNameCache nc (lookupNameCache mod occ) + name <- liftIO $ upNameCache nc (lookupNameCache mod occ) #endif - mdkm <- useWithStaleFast GetDocMap file - let (dm,km) = case mdkm of - Just (DKMap dm km, _) -> (dm,km) - Nothing -> (mempty, mempty) - doc <- case lookupNameEnv dm name of - Just doc -> pure $ spanDocToMarkdown doc - Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name - typ <- case lookupNameEnv km name of - _ | not needType -> pure Nothing - Just ty -> pure (safeTyThingType ty) - Nothing -> do - (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name) - let det1 = case typ of - Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") - Nothing -> Nothing - doc1 = case _documentation of - Just (InR (MarkupContent MarkupKind_Markdown old)) -> - InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc) - _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc - pure (Right $ comp & L.detail .~ (det1 <> _detail) - & L.documentation .~ Just doc1 - ) + mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file + let (dm,km) = case mdkm of + Just (DKMap dm km, _) -> (dm,km) + Nothing -> (mempty, mempty) + doc <- case lookupNameEnv dm name of + Just doc -> pure $ spanDocToMarkdown doc + Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name + typ <- case lookupNameEnv km name of + _ | not needType -> pure Nothing + Just ty -> pure (safeTyThingType ty) + Nothing -> do + (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name) + let det1 = case typ of + Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") + Nothing -> Nothing + doc1 = case _documentation of + Just (InR (MarkupContent MarkupKind_Markdown old)) -> + InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc) + _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc + pure (comp & L.detail .~ (det1 <> _detail) + & L.documentation .~ Just doc1) where stripForall ty = case splitForAllTyCoVars ty of (_,res) -> res -resolveCompletion _ _ _ _ _ = pure $ Left $ PluginInvalidParams "Unable to get normalized file path for url" -- | Generate code actions. getCompletionsLSP :: PluginMethodHandler IdeState 'Method_TextDocumentCompletion diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index dab84da4de..e63d008a71 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -32,7 +32,7 @@ import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server import Development.IDE.Plugin import qualified Development.IDE.Plugin as P -import Development.IDE.Types.Logger hiding (Error) +import Development.IDE.Types.Logger import Ide.Plugin.Config import Ide.Plugin.Error import Ide.PluginUtils (getClientConfig) @@ -44,7 +44,7 @@ import qualified Language.LSP.Server as LSP import Language.LSP.VFS import Prettyprinter.Render.String (renderString) import Text.Regex.TDFA.Text () -import UnliftIO (MonadUnliftIO) +import UnliftIO (MonadUnliftIO, liftIO) import UnliftIO.Async (forConcurrently) import UnliftIO.Exception (catchAny) @@ -54,20 +54,36 @@ import UnliftIO.Exception (catchAny) data Log = LogPluginError PluginId PluginError | LogResponseError PluginId ResponseError + | LogPositionMappingFailed (NE.NonEmpty PluginId) + | LogRequestRefused (NE.NonEmpty PluginId) + | LogRuleFailed (NE.NonEmpty (T.Text, NE.NonEmpty PluginId)) | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier | ExceptionInPlugin PluginId (Some SMethod) SomeException instance Pretty Log where pretty = \case - LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> pretty err - LogResponseError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err + LogPluginError (PluginId pId) err -> + pretty pId <> ":" <+> pretty err + LogResponseError (PluginId pId) err -> + pretty pId <> ":" <+> prettyResponseError err LogNoPluginForMethod (Some method) -> "No plugin enabled for " <> pretty (show method) LogInvalidCommandIdentifier-> "Invalid command identifier" ExceptionInPlugin plId (Some method) exception -> - "Exception in plugin " <> viaShow plId <> " while processing "<> viaShow method <> ": " <> viaShow exception - + "Exception in plugin " <> viaShow plId <> " while processing " + <> viaShow method <> ": " <> viaShow exception + LogPositionMappingFailed (toList -> xs) -> + "Position Mapping failed for the following plugins:" + <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) + LogRequestRefused (toList -> xs) -> + "Handlers from the following plugins refused requests:" + <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) + LogRuleFailed (toList -> xs) -> + let prettyRule (plId, (toList -> xs)) = pretty plId <> ":" <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) + in "The following rules and dependent plugins failed:" + <+> hsep (punctuate semi (prettyRule <$> xs)) + where unwrapPlId (PluginId plId) = plId instance Show Log where show = renderString . layoutCompact . pretty -- various error message specific builders @@ -79,7 +95,7 @@ prettyResponseError err = errorCode <> ":" <+> errorBody pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text pluginNotEnabled method availPlugins = - "No plugin enabled for " <> T.pack (show method) <> ", available: " + "No plugin enabled for " <> T.pack (show method) <> ", Potentially available: " <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins) pluginDoesntExist :: PluginId -> Text @@ -215,8 +231,9 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (commandDoesntExist com p xs) Just (PluginCommand _ _ f) -> case A.fromJSON arg of A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) - A.Success a -> - (first toResponseError <$> f ide a) `catchAny` -- See Note [Exception handling in plugins] + A.Success a -> do + caps <- LSP.getClientCapabilities + (first (toResponseError caps . (p,)) <$> f ide a) `catchAny` -- See Note [Exception handling in plugins] (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e)) -- --------------------------------------------------------------------- @@ -239,22 +256,29 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> do - logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing - msg = pluginNotEnabled m fs' - return $ Left err + Nothing -> liftIO $ noPluginEnabled m fs' Just fs -> do let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs es <- runConcurrently exceptionInPlugin m handlers ide params - + caps <- LSP.getClientCapabilities let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es - unless (null errs) $ logErrors recorder errs + liftIO $ unless (null errs) $ logErrors recorder errs case nonEmpty succs of - Nothing -> pure $ Left $ combineErrors errs + Nothing -> do + let noRefused (_, PluginRequestRefused) = False + noRefused (_, _) = True + filteredErrs = filter noRefused errs + case nonEmpty filteredErrs of + Nothing -> liftIO $ noPluginEnabled m fs' + Just xs -> pure $ Left $ combineErrors caps xs Just xs -> do - caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs + noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c) + noPluginEnabled m fs' = do + logWith recorder Warning (LogNoPluginForMethod $ Some m) + let err = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing + msg = pluginNotEnabled m fs' + return $ Left err -- --------------------------------------------------------------------- @@ -299,21 +323,80 @@ runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedPro f a b -- See Note [Exception handling in plugins] `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: [(PluginId, PluginError)] -> ResponseError -combineErrors [x] = toResponseError (snd x) -combineErrors xs = ResponseError (InR ErrorCodes_InternalError) (T.pack (show (pretty (snd <$> xs)))) Nothing - -toResponseError :: PluginError -> ResponseError -toResponseError (PluginInternalError msg) = ResponseError (InR ErrorCodes_InternalError) msg Nothing -toResponseError PluginStaleResolve = ResponseError (InL LSPErrorCodes_ContentModified) "" Nothing -toResponseError (PluginInvalidParams msg) = ResponseError (InR ErrorCodes_InvalidParams) msg Nothing -toResponseError (PluginParseError msg) = ResponseError (InR ErrorCodes_ParseError) msg Nothing -toResponseError (FastRuleNotReady a) = ResponseError (InL LSPErrorCodes_ServerCancelled) (T.pack $ "FastRuleNotReady: " <> show a) Nothing -toResponseError (RuleFailed a) = ResponseError (InL LSPErrorCodes_ServerCancelled) (T.pack $ "RuleFailed: " <> show a) Nothing - -logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> LSP.LspT Config IO () -logErrors recorder errs = forM_ errs $ \(pId, err) -> - logWith recorder Warning $ LogPluginError pId err +combineErrors :: ClientCapabilities -> NonEmpty (PluginId, PluginError) -> ResponseError +combineErrors caps (x NE.:| []) = toResponseError caps x +combineErrors caps (toList -> xs) = + case filter (isPrecedence1 . snd) xs of + (x: _) -> toResponseError caps x + _ -> case filter (isPrecedence2 . snd) xs of + (x: _) -> toResponseError caps x + _ -> case filter (isPrecedence3 . snd) xs of + (x: _) -> toResponseError caps x + _ -> ResponseError (InR ErrorCodes_InternalError) "Something impossible happened: No error left to return" Nothing + where isPrecedence1 :: PluginError -> Bool + isPrecedence1 (PluginInternalError _) = True + isPrecedence1 _ = False + isPrecedence2 :: PluginError -> Bool + isPrecedence2 (PluginInvalidRequest _) = True + isPrecedence2 (PluginInvalidParams _) = True + isPrecedence2 (PluginParseError _) = True + isPrecedence2 _ = False + isPrecedence3 :: PluginError -> Bool + isPrecedence3 PluginPositionMappingFailed = True + isPrecedence3 (PluginRuleFailed _) = True + isPrecedence3 PluginStaleResolve = True + isPrecedence3 _ = False + + +toResponseError :: ClientCapabilities -> (PluginId, PluginError) -> ResponseError +toResponseError _ (plId, PluginInternalError msg) = ResponseError (InR ErrorCodes_InternalError) msg Nothing +toResponseError _ (plId, PluginInvalidParams msg) = ResponseError (InR ErrorCodes_InvalidParams) msg Nothing +toResponseError _ (plId, PluginInvalidRequest msg) = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing +toResponseError _ (plId, PluginParseError msg) = ResponseError (InR ErrorCodes_ParseError) msg Nothing +toResponseError caps (plId, PluginPositionMappingFailed) = ResponseError (InL LSPErrorCodes_ContentModified) "" Nothing +toResponseError _ (plId, PluginRequestRefused) = ResponseError (InR ErrorCodes_InvalidRequest) "No plugins enabled for this request" Nothing +toResponseError caps (plId, PluginRuleFailed a) = ResponseError (InL LSPErrorCodes_ServerCancelled) (T.pack $ "RuleFailed: " <> show a) Nothing +toResponseError _ (plId, PluginStaleResolve) = ResponseError (InL LSPErrorCodes_ContentModified) "" Nothing + +logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO () +logErrors recorder errs = do + forM_ errs $ \(pId, err) -> + logIndividualErrors pId err + logPositionMappingFailed errs + logRequestRefused errs + logRuleFailed errs + where logIndividualErrors plId err@(PluginInternalError _) = + logWith recorder Error $ LogPluginError plId err + logIndividualErrors plId err@(PluginInvalidParams _) = + logWith recorder Warning $ LogPluginError plId err + logIndividualErrors plId err@(PluginInvalidRequest _) = + logWith recorder Warning $ LogPluginError plId err + logIndividualErrors plId err@(PluginParseError _) = + logWith recorder Warning $ LogPluginError plId err + logIndividualErrors plId err@PluginStaleResolve = + logWith recorder Info $ LogPluginError plId err + logIndividualErrors _ _ = pure () + logPositionMappingFailed errs = do + let pmfErrs = [plId + | (plId, PluginPositionMappingFailed) <- errs] + case nonEmpty pmfErrs of + Nothing -> pure () + Just xs -> logWith recorder Info $ LogPositionMappingFailed xs + logRequestRefused errs = do + let rrErrs = [plId + | (plId, PluginRequestRefused) <- errs] + case nonEmpty rrErrs of + Nothing -> pure () + Just xs -> logWith recorder Info $ LogRequestRefused xs + logRuleFailed errs = do + let rfErrs = [(plId, rule) + | (plId, PluginRuleFailed rule) <- errs] + case nonEmpty $ NE.groupAllWith fst rfErrs of + Nothing -> pure () + Just xs -> do + let setify xs@(x NE.:| _) = (snd x, fst <$> xs) + sxs = setify <$> xs + logWith recorder Info $ LogRuleFailed sxs -- | Combine the 'PluginHandler' for all plugins diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index 51439cc8d5..adaec651df 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -5,14 +5,13 @@ module Ide.Plugin.Error ( -- * Plugin Error Handling API PluginError(..), runExceptT, - runExceptT, + withExceptT, pluginResponseM, handlePluginError, hoistExceptT, hoistMaybeT, handleMaybe, handleMaybeM, - withError, getNormalizedFilePathE, ) where @@ -46,26 +45,83 @@ handlePluginError msg = ResponseError (InR ErrorCodes_InternalError) (renderStri where simpleDoc = layoutPretty defaultLayoutOptions $ pretty msg data PluginError - = PluginInternalError T.Text + = -- |PluginInternalError should be used if something has gone horribly wrong. + -- All uncaught exceptions will be caught and converted to this error. + -- + -- This error will be logged individually with Error, and will be converted + -- into an InternalError response code. It takes the highest precedence (1) + -- in being returned as a response to the client. + PluginInternalError T.Text + -- |PluginInvalidParams should be used if the parameters of the request are + -- invalid. This error means that there is a bug in the client's code + -- (otherwise they wouldn't be sending you requests with invalid + -- parameters). + + -- This error will be logged individually with Warning, and will be + -- converted into a InvalidParams response code. It takes medium precedence + -- (2)in being returned as a response to the client. | PluginInvalidParams T.Text - | PluginParseError T.Text + -- |PluginInvalidRequest should be used if the request is invalid. This + -- error means that there is a bug in the client's code (otherwise they + -- wouldn't be sending you an invalid request). + -- + -- This error will be logged individually with Warning, and will be + -- converted into a InvalidRequest response code. It takes medium precedence + -- (2) in being returned as a response to the client. | PluginInvalidRequest T.Text + -- |PluginParseError should be used sparingly for parse errors. Prefer to + -- use PluginInternalError for bugs in the plugin's code, or + -- PluginInvalidRequest/PluginInvalidParams for invalid requests from the + -- client. + -- + -- This error will be logged individually with Warning, and will be + -- converted into a ParseError response code. It takes a medium precedence + -- (2) in being returned as a response to the client. + | PluginParseError T.Text + -- |PluginPositionMappingFailed should be thrown when a PositionMapping your + -- response depends on fails. + -- + -- This error will be logged together with other errors of the same type + -- with Info, and will be converted into a ServerCancelled or + -- ContentModified response. It takes a low precedence (3) in being returned + -- as a response to the client. + | PluginPositionMappingFailed + -- |PluginRequestRefused allows your handler to inspect a request before + -- rejecting it. In effect it allows your plugin to act make a secondary + -- `pluginEnabled` decision after receiving the request. This should only be + -- used if the decision to accept the request can not be made in + -- `pluginEnabled`. + -- + -- This error will be logged together with other errors of the same type + -- with Info. If it's the only response to a request, HLS will respond as if + -- no plugins passed the `pluginEnabled` stage. + | PluginRequestRefused + -- |PluginRuleFailed should be thrown when a Rule your response depends on + -- fails. + -- + -- This error will be logged together with other errors of the same type + -- with Info, and will be converted into a ServerCancelled or + -- ContentModified response code. It takes a low precedence (3) in being returned + -- as a response to the client. + | PluginRuleFailed T.Text + -- |PluginStaleResolve should be thrown when your resolve request is + -- provided with data it can no longer resolve. + -- + -- This error will be logged individually with Info, and will be converted + -- into a ContentModified response. It takes a low precedence (3) in being + -- returned as a response to the client. | PluginStaleResolve - | PluginBadDependency T.Text - | forall a . Show a => FastRuleNotReady a - | forall a . Show a => RuleFailed a instance Pretty PluginError where pretty = \case - PluginInternalError msg -> "Internal Plugin Error: " <+> viaShow msg + PluginInternalError msg -> "Internal Plugin Error:" <+> pretty msg PluginStaleResolve -> "Stale Resolve" - FastRuleNotReady rule -> "FastRuleNotReady:" <+> viaShow rule - RuleFailed rule -> "RuleFailed:" <+> viaShow rule - PluginInvalidParams text -> "Invalid Params:" <+> viaShow text - PluginParseError text -> "Parse Error:" <+> viaShow text - PluginInvalidRequest text -> "Invalid Request:" <+> viaShow text - PluginBadDependency text -> "Bad dependency" <+> viaShow text - + PluginRuleFailed rule -> "RuleFailed:" <+> pretty rule + PluginInvalidParams text -> "Invalid Params:" <+> pretty text + PluginParseError text -> "Parse Error:" <+> pretty text + PluginInvalidRequest text -> "Invalid Request:" <+> pretty text + PluginPositionMappingFailed -> "PositionMapping failed" + PluginRequestRefused -> "Request Refused" handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return @@ -73,9 +129,6 @@ 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 -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-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 4a0d108920..c3b01144e6 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -99,7 +99,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = runExcep mkActions docPath verTxtDocId diag = do (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state $ useWithStaleE GetHieAst docPath - instancePosition <- handleMaybe (PluginBadDependency "GetHieAst.fromCurrentRange") $ + instancePosition <- handleMaybe (PluginPositionMappingFailed) $ fromCurrentRange pmap range ^? _Just . L.start & fmap (L.character -~ 1) ident <- findClassIdentifier ast instancePosition 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 4e51db8d13..56f8164ae2 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -69,16 +69,14 @@ descriptor recorder plId = (defaultPluginDescriptor plId) } data Log = LogRules Rules.Log - | forall rule. Show rule => LogBadDependency rule instance Pretty Log where pretty log = case log of LogRules codeRangeLog -> pretty codeRangeLog - LogBadDependency rule -> pretty $ "bad dependency: " <> show rule foldingRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentFoldingRange foldingRangeHandler recorder ide _ FoldingRangeParams{..} = - pluginResponseM handleErrors $ do + runExceptT $ do filePath <- getNormalizedFilePathE uri foldingRanges <- runActionE "FoldingRange" ide $ getFoldingRanges filePath pure . InL $ foldingRanges @@ -86,12 +84,6 @@ foldingRangeHandler recorder ide _ FoldingRangeParams{..} = uri :: Uri TextDocumentIdentifier uri = _textDocument - handleErrors = \case - RuleFailed rule -> do - logWith recorder Warning $ LogBadDependency rule - pure $ Right $ InL [] - errs -> pure $ Left errs - getFoldingRanges :: NormalizedFilePath -> ExceptT PluginError Action [FoldingRange] getFoldingRanges file = do codeRange <- useE GetCodeRange file @@ -99,8 +91,8 @@ getFoldingRanges file = do selectionRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentSelectionRange selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do - pluginResponseM handleErrors $ do - filePath <- withError GhcidePluginErrors $ getNormalizedFilePathE uri + runExceptT $ do + filePath <- getNormalizedFilePathE uri fmap id . runIdeAction' $ getSelectionRanges filePath positions where uri :: Uri @@ -109,39 +101,17 @@ selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do positions :: [Position] positions = _positions - runIdeAction' :: MonadIO m => ExceptT SelectionRangeError IdeAction ([SelectionRange] |? Null) -> ExceptT SelectionRangeError m ([SelectionRange] |? Null) + runIdeAction' :: MonadIO m => ExceptT PluginError IdeAction ([SelectionRange] |? Null) -> ExceptT PluginError m ([SelectionRange] |? Null) runIdeAction' action = runIdeActionE "SelectionRange" (shakeExtras ide) action - handleErrors :: - MonadIO m => - SelectionRangeError -> - m (Either PluginError ([a] |? Null)) - 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 $ InL [] - SelectionRangeInputPositionMappingFailure -> - pure $ Left $ PluginInternalError "failed to apply position mapping to input positions" - SelectionRangeOutputPositionMappingFailure -> - pure $ Left $ PluginInternalError "failed to apply position mapping to output positions" - GhcidePluginErrors ghcidePluginError -> - pure $ Left $ ghcidePluginError - - -data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency rule - | SelectionRangeInputPositionMappingFailure - | SelectionRangeOutputPositionMappingFailure - | GhcidePluginErrors PluginError - -getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction ([SelectionRange] |? Null) + + +getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT PluginError IdeAction ([SelectionRange] |? Null) getSelectionRanges file positions = do - (codeRange, positionMapping) <- withError (\_ -> SelectionRangeBadDependency GetCodeRange) $ - useWithStaleFastE GetCodeRange file + (codeRange, positionMapping) <- useWithStaleFastE GetCodeRange file -- 'positionMapping' should be applied to the input before using them - positions' <- maybeToExceptT SelectionRangeInputPositionMappingFailure . MaybeT . pure $ - traverse (fromCurrentPosition positionMapping) positions + positions' <- + traverse (fromCurrentPositionE positionMapping) positions let selectionRanges = flip fmap positions' $ \pos -> -- We need a default selection range if the lookup fails, @@ -150,7 +120,7 @@ getSelectionRanges file positions = do in fromMaybe defaultSelectionRange . findPosition pos $ codeRange -- 'positionMapping' should be applied to the output ranges before returning them - maybeToExceptT SelectionRangeOutputPositionMappingFailure . MaybeT . pure $ + maybeToExceptT PluginPositionMappingFailed . MaybeT . pure $ InL <$> traverse (toCurrentSelectionRange positionMapping) selectionRanges -- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 22baf1c211..876c5512a6 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -56,20 +56,20 @@ 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{..} = pluginResponseM handleGhcidePluginError $ do - nfp <- withError (GhcidePluginErrors) $ getNormalizedFilePathE uri + nfp <- withExceptT (GhcidePluginErrors) $ getNormalizedFilePathE uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d _ -> throwE $ UnexpectedNumberOfDeclarations (Prelude.length decls) - deps <- withError GhcidePluginErrors + deps <- withExceptT GhcidePluginErrors $ runActionE (T.unpack pId' <> ".GhcSessionDeps") state $ useE GhcSessionDeps nfp (hsc_dflags . hscEnv -> df) <- pure deps - txt <- withError (PrettyGadtError . T.pack) $ liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl + txt <- withExceptT (PrettyGadtError . T.pack) $ liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl range <- liftEither $ maybeToEither FailedToFindDataDeclRange $ srcSpanToRange $ locA ann - pragma <- withError GhcidePluginErrors $ getFirstPragma pId state nfp + pragma <- withExceptT GhcidePluginErrors $ getFirstPragma pId state nfp let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] _ <- lift $ sendRequest @@ -87,7 +87,7 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponseM handl codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponseM handleGhcidePluginError $ do - nfp <- withError (GhcidePluginErrors) $ getNormalizedFilePathE (doc ^. L.uri) + nfp <- withExceptT (GhcidePluginErrors) $ getNormalizedFilePathE (doc ^. L.uri) (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls pure $ InL actions @@ -114,7 +114,7 @@ getInRangeH98DeclsAndExts :: (MonadIO m) => -> NormalizedFilePath -> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension]) getInRangeH98DeclsAndExts state range nfp = do - pm <- withError GhcidePluginErrors + pm <- withExceptT GhcidePluginErrors $ runActionE "GADT.GetParsedModuleWithComments" state $ useE GetParsedModuleWithComments nfp let (L _ hsDecls) = hsmodDecls <$> pm_parsed_source pm diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 2cd1e36689..380b20c554 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -348,7 +348,7 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras - range <- handleMaybe (PluginBadDependency "retire:fromCurrentRange") $ fromCurrentRange posMapping range + range <- fromCurrentRangeE posMapping range let pos = range ^. L.start let rewrites = concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds From 9bc837a91095581b3d375377cecde9f5305af93c Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 22 Jul 2023 19:58:55 +0300 Subject: [PATCH 06/28] Further improvements --- ghcide/src/Development/IDE.hs | 3 +- ghcide/src/Development/IDE/Core/Actions.hs | 31 ++----- .../src/Development/IDE/Core/PluginUtils.hs | 53 +++++++---- ghcide/src/Development/IDE/Core/Service.hs | 2 - ghcide/src/Development/IDE/Plugin/HLS.hs | 93 +++++++++++-------- ghcide/src/Development/IDE/Spans/Pragmas.hs | 10 +- hls-plugin-api/src/Ide/Plugin/Error.hs | 30 +++--- hls-plugin-api/src/Ide/PluginUtils.hs | 31 +++---- .../src/Ide/Plugin/Class/CodeAction.hs | 2 +- .../src/Ide/Plugin/Class/Utils.hs | 3 +- .../src/Ide/Plugin/CodeRange.hs | 16 ++-- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 1 - .../src/Ide/Plugin/Rename.hs | 7 +- .../old/src/Wingman/AbstractLSP.hs | 15 +-- 14 files changed, 146 insertions(+), 151 deletions(-) diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 2d46f0e458..05ed0a56bc 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -8,8 +8,7 @@ module Development.IDE import Development.IDE.Core.Actions as X (getAtPoint, getDefinition, - getTypeDefinition, - useNoFileE, usesE) + getTypeDefinition) import Development.IDE.Core.FileExists as X (getFileExists) import Development.IDE.Core.FileStore as X (getFileContents) import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..), diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 92bafd099c..daf1acf269 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -6,9 +6,6 @@ module Development.IDE.Core.Actions , getTypeDefinition , highlightAtPoint , refsAtPoint ---, useE -, useNoFileE -, usesE , workspaceSymbols , lookupMod ) where @@ -20,6 +17,7 @@ import Data.Maybe import qualified Data.Text as T import Data.Tuple.Extra import Development.IDE.Core.OfInterest +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -46,7 +44,7 @@ lookupMod lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing --- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined, +-- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined, -- so we can quickly answer as soon as the IDE is opened -- Even if we don't have persistent information on disk for these rules, the persistent rule -- should just return an empty result @@ -59,9 +57,9 @@ getAtPoint file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useE GetHieAst file - env <- hscEnv . fst <$> useE GhcSession file - dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) + (hf, mapping) <- useWithStaleFastMT GetHieAst file + env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file + dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' @@ -71,24 +69,13 @@ toCurrentLocations mapping = mapMaybe go where go (Location uri range) = Location uri <$> toCurrentRange mapping range --- | useE is useful to implement functions that aren’t rules but need shortcircuiting --- e.g. getDefinition. -useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) -useE k = MaybeT . useWithStaleFast k - -useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v -useNoFileE _ide k = fst <$> useE k emptyFilePath - -usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)] -usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k) - -- | Goto Definition. getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (HAR _ hf _ _ _, mapping) <- useE GetHieAst file - (ImportMap imports, _) <- useE GetImportMap file + (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file + (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' @@ -96,13 +83,13 @@ getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Locatio getTypeDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useE GetHieAst file + (hf, mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do - (HAR _ hf rf _ _,mapping) <- useE GetHieAst file + (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index 630196aedb..144c2aafef 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -6,7 +6,6 @@ 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 @@ -21,54 +20,61 @@ import Development.IDE.Types.Location (NormalizedFilePath) import qualified Development.IDE.Types.Location as Location import qualified Development.IDE.Types.Logger as Logger import Ide.Plugin.Error -import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP -- ---------------------------------------------------------------------------- -- Action wrappers -- ---------------------------------------------------------------------------- +-- |ExceptT version of `runAction`, takes a ExceptT Action runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a runActionE herald ide act = hoistExceptT . ExceptT $ join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act) +-- |MaybeT version of `runAction`, takes a MaybeT Action runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a runActionMT herald ide act = hoistMaybeT . MaybeT $ join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act) --- | useE is useful to implement functions that aren’t rules but need shortcircuiting --- e.g. getDefinition. +-- |ExceptT version of `use` that throws a PluginRuleFailed upon failure useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v -useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMaybeT k +useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k -useMaybeT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v -useMaybeT k = MaybeT . Shake.use k +-- |MaybeT version of `use` +useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v +useMT k = MaybeT . Shake.use k +-- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon +-- failure useWithStaleE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping) useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key +-- |MaybeT version of `useWithStale` useWithStaleMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping) useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) -hoistAction :: Action a -> ExceptT e Action a -hoistAction = ExceptT . fmap Right - -- ---------------------------------------------------------------------------- -- IdeAction wrappers -- ---------------------------------------------------------------------------- +-- |ExceptT version of `runIdeAction`, takes a ExceptT IdeAction runIdeActionE :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a runIdeActionE _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. +-- |MaybeT version of `runIdeAction`, takes a MaybeT IdeAction +runIdeActionMT :: MonadIO m => String -> Shake.ShakeExtras -> MaybeT IdeAction a -> MaybeT m a +runIdeActionMT _herald s i = MaybeT $ liftIO $ runReaderT (Shake.runIdeActionT $ runMaybeT i) s + +-- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon +-- failure useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping) useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k +-- |MaybeT version of `useWithStaleFast` useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k @@ -76,9 +82,12 @@ useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k -- Location wrappers -- ---------------------------------------------------------------------------- +-- |ExceptT version of `uriToFilePath` that throws a PluginInvalidParams upon +-- failure uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <> show uri)) $ uriToFilePathMT uri +-- |MaybeT version of `uriToFilePath` uriToFilePathMT :: Monad m => LSP.Uri -> MaybeT m FilePath uriToFilePathMT = MaybeT . pure . Location.uriToFilePath' @@ -86,26 +95,38 @@ uriToFilePathMT = MaybeT . pure . Location.uriToFilePath' -- PositionMapping wrappers -- ---------------------------------------------------------------------------- +-- |ExceptT version of `toCurrentPosition` that throws a PluginDependencyFailed +-- upon failure toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position -toCurrentPositionE mapping = maybeToExceptT PluginPositionMappingFailed . toCurrentPositionMT mapping +toCurrentPositionE mapping = maybeToExceptT (PluginDependencyFailed "toCurrentPosition"). toCurrentPositionMT mapping +-- |MaybeT version of `toCurrentPosition` toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position toCurrentPositionMT mapping = MaybeT . pure . toCurrentPosition mapping +-- |ExceptT version of `fromCurrentPosition` that throws a PluginDependencyFailed +-- upon failure fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position -fromCurrentPositionE mapping = maybeToExceptT PluginPositionMappingFailed . fromCurrentPositionMT mapping +fromCurrentPositionE mapping = maybeToExceptT (PluginDependencyFailed "fromCurrentPosition") . fromCurrentPositionMT mapping +-- |MaybeT version of `fromCurrentPosition` fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position fromCurrentPositionMT mapping = MaybeT . pure . fromCurrentPosition mapping +-- |ExceptT version of `toCurrentRange` that throws a PluginDependencyFailed +-- upon failure toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range -toCurrentRangeE mapping = maybeToExceptT PluginPositionMappingFailed . toCurrentRangeMT mapping +toCurrentRangeE mapping = maybeToExceptT (PluginDependencyFailed "toCurrentRange") . toCurrentRangeMT mapping +-- |MaybeT version of `toCurrentRange` toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range toCurrentRangeMT mapping = MaybeT . pure . toCurrentRange mapping +-- |ExceptT version of `fromCurrentRange` that throws a PluginDependencyFailed +-- upon failure fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range -fromCurrentRangeE mapping = maybeToExceptT PluginPositionMappingFailed . fromCurrentRangeMT mapping +fromCurrentRangeE mapping = maybeToExceptT (PluginDependencyFailed "fromCurrentRange") . fromCurrentRangeMT mapping +-- |MaybeT version of `fromCurrentRange` fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index eceb98521e..3e61ee582e 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -35,8 +35,6 @@ import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server 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/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index e63d008a71..d7e36cee60 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -54,7 +54,7 @@ import UnliftIO.Exception (catchAny) data Log = LogPluginError PluginId PluginError | LogResponseError PluginId ResponseError - | LogPositionMappingFailed (NE.NonEmpty PluginId) + | LogDependencyFailed (NE.NonEmpty (T.Text, NE.NonEmpty PluginId)) | LogRequestRefused (NE.NonEmpty PluginId) | LogRuleFailed (NE.NonEmpty (T.Text, NE.NonEmpty PluginId)) | LogNoPluginForMethod (Some SMethod) @@ -73,15 +73,16 @@ instance Pretty Log where ExceptionInPlugin plId (Some method) exception -> "Exception in plugin " <> viaShow plId <> " while processing " <> viaShow method <> ": " <> viaShow exception - LogPositionMappingFailed (toList -> xs) -> - "Position Mapping failed for the following plugins:" - <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) + LogDependencyFailed (toList -> xs) -> + let prettyDep (plId, (toList -> xs)) = pretty plId <> ":" <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) + in "The following dependencies and their dependent plugins failed:" + <+> hsep (punctuate semi (prettyDep <$> xs)) LogRequestRefused (toList -> xs) -> "Handlers from the following plugins refused requests:" <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) LogRuleFailed (toList -> xs) -> let prettyRule (plId, (toList -> xs)) = pretty plId <> ":" <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) - in "The following rules and dependent plugins failed:" + in "The following rules and their dependent plugins failed:" <+> hsep (punctuate semi (prettyRule <$> xs)) where unwrapPlId (PluginId plId) = plId instance Show Log where show = renderString . layoutCompact . pretty @@ -232,8 +233,7 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom Just (PluginCommand _ _ f) -> case A.fromJSON arg of A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) A.Success a -> do - caps <- LSP.getClientCapabilities - (first (toResponseError caps . (p,)) <$> f ide a) `catchAny` -- See Note [Exception handling in plugins] + (first (toResponseError . (p,)) <$> f ide a) `catchAny` -- See Note [Exception handling in plugins] (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e)) -- --------------------------------------------------------------------- @@ -270,7 +270,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } filteredErrs = filter noRefused errs case nonEmpty filteredErrs of Nothing -> liftIO $ noPluginEnabled m fs' - Just xs -> pure $ Left $ combineErrors caps xs + Just xs -> pure $ Left $ combineErrors xs Just xs -> do pure $ Right $ combineResponses m config caps params xs noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c) @@ -323,15 +323,15 @@ runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedPro f a b -- See Note [Exception handling in plugins] `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: ClientCapabilities -> NonEmpty (PluginId, PluginError) -> ResponseError -combineErrors caps (x NE.:| []) = toResponseError caps x -combineErrors caps (toList -> xs) = +combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError +combineErrors (x NE.:| []) = toResponseError x +combineErrors (toList -> xs) = case filter (isPrecedence1 . snd) xs of - (x: _) -> toResponseError caps x + (x: _) -> toResponseError x _ -> case filter (isPrecedence2 . snd) xs of - (x: _) -> toResponseError caps x + (x: _) -> toResponseError x _ -> case filter (isPrecedence3 . snd) xs of - (x: _) -> toResponseError caps x + (x: _) -> toResponseError x _ -> ResponseError (InR ErrorCodes_InternalError) "Something impossible happened: No error left to return" Nothing where isPrecedence1 :: PluginError -> Bool isPrecedence1 (PluginInternalError _) = True @@ -342,27 +342,38 @@ combineErrors caps (toList -> xs) = isPrecedence2 (PluginParseError _) = True isPrecedence2 _ = False isPrecedence3 :: PluginError -> Bool - isPrecedence3 PluginPositionMappingFailed = True - isPrecedence3 (PluginRuleFailed _) = True - isPrecedence3 PluginStaleResolve = True - isPrecedence3 _ = False - - -toResponseError :: ClientCapabilities -> (PluginId, PluginError) -> ResponseError -toResponseError _ (plId, PluginInternalError msg) = ResponseError (InR ErrorCodes_InternalError) msg Nothing -toResponseError _ (plId, PluginInvalidParams msg) = ResponseError (InR ErrorCodes_InvalidParams) msg Nothing -toResponseError _ (plId, PluginInvalidRequest msg) = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing -toResponseError _ (plId, PluginParseError msg) = ResponseError (InR ErrorCodes_ParseError) msg Nothing -toResponseError caps (plId, PluginPositionMappingFailed) = ResponseError (InL LSPErrorCodes_ContentModified) "" Nothing -toResponseError _ (plId, PluginRequestRefused) = ResponseError (InR ErrorCodes_InvalidRequest) "No plugins enabled for this request" Nothing -toResponseError caps (plId, PluginRuleFailed a) = ResponseError (InL LSPErrorCodes_ServerCancelled) (T.pack $ "RuleFailed: " <> show a) Nothing -toResponseError _ (plId, PluginStaleResolve) = ResponseError (InL LSPErrorCodes_ContentModified) "" Nothing + isPrecedence3 (PluginDependencyFailed _) = True + isPrecedence3 (PluginRuleFailed _) = True + isPrecedence3 PluginStaleResolve = True + isPrecedence3 _ = False + + + +toResponseError :: (PluginId, PluginError) -> ResponseError +toResponseError = \case + (PluginId plId, err@(PluginInternalError _)) -> + ResponseError (InR ErrorCodes_InternalError) (plId <> ": " <> tPretty err) Nothing + (PluginId plId, err@(PluginInvalidParams _)) -> + ResponseError (InR ErrorCodes_InvalidParams) (plId <> ": " <> tPretty err) Nothing + (PluginId plId, err@(PluginInvalidRequest _)) -> + ResponseError (InR ErrorCodes_InvalidRequest) (plId <> ": " <> tPretty err) Nothing + (PluginId plId, err@(PluginParseError _)) -> + ResponseError (InR ErrorCodes_ParseError) (plId <> ": " <> tPretty err) Nothing + (PluginId plId, err@(PluginDependencyFailed _)) -> + ResponseError (InL LSPErrorCodes_ContentModified) (plId <> ": " <> tPretty err) Nothing + (PluginId plId, err@PluginRequestRefused) -> + ResponseError (InR ErrorCodes_InvalidRequest) (plId <> ": " <> tPretty err) Nothing + (PluginId plId, err@(PluginRuleFailed _)) -> + ResponseError (InL LSPErrorCodes_ContentModified) (plId <> ": " <> tPretty err) Nothing + (PluginId plId, err@PluginStaleResolve) -> + ResponseError (InL LSPErrorCodes_ContentModified) (plId <> ": " <> tPretty err) Nothing + where tPretty = T.pack . show . pretty logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO () logErrors recorder errs = do forM_ errs $ \(pId, err) -> logIndividualErrors pId err - logPositionMappingFailed errs + logDependencyFailed errs logRequestRefused errs logRuleFailed errs where logIndividualErrors plId err@(PluginInternalError _) = @@ -376,12 +387,12 @@ logErrors recorder errs = do logIndividualErrors plId err@PluginStaleResolve = logWith recorder Info $ LogPluginError plId err logIndividualErrors _ _ = pure () - logPositionMappingFailed errs = do - let pmfErrs = [plId - | (plId, PluginPositionMappingFailed) <- errs] - case nonEmpty pmfErrs of + logDependencyFailed errs = do + let pmfErrs = [(plId, dep) + | (plId, PluginDependencyFailed dep) <- errs] + case groupBySnd pmfErrs of Nothing -> pure () - Just xs -> logWith recorder Info $ LogPositionMappingFailed xs + Just xs -> logWith recorder Info $ LogDependencyFailed xs logRequestRefused errs = do let rrErrs = [plId | (plId, PluginRequestRefused) <- errs] @@ -391,12 +402,14 @@ logErrors recorder errs = do logRuleFailed errs = do let rfErrs = [(plId, rule) | (plId, PluginRuleFailed rule) <- errs] - case nonEmpty $ NE.groupAllWith fst rfErrs of + case groupBySnd rfErrs of Nothing -> pure () - Just xs -> do - let setify xs@(x NE.:| _) = (snd x, fst <$> xs) - sxs = setify <$> xs - logWith recorder Info $ LogRuleFailed sxs + Just xs -> logWith recorder Info $ LogRuleFailed xs + -- gives us the list of plugins that failed for each rule/dependency + groupBySnd :: [(PluginId, T.Text)] -> Maybe (NonEmpty (T.Text, NonEmpty PluginId)) + groupBySnd errs = + let setify xs@(x NE.:| _) = (snd x, fst <$> xs) + in fmap setify <$> nonEmpty (NE.groupAllWith snd errs) -- | Combine the 'PluginHandler' for all plugins diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index 2fea43f018..d41e68bc5d 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, GhcSession (..), getFileContents, hscEnv) +import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import qualified Language.LSP.Protocol.Types as LSP @@ -54,11 +54,9 @@ insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit prag getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo getFirstPragma (PluginId pId) state nfp = do - ghcSession <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp - (_, fileContents) <- runActionE (T.unpack pId <> ".GetFileContents") state $ hoistAction $ getFileContents nfp - case ghcSession of - (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> - pure $ getNextPragmaInfo sessionDynFlags fileContents + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp + (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp + pure $ getNextPragmaInfo sessionDynFlags fileContents -- Pre-declaration comments parser ----------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index adaec651df..c180a440a0 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -56,7 +56,7 @@ data PluginError -- invalid. This error means that there is a bug in the client's code -- (otherwise they wouldn't be sending you requests with invalid -- parameters). - + -- -- This error will be logged individually with Warning, and will be -- converted into a InvalidParams response code. It takes medium precedence -- (2)in being returned as a response to the client. @@ -78,14 +78,17 @@ data PluginError -- converted into a ParseError response code. It takes a medium precedence -- (2) in being returned as a response to the client. | PluginParseError T.Text - -- |PluginPositionMappingFailed should be thrown when a PositionMapping your - -- response depends on fails. + -- |PluginDependencyFailed should be thrown when a function that your plugin + -- depends on fails. This should only be used when the function fails + -- because the files the user is working on is in an invalid state. + -- + -- This error takes the name of the function that failed. Prefer to catch + -- this error as close to the source as possible. -- -- This error will be logged together with other errors of the same type - -- with Info, and will be converted into a ServerCancelled or - -- ContentModified response. It takes a low precedence (3) in being returned - -- as a response to the client. - | PluginPositionMappingFailed + -- with Info, and will be converted into a ContentModified response. It + -- takes a low precedence (3) in being returned as a response to the client. + | PluginDependencyFailed T.Text -- |PluginRequestRefused allows your handler to inspect a request before -- rejecting it. In effect it allows your plugin to act make a secondary -- `pluginEnabled` decision after receiving the request. This should only be @@ -99,10 +102,11 @@ data PluginError -- |PluginRuleFailed should be thrown when a Rule your response depends on -- fails. -- + -- This error takes the name of the Rule that failed. + -- -- This error will be logged together with other errors of the same type - -- with Info, and will be converted into a ServerCancelled or - -- ContentModified response code. It takes a low precedence (3) in being returned - -- as a response to the client. + -- with Info, and will be converted into a ContentModified response code. It + -- takes a low precedence (3) in being returned as a response to the client. | PluginRuleFailed T.Text -- |PluginStaleResolve should be thrown when your resolve request is -- provided with data it can no longer resolve. @@ -114,13 +118,13 @@ data PluginError instance Pretty PluginError where pretty = \case - PluginInternalError msg -> "Internal Plugin Error:" <+> pretty msg + PluginInternalError msg -> "Internal Error:" <+> pretty msg PluginStaleResolve -> "Stale Resolve" - PluginRuleFailed rule -> "RuleFailed:" <+> pretty rule + PluginRuleFailed rule -> "Rule Failed:" <+> pretty rule PluginInvalidParams text -> "Invalid Params:" <+> pretty text PluginParseError text -> "Parse Error:" <+> pretty text PluginInvalidRequest text -> "Invalid Request:" <+> pretty text - PluginPositionMappingFailed -> "PositionMapping failed" + PluginDependencyFailed text -> "Dependency Failed:" <+> pretty text PluginRequestRefused -> "Request Refused" handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 0898288399..7b141c04cf 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -36,33 +36,24 @@ module Ide.PluginUtils where -import Control.Arrow ((&&&)) -import Control.Lens (re, (^.)) -import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, - runExceptT, throwE, withExceptT) +import Control.Arrow ((&&&)) +import Control.Lens (re, (^.)) 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.Map as M -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Void (Void) +import Data.Char (isPrint, showLitChar) +import Data.Functor (void) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Void (Void) import Ide.Plugin.Config -import Ide.Plugin.Error import Ide.Plugin.Properties import Ide.Types -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import Language.LSP.Server -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P -import qualified Text.Megaparsec.Char.Lexer as P +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as P -- --------------------------------------------------------------------- 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 c3b01144e6..689a1d2dab 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -99,7 +99,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = runExcep mkActions docPath verTxtDocId diag = do (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state $ useWithStaleE GetHieAst docPath - instancePosition <- handleMaybe (PluginPositionMappingFailed) $ + instancePosition <- handleMaybe (PluginDependencyFailed "fromCurrentRange") $ fromCurrentRange pmap range ^? _Just . L.start & fmap (L.character -~ 1) ident <- findClassIdentifier ast instancePosition 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 652e02fddb..164d75ddc4 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -60,8 +60,7 @@ insertPragmaIfNotPresent :: (MonadIO m) insertPragmaIfNotPresent state nfp pragma = do (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GhcSession" state $ useWithStaleE GhcSession nfp - (_, fileContents) <- runActionE "classplugin.insertPragmaIfNotPresent.GetFileContents" state - $ hoistAction + (_, fileContents) <- liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state $ getFileContents nfp (pm, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state $ useWithStaleE GetParsedModuleWithComments nfp 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 56f8164ae2..08e78d7bef 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -15,7 +15,7 @@ module Ide.Plugin.CodeRange ( , createFoldingRange ) where -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) @@ -93,7 +93,7 @@ selectionRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeS selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do runExceptT $ do filePath <- getNormalizedFilePathE uri - fmap id . runIdeAction' $ getSelectionRanges filePath positions + fmap id . hoistExceptT $ getSelectionRanges ide filePath positions where uri :: Uri TextDocumentIdentifier uri = _textDocument @@ -101,14 +101,10 @@ selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do positions :: [Position] positions = _positions - runIdeAction' :: MonadIO m => ExceptT PluginError IdeAction ([SelectionRange] |? Null) -> ExceptT PluginError m ([SelectionRange] |? Null) - runIdeAction' action = runIdeActionE "SelectionRange" (shakeExtras ide) action - - -getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT PluginError IdeAction ([SelectionRange] |? Null) -getSelectionRanges file positions = do - (codeRange, positionMapping) <- useWithStaleFastE GetCodeRange file +getSelectionRanges :: IdeState -> NormalizedFilePath -> [Position] -> ExceptT PluginError IO ([SelectionRange] |? Null) +getSelectionRanges ide file positions = do + (codeRange, positionMapping) <- runIdeActionE "SelectionRange" (shakeExtras ide) $ useWithStaleFastE GetCodeRange file -- 'positionMapping' should be applied to the input before using them positions' <- traverse (fromCurrentPositionE positionMapping) positions @@ -120,7 +116,7 @@ getSelectionRanges file positions = do in fromMaybe defaultSelectionRange . findPosition pos $ codeRange -- 'positionMapping' should be applied to the output ranges before returning them - maybeToExceptT PluginPositionMappingFailed . MaybeT . pure $ + maybeToExceptT (PluginDependencyFailed "toCurrentSelectionRange") . MaybeT . pure $ InL <$> traverse (toCurrentSelectionRange positionMapping) selectionRanges -- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index adec94cd97..ab5b1bd526 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -145,7 +145,6 @@ import System.Environment (setEnv, unsetEnv) #endif import Development.IDE.Core.PluginUtils as PluginUtils -import Ide.Plugin.Error (getNormalizedFilePathE) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 3cd9ae0ea1..35a178eec3 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -73,7 +73,7 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultP renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier uri) pos newNameText) = runExceptT $ do - nfp <- handleUriToNfp uri + nfp <- getNormalizedFilePathE uri directOldNames <- getNamesAtPos state nfp pos directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames @@ -135,7 +135,7 @@ getSrcEdit :: ExceptT PluginError m WorkspaceEdit getSrcEdit state verTxtDocId updatePs = do ccs <- lift getClientCapabilities - nfp <- handleUriToNfp (verTxtDocId ^. L.uri) + nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) annAst <- runActionE "Rename.GetAnnotatedParsedSource" state (useE GetAnnotatedParsedSource nfp) let (ps, anns) = (astA annAst, annsA annAst) @@ -245,9 +245,6 @@ removeGenerated HAR{..} = HAR{hieAst = go hieAst,..} hf #endif -handleUriToNfp :: (Monad m) => Uri -> ExceptT PluginError m NormalizedFilePath -handleUriToNfp uri = getNormalizedFilePathE uri - -- head is safe since groups are non-empty collectWith :: (Hashable a, Eq a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)] collectWith f = map (\a -> (f $ head a, HS.fromList a)) . groupOn f . HS.toList diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index e31a2f6cd8..dde474e4da 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -1,6 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -21,6 +21,7 @@ import Data.Tuple.Extra (uncurry3) import Development.IDE (IdeState) import Development.IDE.Core.UseStale import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource)) +import Ide.Plugin.Error import qualified Ide.Plugin.Config as Plugin import Ide.Types import Language.LSP.Server (LspM, sendRequest, getClientCapabilities, getVersionedTextDoc) @@ -91,11 +92,7 @@ runContinuation -> CommandFunction IdeState (FileContext, b) runContinuation plId cont state (fc, b) = do fromMaybeT - (Left $ ResponseError - { _code = InR $ ErrorCodes_InternalError - , _message = T.pack "TODO(sandy)" - , _xdata = Nothing - } ) $ do + (Left $ PluginInternalError "TODO(sandy)") $ do env@LspEnv{..} <- buildEnv state plId fc nfp <- getNfp $ fc_verTxtDocId le_fileContext ^. L.uri let stale a = runStaleIde "runContinuation" state nfp a @@ -116,11 +113,7 @@ runContinuation plId cont state (fc, b) = do TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_verTxtDocId le_fileContext) (unTrack pm) gr of Left errs -> - pure $ Just $ ResponseError - { _code = InR ErrorCodes_InternalError - , _message = T.pack $ show errs - , _xdata = Nothing - } + pure $ Just $ PluginInternalError (T.pack $ show errs) Right edits -> do sendEdits edits pure Nothing From 40d589c6f7ae2b75d878bf5b2978ab6d27bdad39 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 22 Jul 2023 22:39:35 +0300 Subject: [PATCH 07/28] Fix code-range test --- plugins/hls-code-range-plugin/test/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index a1948ce51a..8d1f315df1 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -48,6 +48,7 @@ selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDi let res = resp ^. result pure $ fmap (showSelectionRangesForTest . absorbNull) res case res of + Left (ResponseError (InL LSPErrorCodes_ContentModified) _ _) -> pure "" Left err -> assertFailure (show err) Right golden -> pure golden where From 15cf63853912145103a9fa3c3dd5a7b9b39baea4 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 22 Jul 2023 23:55:26 +0300 Subject: [PATCH 08/28] Fix build error --- ghcide/src/Development/IDE/Core/Actions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index e77a22da1f..965ebf21f0 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -92,7 +92,7 @@ toCurrentLocations mapping file = mapMaybeM go else do otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri - useE GetHieAst otherLocationFile + useWithStaleFastMT GetHieAst otherLocationFile pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) where nUri :: NormalizedUri From cdc036431a230d33d1c3a7b6eb30a0ef4579de68 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 24 Jul 2023 11:48:02 +0000 Subject: [PATCH 09/28] Added note --- ghcide/src/Development/IDE/Plugin/HLS.hs | 3 ++ hls-plugin-api/src/Ide/Plugin/Error.hs | 50 ++++++++++++++++-------- 2 files changed, 36 insertions(+), 17 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index d7e36cee60..88f0abdd2d 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -361,6 +361,9 @@ toResponseError = \case ResponseError (InR ErrorCodes_ParseError) (plId <> ": " <> tPretty err) Nothing (PluginId plId, err@(PluginDependencyFailed _)) -> ResponseError (InL LSPErrorCodes_ContentModified) (plId <> ": " <> tPretty err) Nothing + -- PluginRequestRefused should never be a argument to `toResponseError`, as + -- it should be dealt with in `extensiblePlugins`, but this is here to make + -- this function complete (PluginId plId, err@PluginRequestRefused) -> ResponseError (InR ErrorCodes_InvalidRequest) (plId <> ": " <> tPretty err) Nothing (PluginId plId, err@(PluginRuleFailed _)) -> diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index c180a440a0..c2c386906d 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -7,7 +7,6 @@ module Ide.Plugin.Error ( runExceptT, withExceptT, pluginResponseM, - handlePluginError, hoistExceptT, hoistMaybeT, handleMaybe, @@ -15,20 +14,15 @@ module Ide.Plugin.Error ( getNormalizedFilePathE, ) where -import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, - runExceptT, throwE, withExceptT) -import Data.Bifunctor (Bifunctor (first)) -import Data.String - -import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) -import qualified Data.Text as T -import Language.LSP.Protocol.Message +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, + runExceptT, throwE, withExceptT) +import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) +import qualified Data.Text as T import Language.LSP.Protocol.Types import Prettyprinter -import Prettyprinter.Render.Text (renderStrict) -- ---------------------------------------------------------------------------- -- Plugin Error wrapping @@ -40,10 +34,7 @@ pluginResponseM handler act = Right r -> pure $ Right r Left err -> handler err -handlePluginError :: PluginError -> ResponseError -handlePluginError msg = ResponseError (InR ErrorCodes_InternalError) (renderStrict simpleDoc) Nothing - where simpleDoc = layoutPretty defaultLayoutOptions $ pretty msg - +-- See Note [PluginError] data PluginError = -- |PluginInternalError should be used if something has gone horribly wrong. -- All uncaught exceptions will be caught and converted to this error. @@ -145,3 +136,28 @@ getNormalizedFilePathE uri = handleMaybe (PluginInvalidParams (T.pack $ "uriToNo $ toNormalizedUri uri -- --------------------------------------------------------------------- +{- Note [PluginError] +-- Each PluginError corresponds to either a specific ResponseError we want to +-- return or a specific way we want to log the error. If the currently present +-- ones are insufficient for the needs of your plugin, please feel free to add +-- a new one. +-- Currently the PluginErrors we provide can be broken up into several groups. +-- First is PluginInternalError, which is the most serious of the errors, and +-- also the "default" error that is used for things such as uncaught exceptions. +-- Then we have PluginInvalidRequest, PluginInvalidParams, and PluginParseError. +-- All three of these along with PluginInternalError are treated individually +-- and map to a corresponding ResponseError. +-- Next we have PluginRuleFailed and PluginDependencyFailed, with the only +-- difference being PluginRuleFailed is specific to Shake rules and +-- PluginDependencyFailed can be used for everything else. Both of these are +-- "non-errors", and happen whenever the user's code is in a state where the +-- plugin is unable to provide a answer to the users request. PluginStaleResolve +-- is similar to the above two Error types, but is specific to resolve plugins, +-- and is used only when the data provided by the resolve request is stale, +-- preventing the proper resolution of it. +-- Finally we have the outlier, PluginRequestRefused, where we allow a handler +-- to preform "pluginEnabled" checks inside the handler, and reject the request +-- after viewing it. The behavior of only one handler passing `pluginEnabled` +-- and then returning PluginRequestRefused should be the same as if no plugins +-- passed the `pluginEnabled` stage. +-} From 9b539d9fdde7247475d3047a0c8d84bf161191a9 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 27 Jul 2023 17:52:07 +0000 Subject: [PATCH 10/28] address michaelpj's suggestions (1/n) --- .../src/Development/IDE/Core/PluginUtils.hs | 4 +- .../Development/IDE/LSP/HoverDefinition.hs | 24 +-- ghcide/src/Development/IDE/LSP/Outline.hs | 15 +- .../src/Development/IDE/Plugin/Completions.hs | 5 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 110 ++----------- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 13 +- ghcide/src/Development/IDE/Plugin/Test.hs | 10 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 2 +- hls-plugin-api/hls-plugin-api.cabal | 1 + hls-plugin-api/src/Ide/Plugin/Error.hs | 155 ++++++++---------- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 49 +++--- hls-plugin-api/src/Ide/Types.hs | 47 +++--- .../src/Ide/Plugin/AlternateNumberFormat.hs | 2 +- .../hls-cabal-fmt-plugin.cabal | 1 + .../src/Ide/Plugin/CabalFmt.hs | 26 +-- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 4 +- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 6 +- .../src/Ide/Plugin/ChangeTypeSignature.hs | 5 +- .../hls-class-plugin/hls-class-plugin.cabal | 1 + .../src/Ide/Plugin/Class/CodeAction.hs | 6 +- .../src/Ide/Plugin/Class/CodeLens.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 23 +-- .../src/Ide/Plugin/Eval/CodeLens.hs | 2 +- .../src/Ide/Plugin/Eval/Util.hs | 8 +- .../src/Ide/Plugin/ExplicitFixity.hs | 2 +- .../hls-explicit-imports-plugin.cabal | 1 + .../src/Ide/Plugin/ExplicitImports.hs | 15 +- .../src/Ide/Plugin/ExplicitFields.hs | 3 +- .../hls-floskell-plugin.cabal | 1 + .../src/Ide/Plugin/Floskell.hs | 9 +- .../hls-fourmolu-plugin.cabal | 1 + .../src/Ide/Plugin/Fourmolu.hs | 100 +++++------ .../hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 23 +-- .../src/Ide/Plugin/HaddockComments.hs | 2 +- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 1 + .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 17 +- .../src/Ide/Plugin/ModuleName.hs | 60 +++---- .../hls-ormolu-plugin/hls-ormolu-plugin.cabal | 2 + .../src/Ide/Plugin/Ormolu.hs | 24 ++- .../src/Ide/Plugin/OverloadedRecordDot.hs | 70 ++++---- .../src/Ide/Plugin/Pragmas.hs | 37 ++--- .../hls-qualify-imported-names-plugin.cabal | 1 + .../src/Ide/Plugin/QualifyImportedNames.hs | 54 +++--- .../src/Development/IDE/Plugin/CodeAction.hs | 5 +- .../Development/IDE/Plugin/CodeAction/Args.hs | 4 +- .../src/Ide/Plugin/RefineImports.hs | 14 +- .../hls-rename-plugin/hls-rename-plugin.cabal | 1 + .../src/Ide/Plugin/Rename.hs | 12 +- .../hls-retrie-plugin/hls-retrie-plugin.cabal | 1 + .../src/Ide/Plugin/Retrie.hs | 18 +- .../hls-splice-plugin/hls-splice-plugin.cabal | 1 + .../src/Ide/Plugin/Splice.hs | 10 +- .../hls-stylish-haskell-plugin.cabal | 1 + .../src/Ide/Plugin/StylishHaskell.hs | 27 +-- .../old/src/Wingman/AbstractLSP.hs | 12 +- .../src/Wingman/LanguageServer/Metaprogram.hs | 31 ++-- 56 files changed, 479 insertions(+), 602 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index 898ba3026b..9cf4897a0f 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -29,13 +29,13 @@ import qualified Language.LSP.Protocol.Types as LSP -- |ExceptT version of `runAction`, takes a ExceptT Action runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a runActionE herald ide act = - hoistExceptT . ExceptT $ + mapExceptT liftIO . ExceptT $ join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act) -- |MaybeT version of `runAction`, takes a MaybeT Action runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a runActionMT herald ide act = - hoistMaybeT . MaybeT $ + mapMaybeT liftIO . MaybeT $ join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act) -- |ExceptT version of `use` that throws a PluginRuleFailed upon failure diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 7ba4aaf3b9..3a10b7c26e 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -15,6 +15,7 @@ module Development.IDE.LSP.HoverDefinition , wsSymbols ) where +import Control.Monad.Except (ExceptT) import Control.Monad.IO.Class import Data.Maybe (fromMaybe) import Development.IDE.Core.Actions @@ -23,33 +24,34 @@ import Development.IDE.Core.Shake import Development.IDE.Types.Location import Ide.Logger import Ide.Plugin.Error +import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either PluginError (MessageResult Method_TextDocumentDefinition)) -hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either PluginError (Hover |? Null)) -gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either PluginError (MessageResult Method_TextDocumentTypeDefinition)) -documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either PluginError ([DocumentHighlight] |? Null)) +gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition) +hover :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition) +documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null) gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either PluginError ([Location] |? Null)) -references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = runExceptT $ do +references :: PluginMethodHandler IdeState 'Method_TextDocumentReferences +references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do nfp <- getNormalizedFilePathE uri liftIO $ logDebug (ideLogger ide) $ "References request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack (show nfp) InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either PluginError [SymbolInformation]) -wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do +wsSymbols :: PluginMethodHandler IdeState 'Method_WorkspaceSymbol +wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do logDebug (ideLogger ide) $ "Workspace symbols request: " <> query - runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . fromMaybe [] <$> workspaceSymbols query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null foundHover (mbRange, contents) = @@ -63,12 +65,12 @@ request -> (a -> b) -> IdeState -> TextDocumentPositionParams - -> LSP.LspM c (Either PluginError b) + -> ExceptT PluginError (LSP.LspM c) b request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest label getResults ide pos path Nothing -> pure Nothing - pure $ Right $ maybe notFound found mbResult + pure $ maybe notFound found mbResult logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index c15278b079..77e622dfe2 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -22,25 +22,24 @@ import Development.IDE.GHC.Error (rangeToRealSrcSpan, realSrcSpanToRange) import Development.IDE.Types.Location import Development.IDE.GHC.Util (printOutputable) -import Ide.Plugin.Error -import Language.LSP.Server (LspM) +import Ide.Types import Language.LSP.Protocol.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), - SymbolInformation, SymbolKind (..), TextDocumentIdentifier (TextDocumentIdentifier), - type (|?) (InL, InR), uriToFilePath, Null) + type (|?) (InL, InR), uriToFilePath) +import Language.LSP.Protocol.Message #if MIN_VERSION_ghc(9,2,0) import Data.List.NonEmpty (nonEmpty) #endif moduleOutline - :: IdeState -> DocumentSymbolParams -> LspM c (Either PluginError ([SymbolInformation] |? ([DocumentSymbol] |? Null))) -moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } + :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol +moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) - pure $ Right $ case mb_decls of + pure $ case mb_decls of Nothing -> InL [] Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } -> let @@ -66,7 +65,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif InR (InL allSymbols) - Nothing -> pure $ Right $ InL [] + Nothing -> pure $ InL [] documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index df899e055e..c5d17912e7 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -12,6 +12,7 @@ module Development.IDE.Plugin.Completions import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) import Control.Lens ((&), (.~)) +import Control.Monad.Except (ExceptT (ExceptT)) import Control.Monad.IO.Class import Data.Aeson import qualified Data.HashMap.Strict as Map @@ -123,7 +124,7 @@ dropListFromImportDecl iDecl = let resolveCompletion :: ResolveFunction IdeState CompletionResolveData 'Method_CompletionItemResolve resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) = - runExceptT $ do + do file <- getNormalizedFilePathE uri (sess,_) <- withExceptT (const PluginStaleResolve) $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide) @@ -164,7 +165,7 @@ getCompletionsLSP :: PluginMethodHandler IdeState 'Method_TextDocumentCompletion getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position - ,_context=completionContext} = do + ,_context=completionContext} = ExceptT $ do contents <- LSP.getVirtualFile $ toNormalizedUri uri fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 205403ed6a..65ea6f4aa8 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -54,9 +54,6 @@ import UnliftIO.Exception (catchAny) data Log = LogPluginError PluginId PluginError | LogResponseError PluginId ResponseError - | LogDependencyFailed (NE.NonEmpty (T.Text, NE.NonEmpty PluginId)) - | LogRequestRefused (NE.NonEmpty PluginId) - | LogRuleFailed (NE.NonEmpty (T.Text, NE.NonEmpty PluginId)) | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier | ExceptionInPlugin PluginId (Some SMethod) SomeException @@ -73,18 +70,6 @@ instance Pretty Log where ExceptionInPlugin plId (Some method) exception -> "Exception in plugin " <> viaShow plId <> " while processing " <> viaShow method <> ": " <> viaShow exception - LogDependencyFailed (toList -> xs) -> - let prettyDep (plId, (toList -> xs)) = pretty plId <> ":" <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) - in "The following dependencies and their dependent plugins failed:" - <+> hsep (punctuate semi (prettyDep <$> xs)) - LogRequestRefused (toList -> xs) -> - "Handlers from the following plugins refused requests:" - <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) - LogRuleFailed (toList -> xs) -> - let prettyRule (plId, (toList -> xs)) = pretty plId <> ":" <+> hsep (punctuate comma (pretty . unwrapPlId <$> xs)) - in "The following rules and their dependent plugins failed:" - <+> hsep (punctuate semi (prettyRule <$> xs)) - where unwrapPlId (PluginId plId) = plId instance Show Log where show = renderString . layoutCompact . pretty -- various error message specific builders @@ -96,7 +81,7 @@ prettyResponseError err = errorCode <> ":" <+> errorBody pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text pluginNotEnabled method availPlugins = - "No plugin enabled for " <> T.pack (show method) <> ", Potentially available: " + "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins) pluginDoesntExist :: PluginId -> Text @@ -265,8 +250,8 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } liftIO $ unless (null errs) $ logErrors recorder errs case nonEmpty succs of Nothing -> do - let noRefused (_, PluginRequestRefused) = False - noRefused (_, _) = True + let noRefused (_, PluginRequestRefused _) = False + noRefused (_, _) = True filteredErrs = filter noRefused errs case nonEmpty filteredErrs of Nothing -> liftIO $ noPluginEnabled m fs' @@ -276,7 +261,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c) noPluginEnabled m fs' = do logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing + let err = ResponseError (InR ErrorCodes_InvalidParams) msg Nothing msg = pluginNotEnabled m fs' return $ Left err @@ -325,94 +310,21 @@ runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedPro combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError combineErrors (x NE.:| []) = toResponseError x -combineErrors (toList -> xs) = - case filter (isPrecedence1 . snd) xs of - (x: _) -> toResponseError x - _ -> case filter (isPrecedence2 . snd) xs of - (x: _) -> toResponseError x - _ -> case filter (isPrecedence3 . snd) xs of - (x: _) -> toResponseError x - _ -> ResponseError (InR ErrorCodes_InternalError) "Something impossible happened: No error left to return" Nothing - where isPrecedence1 :: PluginError -> Bool - isPrecedence1 (PluginInternalError _) = True - isPrecedence1 _ = False - isPrecedence2 :: PluginError -> Bool - isPrecedence2 (PluginInvalidRequest _) = True - isPrecedence2 (PluginInvalidParams _) = True - isPrecedence2 (PluginParseError _) = True - isPrecedence2 _ = False - isPrecedence3 :: PluginError -> Bool - isPrecedence3 (PluginDependencyFailed _) = True - isPrecedence3 (PluginRuleFailed _) = True - isPrecedence3 PluginStaleResolve = True - isPrecedence3 _ = False - - +combineErrors xs = + case NE.sortWith (toPriority . snd) xs of + (x NE.:| _) -> toResponseError x toResponseError :: (PluginId, PluginError) -> ResponseError -toResponseError = \case - (PluginId plId, err@(PluginInternalError _)) -> - ResponseError (InR ErrorCodes_InternalError) (plId <> ": " <> tPretty err) Nothing - (PluginId plId, err@(PluginInvalidParams _)) -> - ResponseError (InR ErrorCodes_InvalidParams) (plId <> ": " <> tPretty err) Nothing - (PluginId plId, err@(PluginInvalidRequest _)) -> - ResponseError (InR ErrorCodes_InvalidRequest) (plId <> ": " <> tPretty err) Nothing - (PluginId plId, err@(PluginParseError _)) -> - ResponseError (InR ErrorCodes_ParseError) (plId <> ": " <> tPretty err) Nothing - (PluginId plId, err@(PluginDependencyFailed _)) -> - ResponseError (InL LSPErrorCodes_ContentModified) (plId <> ": " <> tPretty err) Nothing - -- PluginRequestRefused should never be a argument to `toResponseError`, as - -- it should be dealt with in `extensiblePlugins`, but this is here to make - -- this function complete - (PluginId plId, err@PluginRequestRefused) -> - ResponseError (InR ErrorCodes_InvalidRequest) (plId <> ": " <> tPretty err) Nothing - (PluginId plId, err@(PluginRuleFailed _)) -> - ResponseError (InL LSPErrorCodes_ContentModified) (plId <> ": " <> tPretty err) Nothing - (PluginId plId, err@PluginStaleResolve) -> - ResponseError (InL LSPErrorCodes_ContentModified) (plId <> ": " <> tPretty err) Nothing +toResponseError (PluginId plId, err) = + ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing where tPretty = T.pack . show . pretty logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO () logErrors recorder errs = do forM_ errs $ \(pId, err) -> logIndividualErrors pId err - logDependencyFailed errs - logRequestRefused errs - logRuleFailed errs - where logIndividualErrors plId err@(PluginInternalError _) = - logWith recorder Error $ LogPluginError plId err - logIndividualErrors plId err@(PluginInvalidParams _) = - logWith recorder Warning $ LogPluginError plId err - logIndividualErrors plId err@(PluginInvalidRequest _) = - logWith recorder Warning $ LogPluginError plId err - logIndividualErrors plId err@(PluginParseError _) = - logWith recorder Warning $ LogPluginError plId err - logIndividualErrors plId err@PluginStaleResolve = - logWith recorder Info $ LogPluginError plId err - logIndividualErrors _ _ = pure () - logDependencyFailed errs = do - let pmfErrs = [(plId, dep) - | (plId, PluginDependencyFailed dep) <- errs] - case groupBySnd pmfErrs of - Nothing -> pure () - Just xs -> logWith recorder Info $ LogDependencyFailed xs - logRequestRefused errs = do - let rrErrs = [plId - | (plId, PluginRequestRefused) <- errs] - case nonEmpty rrErrs of - Nothing -> pure () - Just xs -> logWith recorder Info $ LogRequestRefused xs - logRuleFailed errs = do - let rfErrs = [(plId, rule) - | (plId, PluginRuleFailed rule) <- errs] - case groupBySnd rfErrs of - Nothing -> pure () - Just xs -> logWith recorder Info $ LogRuleFailed xs - -- gives us the list of plugins that failed for each rule/dependency - groupBySnd :: [(PluginId, T.Text)] -> Maybe (NonEmpty (T.Text, NonEmpty PluginId)) - groupBySnd errs = - let setify xs@(x NE.:| _) = (snd x, fst <$> xs) - in fmap setify <$> nonEmpty (NE.groupAllWith snd errs) + where logIndividualErrors plId err = + logWith recorder (toPriority err) $ LogPluginError plId err -- | Combine the 'PluginHandler' for all plugins diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index d0b95c2109..1c1cb8c5b2 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -17,7 +17,6 @@ import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server (LspM) import Text.Regex.TDFA.Text () data Log @@ -45,15 +44,15 @@ descriptors recorder = descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover' - <> mkPluginHandler SMethod_TextDocumentDocumentSymbol symbolsProvider + <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> gotoDefinition ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> gotoTypeDefinition ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentReferences (\ide _ params -> references ide params) - <> mkPluginHandler SMethod_WorkspaceSymbol (\ide _ params -> fmap InL <$> wsSymbols ide params), + <> mkPluginHandler SMethod_TextDocumentReferences references + <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols, pluginConfigDescriptor = defaultConfigDescriptor } @@ -64,9 +63,3 @@ hover' :: PluginMethodHandler IdeState 'Method_TextDocumentHover hover' ideState _ HoverParams{..} = do liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ hover ideState TextDocumentPositionParams{..} - --- --------------------------------------------------------------------- -symbolsProvider :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol -symbolsProvider ide _ params = moduleOutline ide params - --- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 9952f336a1..c6d8de705e 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -14,6 +14,7 @@ module Development.IDE.Plugin.Test import Control.Concurrent (threadDelay) import Control.Monad +import Control.Monad.Except (ExceptT (..), throwError) import Control.Monad.IO.Class import Control.Monad.STM import Data.Aeson (FromJSON (parseJSON), @@ -46,7 +47,6 @@ import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) import Ide.Plugin.Config (CheckParents) import Ide.Plugin.Error -import Ide.Plugin.Error (PluginError (PluginInvalidRequest)) import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -84,10 +84,10 @@ plugin = (defaultPluginDescriptor "test") { where testRequestHandler' ide req | Just customReq <- A.parseMaybe parseJSON req - = testRequestHandler ide customReq + = ExceptT $ testRequestHandler ide customReq | otherwise - = return $ Left - $ PluginInvalidRequest "Cannot parse request" + = throwError + $ PluginInvalidParams "Cannot parse request" testRequestHandler :: IdeState @@ -115,7 +115,7 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp let res = WaitForIdeRuleResult <$> success - return $ bimap PluginInvalidRequest toJSON res + return $ bimap PluginInvalidParams toJSON res testRequestHandler s GetBuildKeysBuilt = liftIO $ do keys <- getDatabaseKeys resultBuilt $ shakeDb s return $ Right $ toJSON $ map show keys diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 7fc5282ab8..56e18fc08b 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -105,7 +105,7 @@ properties = emptyProperties ] Always codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = runExceptT $ do +codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties nfp <- getNormalizedFilePathE uri env <- hscEnv . fst <$> diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 7717b46788..636c2f921a 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -63,6 +63,7 @@ library , lens , lens-aeson , lsp ^>=2.0.0.0 + , mtl , opentelemetry >=0.4 , optparse-applicative , prettyprinter diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index c2c386906d..2db08af463 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -4,71 +4,69 @@ module Ide.Plugin.Error ( -- * Plugin Error Handling API PluginError(..), + toErrorCode, + toPriority, runExceptT, withExceptT, - pluginResponseM, - hoistExceptT, - hoistMaybeT, handleMaybe, handleMaybeM, getNormalizedFilePathE, ) where import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, - runExceptT, throwE, withExceptT) -import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE, + withExceptT) import qualified Data.Text as T +import Ide.Logger import Language.LSP.Protocol.Types -import Prettyprinter -- ---------------------------------------------------------------------------- -- Plugin Error wrapping -- ---------------------------------------------------------------------------- -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 - --- See Note [PluginError] +-- |Each PluginError corresponds to either a specific ResponseError we want to +-- return or a specific way we want to log the error. If the currently present +-- ones are insufficient for the needs of your plugin, please feel free to add +-- a new one. +-- +-- Currently the PluginErrors we provide can be broken up into several groups. +-- First is PluginInternalError, which is the most serious of the errors, and +-- also the "default" error that is used for things such as uncaught exceptions. +-- Then we have PluginInvalidParams, which along with PluginInternalError map +-- to a corresponding ResponseError. +-- +-- Next we have PluginRuleFailed and PluginDependencyFailed, with the only +-- difference being PluginRuleFailed is specific to Shake rules and +-- PluginDependencyFailed can be used for everything else. Both of these are +-- "non-errors", and happen whenever the user's code is in a state where the +-- plugin is unable to provide a answer to the users request. PluginStaleResolve +-- is similar to the above two Error types, but is specific to resolve plugins, +-- and is used only when the data provided by the resolve request is stale, +-- preventing the proper resolution of it. +-- +-- Finally we have the outlier, PluginRequestRefused, where we allow a handler +-- to preform "pluginEnabled" checks inside the handler, and reject the request +-- after viewing it. The behavior of only one handler passing `pluginEnabled` +-- and then returning PluginRequestRefused should be the same as if no plugins +-- passed the `pluginEnabled` stage. data PluginError = -- |PluginInternalError should be used if something has gone horribly wrong. -- All uncaught exceptions will be caught and converted to this error. -- - -- This error will be logged individually with Error, and will be converted - -- into an InternalError response code. It takes the highest precedence (1) - -- in being returned as a response to the client. + -- This error will be be converted into an InternalError response code. It + -- takes the highest precedence (1) in being returned as a response to the + -- client. PluginInternalError T.Text -- |PluginInvalidParams should be used if the parameters of the request are -- invalid. This error means that there is a bug in the client's code -- (otherwise they wouldn't be sending you requests with invalid -- parameters). -- - -- This error will be logged individually with Warning, and will be - -- converted into a InvalidParams response code. It takes medium precedence - -- (2)in being returned as a response to the client. - | PluginInvalidParams T.Text - -- |PluginInvalidRequest should be used if the request is invalid. This - -- error means that there is a bug in the client's code (otherwise they - -- wouldn't be sending you an invalid request). - -- - -- This error will be logged individually with Warning, and will be - -- converted into a InvalidRequest response code. It takes medium precedence - -- (2) in being returned as a response to the client. - | PluginInvalidRequest T.Text - -- |PluginParseError should be used sparingly for parse errors. Prefer to - -- use PluginInternalError for bugs in the plugin's code, or - -- PluginInvalidRequest/PluginInvalidParams for invalid requests from the + -- This error will be will be converted into a InvalidParams response code. + -- It takes medium precedence (2) in being returned as a response to the -- client. - -- - -- This error will be logged individually with Warning, and will be - -- converted into a ParseError response code. It takes a medium precedence - -- (2) in being returned as a response to the client. - | PluginParseError T.Text + | PluginInvalidParams T.Text -- |PluginDependencyFailed should be thrown when a function that your plugin -- depends on fails. This should only be used when the function fails -- because the files the user is working on is in an invalid state. @@ -76,9 +74,9 @@ data PluginError -- This error takes the name of the function that failed. Prefer to catch -- this error as close to the source as possible. -- - -- This error will be logged together with other errors of the same type - -- with Info, and will be converted into a ContentModified response. It - -- takes a low precedence (3) in being returned as a response to the client. + -- This error will be logged with Debug, and will be converted into a + -- ContentModified response. It takes a low precedence (3) in being returned + -- as a response to the client. | PluginDependencyFailed T.Text -- |PluginRequestRefused allows your handler to inspect a request before -- rejecting it. In effect it allows your plugin to act make a secondary @@ -86,25 +84,24 @@ data PluginError -- used if the decision to accept the request can not be made in -- `pluginEnabled`. -- - -- This error will be logged together with other errors of the same type - -- with Info. If it's the only response to a request, HLS will respond as if - -- no plugins passed the `pluginEnabled` stage. - | PluginRequestRefused + -- This error will be with Debug. If it's the only response to a request, + -- HLS will respond as if no plugins passed the `pluginEnabled` stage. + | PluginRequestRefused T.Text -- |PluginRuleFailed should be thrown when a Rule your response depends on -- fails. -- -- This error takes the name of the Rule that failed. -- - -- This error will be logged together with other errors of the same type - -- with Info, and will be converted into a ContentModified response code. It - -- takes a low precedence (3) in being returned as a response to the client. + -- This error will be logged with Debug, and will be converted into a + -- ContentModified response code. It takes a low precedence (3) in being + -- returned as a response to the client. | PluginRuleFailed T.Text -- |PluginStaleResolve should be thrown when your resolve request is -- provided with data it can no longer resolve. -- - -- This error will be logged individually with Info, and will be converted - -- into a ContentModified response. It takes a low precedence (3) in being - -- returned as a response to the client. + -- This error will be logged with Debug, and will be converted into a + -- ContentModified response. It takes a low precedence (3) in being returned + -- as a response to the client. | PluginStaleResolve instance Pretty PluginError where @@ -113,10 +110,27 @@ instance Pretty PluginError where PluginStaleResolve -> "Stale Resolve" PluginRuleFailed rule -> "Rule Failed:" <+> pretty rule PluginInvalidParams text -> "Invalid Params:" <+> pretty text - PluginParseError text -> "Parse Error:" <+> pretty text - PluginInvalidRequest text -> "Invalid Request:" <+> pretty text PluginDependencyFailed text -> "Dependency Failed:" <+> pretty text - PluginRequestRefused -> "Request Refused" + PluginRequestRefused msg -> "Request Refused: " <+> pretty msg + +toErrorCode :: PluginError -> (LSPErrorCodes |? ErrorCodes) +toErrorCode (PluginInternalError _) = InR ErrorCodes_InternalError +toErrorCode (PluginInvalidParams _) = InR ErrorCodes_InvalidParams +toErrorCode (PluginDependencyFailed _) = InL LSPErrorCodes_ContentModified +-- PluginRequestRefused should never be a argument to `toResponseError`, as +-- it should be dealt with in `extensiblePlugins`, but this is here to make +-- this function complete +toErrorCode (PluginRequestRefused _) = InR ErrorCodes_MethodNotFound +toErrorCode (PluginRuleFailed _) = InL LSPErrorCodes_ContentModified +toErrorCode PluginStaleResolve = InL LSPErrorCodes_ContentModified + +toPriority :: PluginError -> Priority +toPriority (PluginInternalError _) = Error +toPriority (PluginInvalidParams _) = Warning +toPriority (PluginDependencyFailed _) = Debug +toPriority (PluginRequestRefused _) = Debug +toPriority (PluginRuleFailed _) = Debug +toPriority PluginStaleResolve = Debug handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return @@ -124,40 +138,7 @@ 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 -hoistExceptT :: MonadIO m => ExceptT e IO a -> ExceptT e m a -hoistExceptT = mapExceptT liftIO - -hoistMaybeT :: MonadIO m => MaybeT IO a -> MaybeT m a -hoistMaybeT = mapMaybeT liftIO - getNormalizedFilePathE :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath getNormalizedFilePathE uri = handleMaybe (PluginInvalidParams (T.pack $ "uriToNormalizedFile failed. Uri:" <> show uri)) $ uriToNormalizedFilePath $ toNormalizedUri uri - --- --------------------------------------------------------------------- -{- Note [PluginError] --- Each PluginError corresponds to either a specific ResponseError we want to --- return or a specific way we want to log the error. If the currently present --- ones are insufficient for the needs of your plugin, please feel free to add --- a new one. --- Currently the PluginErrors we provide can be broken up into several groups. --- First is PluginInternalError, which is the most serious of the errors, and --- also the "default" error that is used for things such as uncaught exceptions. --- Then we have PluginInvalidRequest, PluginInvalidParams, and PluginParseError. --- All three of these along with PluginInternalError are treated individually --- and map to a corresponding ResponseError. --- Next we have PluginRuleFailed and PluginDependencyFailed, with the only --- difference being PluginRuleFailed is specific to Shake rules and --- PluginDependencyFailed can be used for everything else. Both of these are --- "non-errors", and happen whenever the user's code is in a state where the --- plugin is unable to provide a answer to the users request. PluginStaleResolve --- is similar to the above two Error types, but is specific to resolve plugins, --- and is used only when the data provided by the resolve request is stale, --- preventing the proper resolution of it. --- Finally we have the outlier, PluginRequestRefused, where we allow a handler --- to preform "pluginEnabled" checks inside the handler, and reject the request --- after viewing it. The behavior of only one handler passing `pluginEnabled` --- and then returning PluginRequestRefused should be the same as if no plugins --- passed the `pluginEnabled` stage. --} diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 6287f589a7..d8fd731e63 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -12,9 +12,8 @@ mkCodeActionWithResolveAndCommand) where import Control.Lens (_Just, (&), (.~), (?~), (^.), (^?)) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT, - throwE) +import Control.Monad.Except + import qualified Data.Aeson as A import Data.Maybe (catMaybes) import Data.Row ((.!)) @@ -26,7 +25,7 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server (LspM, LspT, +import Language.LSP.Server (LspT, ProgressCancellable (Cancellable), getClientCapabilities, sendRequest, @@ -50,12 +49,12 @@ instance Pretty Log where mkCodeActionHandlerWithResolve :: forall ideState a. (A.FromJSON a) => Recorder (WithPriority Log) - -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either PluginError ([Command |? CodeAction] |? Null))) - -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either PluginError CodeAction)) + -> PluginMethodHandler ideState 'Method_TextDocumentCodeAction + -> ResolveFunction ideState a 'Method_CodeActionResolve -> PluginHandlers ideState mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod = - let newCodeActionMethod ideState pid params = runExceptT $ - do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params + let newCodeActionMethod ideState pid params = + do codeActionReturn <- codeActionMethod ideState pid params caps <- lift getClientCapabilities case codeActionReturn of r@(InR Null) -> pure r @@ -74,14 +73,14 @@ mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod = resolveCodeAction _uri _ideState _plId c@(InL _) = pure c resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do case A.fromJSON value of - A.Error err -> throwE $ parseError (Just value) (T.pack err) + A.Error err -> throwError $ parseError (Just value) (T.pack err) A.Success innerValueDecoded -> do - resolveResult <- ExceptT $ codeResolveMethod ideState pid codeAction uri innerValueDecoded + resolveResult <- codeResolveMethod ideState pid codeAction uri innerValueDecoded case resolveResult of CodeAction {_edit = Just _ } -> do pure $ InR $ dropData resolveResult - _ -> throwE $ invalidParamsError "Returned CodeAction has no data field" - resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwE $ invalidParamsError "CodeAction has no data field" + _ -> throwError $ invalidParamsError "Returned CodeAction has no data field" + resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwError $ invalidParamsError "CodeAction has no data field" -- |When provided with both a codeAction provider with a data field and a resolve @@ -95,12 +94,12 @@ mkCodeActionWithResolveAndCommand :: forall ideState a. (A.FromJSON a) => Recorder (WithPriority Log) -> PluginId - -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either PluginError ([Command |? CodeAction] |? Null))) - -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either PluginError CodeAction)) + -> PluginMethodHandler ideState 'Method_TextDocumentCodeAction + -> ResolveFunction ideState a 'Method_CodeActionResolve -> ([PluginCommand ideState], PluginHandlers ideState) mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod = - let newCodeActionMethod ideState pid params = runExceptT $ - do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params + let newCodeActionMethod ideState pid params = + do codeActionReturn <- codeActionMethod ideState pid params caps <- lift getClientCapabilities case codeActionReturn of r@(InR Null) -> pure r @@ -130,26 +129,26 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMeth wrapWithURI uri codeAction = codeAction & L.data_ .~ (A.toJSON .WithURI uri <$> data_) where data_ = codeAction ^? L.data_ . _Just - executeResolveCmd :: (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either PluginError CodeAction))-> CommandFunction ideState CodeAction + executeResolveCmd :: ResolveFunction ideState a 'Method_CodeActionResolve -> CommandFunction ideState CodeAction executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do case A.fromJSON value of - A.Error err -> throwE $ parseError (Just value) (T.pack err) + A.Error err -> throwError $ parseError (Just value) (T.pack err) A.Success (WithURI uri innerValue) -> do case A.fromJSON innerValue of - A.Error err -> throwE $ parseError (Just value) (T.pack err) + A.Error err -> throwError $ parseError (Just value) (T.pack err) A.Success innerValueDecoded -> do - resolveResult <- ExceptT $ resolveProvider ideState plId ca uri innerValueDecoded + resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded case resolveResult of ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback pure $ InR Null ca2@CodeAction {_edit = Just _ } -> - throwE $ internalError $ + throwError $ internalError $ "The resolve provider unexpectedly returned a code action with the following differing fields: " <> (T.pack $ show $ diffCodeActions ca ca2) - _ -> throwE $ internalError "The resolve provider unexpectedly returned a result with no data field" - executeResolveCmd _ _ CodeAction{_data_= value} = runExceptT $ throwE $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) + _ -> throwError $ internalError "The resolve provider unexpectedly returned a result with no data field" + executeResolveCmd _ _ CodeAction{_data_= value} = runExceptT $ throwError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) handleWEditCallback (Left err ) = do logWith recorder Warning (ApplyWorkspaceEditFailed err) pure () @@ -189,13 +188,13 @@ supportsCodeActionResolve caps = _ -> False internalError :: T.Text -> PluginError -internalError msg = PluginInternalError ("Ide.Plugin.Resolve: Internal Error : " <> msg) +internalError msg = PluginInternalError ("Ide.Plugin.Resolve: " <> msg) invalidParamsError :: T.Text -> PluginError invalidParamsError msg = PluginInvalidParams ("Ide.Plugin.Resolve: : " <> msg) parseError :: Maybe A.Value -> T.Text -> PluginError -parseError value errMsg = PluginParseError ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) +parseError value errMsg = PluginInternalError ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) {- Note [Code action resolve fallback to commands] To make supporting code action resolve easy for plugins, we want to let them diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 57c7c01d6a..65faae6621 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -57,12 +57,14 @@ module Ide.Types import qualified System.Win32.Process as P (getCurrentProcessId) #else import Control.Monad (void) +import Control.Monad.Except (lift, throwError) import qualified System.Posix.Process as P (getProcessID) import System.Posix.Signals #endif import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Lens (_Just, (.~), (?~), (^.), (^?)) +import Control.Monad.Trans.Except (ExceptT) import Data.Aeson hiding (Null, defaultOptions) import Data.Default import Data.Dependent.Map (DMap) @@ -776,7 +778,7 @@ instance Semigroup (PluginNotificationHandlers a) where instance Monoid (PluginNotificationHandlers a) where mempty = PluginNotificationHandlers mempty -type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either PluginError (MessageResult m)) +type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (LspM Config) (MessageResult m) type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () @@ -793,14 +795,14 @@ mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandl -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions -- CodeLens, and Completion methods. f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} = - pure . fmap (wrapCodeActions pid _uri) <$> f ide pid params + pure . fmap (wrapCodeActions pid _uri) <$> runExceptT (f ide pid params) f' SMethod_TextDocumentCodeLens pid ide params@CodeLensParams{_textDocument=TextDocumentIdentifier {_uri}} = - pure . fmap (wrapCodeLenses pid _uri) <$> f ide pid params + pure . fmap (wrapCodeLenses pid _uri) <$> runExceptT (f ide pid params) f' SMethod_TextDocumentCompletion pid ide params@CompletionParams{_textDocument=TextDocumentIdentifier {_uri}} = - pure . fmap (wrapCompletions pid _uri) <$> f ide pid params + pure . fmap (wrapCompletions pid _uri) <$> runExceptT (f ide pid params) -- This is the default case for all other methods - f' _ pid ide params = pure <$> f ide pid params + f' _ pid ide params = pure <$> runExceptT (f ide pid params) -- Todo: use fancy pancy lenses to make this a few lines wrapCodeActions pid uri (InL ls) = @@ -900,19 +902,14 @@ type ResolveFunction ideState a (m :: Method ClientToServer Request) = -> MessageParams m -> Uri -> a - -> LspM Config (Either PluginError (MessageResult m)) + -> ExceptT PluginError (LspM Config) (MessageResult m) -- | Make a handler for resolve methods. In here we take your provided ResolveFunction -- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers] mkResolveHandler :: forall ideState a m. (FromJSON a, PluginRequestMethod m, L.HasData_ (MessageParams m) (Maybe Value)) => SClientMethod m - -> (ideState - ->PluginId - -> MessageParams m - -> Uri - -> a - -> LspM Config (Either PluginError (MessageResult m))) + -> ResolveFunction ideState a m -> PluginHandlers ideState mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do case fromJSON <$> (params ^. L.data_) of @@ -923,11 +920,19 @@ mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do Success decodedValue -> let newParams = params & L.data_ ?~ value in f ideState plId newParams uri decodedValue - Error err -> - pure $ Left $ PluginParseError (parseError value err) - else pure $ Left $ PluginInternalError invalidRequest - (Just (Error err)) -> pure $ Left $ PluginParseError (parseError (params ^. L.data_) err) - _ -> pure $ Left $ PluginInternalError invalidRequest + Error msg -> + -- We are assuming that if we can't decode the data, that this + -- request belongs to another resolve handler for this plugin. + throwError (PluginRequestRefused (T.pack ("Unable to decode payload for handler, assuming that it's for a different handler" <> msg))) + -- If we are getting an owner that isn't us, this means that there is an + -- error, as we filter these our in `pluginEnabled` + else throwError $ PluginInternalError invalidRequest + -- If we are getting params without a decodable data field, this means that + -- there is an error, as we filter these our in `pluginEnabled` + (Just (Error err)) -> throwError $ PluginInternalError (parseError (params ^. L.data_) err) + -- If there are no params at all, this also means that there is an error, + -- as this is filtered out in `pluginEnabled` + _ -> throwError $ PluginInternalError invalidRequest where invalidRequest = "The resolve request incorrectly got routed to the wrong resolve handler!" parseError value err = "Unable to decode: " <> (T.pack $ show value) <> ". Error: " <> (T.pack $ show err) @@ -986,7 +991,7 @@ type FormattingHandler a -> T.Text -> NormalizedFilePath -> FormattingOptions - -> LspM Config (Either PluginError ([TextEdit] |? Null)) + -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null) mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting) @@ -995,7 +1000,7 @@ mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provid provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m provider m ide _pid params | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do - mf <- getVirtualFile $ toNormalizedUri uri + mf <- lift $ getVirtualFile $ toNormalizedUri uri case mf of Just vf -> do let typ = case m of @@ -1003,9 +1008,9 @@ mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provid SMethod_TextDocumentRangeFormatting -> FormatRange (params ^. L.range) _ -> Prelude.error "mkFormattingHandlers: impossible" f ide typ (virtualFileText vf) nfp opts - Nothing -> pure $ Left $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri - | otherwise = pure $ Left $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri where uri = params ^. L.textDocument . L.uri opts = params ^. L.options 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 7472554611..3986ad835b 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 @@ -83,7 +83,7 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec pure ([], CLR <$> litMap <*> exts) codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = runExceptT $ do +codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = do nfp <- getNormalizedFilePathE (docId ^. L.uri) CLR{..} <- requestLiterals pId state nfp pragma <- getFirstPragma pId state nfp diff --git a/plugins/hls-cabal-fmt-plugin/hls-cabal-fmt-plugin.cabal b/plugins/hls-cabal-fmt-plugin/hls-cabal-fmt-plugin.cabal index bf55ec31ad..fe47b12089 100644 --- a/plugins/hls-cabal-fmt-plugin/hls-cabal-fmt-plugin.cabal +++ b/plugins/hls-cabal-fmt-plugin/hls-cabal-fmt-plugin.cabal @@ -37,6 +37,7 @@ library , hls-plugin-api == 2.1.0.0 , lens , lsp-types + , mtl , process , text , transformers diff --git a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs index c85df79c92..a3250ba119 100644 --- a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs +++ b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs @@ -4,16 +4,16 @@ module Ide.Plugin.CabalFmt where import Control.Lens +import Control.Monad.Except (throwError) import Control.Monad.IO.Class -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) -import Ide.Plugin.Error (PluginError (PluginInternalError, PluginInvalidRequest)) +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginInvalidParams)) import Ide.PluginUtils import Ide.Types -import Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types -import Prelude hiding (log) +import Prelude hiding (log) import System.Directory import System.Exit import System.FilePath @@ -48,14 +48,14 @@ descriptor recorder plId = provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState provider recorder _ (FormatRange _) _ _ _ = do logWith recorder Info LogInvalidInvocationInfo - pure $ Left (PluginInvalidRequest "You cannot format a text-range using cabal-fmt.") -provider recorder _ide FormatText contents nfp opts = liftIO $ do + throwError $ PluginInvalidParams "You cannot format a text-range using cabal-fmt." +provider recorder _ide FormatText contents nfp opts = do let cabalFmtArgs = [fp, "--indent", show tabularSize] - x <- findExecutable "cabal-fmt" + x <- liftIO $ findExecutable "cabal-fmt" case x of Just _ -> do (exitCode, out, err) <- - readCreateProcessWithExitCode + liftIO $ readCreateProcessWithExitCode ( proc "cabal-fmt" cabalFmtArgs ) { cwd = Just $ takeDirectory fp @@ -65,13 +65,13 @@ provider recorder _ide FormatText contents nfp opts = liftIO $ do case exitCode of ExitFailure code -> do log Error $ LogProcessInvocationFailure code - pure $ Left (PluginInternalError "Failed to invoke cabal-fmt") + throwError (PluginInternalError "Failed to invoke cabal-fmt") ExitSuccess -> do let fmtDiff = makeDiffTextEdit contents (T.pack out) - pure $ Right $ InL fmtDiff + pure $ InL fmtDiff Nothing -> do log Error LogCabalFmtNotFound - pure $ Left (PluginInternalError "No installation of cabal-fmt could be found. Please install it into your global environment.") + throwError (PluginInternalError "No installation of cabal-fmt could be found. Please install it into your global environment.") where fp = fromNormalizedFilePath nfp tabularSize = opts ^. L.tabSize diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 76f890fcd6..75db11f8fa 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -31,12 +31,10 @@ import GHC.Generics import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest import qualified Ide.Plugin.Cabal.Parse as Parse -import Ide.Plugin.Config (Config) import Ide.Types import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types import qualified Language.LSP.Protocol.Types as LSP -import Language.LSP.Server (LspM) import qualified Language.LSP.VFS as VFS data Log @@ -180,7 +178,7 @@ kick = do licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = - pure $ Right $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction uri) + pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction uri) -- ---------------------------------------------------------------- -- Cabal file of Interest rules and global variable 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 aae2ae348a..dcae70b249 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 @@ -39,7 +39,7 @@ import Text.Read (readMaybe) -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy -prepareCallHierarchy state _ param = runExceptT $ do +prepareCallHierarchy state _ param = do nfp <- getNormalizedFilePathE (param ^. L.textDocument ^. L.uri) items <- liftIO $ runAction "CallHierarchy.prepareHierarchy" state @@ -173,7 +173,7 @@ deriving instance Ord Value -- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls -incomingCalls state pluginId param = runExceptT $ do +incomingCalls state pluginId param = do calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls @@ -188,7 +188,7 @@ incomingCalls state pluginId param = runExceptT $ do -- | Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls -outgoingCalls state pluginId param = runExceptT $ do +outgoingCalls state pluginId param = 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 82d70780eb..a0933fc25b 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 @@ -22,8 +22,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Util (printOutputable) import Generics.SYB (extQ, something) import Ide.Plugin.Error (PluginError, - getNormalizedFilePathE, - runExceptT) + getNormalizedFilePathE) import Ide.Types (PluginDescriptor (..), PluginId (PluginId), PluginMethodHandler, @@ -37,7 +36,7 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) } codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = runExceptT $ do +codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = do nfp <- getNormalizedFilePathE uri decls <- getDecls plId ideState nfp let actions = mapMaybe (generateAction plId uri decls) diags diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index bf1b48d9e8..ac231638b3 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/plugins/hls-class-plugin/hls-class-plugin.cabal @@ -45,6 +45,7 @@ library , hls-plugin-api == 2.1.0.0 , lens , lsp + , mtl , text , transformers 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 689a1d2dab..cc5ad26e2f 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -6,10 +6,10 @@ module Ide.Plugin.Class.CodeAction where import Control.Lens hiding (List, use) +import Control.Monad.Except (ExceptT, throwError) import Control.Monad.Extra import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, throwE) import Control.Monad.Trans.Maybe import Data.Aeson hiding (Null) import Data.Bifunctor (second) @@ -80,7 +80,7 @@ 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 Method_TextDocumentCodeAction -codeAction recorder state plId (CodeActionParams _ _ docId _ context) = runExceptT $ do +codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do verTxtDocId <- lift $ getVersionedTextDoc docId nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags @@ -194,7 +194,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = runExcep AGlobal (AConLike (RealDataCon con)) | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls _ -> fail "Ide.Plugin.Class.findClassFromIdentifier" - findClassFromIdentifier _ (Left _) = throwE (PluginInternalError "Ide.Plugin.Class.findClassIdentifier") + findClassFromIdentifier _ (Left _) = throwError (PluginInternalError "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 a29c679f0f..99fa3b04c0 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -25,7 +25,7 @@ import Language.LSP.Protocol.Types import Language.LSP.Server (sendRequest) codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLens state plId CodeLensParams{..} = runExceptT $ do +codeLens state plId CodeLensParams{..} = do nfp <- getNormalizedFilePathE uri (tmr, _) <- runActionE "classplugin.TypeCheck" state -- Using stale results means that we can almost always return a value. In practice 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 1483787140..34d0bcb784 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -15,26 +15,23 @@ module Ide.Plugin.CodeRange ( , createFoldingRange ) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT, mapExceptT) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) import Data.List.Extra (drop1) import Data.Maybe (fromMaybe) import Data.Vector (Vector) import qualified Data.Vector as V -import Development.IDE (Action, IdeAction, +import Development.IDE (Action, IdeState (shakeExtras), Range (Range), Recorder, WithPriority, cmapWithPrio) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, - fromCurrentPosition, toCurrentRange) -import Ide.Logger (Pretty (..), - Priority (Warning), - logWith) +import Ide.Logger (Pretty (..)) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), codeRangeRule, crkToFrk) @@ -47,7 +44,6 @@ import Ide.Types (PluginDescriptor (pluginH defaultPluginDescriptor, mkPluginHandler) import Language.LSP.Protocol.Message (Method (Method_TextDocumentFoldingRange, Method_TextDocumentSelectionRange), - ResponseError, SMethod (SMethod_TextDocumentFoldingRange, SMethod_TextDocumentSelectionRange)) import Language.LSP.Protocol.Types (FoldingRange (..), FoldingRangeParams (..), @@ -58,7 +54,6 @@ import Language.LSP.Protocol.Types (FoldingRange (..), SelectionRangeParams (..), TextDocumentIdentifier (TextDocumentIdentifier), Uri, type (|?) (InL)) -import Language.LSP.Server (LspM, LspT) import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -75,8 +70,8 @@ instance Pretty Log where LogRules codeRangeLog -> pretty codeRangeLog foldingRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentFoldingRange -foldingRangeHandler recorder ide _ FoldingRangeParams{..} = - runExceptT $ do +foldingRangeHandler _ ide _ FoldingRangeParams{..} = + do filePath <- getNormalizedFilePathE uri foldingRanges <- runActionE "FoldingRange" ide $ getFoldingRanges filePath pure . InL $ foldingRanges @@ -90,10 +85,10 @@ getFoldingRanges file = do pure $ findFoldingRanges codeRange selectionRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentSelectionRange -selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do - runExceptT $ do +selectionRangeHandler _ ide _ SelectionRangeParams{..} = do + do filePath <- getNormalizedFilePathE uri - fmap id . hoistExceptT $ getSelectionRanges ide filePath positions + mapExceptT liftIO $ getSelectionRanges ide filePath positions where uri :: Uri TextDocumentIdentifier uri = _textDocument 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 f1abac8bdd..01cef7d950 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -141,7 +141,7 @@ codeLens st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg in perf "codeLens" $ - runExceptT $ do + do let TextDocumentIdentifier uri = _textDocument fp <- uriToFilePathE uri let nfp = toNormalizedFilePath' fp 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 12e01c8ef2..ef4bf0bcf9 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -19,6 +19,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson (Value) +import Data.Bifunctor (second) import Data.String (IsString (fromString)) import qualified Data.Text as T import Development.IDE (IdeState, Priority (..), @@ -74,12 +75,9 @@ response' act = do `catchAny` \e -> do res <- showErr e pure . Left . PluginInternalError $ fromString res - case res of - Left e -> - return $ Left e - Right a -> do + sequence $ flip second res $ \a -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) - return $ Right $ InR Null + pure $ InR Null gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) gStrictTry op = 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 24c49ea209..e3b68164f5 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -43,7 +43,7 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId) } hover :: PluginMethodHandler IdeState Method_TextDocumentHover -hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = runExceptT $ do +hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = do nfp <- getNormalizedFilePathE uri runIdeActionE "ExplicitFixity" (shakeExtras state) $ do (FixityMap fixmap, _) <- useWithStaleFastE GetFixity nfp diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 0b0f818922..6f2fed8e6b 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -43,6 +43,7 @@ library , hls-plugin-api == 2.1.0.0 , lens , lsp + , mtl , text , transformers , unordered-containers diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 846060ca46..de5e847d49 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -20,6 +20,7 @@ module Ide.Plugin.ExplicitImports import Control.DeepSeq import Control.Lens ((&), (?~)) +import Control.Monad.Except (throwError) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT) @@ -125,8 +126,7 @@ runImportCommand _ _ (ResolveAll _) = do -- -- > import Data.List (intercalate, sortBy) lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens -lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} - = runExceptT $ do +lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do nfp <- getNormalizedFilePathE _uri mbMinImports <- liftIO $ runAction "MinimalImports" state $ use MinimalImports nfp case mbMinImports of @@ -143,8 +143,7 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier { , _command = Nothing } lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeLensResolve -lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) - = runExceptT $ do +lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) = do nfp <- getNormalizedFilePathE uri (MinimalImportsResult{forResolve}) <- runActionE "MinimalImports" ideState $ useE MinimalImports nfp target <- handleMaybe PluginStaleResolve $ forResolve IM.!? uid @@ -155,14 +154,13 @@ lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) let title = abbreviateImportTitle _newText in mkLspCommand pId importCommandId title (Just $ [A.toJSON rd]) lensResolveProvider _ _ _ _ _ (ResolveAll _) = do - pure $ Left $ PluginInvalidParams "Unexpected argument for lens resolve handler: ResolveAll" + throwError $ PluginInvalidParams "Unexpected argument for lens resolve handler: ResolveAll" -- | If there are any implicit imports, provide both one code action per import -- to make that specific import explicit, and one code action to turn them all -- into explicit imports. codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) - = runExceptT $ do +codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) = do nfp <- getNormalizedFilePathE _uri (MinimalImportsResult{forCodeActions}) <- runActionE "MinimalImports" ideState $ useE MinimalImports nfp @@ -185,8 +183,7 @@ codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier , _data_ = data_} codeActionResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeActionResolve -codeActionResolveProvider _ ideState _ ca _ rd = - runExceptT $ do +codeActionResolveProvider _ ideState _ ca _ rd = do wedit <- resolveWTextEdit ideState rd pure $ ca & L.edit ?~ wedit -------------------------------------------------------------------------------- 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 5194838750..afa7e8c619 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 @@ -30,7 +30,6 @@ import Development.IDE (IdeState, NormalizedFilePath, Rules, WithPriority (..), realSrcSpanToRange) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) import Development.IDE.Core.Shake (define, use) @@ -102,7 +101,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) } codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = runExceptT $ do +codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = do nfp <- getNormalizedFilePathE (docId ^. L.uri) pragma <- getFirstPragma pId ideState nfp CRR recMap exts <- collectRecords' ideState nfp diff --git a/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal index 5c5e8ceecb..88524d39cb 100644 --- a/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal +++ b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal @@ -31,6 +31,7 @@ library , ghcide == 2.1.0.0 , hls-plugin-api == 2.1.0.0 , lsp-types ^>=2.0.0.1 + , mtl , text , transformers diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs index 6da8e0b9e2..7a7deaf629 100644 --- a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -5,6 +5,7 @@ module Ide.Plugin.Floskell , provider ) where +import Control.Monad.Except (throwError) import Control.Monad.IO.Class import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -29,16 +30,16 @@ descriptor plId = (defaultPluginDescriptor plId) -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. provider :: FormattingHandler IdeState -provider _ideState typ contents fp _ = liftIO $ do +provider _ideState typ contents fp _ = do let file = fromNormalizedFilePath fp - config <- findConfigOrDefault file + config <- liftIO $ findConfigOrDefault file let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents) result = reformat config (Just file) . TL.encodeUtf8 $ TL.fromStrict selectedContents case result of - Left err -> pure $ Left $ PluginInternalError $ T.pack $ "floskellCmd: " ++ err - Right new -> pure $ Right $ InL [TextEdit range . TL.toStrict $ TL.decodeUtf8 new] + Left err -> throwError $ PluginInternalError $ T.pack $ "floskellCmd: " ++ err + Right new -> pure $ InL [TextEdit range . TL.toStrict $ TL.decodeUtf8 new] -- | Find Floskell Config, user and system wide or provides a default style. -- Every directory of the filepath will be searched to find a user configuration. diff --git a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal index e220eaa9aa..3da9bddf9e 100644 --- a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal +++ b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal @@ -39,6 +39,7 @@ library , hls-plugin-api == 2.1.0.0 , lens , lsp + , mtl , process-extras >= 0.7.1 , text diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index a682f495b4..3ab44a9663 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Ide.Plugin.Fourmolu ( descriptor, @@ -13,11 +14,14 @@ module Ide.Plugin.Fourmolu ( LogEvent, ) where -import Control.Exception (IOException, try) +import Control.Exception (IOException, handle, try) import Control.Lens ((^.)) import Control.Monad +import Control.Monad.Except (ExceptT (..), mapExceptT, + throwError) import Control.Monad.IO.Class -import Data.Bifunctor (bimap, first) +import Control.Monad.Trans +import Data.Bifunctor (bimap) import Data.Maybe import Data.Text (Text) import qualified Data.Text as T @@ -58,51 +62,18 @@ properties = False provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState -provider recorder plId ideState typ contents fp fo = withIndefiniteProgress title Cancellable $ do +provider recorder plId ideState typ contents fp fo = ExceptT $ withIndefiniteProgress title Cancellable $ runExceptT $ do fileOpts <- maybe [] (convertDynFlags . hsc_dflags . hscEnv) <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession fp) useCLI <- liftIO $ runAction "Fourmolu" ideState $ usePropertyAction #external plId properties if useCLI - then liftIO - . fmap (join . first (PluginInternalError . T.pack . show)) - . try @IOException - $ do - CLIVersionInfo{noCabal} <- do -- check Fourmolu version so that we know which flags to use - (exitCode, out, _err) <- readCreateProcessWithExitCode ( proc "fourmolu" ["-v"] ) "" - let version = do - guard $ exitCode == ExitSuccess - "fourmolu" : v : _ <- pure $ T.words out - traverse (readMaybe @Int . T.unpack) $ T.splitOn "." v - case version of - Just v -> pure CLIVersionInfo - { noCabal = v >= [0, 7] - } - Nothing -> do - logWith recorder Warning $ NoVersion out - pure CLIVersionInfo - { noCabal = True - } - (exitCode, out, err) <- -- run Fourmolu - readCreateProcessWithExitCode - ( proc "fourmolu" $ - map ("-o" <>) fileOpts - <> mwhen noCabal ["--no-cabal"] - <> catMaybes - [ ("--start-line=" <>) . show <$> regionStartLine region - , ("--end-line=" <>) . show <$> regionEndLine region - ] - ){cwd = Just $ takeDirectory fp'} - contents - case exitCode of - ExitSuccess -> do - logWith recorder Debug $ StdErr err - pure . Right $ InL $ makeDiffTextEdit contents out - ExitFailure n -> do - logWith recorder Info $ StdErr err - pure . Left . PluginInternalError $ "Fourmolu failed with exit code " <> T.pack (show n) + then mapExceptT liftIO $ ExceptT + $ handle @IOException + (pure . Left . PluginInternalError . T.pack . show) + $ runExceptT $ cliHandler fileOpts else do - let format fourmoluConfig = + let format fourmoluConfig = ExceptT $ bimap (PluginInternalError . T.pack . show) (InL . makeDiffTextEdit contents) #if MIN_VERSION_fourmolu(0,11,0) <$> try @OrmoluException (ormolu config fp' contents) @@ -123,19 +94,19 @@ provider recorder plId ideState typ contents fp fo = withIndefiniteProgress titl defaultPrinterOpts } in liftIO (loadConfigFile fp') >>= \case - ConfigLoaded file opts -> liftIO $ do + ConfigLoaded file opts -> do logWith recorder Info $ ConfigPath file - format opts - ConfigNotFound searchDirs -> liftIO $ do + mapExceptT liftIO $ format opts + ConfigNotFound searchDirs -> do logWith recorder Info $ NoConfigPath searchDirs - format emptyConfig + mapExceptT liftIO $ format emptyConfig ConfigParseError f err -> do - sendNotification SMethod_WindowShowMessage $ + lift $ sendNotification SMethod_WindowShowMessage $ ShowMessageParams { _type_ = MessageType_Error , _message = errorMessage } - return . Left $ PluginInternalError errorMessage + throwError $ PluginInternalError errorMessage where errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack (showParseError err) where @@ -147,6 +118,41 @@ provider recorder plId ideState typ contents fp fo = withIndefiniteProgress titl RegionIndices Nothing Nothing FormatRange (Range (Position sl _) (Position el _)) -> RegionIndices (Just $ fromIntegral $ sl + 1) (Just $ fromIntegral $ el + 1) + cliHandler :: [String] -> ExceptT PluginError IO ([TextEdit] |? Null) + cliHandler fileOpts = do + CLIVersionInfo{noCabal} <- do -- check Fourmolu version so that we know which flags to use + (exitCode, out, _err) <- liftIO $ readCreateProcessWithExitCode ( proc "fourmolu" ["-v"] ) "" + let version = do + guard $ exitCode == ExitSuccess + "fourmolu" : v : _ <- pure $ T.words out + traverse (readMaybe @Int . T.unpack) $ T.splitOn "." v + case version of + Just v -> pure CLIVersionInfo + { noCabal = v >= [0, 7] + } + Nothing -> do + logWith recorder Warning $ NoVersion out + pure CLIVersionInfo + { noCabal = True + } + (exitCode, out, err) <- -- run Fourmolu + liftIO $ readCreateProcessWithExitCode + ( proc "fourmolu" $ + map ("-o" <>) fileOpts + <> mwhen noCabal ["--no-cabal"] + <> catMaybes + [ ("--start-line=" <>) . show <$> regionStartLine region + , ("--end-line=" <>) . show <$> regionEndLine region + ] + ){cwd = Just $ takeDirectory fp'} + contents + case exitCode of + ExitSuccess -> do + logWith recorder Debug $ StdErr err + pure $ InL $ makeDiffTextEdit contents out + ExitFailure n -> do + logWith recorder Info $ StdErr err + throwError $ PluginInternalError $ "Fourmolu failed with exit code " <> T.pack (show n) data LogEvent = NoVersion Text diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 876c5512a6..a954637fad 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -11,17 +11,13 @@ module Ide.Plugin.GADT (descriptor) where import Control.Lens ((^.)) import Control.Monad.Except -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Data.Aeson (FromJSON, ToJSON, Value, - toJSON) +import Data.Aeson (FromJSON, ToJSON, toJSON) import Data.Either.Extra (maybeToEither) import qualified Data.Map as Map 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.Core.PluginUtils import Development.IDE.Spans.Pragmas (getFirstPragma, @@ -55,12 +51,12 @@ 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{..} = pluginResponseM handleGhcidePluginError $ do +toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = runExceptT $ withExceptT handleGhcidePluginError $ do nfp <- withExceptT (GhcidePluginErrors) $ getNormalizedFilePathE uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of [d] -> pure d - _ -> throwE $ UnexpectedNumberOfDeclarations (Prelude.length decls) + _ -> throwError $ UnexpectedNumberOfDeclarations (Prelude.length decls) deps <- withExceptT GhcidePluginErrors $ runActionE (T.unpack pId' <> ".GhcSessionDeps") state $ useE GhcSessionDeps nfp @@ -86,7 +82,7 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponseM handl Nothing Nothing codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction -codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponseM handleGhcidePluginError $ do +codeActionHandler state plId (CodeActionParams _ _ doc range _) = withExceptT handleGhcidePluginError $ do nfp <- withExceptT (GhcidePluginErrors) $ getNormalizedFilePathE (doc ^. L.uri) (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls @@ -131,15 +127,14 @@ data GadtPluginError | GhcidePluginErrors PluginError handleGhcidePluginError :: - Monad m => GadtPluginError -> - m (Either PluginError a) + PluginError handleGhcidePluginError = \case UnexpectedNumberOfDeclarations nums -> do - pure $ Left $ PluginInternalError $ "Expected one declaration but found: " <> T.pack (show nums) + PluginInternalError $ "Expected one declaration but found: " <> T.pack (show nums) FailedToFindDataDeclRange -> - pure $ Left $ PluginInternalError $ "Unable to get data decl range" + PluginInternalError $ "Unable to get data decl range" PrettyGadtError errMsg -> - pure $ Left $ PluginInternalError $ errMsg + PluginInternalError $ errMsg GhcidePluginErrors errors -> - pure $ Left $ errors + errors diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index c5eb1f1592..d542f1d0c4 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -45,7 +45,7 @@ codeActionProvider ideState _pId (CodeActionParams _ _ (TextDocumentIdentifier u let locDecls = hsmodDecls . unLoc . astA <$> pm anns = annsA <$> pm edits = [gen locDecls anns range | noErr, gen <- genList] - return $ Right $ InL [InR $ toAction title uri edit | (Just (title, edit)) <- edits] + pure $ InL [InR $ toAction title uri edit | (Just (title, edit)) <- edits] genList :: [Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit)] genList = diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index a9cd8b80ef..0035934ef2 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -51,6 +51,7 @@ library , hls-plugin-api == 2.1.0.0 , lens , lsp + , mtl , refact , regex-tdfa , stm diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index a70e5eb82c..48d9aaeead 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -43,8 +43,7 @@ import Control.DeepSeq import Control.Exception import Control.Lens ((?~), (^.)) import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except +import Control.Monad.Except import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)) @@ -403,8 +402,8 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context | let TextDocumentIdentifier uri = documentId , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) = do - verTxtDocId <- getVersionedTextDoc documentId - liftIO $ fmap (Right . InL . map LSP.InR) $ do + verTxtDocId <- lift $ getVersionedTextDoc documentId + liftIO $ fmap (InL . map LSP.InR) $ do allDiagnostics <- atomically $ getDiagnostics ideState let numHintsInDoc = length @@ -422,7 +421,7 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context else pure singleHintCodeActions | otherwise - = pure $ Right $ InL [] + = pure $ InL [] where applyAllAction verTxtDocId = @@ -438,7 +437,7 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context diags = context ^. LSP.diagnostics resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve -resolveProvider recorder ideState _plId ca uri resolveValue = runExceptT $ do +resolveProvider recorder ideState _plId ca uri resolveValue = do file <- getNormalizedFilePathE uri case resolveValue of (ApplyHint verTxtDocId oneHint) -> do @@ -517,7 +516,7 @@ ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do Nothing Nothing pure workspaceEdit - Nothing -> throwE $ PluginInternalError "Unable to get fileContents" + Nothing -> throwError $ PluginInternalError "Unable to get fileContents" -- --------------------------------------------------------------------- data HlintResolveCommands = @@ -584,7 +583,7 @@ applyHint recorder ide nfp mhint verTxtDocId = mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp res <- case mbParsedModule of - Nothing -> throwE "Apply hint: error parsing the module" + Nothing -> throwError "Apply hint: error parsing the module" Just pm -> do let anns = pm_annotations pm let modu = pm_parsed_source pm @@ -601,7 +600,7 @@ applyHint recorder ide nfp mhint verTxtDocId = let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions ExceptT $ return (Right wsEdit) Left err -> - throwE $ PluginInternalError $ T.pack err + throwError $ PluginInternalError $ T.pack err where -- | If we are only interested in applying a particular hint then -- let's filter out all the irrelevant ideas diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index 76a003d1ef..c540e1484e 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -2,7 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} + {-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -20,14 +22,14 @@ module Ide.Plugin.ModuleName ( import Control.Monad (forM_, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe -import Data.Aeson (Value, toJSON) +import Data.Aeson (toJSON) import Data.Char (isLower) import Data.List (intercalate, isPrefixOf, minimumBy) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Data.Maybe (fromMaybe, maybeToList) import Data.Ord (comparing) import Data.String (IsString) import qualified Data.Text as T @@ -40,10 +42,9 @@ import Development.IDE (GetParsedModule (GetParse hscEnvWithImportPaths, logWith, realSrcSpanToRange, - runAction, - uriToFilePath', - useWithStale, - useWithStale_, (<+>)) + runAction, useWithStale, + (<+>)) +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.GHC.Compat (GenLocated (L), getSessionDynFlags, @@ -52,6 +53,7 @@ import Development.IDE.GHC.Compat (GenLocated (L), pattern RealSrcSpan, pm_parsed_source, unLoc) import Ide.Logger (Pretty (..)) +import Ide.Plugin.Error import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -76,8 +78,9 @@ updateModuleNameCommand = "updateModuleName" -- | Generate code lenses codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens -codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = - Right . InL . maybeToList . (asCodeLens <$>) <$> action recorder state uri +codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + res <- action recorder state uri + pure $ InL (asCodeLens <$> res) where asCodeLens :: Action -> CodeLens asCodeLens Replace{..} = CodeLens aRange (Just cmd) Nothing @@ -86,15 +89,15 @@ codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdenti -- | (Quasi) Idempotent command execution: recalculate action to execute on command request command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri -command recorder state uri = do +command recorder state uri = runExceptT $ do actMaybe <- action recorder state uri forM_ actMaybe $ \Replace{..} -> let -- | Convert an Action to the corresponding edit operation edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing in - void $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) - pure $ Right $ InR Null + void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) + pure $ InR Null -- | A source code change data Action = Replace @@ -106,41 +109,40 @@ data Action = Replace deriving (Show) -- | Required action (that can be converted to either CodeLenses or CodeActions) -action :: Recorder (WithPriority Log) -> IdeState -> Uri -> LspM c (Maybe Action) -action recorder state uri = - runMaybeT $ do - nfp <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri - fp <- MaybeT . pure $ uriToFilePath' uri +action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action] +action recorder state uri = do + nfp <- getNormalizedFilePathE uri + fp <- uriToFilePathE uri contents <- lift . getVirtualFile $ toNormalizedUri uri let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents - correctNames <- liftIO $ pathModuleNames recorder state nfp fp + correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp logWith recorder Debug (CorrectNames correctNames) - bestName <- minimumBy (comparing T.length) <$> (MaybeT . pure $ NE.nonEmpty correctNames) + let bestName = minimumBy (comparing T.length) <$> NE.nonEmpty correctNames logWith recorder Debug (BestName bestName) statedNameMaybe <- liftIO $ codeModuleName state nfp logWith recorder Debug (ModuleName $ snd <$> statedNameMaybe) - case statedNameMaybe of - Just (nameRange, statedName) + case (bestName, statedNameMaybe) of + (Just bestName, Just (nameRange, statedName)) | statedName `notElem` correctNames -> - pure $ Replace uri nameRange ("Set module name to " <> bestName) bestName - Nothing + pure [Replace uri nameRange ("Set module name to " <> bestName) bestName] + (Just bestName, Nothing) | emptyModule -> let code = "module " <> bestName <> " where\n" - in pure $ Replace uri (Range (Position 0 0) (Position 0 0)) code code - _ -> MaybeT $ pure Nothing + in pure [Replace uri (Range (Position 0 0) (Position 0 0)) code code] + _ -> pure $ [] -- | Possible module names, as derived by the position of the module in the -- source directories. There may be more than one possible name, if the source -- directories are nested inside each other. -pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> IO [T.Text] +pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> ExceptT PluginError IO [T.Text] pathModuleNames recorder state normFilePath filePath | isLower . head $ takeFileName filePath = return ["Main"] | otherwise = do - session <- fst <$> (runAction "ModuleName.ghcSession" state $ useWithStale_ GhcSession normFilePath) - srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags + (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath + srcPaths <- liftIO $ evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags logWith recorder Debug (SrcPaths srcPaths) -- Append a `pathSeparator` to make the path looks like a directory, @@ -149,7 +151,7 @@ pathModuleNames recorder state normFilePath filePath let paths = map (normalise . (<> pure pathSeparator)) srcPaths logWith recorder Debug (NormalisedPaths paths) - mdlPath <- makeAbsolute filePath + mdlPath <- liftIO $ makeAbsolute filePath logWith recorder Debug (AbsoluteFilePath mdlPath) let prefixes = filter (`isPrefixOf` mdlPath) paths @@ -172,7 +174,7 @@ codeModuleName state nfp = runMaybeT $ do data Log = CorrectNames [T.Text] - | BestName T.Text + | BestName (Maybe T.Text) | ModuleName (Maybe T.Text) | SrcPaths [FilePath] | NormalisedPaths [FilePath] diff --git a/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal b/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal index 01e74c17b9..40902789d9 100644 --- a/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal +++ b/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal @@ -29,6 +29,7 @@ library hs-source-dirs: src build-depends: , base >=4.12 && <5 + , extra , filepath , ghc , ghc-boot-th @@ -36,6 +37,7 @@ library , hls-plugin-api == 2.1.0.0 , lens , lsp + , mtl , ormolu ^>=0.1.2 || ^>= 0.2 || ^>= 0.3 || ^>= 0.5 || ^>= 0.6 || ^>= 0.7 , text diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs index 8a9fd22018..f18323374d 100644 --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -11,7 +11,11 @@ where import Control.Exception (Handler (..), IOException, SomeException (..), catches) +import Control.Monad.Except (ExceptT (ExceptT), runExceptT, + throwError) +import Control.Monad.Extra import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans import Data.Functor ((<&>)) import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) @@ -22,6 +26,7 @@ import GHC.LanguageExtensions.Type import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.PluginUtils import Ide.Types hiding (Config) +import qualified Ide.Types as Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server hiding (defaultConfig) @@ -38,8 +43,8 @@ descriptor plId = (defaultPluginDescriptor plId) -- --------------------------------------------------------------------- provider :: FormattingHandler IdeState -provider ideState typ contents fp _ = withIndefiniteProgress title Cancellable $ liftIO $ do - ghc <- runAction "Ormolu" ideState $ use GhcSession fp +provider ideState typ contents fp _ = ExceptT $ withIndefiniteProgress title Cancellable $ runExceptT $ do + ghc <- liftIO $ runAction "Ormolu" ideState $ use GhcSession fp let df = hsc_dflags . hscEnv <$> ghc fileOpts <- case df of Nothing -> pure [] @@ -76,15 +81,18 @@ provider ideState typ contents fp _ = withIndefiniteProgress title Cancellable $ ] case typ of - FormatText -> ret <$> fmt contents (mkConf fileOpts fullRegion) - FormatRange (Range (Position sl _) (Position el _)) -> - ret <$> fmt contents (mkConf fileOpts (rangeRegion (fromIntegral sl) (fromIntegral el))) + FormatText -> do + res <- liftIO $ fmt contents (mkConf fileOpts fullRegion) + ret res + FormatRange (Range (Position sl _) (Position el _)) -> do + res <- liftIO $ fmt contents (mkConf fileOpts (rangeRegion (fromIntegral sl) (fromIntegral el))) + ret res where title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) - ret :: Either SomeException T.Text -> Either PluginError ([TextEdit] |? Null) - ret (Left err) = Left . PluginInternalError . T.pack $ "ormoluCmd: " ++ show err - ret (Right new) = Right $ InL $ makeDiffTextEdit contents new + ret :: Either SomeException T.Text -> ExceptT PluginError (LspM Types.Config) ([TextEdit] |? Null) + ret (Left err) = throwError $ PluginInternalError . T.pack $ "ormoluCmd: " ++ show err + ret (Right new) = pure $ InL $ makeDiffTextEdit contents new fromDyn :: D.DynFlags -> [DynOption] fromDyn df = 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 2ba57596f4..aa48e5ae10 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 @@ -3,9 +3,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} - module Ide.Plugin.OverloadedRecordDot ( descriptor , Log @@ -13,33 +13,27 @@ module Ide.Plugin.OverloadedRecordDot -- based off of Berk Okzuturk's hls-explicit-records-fields-plugin -import Control.Lens (_Just, (^.), (^?)) +import Control.Lens ((^.)) import Control.Monad (replicateM) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, throwE) -import Data.Aeson (FromJSON, Result (..), - ToJSON, fromJSON, toJSON) -import Data.Generics (GenericQ, everything, - everythingBut, mkQ) +import Control.Monad.Trans.Except (ExceptT) +import Data.Aeson (FromJSON, ToJSON, toJSON) +import Data.Generics (GenericQ, everythingBut, + mkQ) import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map -import Data.Maybe (fromJust, mapMaybe, - maybeToList) +import Data.Maybe (mapMaybe, maybeToList) import Data.Text (Text) import Data.Unique (hashUnique, newUnique) import Development.IDE (IdeState, NormalizedFilePath, - NormalizedUri, Pretty (..), Range, Recorder (..), Rules, WithPriority (..), realSrcSpanToRange) -import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) -import Development.IDE.Core.Shake (define, use, - useWithStale) +import Development.IDE.Core.Shake (define, useWithStale) import qualified Development.IDE.Core.Shake as Shake #if __GLASGOW_HASKELL__ >= 903 @@ -50,17 +44,16 @@ import Development.IDE.GHC.Compat (HsExpr (HsRecFld)) import Control.DeepSeq (rwhnf) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.PositionMapping (PositionMapping (PositionMapping), +import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.GHC.Compat (Extension (OverloadedRecordDot), GhcPass, HsExpansion (HsExpanded), - HsExpr (HsApp, HsPar, HsVar, OpApp, XExpr), + HsExpr (HsApp, HsVar, OpApp, XExpr), LHsExpr, Outputable, - Pass (..), RealSrcSpan, - appPrec, dollarName, - getLoc, hs_valds, - parenthesizeHsContext, + Pass (..), appPrec, + dollarName, getLoc, + hs_valds, parenthesizeHsExpr, pattern RealSrcSpan, unLoc) @@ -77,7 +70,7 @@ import Ide.Logger (Priority (..), (<+>)) import Ide.Plugin.Error (PluginError (..), getNormalizedFilePathE, - handleMaybe, runExceptT) + handleMaybe) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve) @@ -85,26 +78,19 @@ import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, ResolveFunction, - defaultPluginDescriptor, - mkPluginHandler) + defaultPluginDescriptor) import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (..), - SMethod (..)) +import Language.LSP.Protocol.Message (Method (..)) import Language.LSP.Protocol.Types (CodeAction (..), CodeActionKind (CodeActionKind_RefactorRewrite), CodeActionParams (..), - Command, TextEdit (..), - Uri (..), + TextEdit (..), Uri (..), WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), - fromNormalizedUri, - normalizedFilePathToUri, type (|?) (..)) -import Language.LSP.Server (getClientCapabilities) data Log = LogShake Shake.Log | LogCollectedRecordSelectors [RecordSelectorExpr] - | LogTextEdits [TextEdit] | forall a. (Pretty a) => LogResolve a instance Pretty Log where @@ -152,7 +138,7 @@ data RecordSelectorExpr = RecordSelectorExpr recordExpr :: LHsExpr (GhcPass 'Renamed) } instance Pretty RecordSelectorExpr where - pretty (RecordSelectorExpr l rs se) = pretty (printOutputable rs) <> ":" + pretty (RecordSelectorExpr _ rs se) = pretty (printOutputable rs) <> ":" <+> pretty (printOutputable se) instance NFData RecordSelectorExpr where @@ -181,7 +167,7 @@ descriptor recorder plId = resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve resolveProvider ideState plId ca uri (ORDRD _ int) = - runExceptT $ do + do nfp <- getNormalizedFilePathE uri CRSR _ crsDetails exts <- collectRecSelResult ideState nfp pragma <- getFirstPragma plId ideState nfp @@ -189,10 +175,10 @@ resolveProvider ideState plId ca uri (ORDRD _ int) = pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = - runExceptT $ do +codeActionProvider ideState _ (CodeActionParams _ _ caDocId caRange _) = + do nfp <- getNormalizedFilePathE (caDocId ^. L.uri) - CRSR crsMap crsDetails exts <- collectRecSelResult ideState nfp + CRSR crsMap _ exts <- collectRecSelResult ideState nfp let mkCodeAction (crsM, nse) = InR CodeAction { -- We pass the record selector to the title function, so that -- we can have the name of the record selector in the title of @@ -200,7 +186,7 @@ codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = -- between the different codeActions when using nested record -- selectors, the disadvantage is we need to print out the -- name of the record selector which will decrease performance - _title = mkCodeActionTitle exts crsM nse + _title = mkCodeActionTitle exts nse , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing @@ -212,8 +198,8 @@ codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap) pure $ InL actions where - mkCodeActionTitle :: [Extension] -> Int -> HsExpr (GhcPass 'Renamed) -> Text - mkCodeActionTitle exts crsM se = + mkCodeActionTitle :: [Extension] -> HsExpr (GhcPass 'Renamed) -> Text + mkCodeActionTitle exts se = if OverloadedRecordDot `elem` exts then title else title <> " (needs extension: OverloadedRecordDot)" @@ -269,11 +255,11 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ case toCurrentRange pm (location recSel) of Just newLoc -> Just $ recSel{location = newLoc} Nothing -> Nothing - toRangeAndUnique (id, RecordSelectorExpr l (unLoc -> se) _) = (l, (id, se)) + toRangeAndUnique (uid, RecordSelectorExpr l (unLoc -> se) _) = (l, (uid, se)) convertRecordSelectors :: RecordSelectorExpr -> TextEdit -convertRecordSelectors (RecordSelectorExpr l se re) = - TextEdit l $ convertRecSel se re +convertRecordSelectors RecordSelectorExpr{..} = + TextEdit location $ convertRecSel selectorExpr recordExpr -- |Converts a record selector expression into record dot syntax, currently we -- are using printOutputable to do it. We are also letting GHC decide when to diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index c5110b14b8..ba2bd833c2 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -19,6 +19,7 @@ module Ide.Plugin.Pragmas import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) import Data.List.Extra (nubOrdOn) import qualified Data.Map as M import Data.Maybe (catMaybes) @@ -26,9 +27,11 @@ import qualified Data.Text as T import Development.IDE import Development.IDE.Core.Compile (sourceParser, sourceTypecheck) +import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) import qualified Development.IDE.Spans.Pragmas as Pragmas +import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Message as LSP @@ -72,23 +75,19 @@ suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDo suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction -mkCodeActionProvider mkSuggest state _plId (LSP.CodeActionParams _ _ docId _ (LSP.CodeActionContext diags _monly _)) - | let LSP.TextDocumentIdentifier{ _uri = uri } = docId - , Just normalizedFilePath <- LSP.uriToNormalizedFilePath $ toNormalizedUri uri = do - -- ghc session to get some dynflags even if module isn't parsed - ghcSession <- liftIO $ runAction "Pragmas.GhcSession" state $ useWithStale GhcSession normalizedFilePath - (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath - parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath - let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule - - case ghcSession of - Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> - let nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents - pedits = (nubOrdOn snd . concat $ mkSuggest parsedModuleDynFlags <$> diags) - in - pure $ Right $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits - Nothing -> pure $ Right $ LSP.InL [] - | otherwise = pure $ Right $ LSP.InL [] +mkCodeActionProvider mkSuggest state _plId + (LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do + normalizedFilePath <- getNormalizedFilePathE uri + -- ghc session to get some dynflags even if module isn't parsed + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- + runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath + (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath + parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath + let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule + nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents + pedits = (nubOrdOn snd . concat $ mkSuggest parsedModuleDynFlags <$> diags) + pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits + -- | Add a Pragma to the given URI at the top of the file. @@ -203,8 +202,8 @@ completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion _ide _ complParams = do let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument position = complParams ^. L.position - contents <- LSP.getVirtualFile $ toNormalizedUri uri - fmap (Right . LSP.InL) $ case (contents, uriToFilePath' uri) of + contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri + fmap (LSP.InL) $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> result <$> VFS.getCompletionPrefix position cnts where diff --git a/plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal b/plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal index 713e73d79f..2c78974a2e 100644 --- a/plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal +++ b/plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal @@ -33,6 +33,7 @@ library , ghcide == 2.1.0.0 , hls-graph , hls-plugin-api == 2.1.0.0 + , lens , lsp , text , unordered-containers diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs index a33d95cfcf..55692825b2 100644 --- a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +++ b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs @@ -7,6 +7,7 @@ module Ide.Plugin.QualifyImportedNames (descriptor) where +import Control.Lens ((^.)) import Control.Monad (foldM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.State.Strict (State) @@ -18,10 +19,11 @@ import qualified Data.HashMap.Strict as HashMap import Data.List (sortOn) import qualified Data.List as List import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text (Text) import qualified Data.Text as Text import Development.IDE (spanContainsRange) +import Development.IDE.Core.PluginUtils import Development.IDE.Core.RuleTypes (GetFileContents (GetFileContents), GetHieAst (GetHieAst), HieAstResult (HAR, refMap), @@ -59,11 +61,15 @@ import Development.IDE.Types.Location (NormalizedFilePath, Position (Position), Range (Range), Uri, toNormalizedUri) +import Ide.Plugin.Error (PluginError (PluginRuleFailed), + getNormalizedFilePathE, + handleMaybe, handleMaybeM) import Ide.Types (PluginDescriptor (pluginHandlers), PluginId, PluginMethodHandler, defaultPluginDescriptor, mkPluginHandler) +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction), SMethod (SMethod_TextDocumentCodeAction)) import Language.LSP.Protocol.Types (CodeAction (CodeAction, _command, _data_, _diagnostics, _disabled, _edit, _isPreferred, _kind, _title), @@ -108,20 +114,6 @@ makeCodeActions uri textEdits = [InR CodeAction {..} | not (null textEdits)] _data_ = Nothing _changeAnnotations = Nothing -getTypeCheckedModule :: IdeState -> NormalizedFilePath -> IO (Maybe TcModuleResult) -getTypeCheckedModule ideState normalizedFilePath = - runAction "QualifyImportedNames.TypeCheck" ideState (use TypeCheck normalizedFilePath) - -getHieAst :: IdeState -> NormalizedFilePath -> IO (Maybe HieAstResult) -getHieAst ideState normalizedFilePath = - runAction "QualifyImportedNames.GetHieAst" ideState (use GetHieAst normalizedFilePath) - -getSourceText :: IdeState -> NormalizedFilePath -> IO (Maybe Text) -getSourceText ideState normalizedFilePath = do - fileContents <- runAction "QualifyImportedNames.GetFileContents" ideState (use GetFileContents normalizedFilePath) - if | Just (_, sourceText) <- fileContents -> pure sourceText - | otherwise -> pure Nothing - data ImportedBy = ImportedBy { importedByAlias :: !ModuleName, importedBySrcSpan :: !SrcSpan @@ -236,22 +228,18 @@ usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers -- 3. For each used name in refMap check whether the name comes from an import -- at the origin of the code action. codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction -codeActionProvider ideState pluginId (CodeActionParams _ _ documentId range context) - | TextDocumentIdentifier uri <- documentId - , Just normalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) = liftIO $ do - tcModuleResult <- getTypeCheckedModule ideState normalizedFilePath - if | Just TcModuleResult { tmrParsed, tmrTypechecked } <- tcModuleResult - , Just _ <- findLImportDeclAt range tmrParsed -> do - hieAstResult <- getHieAst ideState normalizedFilePath - sourceText <- getSourceText ideState normalizedFilePath - if | Just HAR {..} <- hieAstResult - , Just sourceText <- sourceText - , let globalRdrEnv = tcg_rdr_env tmrTypechecked - , let nameToImportedByMap = globalRdrEnvToNameToImportedByMap globalRdrEnv - , let usedIdentifiers = refMapToUsedIdentifiers refMap - , let textEdits = usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers -> - pure $ Right $ InL (makeCodeActions uri textEdits) - | otherwise -> pure $ Right $ InL [] - | otherwise -> pure $ Right $ InL [] - | otherwise = pure $ Right $ InL [] +codeActionProvider ideState pluginId (CodeActionParams _ _ documentId range context) = do + normalizedFilePath <- getNormalizedFilePathE (documentId ^. L.uri) + TcModuleResult { tmrParsed, tmrTypechecked } <- runActionE "QualifyImportedNames.TypeCheck" ideState $ useE TypeCheck normalizedFilePath + if isJust (findLImportDeclAt range tmrParsed) + then do + HAR {..} <- runActionE "QualifyImportedNames.GetHieAst" ideState (useE GetHieAst normalizedFilePath) + (_, sourceTextM) <- runActionE "QualifyImportedNames.GetFileContents" ideState (useE GetFileContents normalizedFilePath) + sourceText <- handleMaybe (PluginRuleFailed "GetFileContents") sourceTextM + let globalRdrEnv = tcg_rdr_env tmrTypechecked + nameToImportedByMap = globalRdrEnvToNameToImportedByMap globalRdrEnv + usedIdentifiers = refMapToUsedIdentifiers refMap + textEdits = usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers + pure $ InL (makeCodeActions (documentId ^. L.uri) textEdits) + else pure $ InL [] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 4990b6ce83..4e5d1c3dba 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -22,6 +22,7 @@ import Control.Arrow (second, import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra import Control.Monad.IO.Class +import Control.Monad.Trans import Control.Monad.Trans.Maybe import Data.Char import qualified Data.DList as DL @@ -123,7 +124,7 @@ import Language.Haskell.GHC.ExactPrint.Types (Annotation ( -- | Generate code actions. codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics= xs}) = do - contents <- LSP.getVirtualFile $ toNormalizedUri uri + contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri liftIO $ do let text = Rope.toText . (_file_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri @@ -132,7 +133,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod let actions = caRemoveRedundantImports parsedModule text diag xs uri <> caRemoveInvalidExports parsedModule text diag xs uri - pure $ Right $ InL $ actions + pure $ InL $ actions ------------------------------------------------------------------------------------------------- diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 8fce494cb5..b70e85b1f6 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -36,7 +36,6 @@ import Development.IDE.Plugin.TypeLenses (GetGlobalBindingT import Development.IDE.Spans.LocalBindings (Bindings) import Development.IDE.Types.Exports (ExportsMap) import Development.IDE.Types.Options (IdeOptions) -import Ide.Plugin.Config (Config) import Ide.Plugin.Error (PluginError) import Ide.Types import Language.LSP.Protocol.Message @@ -99,9 +98,8 @@ mkGhcideCAPlugin codeAction plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction $ \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = diags}) -> do - results <- runGhcideCodeAction state params codeAction + results <- lift $ runGhcideCodeAction state params codeAction pure $ - Right $ InL [ mkCA title kind isPreferred diags edit | (title, kind, isPreferred, tedit) <- results, diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 1e8732c0e3..309ad1e71e 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -114,7 +114,7 @@ lensProvider -- haskell-lsp provides conversion functions | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ do - mbRefinedImports <- + mbRefinedImports <- runIde state $ useWithStale RefineImports nfp case mbRefinedImports of -- Implement the provider logic: @@ -126,10 +126,10 @@ lensProvider | (imp, Just refinedImports) <- result , Just edit <- [mkExplicitEdit posMapping imp refinedImports] ] - return $ Right (InL $ catMaybes commands) - _ -> return $ Right (InL []) + return $ (InL $ catMaybes commands) + _ -> return $ (InL []) | otherwise = - return $ Right (InL []) + return $ (InL []) -- | Provide one code action to refine all imports codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction @@ -145,7 +145,7 @@ codeActionProvider ideState _pId (CodeActionParams _ _ docId range _context) any (within range) rangesImports _ -> False if not insideImport - then return (Right (InL [])) + then return (InL []) else do mbRefinedImports <- runIde ideState $ use RefineImports nfp let edits = @@ -167,9 +167,9 @@ codeActionProvider ideState _pId (CodeActionParams _ _ docId range _context) _disabled = Nothing _data_ = Nothing _changeAnnotations = Nothing - return $ Right $ InL [caExplicitImports | not (null edits)] + return $ InL [caExplicitImports | not (null edits)] | otherwise = - return $ Right $ InL [] + return $ InL [] -------------------------------------------------------------------------------- diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 680d317a95..899da77f12 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -38,6 +38,7 @@ library , lens , lsp , lsp-types + , mtl , mod , syb , text diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 35a178eec3..60384b2f42 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -20,6 +20,7 @@ import GHC.Parser.Annotation (AnnContext, AnnList, import Compat.HieTypes import Control.Lens ((^.)) import Control.Monad +import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except @@ -71,8 +72,7 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultP } renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename -renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier uri) pos newNameText) = - runExceptT $ do +renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier uri) pos newNameText) = do nfp <- getNormalizedFilePathE uri directOldNames <- getNamesAtPos state nfp pos directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames @@ -92,7 +92,7 @@ renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier -- Validate rename crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames - when (any isBuiltInSyntax oldNames) $ throwE $ PluginInternalError "Invalid rename of built-in syntax" + when (any isBuiltInSyntax oldNames) $ throwError $ PluginInternalError "Invalid rename of built-in syntax" -- Perform rename let newName = mkTcOcc $ T.unpack newNameText @@ -117,10 +117,10 @@ failWhenImportOrExport state nfp refLocs names = do 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 $ PluginInternalError "Renaming of an imported name is unsupported" + -> throwError $ PluginInternalError "Renaming of an imported name is unsupported" (_, Just (L _ exports)) | any ((`HS.member` refLocs) . unsafeSrcSpanToLoc . getLoc) exports - -> throwE $ PluginInternalError "Renaming of an exported name is unsupported" - (Just _, Nothing) -> throwE $ PluginInternalError "Explicit export list required for renaming" + -> throwError $ PluginInternalError "Renaming of an exported name is unsupported" + (Just _, Nothing) -> throwError $ PluginInternalError "Explicit export list required for renaming" _ -> pure () --------------------------------------------------------------------------------------------------- diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index 94c965047c..48473d85e7 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -35,6 +35,7 @@ library , lens , lsp , lsp-types + , mtl , retrie >=0.1.1.0 , safe-exceptions , stm diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 380b20c554..bed408faa1 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -26,10 +26,12 @@ import Control.Exception.Safe (Exception (..), catch, throwIO, try) import Control.Lens.Operators import Control.Monad (forM, unless, when) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.Except (ExceptT (ExceptT), - runExceptT, throwE) +import Control.Monad.Except (ExceptT (..), + MonadIO (liftIO), + MonadTrans (lift), forM, + runExceptT, throwError, + unless, when) + import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.Strict import Data.Aeson (FromJSON (..), @@ -268,7 +270,7 @@ runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = runExceptT $ do fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange - when (null inlineRewrite) $ throwE $ PluginInternalError "Empty rewrite" + when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite" let ShakeExtras{..} = shakeExtras state (session, _) <- runActionE "retrie" state $ useWithStaleE GhcSessionDeps nfp @@ -276,8 +278,8 @@ runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = runExceptT $ do result <- liftIO $ try @_ @SomeException $ runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp case result of - Left err -> throwE $ PluginInternalError $ "Retrie - crashed with: " <> T.pack (show err) - Right (_,_,NoChange) -> throwE $ PluginInternalError "Retrie - inline produced no changes" + Left err -> throwError $ PluginInternalError $ "Retrie - crashed with: " <> T.pack (show err) + Right (_,_,NoChange) -> throwError $ PluginInternalError "Retrie - inline produced no changes" Right (_,_,Change replacements imports) -> do let edits = asEditMap $ asTextEdits $ Change ourReplacement imports wedit = WorkspaceEdit (Just edits) Nothing Nothing @@ -338,7 +340,7 @@ extractImports _ _ _ = [] ------------------------------------------------------------------------------- provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction -provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = runExceptT $ do +provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = do let (LSP.CodeActionContext _diags _monly _) = ca nfp <- getNormalizedFilePathE uri diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index e4bf4a1573..96a5131a01 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -47,6 +47,7 @@ library , hls-refactor-plugin , lens , lsp + , mtl , retrie , syb , text diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 558c56c4dc..cdaf9793a7 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -31,10 +31,10 @@ import qualified Control.Foldl as L import Control.Lens (Identity (..), ix, view, (%~), (<&>), (^.)) import Control.Monad +import Control.Monad.Except import Control.Monad.Extra (eitherM) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Unlift -import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Aeson hiding (Null) @@ -104,7 +104,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp (TcModuleResult {..}, _) <- maybe - (throwE "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." + (throwError "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." ) pure mresl reportEditor @@ -154,7 +154,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do verTxtDocId (graft (RealSrcSpan spliceSpan Nothing) expanded) ps - maybe (throwE "No splice information found") (either throwE pure) $ + maybe (throwError "No splice information found") (either throwError pure) $ case spliceContext of Expr -> graftSpliceWith exprSuperSpans Pat -> @@ -486,8 +486,8 @@ fromSearchResult _ = Nothing -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction state plId (CodeActionParams _ _ docId ran _) = do - verTxtDocId <- getVersionedTextDoc docId - liftIO $ fmap (maybe (Right $ InL []) Right) $ + verTxtDocId <- lift $ getVersionedTextDoc docId + liftIO $ fmap (fromMaybe ( InL [])) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri ParsedModule {..} <- diff --git a/plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal b/plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal index 765bd70697..f3d58aab1a 100644 --- a/plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal +++ b/plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal @@ -31,6 +31,7 @@ library , ghcide == 2.1.0.0 , hls-plugin-api == 2.1.0.0 , lsp-types + , mtl , stylish-haskell ^>=0.12 || ^>=0.13 || ^>=0.14.2 , text diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index de2a2df503..9a2aff6908 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -1,23 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.StylishHaskell ( descriptor , provider ) where +import Control.Monad.Except (throwError) import Control.Monad.IO.Class -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts), - extensionFlags) -import qualified Development.IDE.GHC.Compat.Util as Util +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PluginUtils +import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts), + extensionFlags) +import qualified Development.IDE.GHC.Compat.Util as Util import GHC.LanguageExtensions.Type -import Ide.Plugin.Error (PluginError (PluginInternalError)) +import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.PluginUtils -import Ide.Types hiding (Config) +import Ide.Types hiding (Config) import Language.Haskell.Stylish -import Language.LSP.Protocol.Types as LSP +import Language.LSP.Protocol.Types as LSP import System.Directory import System.FilePath @@ -31,7 +34,7 @@ descriptor plId = (defaultPluginDescriptor plId) -- If the provider fails an error is returned that can be displayed to the user. provider :: FormattingHandler IdeState provider ide typ contents fp _opts = do - dyn <- fmap (ms_hspp_opts . msrModSummary) $ liftIO $ runAction "stylish-haskell" ide $ use_ GetModSummary fp + (msrModSummary -> ms_hspp_opts -> dyn) <- runActionE "stylish-haskell" ide $ useE GetModSummary fp let file = fromNormalizedFilePath fp config <- liftIO $ loadConfigFrom file mergedConfig <- liftIO $ getMergedConfig dyn config @@ -40,8 +43,8 @@ provider ide typ contents fp _opts = do FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents) result = runStylishHaskell file mergedConfig selectedContents case result of - Left err -> return $ Left $ PluginInternalError $ T.pack $ "stylishHaskellCmd: " ++ err - Right new -> return $ Right $ LSP.InL [TextEdit range new] + Left err -> throwError $ PluginInternalError $ T.pack $ "stylishHaskellCmd: " ++ err + Right new -> pure $ LSP.InL [TextEdit range new] where getMergedConfig dyn config | null (configLanguageExtensions config) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index dde474e4da..e1308b6e92 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -10,7 +10,7 @@ module Wingman.AbstractLSP (installInteractions) where import Control.Monad (void) import Control.Monad.IO.Class import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) +import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT) import qualified Data.Aeson as A import Data.Coerce import Data.Foldable (traverse_) @@ -173,8 +173,8 @@ codeActionProvider -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider sort k state plId (CodeActionParams _ _ docId range _) = do - verTxtDocId <- getVersionedTextDoc docId - fromMaybeT (Right $ InL []) $ do + verTxtDocId <- lift $ getVersionedTextDoc docId + handleMaybeM (PluginDependencyFailed "codeActionProvider") $ runMaybeT $ do let fc = FileContext { fc_verTxtDocId = verTxtDocId , fc_range = Just $ unsafeMkCurrent range @@ -183,7 +183,6 @@ codeActionProvider sort k state plId args <- fetchTargetArgs @target env actions <- k env args pure - $ Right $ InL $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions @@ -201,8 +200,8 @@ codeLensProvider -> PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider sort k state plId (CodeLensParams _ _ docId) = do - verTxtDocId <- getVersionedTextDoc docId - fromMaybeT (Right $ InL []) $ do + verTxtDocId <- lift $ getVersionedTextDoc docId + handleMaybeM (PluginDependencyFailed "codeLensProvider") $ runMaybeT $ do let fc = FileContext { fc_verTxtDocId = verTxtDocId , fc_range = Nothing @@ -211,7 +210,6 @@ codeLensProvider sort k state plId args <- fetchTargetArgs @target env actions <- k env args pure - $ Right $ InL $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs index 6f6ca119f0..8f55ee2143 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs @@ -37,24 +37,23 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr stale = unsafeRunStaleIdeFast "hoverProvider" state nfp cfg <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId) - (fmap . fmap) maybeToNull <$> liftIO $ fromMaybeT (Right Nothing) $ do + liftIO $ fromMaybeT (InR Null) $ do holes <- stale GetMetaprograms - fmap (Right . Just) $ - case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of - Just (trss, program) -> do - let tr_range = fmap realSrcSpanToRange trss - rsl = realSrcSpanStart $ unTrack trss - HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg - z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program - pure $ Hover - { _contents = InL - $ MarkupContent MarkupKind_Markdown - $ either T.pack T.pack z - , _range = Just $ unTrack tr_range - } - Nothing -> empty -hoverProvider _ _ _ = pure $ Right $ InR Null + case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of + Just (trss, program) -> do + let tr_range = fmap realSrcSpanToRange trss + rsl = realSrcSpanStart $ unTrack trss + HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg + z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program + pure $ InL $ Hover + { _contents = InL + $ MarkupContent MarkupKind_Markdown + $ either T.pack T.pack z + , _range = Just $ unTrack tr_range + } + Nothing -> empty +hoverProvider _ _ _ = pure $ InR Null fromMaybeT :: Functor m => a -> MaybeT m a -> m a fromMaybeT def = fmap (fromMaybe def) . runMaybeT From d415379eac0fd44a6aaa10b1c3c9d60888c7e136 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 28 Jul 2023 17:10:27 +0300 Subject: [PATCH 11/28] more improvements --- .../src/Development/IDE/Core/PluginUtils.hs | 18 ++++----- hls-plugin-api/src/Ide/Plugin/Error.hs | 40 +++++++++---------- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 4 +- hls-plugin-api/src/Ide/Types.hs | 6 ++- .../src/Ide/Plugin/Class/CodeAction.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 2 +- .../old/src/Wingman/AbstractLSP.hs | 4 +- 7 files changed, 40 insertions(+), 36 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index 9cf4897a0f..50bc07dab3 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -95,37 +95,37 @@ uriToFilePathMT = MaybeT . pure . Location.uriToFilePath' -- PositionMapping wrappers -- ---------------------------------------------------------------------------- --- |ExceptT version of `toCurrentPosition` that throws a PluginDependencyFailed +-- |ExceptT version of `toCurrentPosition` that throws a PluginInvalidUserState -- upon failure toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position -toCurrentPositionE mapping = maybeToExceptT (PluginDependencyFailed "toCurrentPosition"). toCurrentPositionMT mapping +toCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentPosition"). toCurrentPositionMT mapping -- |MaybeT version of `toCurrentPosition` toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position toCurrentPositionMT mapping = MaybeT . pure . toCurrentPosition mapping --- |ExceptT version of `fromCurrentPosition` that throws a PluginDependencyFailed --- upon failure +-- |ExceptT version of `fromCurrentPosition` that throws a +-- PluginInvalidUserState upon failure fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position -fromCurrentPositionE mapping = maybeToExceptT (PluginDependencyFailed "fromCurrentPosition") . fromCurrentPositionMT mapping +fromCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentPosition") . fromCurrentPositionMT mapping -- |MaybeT version of `fromCurrentPosition` fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position fromCurrentPositionMT mapping = MaybeT . pure . fromCurrentPosition mapping --- |ExceptT version of `toCurrentRange` that throws a PluginDependencyFailed +-- |ExceptT version of `toCurrentRange` that throws a PluginInvalidUserState -- upon failure toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range -toCurrentRangeE mapping = maybeToExceptT (PluginDependencyFailed "toCurrentRange") . toCurrentRangeMT mapping +toCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentRange") . toCurrentRangeMT mapping -- |MaybeT version of `toCurrentRange` toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range toCurrentRangeMT mapping = MaybeT . pure . toCurrentRange mapping --- |ExceptT version of `fromCurrentRange` that throws a PluginDependencyFailed +-- |ExceptT version of `fromCurrentRange` that throws a PluginInvalidUserState -- upon failure fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range -fromCurrentRangeE mapping = maybeToExceptT (PluginDependencyFailed "fromCurrentRange") . fromCurrentRangeMT mapping +fromCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentRange") . fromCurrentRangeMT mapping -- |MaybeT version of `fromCurrentRange` fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index 2db08af463..c027e44b53 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -36,9 +36,9 @@ import Language.LSP.Protocol.Types -- Then we have PluginInvalidParams, which along with PluginInternalError map -- to a corresponding ResponseError. -- --- Next we have PluginRuleFailed and PluginDependencyFailed, with the only +-- Next we have PluginRuleFailed and PluginInvalidUserState, with the only -- difference being PluginRuleFailed is specific to Shake rules and --- PluginDependencyFailed can be used for everything else. Both of these are +-- PluginInvalidUserState can be used for everything else. Both of these are -- "non-errors", and happen whenever the user's code is in a state where the -- plugin is unable to provide a answer to the users request. PluginStaleResolve -- is similar to the above two Error types, but is specific to resolve plugins, @@ -55,8 +55,8 @@ data PluginError -- All uncaught exceptions will be caught and converted to this error. -- -- This error will be be converted into an InternalError response code. It - -- takes the highest precedence (1) in being returned as a response to the - -- client. + -- will be logged with Error and takes the highest precedence (1) in being + -- returned as a response to the client. PluginInternalError T.Text -- |PluginInvalidParams should be used if the parameters of the request are -- invalid. This error means that there is a bug in the client's code @@ -64,20 +64,20 @@ data PluginError -- parameters). -- -- This error will be will be converted into a InvalidParams response code. - -- It takes medium precedence (2) in being returned as a response to the - -- client. + -- It will be logged with Warning and takes medium precedence (2) in being + -- returned as a response to the client. | PluginInvalidParams T.Text - -- |PluginDependencyFailed should be thrown when a function that your plugin + -- |PluginInvalidUserState should be thrown when a function that your plugin -- depends on fails. This should only be used when the function fails - -- because the files the user is working on is in an invalid state. + -- because the user's code is in an invalid state. -- -- This error takes the name of the function that failed. Prefer to catch -- this error as close to the source as possible. -- -- This error will be logged with Debug, and will be converted into a - -- ContentModified response. It takes a low precedence (3) in being returned + -- RequestFailed response. It takes a low precedence (3) in being returned -- as a response to the client. - | PluginDependencyFailed T.Text + | PluginInvalidUserState T.Text -- |PluginRequestRefused allows your handler to inspect a request before -- rejecting it. In effect it allows your plugin to act make a secondary -- `pluginEnabled` decision after receiving the request. This should only be @@ -93,7 +93,7 @@ data PluginError -- This error takes the name of the Rule that failed. -- -- This error will be logged with Debug, and will be converted into a - -- ContentModified response code. It takes a low precedence (3) in being + -- RequestFailed response code. It takes a low precedence (3) in being -- returned as a response to the client. | PluginRuleFailed T.Text -- |PluginStaleResolve should be thrown when your resolve request is @@ -106,28 +106,28 @@ data PluginError instance Pretty PluginError where pretty = \case - PluginInternalError msg -> "Internal Error:" <+> pretty msg - PluginStaleResolve -> "Stale Resolve" - PluginRuleFailed rule -> "Rule Failed:" <+> pretty rule - PluginInvalidParams text -> "Invalid Params:" <+> pretty text - PluginDependencyFailed text -> "Dependency Failed:" <+> pretty text - PluginRequestRefused msg -> "Request Refused: " <+> pretty msg + PluginInternalError msg -> "Internal Error:" <+> pretty msg + PluginStaleResolve -> "Stale Resolve" + PluginRuleFailed rule -> "Rule Failed:" <+> pretty rule + PluginInvalidParams text -> "Invalid Params:" <+> pretty text + PluginInvalidUserState text -> "Dependency Failed:" <+> pretty text + PluginRequestRefused msg -> "Request Refused: " <+> pretty msg toErrorCode :: PluginError -> (LSPErrorCodes |? ErrorCodes) toErrorCode (PluginInternalError _) = InR ErrorCodes_InternalError toErrorCode (PluginInvalidParams _) = InR ErrorCodes_InvalidParams -toErrorCode (PluginDependencyFailed _) = InL LSPErrorCodes_ContentModified +toErrorCode (PluginInvalidUserState _) = InL LSPErrorCodes_RequestFailed -- PluginRequestRefused should never be a argument to `toResponseError`, as -- it should be dealt with in `extensiblePlugins`, but this is here to make -- this function complete toErrorCode (PluginRequestRefused _) = InR ErrorCodes_MethodNotFound -toErrorCode (PluginRuleFailed _) = InL LSPErrorCodes_ContentModified +toErrorCode (PluginRuleFailed _) = InL LSPErrorCodes_RequestFailed toErrorCode PluginStaleResolve = InL LSPErrorCodes_ContentModified toPriority :: PluginError -> Priority toPriority (PluginInternalError _) = Error toPriority (PluginInvalidParams _) = Warning -toPriority (PluginDependencyFailed _) = Debug +toPriority (PluginInvalidUserState _) = Debug toPriority (PluginRequestRefused _) = Debug toPriority (PluginRuleFailed _) = Debug toPriority PluginStaleResolve = Debug diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index d8fd731e63..69451875b9 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -12,7 +12,9 @@ mkCodeActionWithResolveAndCommand) where import Control.Lens (_Just, (&), (.~), (?~), (^.), (^?)) -import Control.Monad.Except +import Control.Monad.Except (ExceptT (..), + MonadError (throwError)) +import Control.Monad.Trans.Class (lift) import qualified Data.Aeson as A import Data.Maybe (catMaybes) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 65faae6621..5f6e409d72 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -57,7 +57,8 @@ module Ide.Types import qualified System.Win32.Process as P (getCurrentProcessId) #else import Control.Monad (void) -import Control.Monad.Except (lift, throwError) +import Control.Monad.Except (throwError) +import Control.Monad.Trans.Class (lift) import qualified System.Posix.Process as P (getProcessID) import System.Posix.Signals #endif @@ -74,6 +75,7 @@ import Data.GADT.Compare import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Kind (Type) import Data.List.Extra (find, sortOn) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map @@ -258,7 +260,7 @@ instance ToJSON PluginConfig where -- --------------------------------------------------------------------- -data PluginDescriptor (ideState :: *) = +data PluginDescriptor (ideState :: Type) = PluginDescriptor { pluginId :: !PluginId -- ^ Unique identifier of the plugin. , pluginPriority :: Natural 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 cc5ad26e2f..6d6cdd37f9 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -99,7 +99,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do mkActions docPath verTxtDocId diag = do (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state $ useWithStaleE GetHieAst docPath - instancePosition <- handleMaybe (PluginDependencyFailed "fromCurrentRange") $ + instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $ fromCurrentRange pmap range ^? _Just . L.start & fmap (L.character -~ 1) ident <- findClassIdentifier ast instancePosition 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 34d0bcb784..e5c1123a13 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -111,7 +111,7 @@ getSelectionRanges ide file positions = do in fromMaybe defaultSelectionRange . findPosition pos $ codeRange -- 'positionMapping' should be applied to the output ranges before returning them - maybeToExceptT (PluginDependencyFailed "toCurrentSelectionRange") . MaybeT . pure $ + maybeToExceptT (PluginInvalidUserState "toCurrentSelectionRange") . MaybeT . pure $ InL <$> traverse (toCurrentSelectionRange positionMapping) selectionRanges -- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index e1308b6e92..9cc50831a4 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -174,7 +174,7 @@ codeActionProvider codeActionProvider sort k state plId (CodeActionParams _ _ docId range _) = do verTxtDocId <- lift $ getVersionedTextDoc docId - handleMaybeM (PluginDependencyFailed "codeActionProvider") $ runMaybeT $ do + handleMaybeM (PluginInvalidUserState "codeActionProvider") $ runMaybeT $ do let fc = FileContext { fc_verTxtDocId = verTxtDocId , fc_range = Just $ unsafeMkCurrent range @@ -201,7 +201,7 @@ codeLensProvider codeLensProvider sort k state plId (CodeLensParams _ _ docId) = do verTxtDocId <- lift $ getVersionedTextDoc docId - handleMaybeM (PluginDependencyFailed "codeLensProvider") $ runMaybeT $ do + handleMaybeM (PluginInvalidUserState "codeLensProvider") $ runMaybeT $ do let fc = FileContext { fc_verTxtDocId = verTxtDocId , fc_range = Nothing From e618d7e208de50a7a45c701002e99d11e0de71ce Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 28 Jul 2023 17:32:25 +0300 Subject: [PATCH 12/28] window build fix attempt --- ghcide/src/Development/IDE/Plugin/HLS.hs | 2 +- hls-plugin-api/src/Ide/Types.hs | 4 ++-- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 5 ++++- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 65ea6f4aa8..a7767b796d 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -261,7 +261,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c) noPluginEnabled m fs' = do logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError (InR ErrorCodes_InvalidParams) msg Nothing + let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing msg = pluginNotEnabled m fs' return $ Left err diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 5f6e409d72..3990d83d0f 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -57,8 +57,8 @@ module Ide.Types import qualified System.Win32.Process as P (getCurrentProcessId) #else import Control.Monad (void) -import Control.Monad.Except (throwError) -import Control.Monad.Trans.Class (lift) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.Trans.Class (MonadTrans (lift)) import qualified System.Posix.Process as P (getProcessID) import System.Posix.Signals #endif diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 48d9aaeead..3a11141df6 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -43,7 +43,10 @@ import Control.DeepSeq import Control.Exception import Control.Lens ((?~), (^.)) import Control.Monad -import Control.Monad.Except +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..)) import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)) From 6fee73f3f5fb48b99c4923b0e3fd0906a26d0329 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 28 Jul 2023 18:13:47 +0300 Subject: [PATCH 13/28] Fix stack and windows builds --- .../src/Development/IDE/Plugin/Completions.hs | 3 ++- hls-plugin-api/src/Ide/Plugin/Error.hs | 5 +---- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 4 ++-- hls-plugin-api/src/Ide/Types.hs | 13 ++++++++---- .../src/Ide/Plugin/Class/CodeAction.hs | 3 ++- .../src/Ide/Plugin/Eval/CodeLens.hs | 6 +++--- .../src/Ide/Plugin/ExplicitImports.hs | 6 +++--- .../src/Ide/Plugin/ExplicitFields.hs | 5 ++--- .../hls-fourmolu-plugin.cabal | 1 + .../src/Ide/Plugin/Fourmolu.hs | 14 +++++++------ .../hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 8 ++++++- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 3 ++- .../src/Ide/Plugin/Retrie.hs | 9 ++++---- .../src/Ide/Plugin/Splice.hs | 21 +++++++++++++------ 14 files changed, 61 insertions(+), 40 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index c5d17912e7..2157a83511 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -12,8 +12,9 @@ module Development.IDE.Plugin.Completions import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) import Control.Lens ((&), (.~)) -import Control.Monad.Except (ExceptT (ExceptT)) import Control.Monad.IO.Class +import Control.Monad.Trans.Except (ExceptT (ExceptT), + withExceptT) import Data.Aeson import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index c027e44b53..e54d7583bf 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -6,8 +6,6 @@ module Ide.Plugin.Error ( PluginError(..), toErrorCode, toPriority, - runExceptT, - withExceptT, handleMaybe, handleMaybeM, getNormalizedFilePathE, @@ -15,8 +13,7 @@ module Ide.Plugin.Error ( import Control.Monad.Extra (maybeM) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE, - withExceptT) +import Control.Monad.Trans.Except (ExceptT (..), throwE) import qualified Data.Text as T import Ide.Logger import Language.LSP.Protocol.Types diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 69451875b9..f24b82d5f9 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -12,9 +12,9 @@ mkCodeActionWithResolveAndCommand) where import Control.Lens (_Just, (&), (.~), (?~), (^.), (^?)) -import Control.Monad.Except (ExceptT (..), - MonadError (throwError)) +import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import qualified Data.Aeson as A import Data.Maybe (catMaybes) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 3990d83d0f..e47d24c54b 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -54,18 +54,23 @@ module Ide.Types where #ifdef mingw32_HOST_OS + import qualified System.Win32.Process as P (getCurrentProcessId) + #else -import Control.Monad (void) -import Control.Monad.Error.Class (MonadError (throwError)) -import Control.Monad.Trans.Class (MonadTrans (lift)) + import qualified System.Posix.Process as P (getProcessID) import System.Posix.Signals + #endif + import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Lens (_Just, (.~), (?~), (^.), (^?)) -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad (void) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.Aeson hiding (Null, defaultOptions) import Data.Default import Data.Dependent.Map (DMap) 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 6d6cdd37f9..e4d41ff39f 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -6,10 +6,11 @@ module Ide.Plugin.Class.CodeAction where import Control.Lens hiding (List, use) -import Control.Monad.Except (ExceptT, throwError) +import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Extra import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Maybe import Data.Aeson hiding (Null) import Data.Bifunctor (second) 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 01cef7d950..c84be7c50b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -32,7 +32,8 @@ import Control.Lens (_1, _3, ix, (%~), import Control.Monad (guard, void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except (ExceptT (..)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) import Data.Aeson (toJSON) import Data.Char (isSpace) import Data.Foldable (toList) @@ -103,8 +104,7 @@ import GHC.Types.SrcLoc (UnhelpfulSpanReas #endif import Ide.Plugin.Error (PluginError (PluginInternalError), handleMaybe, - handleMaybeM, - runExceptT) + handleMaybeM) import Ide.Plugin.Eval.Code (Statement, asStatements, myExecStmt, diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index de5e847d49..ca40dc8b12 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -20,10 +20,10 @@ module Ide.Plugin.ExplicitImports import Control.DeepSeq import Control.Lens ((&), (?~)) -import Control.Monad.Except (throwError) +import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Maybe import qualified Data.Aeson as A (ToJSON (toJSON)) import Data.Aeson.Types (FromJSON) @@ -46,7 +46,7 @@ import Development.IDE.Graph.Classes import GHC.Generics (Generic) import Ide.Plugin.Error (PluginError (..), getNormalizedFilePathE, - handleMaybe, runExceptT) + handleMaybe) import Ide.Plugin.RangeMap (filterByRange) import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) import Ide.Plugin.Resolve 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 afa7e8c619..c604f13b65 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 @@ -17,7 +17,7 @@ module Ide.Plugin.ExplicitFields import Control.Lens ((^.)) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.Functor ((<&>)) import Data.Generics (GenericQ, everything, extQ, mkQ) @@ -62,8 +62,7 @@ import GHC.Generics (Generic) import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) import Ide.Plugin.Error (PluginError, - getNormalizedFilePathE, - runExceptT) + getNormalizedFilePathE) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.Types (PluginDescriptor (..), diff --git a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal index 3da9bddf9e..b0910a071c 100644 --- a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal +++ b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal @@ -42,6 +42,7 @@ library , mtl , process-extras >= 0.7.1 , text + , transformers -- fourmolu 0.9.0 fails to build on Windows CI for reasons unknown if impl(ghc >= 9.2) && os(windows) && impl(ghc < 9.4) diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index 3ab44a9663..b6b46f2426 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -16,13 +16,15 @@ module Ide.Plugin.Fourmolu ( import Control.Exception (IOException, handle, try) import Control.Lens ((^.)) -import Control.Monad -import Control.Monad.Except (ExceptT (..), mapExceptT, - throwError) -import Control.Monad.IO.Class -import Control.Monad.Trans +import Control.Monad (guard) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, + runExceptT) + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Bifunctor (bimap) -import Data.Maybe +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index a954637fad..a68655c2cd 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -10,7 +10,13 @@ module Ide.Plugin.GADT (descriptor) where import Control.Lens ((^.)) -import Control.Monad.Except + +import Control.Monad.Error.Class (MonadError (throwError), + liftEither) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT, runExceptT, + withExceptT) import Data.Aeson (FromJSON, ToJSON, toJSON) import Data.Either.Extra (maybeToEither) import qualified Data.Map as Map diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 3a11141df6..2c02c6c6e0 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -46,7 +46,8 @@ import Control.Monad import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.Except (ExceptT (..)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)) diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index bed408faa1..9752bd221d 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -26,11 +26,10 @@ import Control.Exception.Safe (Exception (..), catch, throwIO, try) import Control.Lens.Operators import Control.Monad (forM, unless, when) -import Control.Monad.Except (ExceptT (..), - MonadIO (liftIO), - MonadTrans (lift), forM, - runExceptT, throwError, - unless, when) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.Strict diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index cdaf9793a7..59bd547445 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -25,17 +25,18 @@ module Ide.Plugin.Splice where import Control.Applicative (Alternative ((<|>))) -import Control.Arrow -import Control.Exception +import Control.Arrow ( Arrow(first) ) +import Control.Exception ( SomeException ) import qualified Control.Foldl as L import Control.Lens (Identity (..), ix, view, (%~), (<&>), (^.)) -import Control.Monad -import Control.Monad.Except +import Control.Monad ( guard, unless, forM ) +import Control.Monad.Error.Class ( MonadError(throwError) ) import Control.Monad.Extra (eitherM) import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Unlift -import Control.Monad.Trans.Except +import Control.Monad.IO.Unlift ( MonadIO(..), askRunInIO ) +import Control.Monad.Trans.Class ( MonadTrans(lift) ) +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT ) import Control.Monad.Trans.Maybe import Data.Aeson hiding (Null) import Data.Foldable (Foldable (foldl')) @@ -52,14 +53,22 @@ import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Transform (TransformT(TransformT)) + #if MIN_VERSION_ghc(9,4,1) + import GHC.Data.Bag (Bag) + #endif + import GHC.Exts + #if MIN_VERSION_ghc(9,2,0) + import GHC.Parser.Annotation (SrcSpanAnn'(..)) import qualified GHC.Types.Error as Error + #endif + import Ide.Plugin.Splice.Types import Ide.Types import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) From 6cbe6d9055c452b6f852bc4247ab4ac5b0eb9d40 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 28 Jul 2023 18:18:38 +0300 Subject: [PATCH 14/28] Fix code-range test --- plugins/hls-code-range-plugin/test/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index d77e26b8f0..8dc0e713fd 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -48,7 +48,7 @@ selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDi let res = resp ^. result pure $ fmap (showSelectionRangesForTest . absorbNull) res case res of - Left (ResponseError (InL LSPErrorCodes_ContentModified) _ _) -> pure "" + Left (ResponseError (InL LSPErrorCodes_RequestFailed) _ _) -> pure "" Left err -> assertFailure (show err) Right golden -> pure golden where From e0bbec18403c8b948e1d1d79b1a51b10a5345aab Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 28 Jul 2023 20:16:06 +0300 Subject: [PATCH 15/28] refactor splice and eval to remove underscore func --- .../src/Development/IDE/Core/PluginUtils.hs | 8 ++++ ghcide/src/Development/IDE/Core/Shake.hs | 28 +++++++++-- hls-plugin-api/src/Ide/Plugin/Error.hs | 10 ++-- .../src/Ide/Plugin/Eval/CodeLens.hs | 20 ++++---- .../src/Ide/Plugin/Splice.hs | 46 +++++++++---------- 5 files changed, 68 insertions(+), 44 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index 50bc07dab3..2b2bf2192b 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -46,6 +46,14 @@ useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v useMT k = MaybeT . Shake.use k +-- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure +usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v) +usesE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . usesMT k + +-- |MaybeT version of `uses` +usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v) +usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs + -- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon -- failure useWithStaleE :: IdeRule k v diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b37c02076c..fbe7b5df29 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -961,17 +961,23 @@ useWithStale :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) 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. +-- |Request a Rule result, it not available return the last computed result +-- which may be stale. -- --- The thrown error is a 'BadDependency' error which is caught by the rule system. +-- Throws an `BadDependency` IO exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead. useWithStale_ :: IdeRule k v => k -> NormalizedFilePath -> Action (v, PositionMapping) useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) --- | Plural version of 'useWithStale_' +-- |Plural version of 'useWithStale_' +-- +-- Throws an `BadDependency` IO exception which is caught by the rule system if +-- none available. -- --- The thrown error is a 'BadDependency' error which is caught by the rule system. +-- WARNING: Not suitable for PluginHandlers. usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do res <- usesWithStale key files @@ -1045,12 +1051,24 @@ useWithStaleFast' key file = do useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath +-- Requests a rule if available. +-- +-- Throws an `BadDependency` IO exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `useE` instead. use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v use_ key file = runIdentity <$> uses_ key (Identity file) useNoFile_ :: IdeRule k v => k -> Action v useNoFile_ key = use_ key emptyFilePath +-- |Plural version of `use_` +-- +-- Throws an `BadDependency` IO exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `usesE` instead. uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v) uses_ key files = do res <- uses key files diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index e54d7583bf..877dc02188 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -103,12 +103,12 @@ data PluginError instance Pretty PluginError where pretty = \case - PluginInternalError msg -> "Internal Error:" <+> pretty msg + PluginInternalError msg -> "Internal Error:" <+> pretty msg PluginStaleResolve -> "Stale Resolve" - PluginRuleFailed rule -> "Rule Failed:" <+> pretty rule - PluginInvalidParams text -> "Invalid Params:" <+> pretty text - PluginInvalidUserState text -> "Dependency Failed:" <+> pretty text - PluginRequestRefused msg -> "Request Refused: " <+> pretty msg + PluginRuleFailed rule -> "Rule Failed:" <+> pretty rule + PluginInvalidParams text -> "Invalid Params:" <+> pretty text + PluginInvalidUserState text -> "Invalid User State:" <+> pretty text + PluginRequestRefused msg -> "Request Refused: " <+> pretty msg toErrorCode :: PluginError -> (LSPErrorCodes |? ErrorCodes) toErrorCode (PluginInternalError _) = InR ErrorCodes_InternalError 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 c84be7c50b..c67a2044a6 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -53,8 +53,6 @@ import Development.IDE.Core.RuleTypes (LinkableResult (l 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, @@ -220,7 +218,7 @@ runEvalCmd plId st EvalParams{..} = liftIO $ queueForEvaluation st nfp liftIO $ setSomethingModified VFSUnmodified st [toKey NeedsCompilation nfp] "Eval" -- Setup a session with linkables for all dependencies and GHCi specific options - final_hscEnv <- liftIO $ initialiseSessionForEval + final_hscEnv <- initialiseSessionForEval (needsQuickCheck tests) st nfp @@ -246,21 +244,21 @@ runEvalCmd plId st EvalParams{..} = -- also be loaded into the environment. -- -- The interactive context and interactive dynamic flags are also set appropiately. -initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv +initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> ExceptT PluginError (LspM Config) HscEnv initialiseSessionForEval needs_quickcheck st nfp = do - (ms, env1) <- runAction "runEvalCmd" st $ do + (ms, env1) <- runActionE "runEvalCmd" st $ do - ms <- msrModSummary <$> use_ GetModSummary nfp - deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp + ms <- msrModSummary <$> useE GetModSummary nfp + deps_hsc <- hscEnv <$> useE GhcSessionDeps nfp - linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp - linkables <- uses_ GetLinkable linkables_needed + linkables_needed <- reachableModules <$> useE GetDependencyInformation nfp + linkables <- usesE GetLinkable linkables_needed -- We unset the global rdr env in mi_globals when we generate interfaces -- See Note [Clearing mi_globals after generating an iface] -- However, the eval plugin (setContext specifically) requires the rdr_env -- for the current module - so get it from the Typechecked Module and add -- it back to the iface for the current module. - rdr_env <- tcg_rdr_env . tmrTypechecked <$> use_ TypeCheck nfp + rdr_env <- tcg_rdr_env . tmrTypechecked <$> useE TypeCheck nfp let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc addRdrEnv hmi | iface <- hm_iface hmi @@ -271,7 +269,7 @@ initialiseSessionForEval needs_quickcheck st nfp = do return (ms, linkable_hsc) -- Bit awkward we need to use evalGhcEnv here but setContext requires to run -- in the Ghc monad - env2 <- evalGhcEnv env1 $ do + env2 <- liftIO $ evalGhcEnv env1 $ do setContext [Compat.IIModule (moduleName (ms_mod ms))] let df = flip xopt_set LangExt.ExtendedDefaultRules . flip xopt_unset LangExt.MonomorphismRestriction diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 59bd547445..62b108f3c0 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -25,20 +25,21 @@ module Ide.Plugin.Splice where import Control.Applicative (Alternative ((<|>))) -import Control.Arrow ( Arrow(first) ) -import Control.Exception ( SomeException ) +import Control.Arrow ( Arrow(first) ) +import Control.Exception ( SomeException ) import qualified Control.Foldl as L import Control.Lens (Identity (..), ix, view, (%~), (<&>), (^.)) -import Control.Monad ( guard, unless, forM ) -import Control.Monad.Error.Class ( MonadError(throwError) ) +import Control.Monad ( guard, unless, forM ) +import Control.Monad.Error.Class ( MonadError(throwError) ) import Control.Monad.Extra (eitherM) import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Unlift ( MonadIO(..), askRunInIO ) -import Control.Monad.Trans.Class ( MonadTrans(lift) ) -import Control.Monad.Trans.Except ( ExceptT(..), runExceptT ) +import Control.Monad.IO.Unlift ( MonadIO(..), askRunInIO ) +import Control.Monad.Trans.Class ( MonadTrans(lift) ) +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT ) import Control.Monad.Trans.Maybe import Data.Aeson hiding (Null) +import qualified Data.Bifunctor as B (first) import Data.Foldable (Foldable (foldl')) import Data.Function import Data.Generics @@ -48,6 +49,7 @@ import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat as Compat hiding (getLoc) import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util @@ -108,12 +110,13 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do rio <- askRunInIO let reportEditor :: ReportEditor reportEditor msgTy msgs = liftIO $ rio $ sendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) + expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit expandManually fp = do mresl <- liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp (TcModuleResult {..}, _) <- maybe - (throwError "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." + (throwError $ PluginInternalError "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." ) pure mresl reportEditor @@ -121,10 +124,8 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do [ "Expansion in type-checking phase failed;" , "trying to expand manually, but note that it is less rigorous." ] - pm <- - liftIO $ - runAction "expandTHSplice.fallback.GetParsedModule" ideState $ - use_ GetParsedModule fp + pm <- runActionE "expandTHSplice.fallback.GetParsedModule" ideState $ + useE GetParsedModule fp (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm manualCalcEdit @@ -163,7 +164,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do verTxtDocId (graft (RealSrcSpan spliceSpan Nothing) expanded) ps - maybe (throwError "No splice information found") (either throwError pure) $ + maybe (throwError $ PluginInternalError "No splice information found") (either (throwError . PluginInternalError . T.pack) pure) $ case spliceContext of Expr -> graftSpliceWith exprSuperSpans Pat -> @@ -197,13 +198,13 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do Left err -> do reportEditor MessageType_Error - ["Error during expanding splice: " <> T.pack err] - pure (Left $ PluginInternalError $ T.pack err) + [T.pack $ "Error during expanding splice: " <> show (pretty err)] + pure (Left err) Right edits -> pure (Right edits) case res of Nothing -> pure $ Right $ InR Null - Just (Left err) -> pure $ Left err + Just (Left err) -> pure $ Left $ err Just (Right edit) -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) pure $ Right $ InR Null @@ -217,12 +218,10 @@ setupHscEnv :: IdeState -> NormalizedFilePath -> ParsedModule - -> ExceptT String IO (Annotated ParsedSource, HscEnv, DynFlags) + -> ExceptT PluginError IO (Annotated ParsedSource, HscEnv, DynFlags) setupHscEnv ideState fp pm = do - hscEnvEq <- - liftIO $ - runAction "expandTHSplice.fallback.ghcSessionDeps" ideState $ - use_ GhcSessionDeps fp + hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $ + useE GhcSessionDeps fp let ps = annotateParsedSource pm hscEnv0 = hscEnvWithImportPaths hscEnvEq modSum = pm_mod_summary pm @@ -379,7 +378,7 @@ manualCalcEdit :: RealSrcSpan -> ExpandStyle -> ExpandSpliceParams -> - ExceptT String IO WorkspaceEdit + ExceptT PluginError IO WorkspaceEdit manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do (warns, resl) <- ExceptT $ do @@ -420,7 +419,8 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e #else msgs #endif - pure $ (warns,) <$> fromMaybe (Left $ showErrors errs) eresl + pure $ (warns,) <$> maybe (throwError $ PluginInternalError $ T.pack $ showErrors errs) + (B.first (PluginInternalError . T.pack)) eresl unless (null warns) From 6102e6b57120be5a4aa4ba57cd51f012b0a5118b Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 28 Jul 2023 21:09:41 +0300 Subject: [PATCH 16/28] Fix hls-tactics-plugin test --- plugins/hls-tactics-plugin/old/test/Utils.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/plugins/hls-tactics-plugin/old/test/Utils.hs b/plugins/hls-tactics-plugin/old/test/Utils.hs index b36c5b54e1..cedef8e1d6 100644 --- a/plugins/hls-tactics-plugin/old/test/Utils.hs +++ b/plugins/hls-tactics-plugin/old/test/Utils.hs @@ -87,19 +87,20 @@ mkTest -> SpecWith (Arg Bool) mkTest name fp line col ts = it name $ do resetGlobalHoleRef - runSessionForTactics $ do + actions <- E.handle (\(UnexpectedResponseError _ _) -> pure []) + $ runSessionForTactics $ do doc <- openDoc (fp <.> "hs") "haskell" -- wait for diagnostics to start coming void waitForDiagnostics -- wait for the entire build to finish, so that Tactics code actions that -- use stale data will get uptodate stuff void $ waitForTypecheck doc - actions <- getCodeActions doc $ pointRange line col - let titles = mapMaybe codeActionTitle actions - for_ ts $ \(f, tc, var) -> do - let title = tacticTitle tc var - liftIO $ - (title `elem` titles) `shouldSatisfy` f + getCodeActions doc $ pointRange line col + let titles = mapMaybe codeActionTitle actions + for_ ts $ \(f, tc, var) -> do + let title = tacticTitle tc var + liftIO $ + (title `elem` titles) `shouldSatisfy` f data InvokeTactic = InvokeTactic { it_command :: TacticCommand From 953003a18240ae98c3f3fe8ad07f3f85e017979a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 14:17:27 +0300 Subject: [PATCH 17/28] Broke up the ghcide test file --- ghcide/ghcide.cabal | 32 + ghcide/test/exe/AsyncTests.hs | 53 + ghcide/test/exe/BootTests.hs | 55 + ghcide/test/exe/CPPTests.hs | 56 + ghcide/test/exe/ClientSettingsTests.hs | 34 + ghcide/test/exe/CodeLensTests.hs | 114 + ghcide/test/exe/CompletionTests.hs | 584 +++ ghcide/test/exe/CradleTests.hs | 219 + ghcide/test/exe/DependentFileTest.hs | 62 + ghcide/test/exe/DiagnosticTests.hs | 565 +++ .../test/exe/FindDefinitionAndHoverTests.hs | 250 ++ ghcide/test/exe/FuzzySearch.hs | 3 - ghcide/test/exe/GarbageCollectionTests.hs | 94 + ghcide/test/exe/HaddockTests.hs | 90 + ghcide/test/exe/HighlightTests.hs | 85 + ghcide/test/exe/IfaceTests.hs | 163 + ghcide/test/exe/InitializeResponseTests.hs | 97 + ghcide/test/exe/LogType.hs | 17 + ghcide/test/exe/Main.hs | 3624 +---------------- ghcide/test/exe/NonLspCommandLine.hs | 27 + ghcide/test/exe/OpenCloseTest.hs | 18 + ghcide/test/exe/OutlineTests.hs | 189 + ghcide/test/exe/PluginParsedResultTests.hs | 17 + ghcide/test/exe/PluginSimpleTests.hs | 51 + ghcide/test/exe/PositionMappingTests.hs | 199 + ghcide/test/exe/PreprocessorTests.hs | 27 + ghcide/test/exe/ReferenceTests.hs | 199 + ghcide/test/exe/RootUriTests.hs | 26 + ghcide/test/exe/SafeTests.hs | 38 + ghcide/test/exe/SymlinkTests.hs | 27 + ghcide/test/exe/THTests.hs | 194 + ghcide/test/exe/TestUtils.hs | 391 ++ ghcide/test/exe/UnitTests.hs | 130 + ghcide/test/exe/WatchedFileTests.hs | 83 + 34 files changed, 4248 insertions(+), 3565 deletions(-) create mode 100644 ghcide/test/exe/AsyncTests.hs create mode 100644 ghcide/test/exe/BootTests.hs create mode 100644 ghcide/test/exe/CPPTests.hs create mode 100644 ghcide/test/exe/ClientSettingsTests.hs create mode 100644 ghcide/test/exe/CodeLensTests.hs create mode 100644 ghcide/test/exe/CompletionTests.hs create mode 100644 ghcide/test/exe/CradleTests.hs create mode 100644 ghcide/test/exe/DependentFileTest.hs create mode 100644 ghcide/test/exe/DiagnosticTests.hs create mode 100644 ghcide/test/exe/FindDefinitionAndHoverTests.hs create mode 100644 ghcide/test/exe/GarbageCollectionTests.hs create mode 100644 ghcide/test/exe/HaddockTests.hs create mode 100644 ghcide/test/exe/HighlightTests.hs create mode 100644 ghcide/test/exe/IfaceTests.hs create mode 100644 ghcide/test/exe/InitializeResponseTests.hs create mode 100644 ghcide/test/exe/LogType.hs create mode 100644 ghcide/test/exe/NonLspCommandLine.hs create mode 100644 ghcide/test/exe/OpenCloseTest.hs create mode 100644 ghcide/test/exe/OutlineTests.hs create mode 100644 ghcide/test/exe/PluginParsedResultTests.hs create mode 100644 ghcide/test/exe/PluginSimpleTests.hs create mode 100644 ghcide/test/exe/PositionMappingTests.hs create mode 100644 ghcide/test/exe/PreprocessorTests.hs create mode 100644 ghcide/test/exe/ReferenceTests.hs create mode 100644 ghcide/test/exe/RootUriTests.hs create mode 100644 ghcide/test/exe/SafeTests.hs create mode 100644 ghcide/test/exe/SymlinkTests.hs create mode 100644 ghcide/test/exe/THTests.hs create mode 100644 ghcide/test/exe/TestUtils.hs create mode 100644 ghcide/test/exe/UnitTests.hs create mode 100644 ghcide/test/exe/WatchedFileTests.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index aa724be5f1..1e6c7b8a00 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -383,6 +383,38 @@ test-suite ghcide-tests HieDbRetry Development.IDE.Test Development.IDE.Test.Diagnostic + -- Tests that have been pulled out of the main file + BootTests + CodeLensTests + CompletionTests + CPPTests + CradleTests + DependentFileTest + DiagnosticTests + FindDefinitionAndHoverTests + HaddockTests + HighlightTests + IfaceTests + InitializeResponseTests + LogType + NonLspCommandLine + OutlineTests + PluginParsedResultTests + PluginSimpleTests + PositionMappingTests + PreprocessorTests + RootUriTests + SafeTests + SymlinkTests + TestUtils + THTests + UnitTests + WatchedFileTests + AsyncTests + ClientSettingsTests + ReferenceTests + GarbageCollectionTests + OpenCloseTest default-extensions: BangPatterns DeriveFunctor diff --git a/ghcide/test/exe/AsyncTests.hs b/ghcide/test/exe/AsyncTests.hs new file mode 100644 index 0000000000..d8ed66c040 --- /dev/null +++ b/ghcide/test/exe/AsyncTests.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} + +module AsyncTests (tests) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (toJSON) +import Data.Proxy +import qualified Data.Text as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), + blockCommandId) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +-- | Test if ghcide asynchronously handles Commands and user Requests +tests :: TestTree +tests = testGroup "async" + [ + testSession "command" $ do + -- Execute a command that will block forever + let req = ExecuteCommandParams Nothing blockCommandId Nothing + void $ sendRequest SMethod_WorkspaceExecuteCommand req + -- Load a file and check for code actions. Will only work if the command is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + , testSession "request" $ do + -- Execute a custom request that will block for 1000 seconds + void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000 + -- Load a file and check for code actions. Will only work if the request is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + ] diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs new file mode 100644 index 0000000000..3e4d87c550 --- /dev/null +++ b/ghcide/test/exe/BootTests.hs @@ -0,0 +1,55 @@ +module BootTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectNoMoreDiagnostics, + isReferenceReady) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "boot" + [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do + let cPath = dir "C.hs" + cSource <- liftIO $ readFileUtf8 cPath + -- Dirty the cache + liftIO $ runInDir dir $ do + cDoc <- createDoc cPath "haskell" cSource + -- We send a hover request then wait for either the hover response or + -- `ghcide/reference/ready` notification. + -- Once we receive one of the above, we wait for the other that we + -- haven't received yet. + -- If we don't wait for the `ready` notification it is possible + -- that the `getDefinitions` request/response in the outer ghcide + -- session will find no definitions. + let hoverParams = HoverParams cDoc (Position 4 3) Nothing + hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams + let parseReadyMessage = isReferenceReady cPath + let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId + hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) + _ <- skipManyTill anyMessage $ + case hoverResponseOrReadyMessage of + Left _ -> void parseReadyMessage + Right _ -> void parseHoverResponse + closeDoc cDoc + cdoc <- createDoc cPath "haskell" cSource + locs <- getDefinitions cdoc (Position 7 4) + let floc = mkR 9 0 9 1 + checkDefs locs (pure [floc]) + , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do + _ <- openDoc (dir "A.hs") "haskell" + expectNoMoreDiagnostics 2 + ] diff --git a/ghcide/test/exe/CPPTests.hs b/ghcide/test/exe/CPPTests.hs new file mode 100644 index 0000000000..da9f564fe4 --- /dev/null +++ b/ghcide/test/exe/CPPTests.hs @@ -0,0 +1,56 @@ +module CPPTests (tests) where + +import Control.Exception (catch) +import qualified Data.Text as T +import Development.IDE.Test (Cursor, expectDiagnostics, + expectNoMoreDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = + testGroup "cpp" + [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do + let content = + T.unlines + [ "{-# LANGUAGE CPP #-}", + "module Testing where", + "#ifdef FOO", + "foo = 42" + ] + -- The error locations differ depending on which C-preprocessor is used. + -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either + -- of them. + (run $ expectError content (2, maxBound)) + `catch` ( \e -> do + let _ = e :: HUnitFailure + run $ expectError content (2, 1) + ) + , testSessionWait "cpp-ghcide" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + ["{-# LANGUAGE CPP #-}" + ,"main =" + ,"#ifdef __GHCIDE__" + ," worked" + ,"#else" + ," failed" + ,"#endif" + ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked")])] + ] + where + expectError :: T.Text -> Cursor -> Session () + expectError content cursor = do + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DiagnosticSeverity_Error, cursor, "error: unterminated")] + ) + ] + expectNoMoreDiagnostics 0.5 diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs new file mode 100644 index 0000000000..46efe9e45d --- /dev/null +++ b/ghcide/test/exe/ClientSettingsTests.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GADTs #-} +module ClientSettingsTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Data.Aeson (toJSON) +import qualified Data.Aeson as A +import qualified Data.Text as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testGroup "client settings handling" + [ testSession "ghcide restarts shake session on config changes" $ do + void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability + void $ createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + sendNotification SMethod_WorkspaceDidChangeConfiguration + (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) + skipManyTill anyMessage restartingBuildSession + + ] + where + restartingBuildSession :: Session () + restartingBuildSession = do + FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification + guard $ "Restarting build session" `T.isInfixOf` _message diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs new file mode 100644 index 0000000000..9ae3268c49 --- /dev/null +++ b/ghcide/test/exe/CodeLensTests.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE GADTs #-} + +module CodeLensTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Data.Tuple.Extra +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "code lenses" + [ addSigLensesTests + ] + + +addSigLensesTests :: TestTree +addSigLensesTests = + let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH exported = + T.unlines + [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" + , "module Sigs(" <> exported <> ") where" + , "import qualified Data.Complex as C" + , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" + ] + before enableGHCWarnings exported (def, _) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others + after' enableGHCWarnings exported (def, sig) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others + createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] + sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do + let originalCode = before enableGHCWarnings exported def others + let expectedCode = after' enableGHCWarnings exported def others + sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + doc <- createDoc "Sigs.hs" "haskell" originalCode + waitForProgressDone + codeLenses <- getCodeLenses doc + if not $ null $ snd def + then do + liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses + executeCommand $ fromJust $ head codeLenses ^. L.command + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) + liftIO $ expectedCode @=? modifiedCode + else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses + cases = + [ ("abc = True", "abc :: Bool") + , ("foo a b = a + b", "foo :: Num a => a -> a -> a") + , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") + , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") + , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") + , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") + , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") + , ("head = 233", "head :: Integer") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") + , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") + , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") + , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") + , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + ] + in testGroup + "add signature" + [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + , testGroup + "diagnostics mode works" + [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] + ] + , testSession "keep stale lens" $ do + let content = T.unlines + [ "module Stale where" + , "f = _" + ] + doc <- createDoc "Stale.hs" "haskell" content + oldLens <- getCodeLenses doc + liftIO $ length oldLens @?= 1 + let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_` + _ <- applyEdit doc edit + newLens <- getCodeLenses doc + liftIO $ newLens @?= oldLens + ] + +-- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String +listOfChar :: T.Text +listOfChar | ghcVersion >= GHC90 = "String" + | otherwise = "[Char]" diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs new file mode 100644 index 0000000000..c6953710ca --- /dev/null +++ b/ghcide/test/exe/CompletionTests.hs @@ -0,0 +1,584 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module CompletionTests (tests) where + +import Control.Lens ((^.)) +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.List.Extra +import Data.Maybe +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.Test (waitForTypecheck) +import Development.IDE.Types.Location +import Ide.Plugin.Config +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests + = testGroup "completion" + [ + testGroup "non local" nonLocalCompletionTests + , testGroup "topLevel" topLevelCompletionTests + , testGroup "local" localCompletionTests + , testGroup "package" packageCompletionTests + , testGroup "project" projectCompletionTests + , testGroup "other" otherCompletionTests + , testGroup "doc" completionDocTests + ] + +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree +completionTest name src pos expected = testSessionWait name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getCompletions docId pos + let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] + let emptyToMaybe x = if T.null x then Nothing else Just x + liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(item, (_,_,_,expectedSig, expectedDocs, _)) -> do + CompletionItem{..} <- + if (expectedSig || expectedDocs) && isJust (item ^. L.data_) + then do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item + when expectedSig $ + liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + + +topLevelCompletionTests :: [TestTree] +topLevelCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)], + completionTest + "type" + ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] + (Position 0 9) + [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)], + completionTest + "class" + ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] + (Position 0 9) + [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)], + completionTest + "records" + ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] + (Position 1 19) + [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing), + ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)], + completionTest + "recordsConstructor" + ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] + (Position 1 19) + [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing), + ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] + ] + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "argument" + ["bar (Just abcdef) abcdefg = abcd"] + (Position 0 32) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "let" + ["bar = let (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ," in abcd" + ] + (Position 2 15) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "where" + ["bar = abcd" + ," where (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ] + (Position 0 10) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "do/1" + ["bar = do" + ," Just abcdef <- undefined" + ," abcd" + ," abcdefg <- undefined" + ," pure ()" + ] + (Position 2 6) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ], + completionTest + "do/2" + ["bar abcde = do" + ," Just [(abcdef,_)] <- undefined" + ," abcdefg <- undefined" + ," let abcdefgh = undefined" + ," (Just [abcdefghi]) = undefined" + ," abcd" + ," where" + ," abcdefghij = undefined" + ] + (Position 5 8) + [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing) + ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing) + ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing) + ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing) + ], + completionTest + "type family" + ["{-# LANGUAGE DataKinds, TypeFamilies #-}" + ,"type family Bar a" + ,"a :: Ba" + ] + (Position 2 7) + [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing) + ], + completionTest + "class method" + [ + "class Test a where" + , " abcd :: a -> ()" + , " abcde :: a -> Int" + , "instance Test Int where" + , " abcd = abc" + ] + (Position 4 14) + [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) + ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ], + testSessionWait "incomplete entries" $ do + let src a = "data Data = " <> a + doc <- createDoc "A.hs" "haskell" $ src "AAA" + void $ waitForTypecheck doc + let editA rhs = + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs] + editA "AAAA" + void $ waitForTypecheck doc + editA "AAAAA" + void $ waitForTypecheck doc + + compls <- getCompletions doc (Position 0 15) + liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] + pure () + ] + +nonLocalCompletionTests :: [TestTree] +nonLocalCompletionTests = + [ brokenForWinGhc $ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CompletionItemKind_Function, "head", True, True, Nothing)], + completionTest + "constructor" + ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] + (Position 2 8) + [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing) + ], + brokenForWinGhc $ completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] + (Position 2 8) + [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CompletionItemKind_Function, "head", True, True, Nothing) + ], + completionTest + "duplicate import" + ["module A where", "import Data.List", "import Data.List", "f = permu"] + (Position 3 9) + [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing) + ], + completionTest + "dont show hidden items" + [ "{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", + "import Control.Monad hiding (join)", + "f = joi" + ] + (Position 3 6) + [], + testGroup "ordering" + [completionTest "qualified has priority" + ["module A where" + ,"import qualified Data.ByteString as BS" + ,"f = BS.read" + ] + (Position 2 10) + [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)] + ], + -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls + completionTest + "do not show pragma completions" + [ "{-# LANGUAGE ", + "{module A where}", + "main = return ()" + ] + (Position 0 13) + [] + ] + where + brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94, GHC96]) "Windows has strange things in scope for some reason" + +otherCompletionTests :: [TestTree] +otherCompletionTests = [ + completionTest + "keyword" + ["module A where", "f = newty"] + (Position 1 9) + [("newtype", CompletionItemKind_Keyword, "", False, False, Nothing)], + completionTest + "type context" + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "f = f", + "g :: Intege" + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + (Position 3 11) + [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)], + + testSession "duplicate record fields" $ do + void $ + createDoc "B.hs" "haskell" $ + T.unlines + [ "{-# LANGUAGE DuplicateRecordFields #-}", + "module B where", + "newtype Foo = Foo { member :: () }", + "newtype Bar = Bar { member :: () }" + ] + docA <- + createDoc "A.hs" "haskell" $ + T.unlines + [ "module A where", + "import B", + "memb" + ] + _ <- waitForDiagnostics + compls <- getCompletions docA $ Position 2 4 + let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] + liftIO $ take 2 compls' @?= ["member"], + + testSessionWait "maxCompletions" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = Prelude." + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + liftIO $ length compls @?= maxCompletions def + ] + +packageCompletionTests :: [TestTree] +packageCompletionTests = + [ testSession' "fromList" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 12) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "fromList" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) ( + [ "'Data.List.NonEmpty" + , "'GHC.Exts" + ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) + + , testSessionWait "Map" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a :: Map" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 7) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "Map" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.Map" + , "'Data.Map.Lazy" + , "'Data.Map.Strict" + ] + , testSessionWait "no duplicates" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let duplicate = + filter + (\case + CompletionItem + { _insertText = Just "fromList" + , _documentation = + Just (InR (MarkupContent MarkupKind_Markdown d)) + } -> + "GHC.Exts" `T.isInfixOf` d + _ -> False + ) compls + liftIO $ length duplicate @?= 1 + + , testSessionWait "non-local before global" $ do + -- non local completions are more specific + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let compls' = + [_insertText + | CompletionItem {_label, _insertText} <- compls + , _label == "fromList" + ] + liftIO $ take 3 compls' @?= + map Just ["fromList"] + ] + +projectCompletionTests :: [TestTree] +projectCompletionTests = + [ testSession' "from hiedb" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "b = anidenti" + ] + compls <- getCompletions doc (Position 1 10) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "anidentifier" + ] + liftIO $ compls' @?= ["Defined in 'A"], + testSession' "auto complete project imports" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" + _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines + [ "module ALocalModule (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import ALocal" + ] + compls <- getCompletions doc (Position 1 13) + let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls + liftIO $ do + item ^. L.label @?= "ALocalModule", + testSession' "auto complete functions from qualified imports without alias" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A", + "A." + ] + compls <- getCompletions doc (Position 2 2) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier", + testSession' "auto complete functions from qualified imports with alias" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A as Alias", + "foo = Alias." + ] + compls <- getCompletions doc (Position 2 12) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier" + ] + +completionDocTests :: [TestTree] +completionDocTests = + [ testSession "local define" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + let expected = "*Defined at line 2, column 1 in this module*\n" + test doc (Position 2 8) "foo" Nothing [expected] + , testSession "local empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] + , testSession "local single line doc without newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- |docdoc" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] + , testSession "local multi line doc with newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] + , testSession "local multi line doc without newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "--def" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] + , testSession "extern empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = od" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern single line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = no" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" + test doc (Position 1 8) "not" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern mulit line doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + , testSession "extern defined doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + ] + where + brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94, GHC96]) "Completion doc doesn't support ghc9" + brokenForWinGhc90 = knownBrokenFor (BrokenSpecific Windows [GHC90]) "Extern doc doesn't support Windows for ghc9.2" + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 + brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9" + test doc pos label mn expected = do + _ <- waitForDiagnostics + compls <- getCompletions doc pos + rcompls <- forM compls $ \item -> do + if isJust (item ^. L.data_) + then do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item + let compls' = [ + -- We ignore doc uris since it points to the local path which determined by specific machines + case mn of + Nothing -> txt + Just n -> T.take n txt + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls + , _label == label + ] + liftIO $ compls' @?= expected diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs new file mode 100644 index 0000000000..167860833b --- /dev/null +++ b/ghcide/test/exe/CradleTests.hs @@ -0,0 +1,219 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module CradleTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + isReferenceReady, + waitForAction) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import System.IO.Extra hiding (withTempDir) +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import GHC.TypeLits (symbolVal) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "ignore-fatal" [ignoreFatalWarning] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] + ,testGroup "sub-directory" [simpleSubDirectoryTest] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testSession' "implicit" implicit + , testSession' "direct" direct + ] + where + direct dir = do + liftIO $ writeFileUTF8 (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + test dir + implicit dir = test dir + test _dir = do + doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 1 + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + +retryFailedCradle :: TestTree +retryFailedCradle = testSession' "retry failed" $ \dir -> do + -- The false cradle always fails + let hieContents = "cradle: {bios: {shell: \"false\"}}" + hiePath = dir "hie.yaml" + liftIO $ writeFile hiePath hieContents + let aPath = dir "A.hs" + doc <- createDoc aPath "haskell" "main = return ()" + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess + + -- Fix the cradle and typecheck again + let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" + liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] + + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess + + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: String +cradleLoadedMethod = "ghcide/cradle/loaded" + +ignoreFatalWarning :: TestTree +ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do + let srcPath = dir "IgnoreFatal.hs" + src <- liftIO $ readFileUtf8 srcPath + _ <- createDoc srcPath "haskell" src + expectNoMoreDiagnostics 5 + +simpleSubDirectoryTest :: TestTree +simpleSubDirectoryTest = + testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do + let mainPath = dir "a/src/Main.hs" + mainSource <- liftIO $ readFileUtf8 mainPath + _mdoc <- createDoc mainPath "haskell" mainSource + expectDiagnosticsWithTags + [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ] + expectNoMoreDiagnostics 0.5 + +simpleMultiTest :: TestTree +simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- openDoc aPath "haskell" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + liftIO $ assertBool "A should typecheck" ideResultSuccess + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc + liftIO $ assertBool "B should typecheck" ideResultSuccess + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in the other order +simpleMultiTest2 :: TestTree +simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Now with 3 components +simpleMultiTest3 :: TestTree +simpleMultiTest3 = + testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + cPath = dir "c/C.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in component 'a' in a separate session +simpleMultiDefTest :: TestTree +simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- liftIO $ runInDir dir $ do + aSource <- liftIO $ readFileUtf8 aPath + adoc <- createDoc aPath "haskell" aSource + skipManyTill anyMessage $ isReferenceReady aPath + closeDoc adoc + pure adoc + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + + +sessionDepsArePickedUp :: TestTree +sessionDepsArePickedUp = testSession' + "session-deps-are-picked-up" + $ \dir -> do + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + -- Open without OverloadedStrings and expect an error. + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics $ + if ghcVersion >= GHC90 + -- String vs [Char] causes this change in error message + then [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + else [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match expected type")])] + -- Update hie.yaml to enable OverloadedStrings. + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: [-XOverloadedStrings]}}" + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] + -- Send change event. + let change = + TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 4 0) (Position 4 0) + .+ #rangeLength .== Nothing + .+ #text .== "\n" + changeDoc doc [change] + -- Now no errors. + expectDiagnostics [("Foo.hs", [])] + where + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs new file mode 100644 index 0000000000..d78ad49a8a --- /dev/null +++ b/ghcide/test/exe/DependentFileTest.hs @@ -0,0 +1,62 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module DependentFileTest (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.Test (expectDiagnostics) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testGroup "addDependentFile" + [testGroup "file-changed" [testSession' "test" test] + ] + where + test dir = do + -- If the file contains B then no type error + -- otherwise type error + let depFilePath = dir "dep-file.txt" + liftIO $ writeFile depFilePath "A" + let fooContent = T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Foo where" + , "import Language.Haskell.TH.Syntax" + , "foo :: Int" + , "foo = 1 + $(do" + , " qAddDependentFile \"dep-file.txt\"" + , " f <- qRunIO (readFile \"dep-file.txt\")" + , " if f == \"B\" then [| 1 |] else lift f)" + ] + let bazContent = T.unlines ["module Baz where", "import Foo ()"] + _ <- createDoc "Foo.hs" "haskell" fooContent + doc <- createDoc "Baz.hs" "haskell" bazContent + expectDiagnostics $ + if ghcVersion >= GHC90 + -- String vs [Char] causes this change in error message + then [("Foo.hs", [(DiagnosticSeverity_Error, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] + else [("Foo.hs", [(DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type")])] + -- Now modify the dependent file + liftIO $ writeFile depFilePath "B" + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] + + -- Modifying Baz will now trigger Foo to be rebuilt as well + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 0) (Position 2 6) + .+ #rangeLength .== Nothing + .+ #text .== "f = ()" + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [])] diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs new file mode 100644 index 0000000000..5a219f6c50 --- /dev/null +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -0,0 +1,565 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module DiagnosticTests (tests) where + +import Control.Applicative.Combinators +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.List.Extra +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import Development.IDE.Test (diagnostic, + expectCurrentDiagnostics, + expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + flushMessages, waitForAction) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +import System.IO.Extra hiding (withTempDir) +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Control.Monad.Extra (whenJust) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import System.Time.Extra +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "diagnostics" + [ testSessionWait "fix syntax error" $ do + let content = T.unlines [ "module Testing wher" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 19) + .+ #rangeLength .== Nothing + .+ #text .== "where" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [])] + , testSessionWait "introduce syntax error" $ do + let content = T.unlines [ "module Testing where" ] + doc <- createDoc "Testing.hs" "haskell" content + void $ skipManyTill anyMessage (message SMethod_WindowWorkDoneProgressCreate) + waitForProgressBegin + let change = TextDocumentContentChangeEvent$ InL $ #range .== Range (Position 0 15) (Position 0 18) + .+ #rangeLength .== Nothing + .+ #text .== "wher" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + , testSessionWait "update syntax error" $ do + let content = T.unlines [ "module Testing(missing) where" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])] + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16) + .+ #rangeLength .== Nothing + .+ #text .== "l" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])] + , testSessionWait "variable not in scope" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int -> Int" + , "foo a _b = a + ab" + , "bar :: Int -> Int -> Int" + , "bar _a b = cd + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab") + , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd") + ] + ) + ] + , testSessionWait "type error" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String -> Int" + , "foo a b = a + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'")] + ) + ] + , testSessionWait "typed hole" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String" + , "foo a = _ a" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")] + ) + ] + + , testGroup "deferral" $ + let sourceA a = T.unlines + [ "module A where" + , "a :: Int" + , "a = " <> a] + sourceB = T.unlines + [ "module B where" + , "import A ()" + , "b :: Float" + , "b = True"] + bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" + expectedDs aMessage = + [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage)]) + , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage)])] + deferralTest title binding msg = testSessionWait title $ do + _ <- createDoc "A.hs" "haskell" $ sourceA binding + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics $ expectedDs msg + in + [ deferralTest "type error" "True" "Couldn't match expected type" + , deferralTest "typed hole" "_" "Found hole" + , deferralTest "out of scope var" "unbound" "Variable not in scope" + ] + + , testSessionWait "remove required module" $ do + let contentA = T.unlines [ "module ModuleA where" ] + docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 20) + .+ #rangeLength .== Nothing + .+ #text .== "" + changeDoc docA [change] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])] + , testSessionWait "add missing module" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + expectDiagnostics [("ModuleB.hs", [])] + , testCase "add missing module (non workspace)" $ + -- By default lsp-test sends FileWatched notifications for all files, which we don't want + -- as non workspace modules will not be watched by the LSP server. + -- To work around this, we tell lsp-test that our client doesn't have the + -- FileWatched capability, which is enough to disable the notifications + withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] + , testSessionWait "cyclic module dependency" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB" + ] + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics + [ ( "ModuleA.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + , ( "ModuleB.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSession' "deeply nested cyclic module dependency" $ \path -> do + let contentA = unlines + [ "module ModuleA where" , "import ModuleB" ] + let contentB = unlines + [ "module ModuleB where" , "import ModuleA" ] + let contentC = unlines + [ "module ModuleC where" , "import ModuleB" ] + let contentD = T.unlines + [ "module ModuleD where" , "import ModuleC" ] + cradle = + "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}" + liftIO $ writeFile (path "ModuleA.hs") contentA + liftIO $ writeFile (path "ModuleB.hs") contentB + liftIO $ writeFile (path "ModuleC.hs") contentC + liftIO $ writeFile (path "hie.yaml") cradle + _ <- createDoc "ModuleD.hs" "haskell" contentD + expectDiagnostics + [ ( "ModuleB.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSessionWait "cyclic module dependency with hs-boot" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import {-# SOURCE #-} ModuleB" + ] + let contentB = T.unlines + [ "{-# OPTIONS -Wmissing-signatures#-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial diagnostic + , "foo = ()" + ] + let contentBboot = T.unlines + [ "module ModuleB where" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "correct reference used with hs-boot" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import {-# SOURCE #-} ModuleA()" + ] + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB()" + , "x = 5" + ] + let contentAboot = T.unlines + [ "module ModuleA where" + ] + let contentC = T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "module ModuleC where" + , "import ModuleA" + -- this reference will fail if it gets incorrectly + -- resolved to the hs-boot file + , "y = x" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot + _ <- createDoc "ModuleC.hs" "haskell" contentC + expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "redundant import" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnosticsWithTags + [ ( "ModuleB.hs" + , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)] + ) + ] + , testSessionWait "redundant import even without warning" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial warning for testing purposes + , "foo = ()" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "package imports" $ do + let thisDataListContent = T.unlines + [ "module Data.List where" + , "x :: Integer" + , "x = 123" + ] + let mainContent = T.unlines + [ "{-# LANGUAGE PackageImports #-}" + , "module Main where" + , "import qualified \"this\" Data.List as ThisList" + , "import qualified \"base\" Data.List as BaseList" + , "useThis = ThisList.x" + , "useBase = BaseList.map" + , "wrong1 = ThisList.map" + , "wrong2 = BaseList.x" + , "main = pure ()" + ] + _ <- createDoc "Data/List.hs" "haskell" thisDataListContent + _ <- createDoc "Main.hs" "haskell" mainContent + expectDiagnostics + [ ( "Main.hs" + , [(DiagnosticSeverity_Error, (6, 9), + if ghcVersion >= GHC96 then + "Variable not in scope: ThisList.map" + else if ghcVersion >= GHC94 then + "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else + "Not in scope: \8216ThisList.map\8217") + ,(DiagnosticSeverity_Error, (7, 9), + if ghcVersion >= GHC96 then + "Variable not in scope: BaseList.x" + else if ghcVersion >= GHC94 then + "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else + "Not in scope: \8216BaseList.x\8217") + ] + ) + ] + , testSessionWait "unqualified warnings" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Foo where" + , "foo :: Ord a => a -> Int" + , "foo _a = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + -- The test is to make sure that warnings contain unqualified names + -- where appropriate. The warning should use an unqualified name 'Ord', not + -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to + -- test this is fairly arbitrary. + , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") + ] + ) + ] + , testSessionWait "lower-case drive" $ do + let aContent = T.unlines + [ "module A.A where" + , "import A.B ()" + ] + bContent = T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A.B where" + , "import Data.List" + ] + uriB <- getDocUri "A/B.hs" + Just pathB <- pure $ uriToFilePath uriB + uriB <- pure $ + let (drive, suffix) = splitDrive pathB + in filePathToUri (joinDrive (lower drive) suffix) + liftIO $ createDirectoryIfMissing True (takeDirectory pathB) + liftIO $ writeFileUTF8 pathB $ T.unpack bContent + uriA <- getDocUri "A/A.hs" + Just pathA <- pure $ uriToFilePath uriA + uriA <- pure $ + let (drive, suffix) = splitDrive pathA + in filePathToUri (joinDrive (lower drive) suffix) + let itemA = TextDocumentItem uriA "haskell" 0 aContent + let a = TextDocumentIdentifier uriA + sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams itemA) + TNotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic + -- Check that if we put a lower-case drive in for A.A + -- the diagnostics for A.B will also be lower-case. + liftIO $ fileUri @?= uriB + let msg :: T.Text = (head diags) ^. L.message + liftIO $ unless ("redundant" `T.isInfixOf` msg) $ + assertFailure ("Expected redundant import but got " <> T.unpack msg) + closeDoc a + , testSessionWait "haddock parse error" $ do + let fooContent = T.unlines + [ "module Foo where" + , "foo :: Int" + , "foo = 1 {-|-}" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + if ghcVersion >= GHC90 then + -- Haddock parse errors are ignored on ghc-9.0 + pure () + else + expectDiagnostics + [ ( "Foo.hs" + , [(DiagnosticSeverity_Warning, (2, 8), "Haddock parse error on input")] + ) + ] + , testSessionWait "strip file path" $ do + let + name = "Testing" + content = T.unlines + [ "module " <> name <> " where" + , "value :: Maybe ()" + , "value = [()]" + ] + _ <- createDoc (T.unpack name <> ".hs") "haskell" content + notification <- skipManyTill anyMessage diagnostic + let + offenders = + L.params . + L.diagnostics . + Lens.folded . + L.message . + Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) + failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg + Lens.mapMOf_ offenders failure notification + , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" + let fooContent = T.unlines + [ "module Foo where" + , "foo = ()" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DiagnosticSeverity_Warning, (1, 0), "Top-level binding with no type signature:") + ] + ) + ] + , testSessionWait "-Werror in pragma is ignored" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wall -Werror #-}" + , "module Foo() where" + , "foo :: Int" + , "foo = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DiagnosticSeverity_Warning, (3, 0), "Defined but not used:") + ] + ) + ] + , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + aPath = dir "A.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int + + bdoc <- createDoc bPath "haskell" bSource + _pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B which introduces a type error in A (imported from P) + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module B where", "y :: Bool", "y = undefined"]] + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ] + + -- Open A and edit to fix the type error + adoc <- createDoc aPath "haskell" aSource + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] + + expectDiagnostics + [ ( "P.hs", + [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), + (DiagnosticSeverity_Warning, (4, 0), "Top-level binding") + ] + ), + ("A.hs", []) + ] + expectNoMoreDiagnostics 1 + + , testSessionWait "deduplicate missing module diagnostics" $ do + let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] + + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module Foo() where" ] + expectDiagnostics [] + + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines + [ "module Foo() where" , "import MissingModule" ] ] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] + + , testGroup "Cancellation" + [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc + , cancellationTestGroup "edit import" editImport noSession yesParse noTc + , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc + ] + ] + where + editPair x y = let p = Position x y ; p' = Position x (y+2) in + (TextDocumentContentChangeEvent $ InL $ #range .== Range p p + .+ #rangeLength .== Nothing + .+ #text .== "fd" + ,TextDocumentContentChangeEvent $ InL $ #range .== Range p p' + .+ #rangeLength .== Nothing + .+ #text .== "") + editHeader = editPair 0 0 + editImport = editPair 2 10 + editBody = editPair 3 10 + + noParse = False + yesParse = True + + noSession = False + yesSession = True + + noTc = False + yesTc = True + +cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree +cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name + [ cancellationTemplate edits Nothing + , cancellationTemplate edits $ Just ("GetFileContents", True) + , cancellationTemplate edits $ Just ("GhcSession", True) + -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) + , cancellationTemplate edits $ Just ("GetModSummary", True) + , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) + -- getLocatedImports never fails + , cancellationTemplate edits $ Just ("GetLocatedImports", True) + , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) + , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) + , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) + , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) + ] + +cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree +cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do + doc <- createDoc "Foo.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module Foo where" + , "import Data.List()" + , "f0 x = (x,x)" + ] + + -- for the example above we expect one warning + let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding") ] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + -- Now we edit the document and wait for the given key (if any) + changeDoc doc [edit] + whenJust mbKey $ \(key, expectedResult) -> do + WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc + liftIO $ ideResultSuccess @?= expectedResult + + -- The 2nd edit cancels the active session and unbreaks the file + -- wait for typecheck and check that the current diagnostics are accurate + changeDoc doc [undoEdit] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + expectNoMoreDiagnostics 0.5 + where + -- similar to run except it disables kick + runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s + + typeCheck doc = do + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ assertBool "The file should typecheck" ideResultSuccess + -- wait for the debouncer to publish diagnostics if the rule runs + liftIO $ sleep 0.2 + -- flush messages to ensure current diagnostics state is updated + flushMessages diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs new file mode 100644 index 0000000000..ceba6e3971 --- /dev/null +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -0,0 +1,250 @@ + +{-# LANGUAGE MultiWayIf #-} + +module FindDefinitionAndHoverTests (tests) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Foldable +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectDiagnostics, + standardizeQuotes) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import System.Info.Extra (isWindows) +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils +import Text.Regex.TDFA ((=~)) + +tests :: TestTree +tests = let + + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree + tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do + + -- Dirty the cache to check that definitions work even in the presence of iface files + liftIO $ runInDir dir $ do + let fooPath = dir "Foo.hs" + fooSource <- liftIO $ readFileUtf8 fooPath + fooDoc <- createDoc fooPath "haskell" fooSource + _ <- getHover fooDoc $ Position 4 3 + closeDoc fooDoc + + doc <- openTestDataDoc (dir sfp) + waitForProgressDone + found <- get doc pos + check found targetRange + + + + checkHover :: Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets + ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + assertNotFoundIn :: T.Text -> T.Text -> Assertion + assertNotFoundIn part whole = assertBool + (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) + (not . T.isInfixOf part $ whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoHover.hs" + + mkFindTests tests = testGroup "get" + [ testGroup "definition" $ mapMaybe fst tests + , testGroup "hover" $ mapMaybe snd tests + , checkFileCompiles sourceFilePath $ + expectDiagnostics + [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) + , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) + ] + , testGroup "type-definition" typeDefinitionTests + , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] + + typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" + , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] + + recordDotSyntaxTests + | ghcVersion >= GHC92 = + [ tst (getHover, checkHover) (Position 19 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" + , tst (getHover, checkHover) (Position 19 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" + , tst (getHover, checkHover) (Position 19 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" + ] + | otherwise = [] + + test runDef runHover look expect = testM runDef runHover look (return expect) + + testM runDef runHover look expect title = + ( runDef $ tst def look sourceFilePath expect title + , runHover $ tst hover look sourceFilePath expect title ) where + def = (getDefinitions, checkDefs) + hover = (getHover , checkHover) + + -- search locations expectations on results + fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] + fffL8 = Position 12 4 ; + fffL14 = Position 18 7 ; + aL20 = Position 19 15 + aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] + dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] + dcL12 = Position 16 11 ; + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] + tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] + vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] + opL16 = Position 20 15 ; op = [mkR 21 2 21 4] + opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] + aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] + b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] + clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] + clL25 = Position 29 9 + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] + dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] + dnbL30 = Position 34 23 + lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] + lclL33 = Position 37 22 + mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] + mclL37 = Position 41 1 + spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] + docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] + ; constr = [ExpectHoverText ["Monad m"]] + eitL40 = Position 44 28 ; kindE = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]] + tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] + intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] + chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] + txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] + lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] + holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] + holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] + cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] + imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] + reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] + thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] + cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] + in + mkFindTests + -- def hover look expect + [ + if ghcVersion >= GHC90 then + -- It suggests either going to the constructor or to the field + test broken yes fffL4 fff "field in record definition" + else + test yes yes fffL4 fff "field in record definition" + , test yes yes fffL8 fff "field in record construction #1102" + , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs + , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes dcL7 tcDC "data constructor record #1029" + , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 + , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes xtcL5 xtc "type constructor external #717,1028" + , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes clL23 cls "class in instance declaration #1027" + , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes eclL15 ecls "external class in signature #717,1027" + , test yes yes dnbL29 dnb "do-notation bind #1073" + , test yes yes dnbL30 dnb "do-notation lookup" + , test yes yes lcbL33 lcb "listcomp bind #1073" + , test yes yes lclL33 lcb "listcomp lookup" + , test yes yes mclL36 mcl "top-level fn 1st clause" + , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" + , if ghcVersion >= GHC810 then + test yes yes spaceL37 space "top-level fn on space #1002" + else + test yes broken spaceL37 space "top-level fn on space #1002" + , test no yes docL41 doc "documentation #1129" + , test no yes eitL40 kindE "kind of Either #1017" + , test no yes intL40 kindI "kind of Int #1017" + , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" + , test no broken intL41 litI "literal Int in hover info #1016" + , test no broken chrL36 litC "literal Char in hover info #1016" + , test no broken txtL8 litT "literal Text in hover info #1016" + , test no broken lstL43 litL "literal List in hover info #1016" + , test yes yes cmtL68 lackOfdEq "no Core symbols #3280" + , if ghcVersion >= GHC90 then + test no yes docL41 constr "type constraint in hover info #1012" + else + test no broken docL41 constr "type constraint in hover info #1012" + , test no yes outL45 outSig "top-level signature #767" + , test broken broken innL48 innSig "inner signature #767" + , test no yes holeL60 hleInfo "hole without internal name #831" + , test no yes holeL65 hleInfo2 "hole with variable" + , test no yes cccL17 docLink "Haddock html links" + , testM yes yes imported importedSig "Imported symbol" + , if | isWindows -> + -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 + testM no yes reexported reexportedSig "Imported symbol (reexported)" + | otherwise -> + testM yes yes reexported reexportedSig "Imported symbol (reexported)" + , if | ghcVersion == GHC90 && isWindows -> + test no broken thLocL57 thLoc "TH Splice Hover" + | otherwise -> + test no yes thLocL57 thLoc "TH Splice Hover" + ] + where yes, broken :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + broken = Just . (`xfail` "known broken") + no = const Nothing -- don't run this test at all + skip = const Nothing -- unreliable, don't run + +checkFileCompiles :: FilePath -> Session () -> TestTree +checkFileCompiles fp diag = + testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do + void (openTestDataDoc (dir fp)) + diag diff --git a/ghcide/test/exe/FuzzySearch.hs b/ghcide/test/exe/FuzzySearch.hs index 8d2f196b52..f565b94526 100644 --- a/ghcide/test/exe/FuzzySearch.hs +++ b/ghcide/test/exe/FuzzySearch.hs @@ -1,6 +1,5 @@ module FuzzySearch (tests) where -import Control.Monad (guard) import Data.Char (toLower) import Data.Maybe (catMaybes) import qualified Data.Monoid.Textual as T @@ -8,12 +7,10 @@ import Data.Text (Text, inits, pack) import qualified Data.Text as Text import Prelude hiding (filter) import System.Directory (doesFileExist) -import System.Info.Extra (isWindows) import System.IO.Unsafe (unsafePerformIO) import Test.QuickCheck import Test.Tasty import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit import Test.Tasty.QuickCheck (testProperty) import qualified Text.Fuzzy as Fuzzy import Text.Fuzzy (Fuzzy (..)) diff --git a/ghcide/test/exe/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs new file mode 100644 index 0000000000..d7033a8439 --- /dev/null +++ b/ghcide/test/exe/GarbageCollectionTests.hs @@ -0,0 +1,94 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module GarbageCollectionTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Set as Set +import qualified Data.Text as T +import Development.IDE.Test (expectCurrentDiagnostics, + getStoredKeys, waitForGC, + waitForTypecheck) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils +import Text.Printf (printf) + +tests :: TestTree +tests = testGroup "garbage collection" + [ testGroup "dirty keys" + [ testSession' "are collected" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + doc <- generateGarbage "A" dir + closeDoc doc + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + + , testSession' "are deleted from the state" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + keys0 <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keys1 <- getStoredKeys + liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) + + , testSession' "are not regenerated unless needed" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" + docA <- generateGarbage "A" dir + _docB <- generateGarbage "B" dir + + -- garbage collect A keys + keysBeforeGC <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keysAfterGC <- getStoredKeys + liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" + (length keysAfterGC < length keysBeforeGC) + + -- re-typecheck B and check that the keys for A have not materialized back + _docB <- generateGarbage "B" dir + keysB <- getStoredKeys + let regeneratedKeys = Set.filter (not . isExpected) $ + Set.intersection (Set.fromList garbage) (Set.fromList keysB) + liftIO $ regeneratedKeys @?= mempty + + , testSession' "regenerate successfully" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + let edit = T.unlines + [ "module A where" + , "a :: Bool" + , "a = ()" + ] + doc <- generateGarbage "A" dir + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ edit] + builds <- waitForTypecheck doc + liftIO $ assertBool "it still builds" builds + expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")] + ] + ] + where + isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] + + generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier + generateGarbage modName dir = do + let fp = modName <> ".hs" + body = printf "module %s where" modName + doc <- createDoc fp "haskell" (T.pack body) + liftIO $ writeFile (dir fp) body + builds <- waitForTypecheck doc + liftIO $ assertBool "something is wrong with this test" builds + return doc diff --git a/ghcide/test/exe/HaddockTests.hs b/ghcide/test/exe/HaddockTests.hs new file mode 100644 index 0000000000..f45468d87f --- /dev/null +++ b/ghcide/test/exe/HaddockTests.hs @@ -0,0 +1,90 @@ + +module HaddockTests (tests) where + +import Development.IDE.Spans.Common +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests + = testGroup "haddock" + [ testCase "Num" $ checkHaddock + (unlines + [ "However, '(+)' and '(*)' are" + , "customarily expected to define a ring and have the following properties:" + , "" + , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" + , "[__Commutativity of (+)__]: @x + y@ = @y + x@" + , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" + ] + ) + (unlines + [ "" + , "" + , "However, `(+)` and `(*)` are" + , "customarily expected to define a ring and have the following properties: " + , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" + , "+ ****Commutativity of (+)****: `x + y` = `y + x`" + , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" + ] + ) + , testCase "unsafePerformIO" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + , testCase "ordered list" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + ] + where + checkHaddock s txt = spanDocToMarkdownForTest s @?= txt diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs new file mode 100644 index 0000000000..f630d52e39 --- /dev/null +++ b/ghcide/test/exe/HighlightTests.hs @@ -0,0 +1,85 @@ + +module HighlightTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "highlight" + [ testSessionWait "value" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 3 2) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 0 2 3) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 0 3 3) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read) + ] + , testSessionWait "type" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 2 8) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read) + ] + , testSessionWait "local" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 6 5) + liftIO $ highlights @?= + [ DocumentHighlight (R 6 4 6 7) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) + ] + , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96] "Ghc9 highlights the constructor and not just this field" $ + testSessionWait "record" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 4 15) + liftIO $ highlights @?= + -- Span is just the .. on 8.10, but Rec{..} before + [ if ghcVersion >= GHC810 + then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) + else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) + ] + highlights <- getHighlights doc (Position 3 17) + liftIO $ highlights @?= + [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) + -- Span is just the .. on 8.10, but Rec{..} before + , if ghcVersion >= GHC810 + then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) + else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Read) + ] + ] + where + source = T.unlines + ["{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"foo :: Int" + ,"foo = 3 :: Int" + ,"bar = foo" + ," where baz = let x = foo in x" + ,"baz arg = arg + x" + ," where x = arg" + ] + recsource = T.unlines + ["{-# LANGUAGE RecordWildCards #-}" + ,"{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"data Rec = Rec { field1 :: Int, field2 :: Char }" + ,"foo Rec{..} = field2 + field1" + ] diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs new file mode 100644 index 0000000000..7aad572564 --- /dev/null +++ b/ghcide/test/exe/IfaceTests.hs @@ -0,0 +1,163 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module IfaceTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Util +import Development.IDE.Test (configureCheckProject, + expectDiagnostics, + expectNoMoreDiagnostics, + getInterfaceFilesDir) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +import System.IO.Extra hiding (withTempDir) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "Interface loading tests" + [ -- https://github.com/haskell/ghcide/pull/645/ + ifaceErrorTest + , ifaceErrorTest2 + , ifaceErrorTest3 + , ifaceTHTest + ] + + +-- | test that TH reevaluates across interfaces +ifaceTHTest :: TestTree +ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () + _bSource <- liftIO $ readFileUtf8 bPath -- a :: () + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + cdoc <- createDoc cPath "haskell" cSource + + -- Change [TH]a from () to Bool + liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) + + -- Check that the change propagates to C + changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource] + expectDiagnostics + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] + closeDoc cdoc + +ifaceErrorTest :: TestTree +ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do + configureCheckProject True + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + -- save so that we can that the error propagates to A + sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) + + + -- Check that the error propagates to A + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] + + -- Check that we wrote the interfaces for B when we saved + hidir <- getInterfaceFilesDir bdoc + hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" + liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists + + pdoc <- openDoc pPath "haskell" + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ] + changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + -- This is clearly inconsistent, and the expected outcome a bit surprising: + -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics + -- - P is being typechecked with the last successful artifacts for A. + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 + +ifaceErrorTest2 :: TestTree +ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- Add a new definition to P + changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + expectDiagnostics + -- As in the other test, P is being typechecked with the last successful artifacts for A + -- (ot thanks to -fdeferred-type-errors) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding")]) + ] + + expectNoMoreDiagnostics 2 + +ifaceErrorTest3 :: TestTree +ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- P should not typecheck, as there are no last valid artifacts for A + _pdoc <- createDoc pPath "haskell" pSource + + -- In this example the interface file for A should not exist (modulo the cache folder) + -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs new file mode 100644 index 0000000000..681e214225 --- /dev/null +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -0,0 +1,97 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} + +module InitializeResponseTests (tests) where + +import Control.Monad +import Data.List.Extra +import Data.Row +import qualified Data.Text as T +import Development.IDE.Plugin.TypeLenses (typeLensCommandId) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Development.IDE.Plugin.Test (blockCommandId) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = withResource acquire release tests where + + -- these tests document and monitor the evolution of the + -- capabilities announced by the server in the initialize + -- response. Currently the server advertises almost no capabilities + -- at all, in some cases failing to announce capabilities that it + -- actually does provide! Hopefully this will change ... + tests :: IO (TResponseMessage Method_Initialize) -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just $ InL True) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True) Nothing) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InL True) + , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) + -- BUG in lsp-test, this test fails, just change the accepted response + -- for now + , chk "NO goto implementation" _implementationProvider (Just $ InL False) + , chk " find references" _referencesProvider (Just $ InL True) + , chk " doc highlight" _documentHighlightProvider (Just $ InL True) + , chk " doc symbol" _documentSymbolProvider (Just $ InL True) + , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) + , chk " code action" _codeActionProvider (Just $ InL False) + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) + , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) + , chk "NO doc range formatting" + _documentRangeFormattingProvider (Just $ InL False) + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider (Just $ InL False) + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" (^. L.colorProvider) (Just $ InL False) + , chk "NO folding range" _foldingRangeProvider (Just $ InL False) + , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] + , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} + .+ #fileOperations .== Nothing) + , chk "NO experimental" (^. L.experimental) Nothing + ] where + + tds = Just (InL (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TextDocumentSyncKind_Incremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title doTest + where + doTest = do + ir <- getInitializeResponse + let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir + commandNames = (!! 2) . T.splitOn ":" <$> commands + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) + + innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities + innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" + + acquire :: IO (TResponseMessage Method_Initialize) + acquire = run initializeResponse + + release :: TResponseMessage Method_Initialize -> IO () + release = const $ pure () + diff --git a/ghcide/test/exe/LogType.hs b/ghcide/test/exe/LogType.hs new file mode 100644 index 0000000000..292a81c32e --- /dev/null +++ b/ghcide/test/exe/LogType.hs @@ -0,0 +1,17 @@ +module LogType (Log(..)) where + +import qualified Development.IDE.Main as IDE +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import Ide.Logger (Pretty (pretty)) +import Language.LSP.VFS (VfsLog) + +data Log + = LogGhcIde Ghcide.Log + | LogIDEMain IDE.Log + | LogVfs VfsLog + +instance Pretty Log where + pretty = \case + LogGhcIde log -> pretty log + LogIDEMain log -> pretty log + LogVfs log -> pretty log diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 91fa90bf00..47aa36a568 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -26,110 +26,11 @@ Therefore, avoid mixing both progress reports and diagnostics in the same test -} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} -module Main (main) where -import Data.Row -import Control.Applicative.Combinators -import Control.Concurrent -import Control.Exception (bracket_, catch, - finally) -import qualified Control.Lens as Lens -import qualified Control.Lens.Extras as Lens -import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (toJSON) -import qualified Data.Aeson as A -import Data.Default -import Data.Foldable -import Data.List.Extra -import Data.Proxy -import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Utf16.Rope (Rope) -import qualified Data.Text.Utf16.Rope as Rope -import Development.IDE.Core.PositionMapping (PositionResult (..), - fromCurrent, - positionResultToMaybe, - toCurrent) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) -import Development.IDE.GHC.Util -import qualified Development.IDE.Main as IDE -import Development.IDE.Plugin.TypeLenses (typeLensCommandId) -import Development.IDE.Spans.Common -import Development.IDE.Test (Cursor, - canonicalizeUri, - configureCheckProject, - diagnostic, - expectCurrentDiagnostics, - expectDiagnostics, - expectDiagnosticsWithTags, - expectNoMoreDiagnostics, - flushMessages, - getInterfaceFilesDir, - getStoredKeys, - isReferenceReady, - referenceReady, - standardizeQuotes, - waitForAction, - waitForGC, - waitForTypecheck) -import Development.IDE.Test.Runfiles -import qualified Development.IDE.Types.Diagnostics as Diagnostics -import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import Ide.Plugin.Config -import Language.LSP.Test -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), mkRange) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message -import Language.LSP.VFS (VfsLog, applyChange) -import Network.URI -import System.Directory -import System.Environment.Blank (getEnv, setEnv, - unsetEnv) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath -import System.Info.Extra (isMac, isWindows) -import qualified System.IO.Extra -import System.IO.Extra hiding (withTempDir) -import System.Mem (performGC) -import System.Process.Extra (CreateProcess (cwd), - createPipe, proc, - readCreateProcessWithExitCode) -import Test.QuickCheck +module Main (main) where -- import Test.QuickCheck.Instances () -import Control.Concurrent.Async -import Control.Lens (to, (.~), (^.)) -import Control.Monad.Extra (whenJust) import Data.Function ((&)) -import Data.Functor.Identity (runIdentity) -import Data.IORef -import Data.IORef.Extra (atomicModifyIORef_) -import Data.String (IsString (fromString)) -import Data.Tuple.Extra -import Development.IDE.Core.FileStore (getModTime) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), - WaitForIdeRuleResult (..), - blockCommandId) import Ide.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), @@ -138,62 +39,42 @@ import Ide.Logger (Logger (Logger), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, - makeDefaultStderrRecorder, - toCologActionWithPrio) -import qualified FuzzySearch + makeDefaultStderrRecorder) import GHC.Stack (emptyCallStack) -import GHC.TypeLits (symbolVal) import qualified HieDbRetry -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types -import qualified Progress -import System.Time.Extra -import qualified Test.QuickCheck.Monadic as MonadicQuickCheck -import Test.QuickCheck.Monadic (forAllM, monadicIO) import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun -import Test.Tasty.QuickCheck -import Text.Printf (printf) -import Text.Regex.TDFA ((=~)) - -data Log - = LogGhcIde Ghcide.Log - | LogIDEMain IDE.Log - | LogVfs VfsLog - -instance Pretty Log where - pretty = \case - LogGhcIde log -> pretty log - LogIDEMain log -> pretty log - LogVfs log -> pretty log - --- | Wait for the next progress begin step -waitForProgressBegin :: Session () -waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just () - _ -> Nothing --- | Wait for the first progress end step --- Also implemented in hls-test-utils Test.Hls -waitForProgressDone :: Session () -waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just () - _ -> Nothing - --- | Wait for all progress to be done --- Needs at least one progress done notification to return --- Also implemented in hls-test-utils Test.Hls -waitForAllProgressDone :: Session () -waitForAllProgressDone = loop - where - loop = do - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just () - _ -> Nothing - done <- null <$> getIncompleteProgressSessions - unless done loop +import LogType () +import OpenCloseTest +import InitializeResponseTests +import CompletionTests +import CPPTests +import DiagnosticTests +import CodeLensTests +import OutlineTests +import HighlightTests +import FindDefinitionAndHoverTests +import PluginSimpleTests +import PluginParsedResultTests +import PreprocessorTests +import THTests +import SymlinkTests +import SafeTests +import UnitTests +import HaddockTests +import PositionMappingTests +import WatchedFileTests +import CradleTests +import DependentFileTest +import NonLspCommandLine +import IfaceTests +import BootTests +import RootUriTests +import AsyncTests +import ClientSettingsTests +import ReferenceTests +import GarbageCollectionTests main :: IO () main = do @@ -211,3415 +92,34 @@ main = do -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" - [ testSession "open close" $ do - doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate) - waitForProgressBegin - closeDoc doc - waitForProgressDone - , initializeResponseTests - , completionTests - , cppTests - , diagnosticTests - , codeLensesTests - , outlineTests - , highlightTests - , findDefinitionAndHoverTests - , pluginSimpleTests - , pluginParsedResultTests - , preprocessorTests - , thTests - , symlinkTests - , safeTests - , unitTests recorder logger - , haddockTests - , positionMappingTests recorder - , watchedFilesTests - , cradleTests - , dependentFileTest - , nonLspCommandLine - , ifaceTests - , bootTests - , rootUriTests - , asyncTests - , clientSettingsTest - , referenceTests - , garbageCollectionTests + [ OpenCloseTest.tests + , InitializeResponseTests.tests + , CompletionTests.tests + , CPPTests.tests + , DiagnosticTests.tests + , CodeLensTests.tests + , OutlineTests.tests + , HighlightTests.tests + , FindDefinitionAndHoverTests.tests + , PluginSimpleTests.tests + , PluginParsedResultTests.tests + , PreprocessorTests.tests + , THTests.tests + , SymlinkTests.tests + , SafeTests.tests + , UnitTests.tests recorder logger + , HaddockTests.tests + , PositionMappingTests.tests + , WatchedFileTests.tests + , CradleTests.tests + , DependentFileTest.tests + , NonLspCommandLine.tests + , IfaceTests.tests + , BootTests.tests + , RootUriTests.tests + , AsyncTests.tests + , ClientSettingsTests.tests + , ReferenceTests.tests + , GarbageCollectionTests.tests , HieDbRetry.tests - ] - -initializeResponseTests :: TestTree -initializeResponseTests = withResource acquire release tests where - - -- these tests document and monitor the evolution of the - -- capabilities announced by the server in the initialize - -- response. Currently the server advertises almost no capabilities - -- at all, in some cases failing to announce capabilities that it - -- actually does provide! Hopefully this will change ... - tests :: IO (TResponseMessage Method_Initialize) -> TestTree - tests getInitializeResponse = - testGroup "initialize response capabilities" - [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just $ InL True) - , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True) Nothing) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just $ InL True) - , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) - -- BUG in lsp-test, this test fails, just change the accepted response - -- for now - , chk "NO goto implementation" _implementationProvider (Just $ InL False) - , chk " find references" _referencesProvider (Just $ InL True) - , chk " doc highlight" _documentHighlightProvider (Just $ InL True) - , chk " doc symbol" _documentSymbolProvider (Just $ InL True) - , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) - , chk " code action" _codeActionProvider (Just $ InL False) - , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) - , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) - , chk "NO doc range formatting" - _documentRangeFormattingProvider (Just $ InL False) - , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ InL False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" (^. L.colorProvider) (Just $ InL False) - , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] - , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} - .+ #fileOperations .== Nothing) - , chk "NO experimental" (^. L.experimental) Nothing - ] where - - tds = Just (InL (TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TextDocumentSyncKind_Incremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) - - chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree - chk title getActual expected = - testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - - che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree - che title getActual expected = testCase title doTest - where - doTest = do - ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir - commandNames = (!! 2) . T.splitOn ":" <$> commands - zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) - - innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities - innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c - innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" - - acquire :: IO (TResponseMessage Method_Initialize) - acquire = run initializeResponse - - release :: TResponseMessage Method_Initialize -> IO () - release = const $ pure () - - -diagnosticTests :: TestTree -diagnosticTests = testGroup "diagnostics" - [ testSessionWait "fix syntax error" $ do - let content = T.unlines [ "module Testing wher" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] - let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 19) - .+ #rangeLength .== Nothing - .+ #text .== "where" - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [])] - , testSessionWait "introduce syntax error" $ do - let content = T.unlines [ "module Testing where" ] - doc <- createDoc "Testing.hs" "haskell" content - void $ skipManyTill anyMessage (message SMethod_WindowWorkDoneProgressCreate) - waitForProgressBegin - let change = TextDocumentContentChangeEvent$ InL $ #range .== Range (Position 0 15) (Position 0 18) - .+ #rangeLength .== Nothing - .+ #text .== "wher" - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] - , testSessionWait "update syntax error" $ do - let content = T.unlines [ "module Testing(missing) where" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])] - let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16) - .+ #rangeLength .== Nothing - .+ #text .== "l" - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])] - , testSessionWait "variable not in scope" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int -> Int" - , "foo a _b = a + ab" - , "bar :: Int -> Int -> Int" - , "bar _a b = cd + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab") - , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd") - ] - ) - ] - , testSessionWait "type error" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String -> Int" - , "foo a b = a + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'")] - ) - ] - , testSessionWait "typed hole" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String" - , "foo a = _ a" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")] - ) - ] - - , testGroup "deferral" $ - let sourceA a = T.unlines - [ "module A where" - , "a :: Int" - , "a = " <> a] - sourceB = T.unlines - [ "module B where" - , "import A ()" - , "b :: Float" - , "b = True"] - bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" - expectedDs aMessage = - [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage)]) - , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage)])] - deferralTest title binding msg = testSessionWait title $ do - _ <- createDoc "A.hs" "haskell" $ sourceA binding - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics $ expectedDs msg - in - [ deferralTest "type error" "True" "Couldn't match expected type" - , deferralTest "typed hole" "_" "Found hole" - , deferralTest "out of scope var" "unbound" "Variable not in scope" - ] - - , testSessionWait "remove required module" $ do - let contentA = T.unlines [ "module ModuleA where" ] - docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 20) - .+ #rangeLength .== Nothing - .+ #text .== "" - changeDoc docA [change] - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])] - , testSessionWait "add missing module" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - expectDiagnostics [("ModuleB.hs", [])] - , testCase "add missing module (non workspace)" $ - -- By default lsp-test sends FileWatched notifications for all files, which we don't want - -- as non workspace modules will not be watched by the LSP server. - -- To work around this, we tell lsp-test that our client doesn't have the - -- FileWatched capability, which is enough to disable the notifications - withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA - expectDiagnostics [(tmpDir "ModuleB.hs", [])] - , testSessionWait "cyclic module dependency" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB" - ] - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics - [ ( "ModuleA.hs" - , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - , ( "ModuleB.hs" - , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSession' "deeply nested cyclic module dependency" $ \path -> do - let contentA = unlines - [ "module ModuleA where" , "import ModuleB" ] - let contentB = unlines - [ "module ModuleB where" , "import ModuleA" ] - let contentC = unlines - [ "module ModuleC where" , "import ModuleB" ] - let contentD = T.unlines - [ "module ModuleD where" , "import ModuleC" ] - cradle = - "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}" - liftIO $ writeFile (path "ModuleA.hs") contentA - liftIO $ writeFile (path "ModuleB.hs") contentB - liftIO $ writeFile (path "ModuleC.hs") contentC - liftIO $ writeFile (path "hie.yaml") cradle - _ <- createDoc "ModuleD.hs" "haskell" contentD - expectDiagnostics - [ ( "ModuleB.hs" - , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSessionWait "cyclic module dependency with hs-boot" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import {-# SOURCE #-} ModuleB" - ] - let contentB = T.unlines - [ "{-# OPTIONS -Wmissing-signatures#-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial diagnostic - , "foo = ()" - ] - let contentBboot = T.unlines - [ "module ModuleB where" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] - , testSessionWait "correct reference used with hs-boot" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import {-# SOURCE #-} ModuleA()" - ] - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB()" - , "x = 5" - ] - let contentAboot = T.unlines - [ "module ModuleA where" - ] - let contentC = T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "module ModuleC where" - , "import ModuleA" - -- this reference will fail if it gets incorrectly - -- resolved to the hs-boot file - , "y = x" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot - _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] - , testSessionWait "redundant import" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnosticsWithTags - [ ( "ModuleB.hs" - , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)] - ) - ] - , testSessionWait "redundant import even without warning" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial warning for testing purposes - , "foo = ()" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] - , testSessionWait "package imports" $ do - let thisDataListContent = T.unlines - [ "module Data.List where" - , "x :: Integer" - , "x = 123" - ] - let mainContent = T.unlines - [ "{-# LANGUAGE PackageImports #-}" - , "module Main where" - , "import qualified \"this\" Data.List as ThisList" - , "import qualified \"base\" Data.List as BaseList" - , "useThis = ThisList.x" - , "useBase = BaseList.map" - , "wrong1 = ThisList.map" - , "wrong2 = BaseList.x" - , "main = pure ()" - ] - _ <- createDoc "Data/List.hs" "haskell" thisDataListContent - _ <- createDoc "Main.hs" "haskell" mainContent - expectDiagnostics - [ ( "Main.hs" - , [(DiagnosticSeverity_Error, (6, 9), - if ghcVersion >= GHC96 then - "Variable not in scope: ThisList.map" - else if ghcVersion >= GHC94 then - "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 - else - "Not in scope: \8216ThisList.map\8217") - ,(DiagnosticSeverity_Error, (7, 9), - if ghcVersion >= GHC96 then - "Variable not in scope: BaseList.x" - else if ghcVersion >= GHC94 then - "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 - else - "Not in scope: \8216BaseList.x\8217") - ] - ) - ] - , testSessionWait "unqualified warnings" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Foo where" - , "foo :: Ord a => a -> Int" - , "foo _a = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - -- The test is to make sure that warnings contain unqualified names - -- where appropriate. The warning should use an unqualified name 'Ord', not - -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to - -- test this is fairly arbitrary. - , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") - ] - ) - ] - , testSessionWait "lower-case drive" $ do - let aContent = T.unlines - [ "module A.A where" - , "import A.B ()" - ] - bContent = T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A.B where" - , "import Data.List" - ] - uriB <- getDocUri "A/B.hs" - Just pathB <- pure $ uriToFilePath uriB - uriB <- pure $ - let (drive, suffix) = splitDrive pathB - in filePathToUri (joinDrive (lower drive) suffix) - liftIO $ createDirectoryIfMissing True (takeDirectory pathB) - liftIO $ writeFileUTF8 pathB $ T.unpack bContent - uriA <- getDocUri "A/A.hs" - Just pathA <- pure $ uriToFilePath uriA - uriA <- pure $ - let (drive, suffix) = splitDrive pathA - in filePathToUri (joinDrive (lower drive) suffix) - let itemA = TextDocumentItem uriA "haskell" 0 aContent - let a = TextDocumentIdentifier uriA - sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams itemA) - TNotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic - -- Check that if we put a lower-case drive in for A.A - -- the diagnostics for A.B will also be lower-case. - liftIO $ fileUri @?= uriB - let msg :: T.Text = (head diags) ^. L.message - liftIO $ unless ("redundant" `T.isInfixOf` msg) $ - assertFailure ("Expected redundant import but got " <> T.unpack msg) - closeDoc a - , testSessionWait "haddock parse error" $ do - let fooContent = T.unlines - [ "module Foo where" - , "foo :: Int" - , "foo = 1 {-|-}" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - if ghcVersion >= GHC90 then - -- Haddock parse errors are ignored on ghc-9.0 - pure () - else - expectDiagnostics - [ ( "Foo.hs" - , [(DiagnosticSeverity_Warning, (2, 8), "Haddock parse error on input")] - ) - ] - , testSessionWait "strip file path" $ do - let - name = "Testing" - content = T.unlines - [ "module " <> name <> " where" - , "value :: Maybe ()" - , "value = [()]" - ] - _ <- createDoc (T.unpack name <> ".hs") "haskell" content - notification <- skipManyTill anyMessage diagnostic - let - offenders = - L.params . - L.diagnostics . - Lens.folded . - L.message . - Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) - failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg - Lens.mapMOf_ offenders failure notification - , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" - let fooContent = T.unlines - [ "module Foo where" - , "foo = ()" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DiagnosticSeverity_Warning, (1, 0), "Top-level binding with no type signature:") - ] - ) - ] - , testSessionWait "-Werror in pragma is ignored" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wall -Werror #-}" - , "module Foo() where" - , "foo :: Int" - , "foo = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DiagnosticSeverity_Warning, (3, 0), "Defined but not used:") - ] - ) - ] - , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - aPath = dir "A.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int - - bdoc <- createDoc bPath "haskell" bSource - _pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B which introduces a type error in A (imported from P) - changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ - T.unlines ["module B where", "y :: Bool", "y = undefined"]] - expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ] - - -- Open A and edit to fix the type error - adoc <- createDoc aPath "haskell" aSource - changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ - T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] - - expectDiagnostics - [ ( "P.hs", - [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), - (DiagnosticSeverity_Warning, (4, 0), "Top-level binding") - ] - ), - ("A.hs", []) - ] - expectNoMoreDiagnostics 1 - - , testSessionWait "deduplicate missing module diagnostics" $ do - let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] - - changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module Foo() where" ] - expectDiagnostics [] - - changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines - [ "module Foo() where" , "import MissingModule" ] ] - expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] - - , testGroup "Cancellation" - [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc - , cancellationTestGroup "edit import" editImport noSession yesParse noTc - , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc - ] - ] - where - editPair x y = let p = Position x y ; p' = Position x (y+2) in - (TextDocumentContentChangeEvent $ InL $ #range .== Range p p - .+ #rangeLength .== Nothing - .+ #text .== "fd" - ,TextDocumentContentChangeEvent $ InL $ #range .== Range p p' - .+ #rangeLength .== Nothing - .+ #text .== "") - editHeader = editPair 0 0 - editImport = editPair 2 10 - editBody = editPair 3 10 - - noParse = False - yesParse = True - - noSession = False - yesSession = True - - noTc = False - yesTc = True - -cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree -cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name - [ cancellationTemplate edits Nothing - , cancellationTemplate edits $ Just ("GetFileContents", True) - , cancellationTemplate edits $ Just ("GhcSession", True) - -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) - , cancellationTemplate edits $ Just ("GetModSummary", True) - , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) - -- getLocatedImports never fails - , cancellationTemplate edits $ Just ("GetLocatedImports", True) - , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) - , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) - , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) - , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) - ] - -cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree -cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do - doc <- createDoc "Foo.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module Foo where" - , "import Data.List()" - , "f0 x = (x,x)" - ] - - -- for the example above we expect one warning - let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding") ] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - -- Now we edit the document and wait for the given key (if any) - changeDoc doc [edit] - whenJust mbKey $ \(key, expectedResult) -> do - WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc - liftIO $ ideResultSuccess @?= expectedResult - - -- The 2nd edit cancels the active session and unbreaks the file - -- wait for typecheck and check that the current diagnostics are accurate - changeDoc doc [undoEdit] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - expectNoMoreDiagnostics 0.5 - where - -- similar to run except it disables kick - runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s - - typeCheck doc = do - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ assertBool "The file should typecheck" ideResultSuccess - -- wait for the debouncer to publish diagnostics if the rule runs - liftIO $ sleep 0.2 - -- flush messages to ensure current diagnostics state is updated - flushMessages - -codeLensesTests :: TestTree -codeLensesTests = testGroup "code lenses" - [ addSigLensesTests - ] - -watchedFilesTests :: TestTree -watchedFilesTests = testGroup "watched files" - [ testGroup "Subscriptions" - [ testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" - _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics - - -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle - liftIO $ length watchedFileRegs @?= 2 - - , testSession' "non workspace file" $ \sessionDir -> do - tmpDir <- liftIO getTemporaryDirectory - let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" - liftIO $ writeFile (sessionDir "hie.yaml") yaml - _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics - - -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle - liftIO $ length watchedFileRegs @?= 2 - - -- TODO add a test for didChangeWorkspaceFolder - ] - , testGroup "Changes" - [ - testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Bool" - ,"b = False"] - _doc <- createDoc "A.hs" "haskell" $ T.unlines - ["module A where" - ,"import B" - ,"a :: ()" - ,"a = b" - ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] - -- modify B off editor - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Int" - ,"b = 0"] - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - [FileEvent (filePathToUri $ sessionDir "B.hs") FileChangeType_Changed ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] - ] - ] - -addSigLensesTests :: TestTree -addSigLensesTests = - let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - moduleH exported = - T.unlines - [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" - , "module Sigs(" <> exported <> ") where" - , "import qualified Data.Complex as C" - , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" - , "data T1 a where" - , " MkT1 :: (Show b) => a -> b -> T1 a" - ] - before enableGHCWarnings exported (def, _) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others - after' enableGHCWarnings exported (def, sig) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others - createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] - sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do - let originalCode = before enableGHCWarnings exported def others - let expectedCode = after' enableGHCWarnings exported def others - sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode - doc <- createDoc "Sigs.hs" "haskell" originalCode - waitForProgressDone - codeLenses <- getCodeLenses doc - if not $ null $ snd def - then do - liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses - executeCommand $ fromJust $ head codeLenses ^. L.command - modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) - liftIO $ expectedCode @=? modifiedCode - else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses - cases = - [ ("abc = True", "abc :: Bool") - , ("foo a b = a + b", "foo :: Num a => a -> a -> a") - , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") - , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") - , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") - , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") - , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") - , ("head = 233", "head :: Integer") - , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") - , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") - , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") - , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") - , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") - ] - in testGroup - "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] - , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) - , testGroup - "diagnostics mode works" - [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] - , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] - ] - , testSession "keep stale lens" $ do - let content = T.unlines - [ "module Stale where" - , "f = _" - ] - doc <- createDoc "Stale.hs" "haskell" content - oldLens <- getCodeLenses doc - liftIO $ length oldLens @?= 1 - let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_` - _ <- applyEdit doc edit - newLens <- getCodeLenses doc - liftIO $ newLens @?= oldLens - ] - -defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location] -defToLocation (InL (Definition (InL l))) = [l] -defToLocation (InL (Definition (InR ls))) = ls -defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink -defToLocation (InR (InR Null)) = [] - -checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session () -checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where - check (ExpectRange expectedRange) = do - assertNDefinitionsFound 1 defs - assertRangeCorrect (head defs) expectedRange - check (ExpectLocation expectedLocation) = do - assertNDefinitionsFound 1 defs - liftIO $ do - canonActualLoc <- canonicalizeLocation (head defs) - canonExpectedLoc <- canonicalizeLocation expectedLocation - canonActualLoc @?= canonExpectedLoc - check ExpectNoDefinitions = do - assertNDefinitionsFound 0 defs - check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" - check _ = pure () -- all other expectations not relevant to getDefinition - - assertNDefinitionsFound :: Int -> [a] -> Session () - assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) - - assertRangeCorrect Location{_range = foundRange} expectedRange = - liftIO $ expectedRange @=? foundRange - -canonicalizeLocation :: Location -> IO Location -canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range - -findDefinitionAndHoverTests :: TestTree -findDefinitionAndHoverTests = let - - tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree - tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do - - -- Dirty the cache to check that definitions work even in the presence of iface files - liftIO $ runInDir dir $ do - let fooPath = dir "Foo.hs" - fooSource <- liftIO $ readFileUtf8 fooPath - fooDoc <- createDoc fooPath "haskell" fooSource - _ <- getHover fooDoc $ Position 4 3 - closeDoc fooDoc - - doc <- openTestDataDoc (dir sfp) - waitForProgressDone - found <- get doc pos - check found targetRange - - - - checkHover :: Maybe Hover -> Session [Expect] -> Session () - checkHover hover expectations = traverse_ check =<< expectations where - - check expected = - case hover of - Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> - case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets - ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets - ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) - ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover - _ -> pure () -- all other expectations not relevant to hover - _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - - assertFoundIn :: T.Text -> T.Text -> Assertion - assertFoundIn part whole = assertBool - (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) - (part `T.isInfixOf` whole) - - assertNotFoundIn :: T.Text -> T.Text -> Assertion - assertNotFoundIn part whole = assertBool - (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) - (not . T.isInfixOf part $ whole) - - sourceFilePath = T.unpack sourceFileName - sourceFileName = "GotoHover.hs" - - mkFindTests tests = testGroup "get" - [ testGroup "definition" $ mapMaybe fst tests - , testGroup "hover" $ mapMaybe snd tests - , checkFileCompiles sourceFilePath $ - expectDiagnostics - [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) - , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) - ] - , testGroup "type-definition" typeDefinitionTests - , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] - - typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" - , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] - - recordDotSyntaxTests - | ghcVersion >= GHC92 = - [ tst (getHover, checkHover) (Position 19 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" - , tst (getHover, checkHover) (Position 19 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" - , tst (getHover, checkHover) (Position 19 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" - ] - | otherwise = [] - - test runDef runHover look expect = testM runDef runHover look (return expect) - - testM runDef runHover look expect title = - ( runDef $ tst def look sourceFilePath expect title - , runHover $ tst hover look sourceFilePath expect title ) where - def = (getDefinitions, checkDefs) - hover = (getHover , checkHover) - - -- search locations expectations on results - fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] - fffL8 = Position 12 4 ; - fffL14 = Position 18 7 ; - aL20 = Position 19 15 - aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] - dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] - dcL12 = Position 16 11 ; - xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] - tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] - vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] - opL16 = Position 20 15 ; op = [mkR 21 2 21 4] - opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] - aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] - b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] - xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] - clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] - clL25 = Position 29 9 - eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] - dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] - dnbL30 = Position 34 23 - lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] - lclL33 = Position 37 22 - mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] - mclL37 = Position 41 1 - spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] - docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] - ; constr = [ExpectHoverText ["Monad m"]] - eitL40 = Position 44 28 ; kindE = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]] - intL40 = Position 44 34 ; kindI = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]] - tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] - intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] - chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] - txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] - lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] - outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] - innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] - holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] - holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] - cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] - imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] - reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] - thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] - cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] - in - mkFindTests - -- def hover look expect - [ - if ghcVersion >= GHC90 then - -- It suggests either going to the constructor or to the field - test broken yes fffL4 fff "field in record definition" - else - test yes yes fffL4 fff "field in record definition" - , test yes yes fffL8 fff "field in record construction #1102" - , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs - , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes dcL7 tcDC "data constructor record #1029" - , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 - , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes xtcL5 xtc "type constructor external #717,1028" - , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes clL23 cls "class in instance declaration #1027" - , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes eclL15 ecls "external class in signature #717,1027" - , test yes yes dnbL29 dnb "do-notation bind #1073" - , test yes yes dnbL30 dnb "do-notation lookup" - , test yes yes lcbL33 lcb "listcomp bind #1073" - , test yes yes lclL33 lcb "listcomp lookup" - , test yes yes mclL36 mcl "top-level fn 1st clause" - , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" - , if ghcVersion >= GHC810 then - test yes yes spaceL37 space "top-level fn on space #1002" - else - test yes broken spaceL37 space "top-level fn on space #1002" - , test no yes docL41 doc "documentation #1129" - , test no yes eitL40 kindE "kind of Either #1017" - , test no yes intL40 kindI "kind of Int #1017" - , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" - , test no broken intL41 litI "literal Int in hover info #1016" - , test no broken chrL36 litC "literal Char in hover info #1016" - , test no broken txtL8 litT "literal Text in hover info #1016" - , test no broken lstL43 litL "literal List in hover info #1016" - , test yes yes cmtL68 lackOfdEq "no Core symbols #3280" - , if ghcVersion >= GHC90 then - test no yes docL41 constr "type constraint in hover info #1012" - else - test no broken docL41 constr "type constraint in hover info #1012" - , test no yes outL45 outSig "top-level signature #767" - , test broken broken innL48 innSig "inner signature #767" - , test no yes holeL60 hleInfo "hole without internal name #831" - , test no yes holeL65 hleInfo2 "hole with variable" - , test no yes cccL17 docLink "Haddock html links" - , testM yes yes imported importedSig "Imported symbol" - , if | isWindows -> - -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 - testM no yes reexported reexportedSig "Imported symbol (reexported)" - | otherwise -> - testM yes yes reexported reexportedSig "Imported symbol (reexported)" - , if | ghcVersion == GHC90 && isWindows -> - test no broken thLocL57 thLoc "TH Splice Hover" - | otherwise -> - test no yes thLocL57 thLoc "TH Splice Hover" - ] - where yes, broken :: (TestTree -> Maybe TestTree) - yes = Just -- test should run and pass - broken = Just . (`xfail` "known broken") - no = const Nothing -- don't run this test at all - skip = const Nothing -- unreliable, don't run - -checkFileCompiles :: FilePath -> Session () -> TestTree -checkFileCompiles fp diag = - testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do - void (openTestDataDoc (dir fp)) - diag - - -pluginSimpleTests :: TestTree -pluginSimpleTests = - ignoreInWindowsForGHC810 $ - -- Build profile: -w ghc-9.4.2 -O1 - -- In order, the following will be built (use -v for more details): - -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) - -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) - -- - plugin-1.0.0 (lib) (first run) - -- Starting ghc-typelits-natnormalise-0.7.7 (lib) - -- Building ghc-typelits-natnormalise-0.7.7 (lib) - - -- Failed to build ghc-typelits-natnormalise-0.7.7. - -- Build log ( - -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log - -- ): - -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. - -- Building library for ghc-typelits-natnormalise-0.7.7.. - -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) - -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) - -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) - -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory - - -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is - -- required by plugin-1.0.0). See the build log above for details. - ignoreFor (BrokenForGHC [GHC96]) "fragile, frequently times out" $ - ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $ - testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do - _ <- openDoc (dir "KnownNat.hs") "haskell" - liftIO $ writeFile (dir"hie.yaml") - "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" - - expectDiagnostics - [ ( "KnownNat.hs", - [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")] - ) - ] - -pluginParsedResultTests :: TestTree -pluginParsedResultTests = - ignoreInWindowsForGHC810 $ - ignoreForGHC92Plus "No need for this plugin anymore!" $ - testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do - _ <- openDoc (dir "RecordDot.hs") "haskell" - expectNoMoreDiagnostics 2 - -cppTests :: TestTree -cppTests = - testGroup "cpp" - [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do - let content = - T.unlines - [ "{-# LANGUAGE CPP #-}", - "module Testing where", - "#ifdef FOO", - "foo = 42" - ] - -- The error locations differ depending on which C-preprocessor is used. - -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either - -- of them. - (run $ expectError content (2, maxBound)) - `catch` ( \e -> do - let _ = e :: HUnitFailure - run $ expectError content (2, 1) - ) - , testSessionWait "cpp-ghcide" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - ["{-# LANGUAGE CPP #-}" - ,"main =" - ,"#ifdef __GHCIDE__" - ," worked" - ,"#else" - ," failed" - ,"#endif" - ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked")])] - ] - where - expectError :: T.Text -> Cursor -> Session () - expectError content cursor = do - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DiagnosticSeverity_Error, cursor, "error: unterminated")] - ) - ] - expectNoMoreDiagnostics 0.5 - -preprocessorTests :: TestTree -preprocessorTests = testSessionWait "preprocessor" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" - , "module Testing where" - , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")] - ) - ] - - -safeTests :: TestTree -safeTests = - testGroup - "SafeHaskell" - [ -- Test for https://github.com/haskell/ghcide/issues/424 - testSessionWait "load" $ do - let sourceA = - T.unlines - ["{-# LANGUAGE Trustworthy #-}" - ,"module A where" - ,"import System.IO.Unsafe" - ,"import System.IO ()" - ,"trustWorthyId :: a -> a" - ,"trustWorthyId i = unsafePerformIO $ do" - ," putStrLn \"I'm safe\"" - ," return i"] - sourceB = - T.unlines - ["{-# LANGUAGE Safe #-}" - ,"module B where" - ,"import A" - ,"safeId :: a -> a" - ,"safeId = trustWorthyId" - ] - - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectNoMoreDiagnostics 1 ] - -thTests :: TestTree -thTests = - testGroup - "TemplateHaskell" - [ -- Test for https://github.com/haskell/ghcide/pull/212 - testSessionWait "load" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module A where", - "import \"template-haskell\" Language.Haskell.TH", - "a :: Integer", - "a = $(litE $ IntegerL 3)" - ] - sourceB = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module B where", - "import A", - "import \"template-haskell\" Language.Haskell.TH", - "b :: Integer", - "b = $(litE $ IntegerL $ a) + n" - ] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ] - , testSessionWait "newtype-closure" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE DeriveDataTypeable #-}" - ,"{-# LANGUAGE TemplateHaskell #-}" - ,"module A (a) where" - ,"import Data.Data" - ,"import Language.Haskell.TH" - ,"newtype A = A () deriving (Data)" - ,"a :: ExpQ" - ,"a = [| 0 |]"] - let sourceB = - T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - ,"module B where" - ,"import A" - ,"b :: Int" - ,"b = $( a )" ] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - return () - , thReloadingTest False - , thLoadingTest - , thCoreTest - , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True - -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 - , thLinkingTest False - , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True - , testSessionWait "findsTHIdentifiers" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module A (a) where" - , "import Language.Haskell.TH (ExpQ)" - , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic - , "a = [| glorifiedID |]" - , "glorifiedID :: a -> a" - , "glorifiedID = id" ] - let sourceB = - T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "module B where" - , "import A" - , "main = $a (putStrLn \"success!\")"] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] - , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do - - -- This test defines a TH value with the meaning "data A = A" in A.hs - -- Loads and export the template in B.hs - -- And checks wether the constructor A can be loaded in C.hs - -- This test does not fail when either A and B get manually loaded before C.hs - -- or when we remove the seemingly unnecessary TH pragma from C.hs - - let cPath = dir "C.hs" - _ <- openDoc cPath "haskell" - expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] - ] - --- | Tests for projects that use symbolic links one way or another -symlinkTests :: TestTree -symlinkTests = - testGroup "Projects using Symlinks" - [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do - liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") - let fooPath = dir "src" "Foo.hs" - _ <- openDoc fooPath "haskell" - expectDiagnosticsWithTags [("src" "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])] - pure () - ] - --- | Test that all modules have linkables -thLoadingTest :: TestTree -thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do - let thb = dir "THB.hs" - _ <- openDoc thb "haskell" - expectNoMoreDiagnostics 1 - -thCoreTest :: TestTree -thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do - let thc = dir "THC.hs" - _ <- openDoc thc "haskell" - expectNoMoreDiagnostics 1 - --- | test that TH is reevaluated on typecheck -thReloadingTest :: Bool -> TestTree -thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do - - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] - bSource <- liftIO $ readFileUtf8 bPath -- $th - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - adoc <- createDoc aPath "haskell" aSource - bdoc <- createDoc bPath "haskell" bSource - cdoc <- createDoc cPath "haskell" cSource - - expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] - - -- Change th from () to Bool - let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] - -- generate an artificial warning to avoid timing out if the TH change does not propagate - changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource <> "\nfoo=()"] - - -- Check that the change propagates to C - expectDiagnostics - [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level bindin")]) - ] - - closeDoc adoc - closeDoc bdoc - closeDoc cdoc - where - name = "reloading-th-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -thLinkingTest :: Bool -> TestTree -thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do - - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] - bSource <- liftIO $ readFileUtf8 bPath -- $th_a - - adoc <- createDoc aPath "haskell" aSource - bdoc <- createDoc bPath "haskell" bSource - - expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] - - let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] - - -- modify b too - let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] - changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ bSource'] - waitForProgressBegin - waitForAllProgressDone - - expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")] - - closeDoc adoc - closeDoc bdoc - where - name = "th-linking-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -completionTests :: TestTree -completionTests - = testGroup "completion" - [ - testGroup "non local" nonLocalCompletionTests - , testGroup "topLevel" topLevelCompletionTests - , testGroup "local" localCompletionTests - , testGroup "package" packageCompletionTests - , testGroup "project" projectCompletionTests - , testGroup "other" otherCompletionTests - , testGroup "doc" completionDocTests - ] - -completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree -completionTest name src pos expected = testSessionWait name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- getCompletions docId pos - let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] - let emptyToMaybe x = if T.null x then Nothing else Just x - liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= - sortOn (Lens.view Lens._1) - [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] - forM_ (zip compls expected) $ \(item, (_,_,_,expectedSig, expectedDocs, _)) -> do - CompletionItem{..} <- - if (expectedSig || expectedDocs) && isJust (item ^. L.data_) - then do - rsp <- request SMethod_CompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x - else pure item - when expectedSig $ - liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) - when expectedDocs $ - liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) - - -topLevelCompletionTests :: [TestTree] -topLevelCompletionTests = [ - completionTest - "variable" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) - ], - completionTest - "constructor" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) - ], - completionTest - "class method" - ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] - (Position 0 8) - [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)], - completionTest - "type" - ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] - (Position 0 9) - [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)], - completionTest - "class" - ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] - (Position 0 9) - [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)], - completionTest - "records" - ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] - (Position 1 19) - [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing), - ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)], - completionTest - "recordsConstructor" - ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] - (Position 1 19) - [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing), - ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] - ] - -localCompletionTests :: [TestTree] -localCompletionTests = [ - completionTest - "argument" - ["bar (Just abcdef) abcdefg = abcd"] - (Position 0 32) - [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), - ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) - ], - completionTest - "let" - ["bar = let (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ," in abcd" - ] - (Position 2 15) - [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), - ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) - ], - completionTest - "where" - ["bar = abcd" - ," where (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ] - (Position 0 10) - [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), - ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) - ], - completionTest - "do/1" - ["bar = do" - ," Just abcdef <- undefined" - ," abcd" - ," abcdefg <- undefined" - ," pure ()" - ] - (Position 2 6) - [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) - ], - completionTest - "do/2" - ["bar abcde = do" - ," Just [(abcdef,_)] <- undefined" - ," abcdefg <- undefined" - ," let abcdefgh = undefined" - ," (Just [abcdefghi]) = undefined" - ," abcd" - ," where" - ," abcdefghij = undefined" - ] - (Position 5 8) - [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) - ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing) - ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) - ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing) - ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing) - ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing) - ], - completionTest - "type family" - ["{-# LANGUAGE DataKinds, TypeFamilies #-}" - ,"type family Bar a" - ,"a :: Ba" - ] - (Position 2 7) - [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing) - ], - completionTest - "class method" - [ - "class Test a where" - , " abcd :: a -> ()" - , " abcde :: a -> Int" - , "instance Test Int where" - , " abcd = abc" - ] - (Position 4 14) - [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) - ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) - ], - testSessionWait "incomplete entries" $ do - let src a = "data Data = " <> a - doc <- createDoc "A.hs" "haskell" $ src "AAA" - void $ waitForTypecheck doc - let editA rhs = - changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs] - editA "AAAA" - void $ waitForTypecheck doc - editA "AAAAA" - void $ waitForTypecheck doc - - compls <- getCompletions doc (Position 0 15) - liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] - pure () - ] - -nonLocalCompletionTests :: [TestTree] -nonLocalCompletionTests = - [ brokenForWinGhc $ completionTest - "variable" - ["module A where", "f = hea"] - (Position 1 7) - [("head", CompletionItemKind_Function, "head", True, True, Nothing)], - completionTest - "constructor" - ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] - (Position 2 8) - [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing) - ], - brokenForWinGhc $ completionTest - "type" - ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] - (Position 2 8) - [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing) - ], - completionTest - "qualified" - ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] - (Position 2 15) - [ ("head", CompletionItemKind_Function, "head", True, True, Nothing) - ], - completionTest - "duplicate import" - ["module A where", "import Data.List", "import Data.List", "f = permu"] - (Position 3 9) - [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing) - ], - completionTest - "dont show hidden items" - [ "{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", - "import Control.Monad hiding (join)", - "f = joi" - ] - (Position 3 6) - [], - testGroup "ordering" - [completionTest "qualified has priority" - ["module A where" - ,"import qualified Data.ByteString as BS" - ,"f = BS.read" - ] - (Position 2 10) - [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)] - ], - -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls - completionTest - "do not show pragma completions" - [ "{-# LANGUAGE ", - "{module A where}", - "main = return ()" - ] - (Position 0 13) - [] - ] - where - brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94, GHC96]) "Windows has strange things in scope for some reason" - -otherCompletionTests :: [TestTree] -otherCompletionTests = [ - completionTest - "keyword" - ["module A where", "f = newty"] - (Position 1 9) - [("newtype", CompletionItemKind_Keyword, "", False, False, Nothing)], - completionTest - "type context" - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "f = f", - "g :: Intege" - ] - -- At this point the module parses but does not typecheck. - -- This should be sufficient to detect that we are in a - -- type context and only show the completion to the type. - (Position 3 11) - [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)], - - testSession "duplicate record fields" $ do - void $ - createDoc "B.hs" "haskell" $ - T.unlines - [ "{-# LANGUAGE DuplicateRecordFields #-}", - "module B where", - "newtype Foo = Foo { member :: () }", - "newtype Bar = Bar { member :: () }" - ] - docA <- - createDoc "A.hs" "haskell" $ - T.unlines - [ "module A where", - "import B", - "memb" - ] - _ <- waitForDiagnostics - compls <- getCompletions docA $ Position 2 4 - let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] - liftIO $ take 2 compls' @?= ["member"], - - testSessionWait "maxCompletions" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = Prelude." - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - liftIO $ length compls @?= maxCompletions def - ] - -packageCompletionTests :: [TestTree] -packageCompletionTests = - [ testSession' "fromList" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 12) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} - <- compls - , _label == "fromList" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) ( - [ "'Data.List.NonEmpty" - , "'GHC.Exts" - ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) - - , testSessionWait "Map" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a :: Map" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 7) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} - <- compls - , _label == "Map" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) - [ "'Data.Map" - , "'Data.Map.Lazy" - , "'Data.Map.Strict" - ] - , testSessionWait "no duplicates" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "import GHC.Exts(fromList)", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - let duplicate = - filter - (\case - CompletionItem - { _insertText = Just "fromList" - , _documentation = - Just (InR (MarkupContent MarkupKind_Markdown d)) - } -> - "GHC.Exts" `T.isInfixOf` d - _ -> False - ) compls - liftIO $ length duplicate @?= 1 - - , testSessionWait "non-local before global" $ do - -- non local completions are more specific - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "import GHC.Exts(fromList)", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - let compls' = - [_insertText - | CompletionItem {_label, _insertText} <- compls - , _label == "fromList" - ] - liftIO $ take 3 compls' @?= - map Just ["fromList"] - ] - -projectCompletionTests :: [TestTree] -projectCompletionTests = - [ testSession' "from hiedb" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "b = anidenti" - ] - compls <- getCompletions doc (Position 1 10) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} - <- compls - , _label == "anidentifier" - ] - liftIO $ compls' @?= ["Defined in 'A"], - testSession' "auto complete project imports" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" - _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines - [ "module ALocalModule (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import ALocal" - ] - compls <- getCompletions doc (Position 1 13) - let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls - liftIO $ do - item ^. L.label @?= "ALocalModule", - testSession' "auto complete functions from qualified imports without alias" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A", - "A." - ] - compls <- getCompletions doc (Position 2 2) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier", - testSession' "auto complete functions from qualified imports with alias" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A as Alias", - "foo = Alias." - ] - compls <- getCompletions doc (Position 2 12) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier" - ] - -completionDocTests :: [TestTree] -completionDocTests = - [ testSession "local define" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = ()" - , "bar = fo" - ] - let expected = "*Defined at line 2, column 1 in this module*\n" - test doc (Position 2 8) "foo" Nothing [expected] - , testSession "local empty doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] - , testSession "local single line doc without newline" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- |docdoc" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] - , testSession "local multi line doc with newline" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- | abcabc" - , "--" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] - , testSession "local multi line doc without newline" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- | abcabc" - , "--" - , "--def" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] - , testSession "extern empty doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = od" - ] - let expected = "*Imported from 'Prelude'*\n" - test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern single line doc without '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = no" - ] - let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" - test doc (Position 1 8) "not" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern mulit line doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = i" - ] - let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" - test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - , testSession "extern defined doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = i" - ] - let expected = "*Imported from 'Prelude'*\n" - test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - ] - where - brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94, GHC96]) "Completion doc doesn't support ghc9" - brokenForWinGhc90 = knownBrokenFor (BrokenSpecific Windows [GHC90]) "Extern doc doesn't support Windows for ghc9.2" - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 - brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9" - test doc pos label mn expected = do - _ <- waitForDiagnostics - compls <- getCompletions doc pos - rcompls <- forM compls $ \item -> do - if isJust (item ^. L.data_) - then do - rsp <- request SMethod_CompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x - else pure item - let compls' = [ - -- We ignore doc uris since it points to the local path which determined by specific machines - case mn of - Nothing -> txt - Just n -> T.take n txt - | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls - , _label == label - ] - liftIO $ compls' @?= expected - -highlightTests :: TestTree -highlightTests = testGroup "highlight" - [ testSessionWait "value" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 3 2) - liftIO $ highlights @?= - [ DocumentHighlight (R 2 0 2 3) (Just DocumentHighlightKind_Read) - , DocumentHighlight (R 3 0 3 3) (Just DocumentHighlightKind_Write) - , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read) - , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read) - ] - , testSessionWait "type" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 2 8) - liftIO $ highlights @?= - [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read) - , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read) - ] - , testSessionWait "local" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 6 5) - liftIO $ highlights @?= - [ DocumentHighlight (R 6 4 6 7) (Just DocumentHighlightKind_Write) - , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read) - , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) - ] - , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96] "Ghc9 highlights the constructor and not just this field" $ - testSessionWait "record" $ do - doc <- createDoc "A.hs" "haskell" recsource - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= - -- Span is just the .. on 8.10, but Rec{..} before - [ if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) - else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Write) - , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) - ] - highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= - [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) - -- Span is just the .. on 8.10, but Rec{..} before - , if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) - else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Read) - ] - ] - where - source = T.unlines - ["{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"foo :: Int" - ,"foo = 3 :: Int" - ,"bar = foo" - ," where baz = let x = foo in x" - ,"baz arg = arg + x" - ," where x = arg" - ] - recsource = T.unlines - ["{-# LANGUAGE RecordWildCards #-}" - ,"{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"data Rec = Rec { field1 :: Int, field2 :: Char }" - ,"foo Rec{..} = field2 + field1" - ] - -outlineTests :: TestTree -outlineTests = testGroup - "outline" - [ testSessionWait "type class" $ do - let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol "A a" - (R 1 0 1 30) - [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] - ] - ] - , testSessionWait "type class instance " $ do - let source = T.unlines ["class A a where", "instance A () where"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) - ] - , testSessionWait "type family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] - , testSessionWait "type family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "type family A a" - , "type instance A () = ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) - , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) - ] - , testSessionWait "data family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] - , testSessionWait "data family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "data family A a" - , "data instance A () = A ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) - , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) - ] - , testSessionWait "constant" $ do - let source = T.unlines ["a = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] - , testSessionWait "pattern" $ do - let source = T.unlines ["Just foo = Just 21"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] - , testSessionWait "pattern with type signature" $ do - let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] - , testSessionWait "function" $ do - let source = T.unlines ["a _x = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] - , testSessionWait "type synonym" $ do - let source = T.unlines ["type A = Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] - , testSessionWait "datatype" $ do - let source = T.unlines ["data A = C"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolWithChildren "A" - SymbolKind_Struct - (R 0 0 0 10) - [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] - ] - , testSessionWait "record fields" $ do - let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) - [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) - , docSymbol "y" SymbolKind_Field (R 2 4 2 5) - ] - ] - ] - , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbolWithChildren "imports" - SymbolKind_Module - (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) - ] - ] - , testSessionWait "multiple import" $ do - let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbolWithChildren "imports" - SymbolKind_Module - (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) - , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) - ] - ] - , testSessionWait "foreign import" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign import ccall \"a\" a :: Int" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] - , testSessionWait "foreign export" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign export ccall odd :: Int -> Bool" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SymbolKind_File - Nothing - Nothing - (R 0 0 maxBound 0) - loc - (Just cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SymbolKind_Interface - Nothing - Nothing - loc - loc - (Just cc) - -pattern R :: UInt -> UInt -> UInt -> UInt -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - -xfail :: TestTree -> String -> TestTree -xfail = flip expectFailBecause - -ignoreInWindowsBecause :: String -> TestTree -> TestTree -ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) - -ignoreInWindowsForGHC810 :: TestTree -> TestTree -ignoreInWindowsForGHC810 = - ignoreFor (BrokenSpecific Windows [GHC810]) "tests are unreliable in windows for ghc 8.10" - -ignoreForGHC92Plus :: String -> TestTree -> TestTree -ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94, GHC96]) - -knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree -knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) - -data BrokenOS = Linux | MacOS | Windows deriving (Show) - -data IssueSolution = Broken | Ignore deriving (Show) - -data BrokenTarget = - BrokenSpecific BrokenOS [GhcVersion] - -- ^Broken for `BrokenOS` with `GhcVersion` - | BrokenForOS BrokenOS - -- ^Broken for `BrokenOS` - | BrokenForGHC [GhcVersion] - -- ^Broken for `GhcVersion` - deriving (Show) - --- | Ignore test for specific os and ghc with reason. -ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree -ignoreFor = knownIssueFor Ignore - --- | Known broken for specific os and ghc with reason. -knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree -knownBrokenFor = knownIssueFor Broken - --- | Deal with `IssueSolution` for specific OS and GHC. -knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree -knownIssueFor solution = go . \case - BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers - BrokenForOS bos -> isTargetOS bos - BrokenForGHC vers -> isTargetGhc vers - where - isTargetOS = \case - Windows -> isWindows - MacOS -> isMac - Linux -> not isWindows && not isMac - - isTargetGhc = elem ghcVersion - - go True = case solution of - Broken -> expectFailBecause - Ignore -> ignoreTestBecause - go False = \_ -> id - -data Expect - = ExpectRange Range -- Both gotoDef and hover should report this range - | ExpectLocation Location --- | ExpectDefRange Range -- Only gotoDef should report this range - | ExpectHoverRange Range -- Only hover should report this range - | ExpectHoverText [T.Text] -- the hover message must contain these snippets - | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets - | ExpectHoverTextRegex T.Text -- the hover message must match this pattern - | ExpectExternFail -- definition lookup in other file expected to fail - | ExpectNoDefinitions - | ExpectNoHover --- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples - deriving Eq - -mkR :: UInt -> UInt -> UInt -> UInt -> Expect -mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn - -mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect -mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn - -haddockTests :: TestTree -haddockTests - = testGroup "haddock" - [ testCase "Num" $ checkHaddock - (unlines - [ "However, '(+)' and '(*)' are" - , "customarily expected to define a ring and have the following properties:" - , "" - , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" - , "[__Commutativity of (+)__]: @x + y@ = @y + x@" - , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" - ] - ) - (unlines - [ "" - , "" - , "However, `(+)` and `(*)` are" - , "customarily expected to define a ring and have the following properties: " - , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" - , "+ ****Commutativity of (+)****: `x + y` = `y + x`" - , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" - ] - ) - , testCase "unsafePerformIO" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - , testCase "ordered list" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - ] - where - checkHaddock s txt = spanDocToMarkdownForTest s @?= txt - -cradleTests :: TestTree -cradleTests = testGroup "cradle" - [testGroup "dependencies" [sessionDepsArePickedUp] - ,testGroup "ignore-fatal" [ignoreFatalWarning] - ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] - ,testGroup "sub-directory" [simpleSubDirectoryTest] - ] - -loadCradleOnlyonce :: TestTree -loadCradleOnlyonce = testGroup "load cradle only once" - [ testSession' "implicit" implicit - , testSession' "direct" direct - ] - where - direct dir = do - liftIO $ writeFileUTF8 (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - test dir - implicit dir = test dir - test _dir = do - doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" - msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 1 - changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - -retryFailedCradle :: TestTree -retryFailedCradle = testSession' "retry failed" $ \dir -> do - -- The false cradle always fails - let hieContents = "cradle: {bios: {shell: \"false\"}}" - hiePath = dir "hie.yaml" - liftIO $ writeFile hiePath hieContents - let aPath = dir "A.hs" - doc <- createDoc aPath "haskell" "main = return ()" - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess - - -- Fix the cradle and typecheck again - let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" - liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] - - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess - - -dependentFileTest :: TestTree -dependentFileTest = testGroup "addDependentFile" - [testGroup "file-changed" [testSession' "test" test] - ] - where - test dir = do - -- If the file contains B then no type error - -- otherwise type error - let depFilePath = dir "dep-file.txt" - liftIO $ writeFile depFilePath "A" - let fooContent = T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module Foo where" - , "import Language.Haskell.TH.Syntax" - , "foo :: Int" - , "foo = 1 + $(do" - , " qAddDependentFile \"dep-file.txt\"" - , " f <- qRunIO (readFile \"dep-file.txt\")" - , " if f == \"B\" then [| 1 |] else lift f)" - ] - let bazContent = T.unlines ["module Baz where", "import Foo ()"] - _ <- createDoc "Foo.hs" "haskell" fooContent - doc <- createDoc "Baz.hs" "haskell" bazContent - expectDiagnostics $ - if ghcVersion >= GHC90 - -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DiagnosticSeverity_Error, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] - else [("Foo.hs", [(DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type")])] - -- Now modify the dependent file - liftIO $ writeFile depFilePath "B" - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] - - -- Modifying Baz will now trigger Foo to be rebuilt as well - let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 0) (Position 2 6) - .+ #rangeLength .== Nothing - .+ #text .== "f = ()" - changeDoc doc [change] - expectDiagnostics [("Foo.hs", [])] - - -cradleLoadedMessage :: Session FromServerMessage -cradleLoadedMessage = satisfy $ \case - FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod - _ -> False - -cradleLoadedMethod :: String -cradleLoadedMethod = "ghcide/cradle/loaded" - -ignoreFatalWarning :: TestTree -ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do - let srcPath = dir "IgnoreFatal.hs" - src <- liftIO $ readFileUtf8 srcPath - _ <- createDoc srcPath "haskell" src - expectNoMoreDiagnostics 5 - -simpleSubDirectoryTest :: TestTree -simpleSubDirectoryTest = - testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do - let mainPath = dir "a/src/Main.hs" - mainSource <- liftIO $ readFileUtf8 mainPath - _mdoc <- createDoc mainPath "haskell" mainSource - expectDiagnosticsWithTags - [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded - ] - expectNoMoreDiagnostics 0.5 - -simpleMultiTest :: TestTree -simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- openDoc aPath "haskell" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc - liftIO $ assertBool "A should typecheck" ideResultSuccess - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc - liftIO $ assertBool "B should typecheck" ideResultSuccess - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in the other order -simpleMultiTest2 :: TestTree -simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" - skipManyTill anyMessage $ isReferenceReady aPath - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL auri 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Now with 3 components -simpleMultiTest3 :: TestTree -simpleMultiTest3 = - testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - cPath = dir "c/C.hs" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" - skipManyTill anyMessage $ isReferenceReady aPath - cdoc <- openDoc cPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc - locs <- getDefinitions cdoc (Position 2 7) - let fooL = mkL auri 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in component 'a' in a separate session -simpleMultiDefTest :: TestTree -simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- liftIO $ runInDir dir $ do - aSource <- liftIO $ readFileUtf8 aPath - adoc <- createDoc aPath "haskell" aSource - skipManyTill anyMessage $ isReferenceReady aPath - closeDoc adoc - pure adoc - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - -ifaceTests :: TestTree -ifaceTests = testGroup "Interface loading tests" - [ -- https://github.com/haskell/ghcide/pull/645/ - ifaceErrorTest - , ifaceErrorTest2 - , ifaceErrorTest3 - , ifaceTHTest - ] - -bootTests :: TestTree -bootTests = testGroup "boot" - [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir "C.hs" - cSource <- liftIO $ readFileUtf8 cPath - -- Dirty the cache - liftIO $ runInDir dir $ do - cDoc <- createDoc cPath "haskell" cSource - -- We send a hover request then wait for either the hover response or - -- `ghcide/reference/ready` notification. - -- Once we receive one of the above, we wait for the other that we - -- haven't received yet. - -- If we don't wait for the `ready` notification it is possible - -- that the `getDefinitions` request/response in the outer ghcide - -- session will find no definitions. - let hoverParams = HoverParams cDoc (Position 4 3) Nothing - hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams - let parseReadyMessage = isReferenceReady cPath - let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId - hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) - _ <- skipManyTill anyMessage $ - case hoverResponseOrReadyMessage of - Left _ -> void parseReadyMessage - Right _ -> void parseHoverResponse - closeDoc cDoc - cdoc <- createDoc cPath "haskell" cSource - locs <- getDefinitions cdoc (Position 7 4) - let floc = mkR 9 0 9 1 - checkDefs locs (pure [floc]) - , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir "A.hs") "haskell" - expectNoMoreDiagnostics 2 - ] - --- | test that TH reevaluates across interfaces -ifaceTHTest :: TestTree -ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () - _bSource <- liftIO $ readFileUtf8 bPath -- a :: () - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - cdoc <- createDoc cPath "haskell" cSource - - -- Change [TH]a from () to Bool - liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) - - -- Check that the change propagates to C - changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource] - expectDiagnostics - [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] - closeDoc cdoc - -ifaceErrorTest :: TestTree -ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do - configureCheckProject True - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - -- save so that we can that the error propagates to A - sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) - - - -- Check that the error propagates to A - expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] - - -- Check that we wrote the interfaces for B when we saved - hidir <- getInterfaceFilesDir bdoc - hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" - liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists - - pdoc <- openDoc pPath "haskell" - expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) - ] - changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - -- This is clearly inconsistent, and the expected outcome a bit surprising: - -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics - -- - P is being typechecked with the last successful artifacts for A. - expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) - ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -ifaceErrorTest2 :: TestTree -ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- Add a new definition to P - changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - expectDiagnostics - -- As in the other test, P is being typechecked with the last successful artifacts for A - -- (ot thanks to -fdeferred-type-errors) - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding")]) - ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding")]) - ] - - expectNoMoreDiagnostics 2 - -ifaceErrorTest3 :: TestTree -ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- P should not typecheck, as there are no last valid artifacts for A - _pdoc <- createDoc pPath "haskell" pSource - - -- In this example the interface file for A should not exist (modulo the cache folder) - -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors - expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testSession' - "session-deps-are-picked-up" - $ \dir -> do - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - -- Open without OverloadedStrings and expect an error. - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics $ - if ghcVersion >= GHC90 - -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] - else [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match expected type")])] - -- Update hie.yaml to enable OverloadedStrings. - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: [-XOverloadedStrings]}}" - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] - -- Send change event. - let change = - TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 4 0) (Position 4 0) - .+ #rangeLength .== Nothing - .+ #text .== "\n" - changeDoc doc [change] - -- Now no errors. - expectDiagnostics [("Foo.hs", [])] - where - fooContent = - T.unlines - [ "module Foo where", - "import Data.Text", - "foo :: Text", - "foo = \"hello\"" - ] - --- A test to ensure that the command line ghcide workflow stays working -nonLspCommandLine :: TestTree -nonLspCommandLine = testGroup "ghcide command line" - [ testCase "works" $ withTempDir $ \dir -> do - ghcide <- locateGhcideExecutable - copyTestDataFiles dir "multi" - let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} - - setEnv "HOME" "/homeless-shelter" False - - (ec, _, _) <- readCreateProcessWithExitCode cmd "" - - ec @?= ExitSuccess - ] - --- | checks if we use InitializeParams.rootUri for loading session -rootUriTests :: TestTree -rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do - let bPath = dir "dirB/Foo.hs" - liftIO $ copyTestDataFiles dir "rootUri" - bSource <- liftIO $ readFileUtf8 bPath - _ <- createDoc "Foo.hs" "haskell" bSource - expectNoMoreDiagnostics 0.5 - where - -- similar to run' except we can configure where to start ghcide and session - runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () - runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) - --- | Test if ghcide asynchronously handles Commands and user Requests -asyncTests :: TestTree -asyncTests = testGroup "async" - [ - testSession "command" $ do - -- Execute a command that will block forever - let req = ExecuteCommandParams Nothing blockCommandId Nothing - void $ sendRequest SMethod_WorkspaceExecuteCommand req - -- Load a file and check for code actions. Will only work if the command is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - codeLenses <- getCodeLenses doc - liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? - [ "foo :: a -> a" ] - , testSession "request" $ do - -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000 - -- Load a file and check for code actions. Will only work if the request is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - codeLenses <- getCodeLenses doc - liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? - [ "foo :: a -> a" ] - ] - - -clientSettingsTest :: TestTree -clientSettingsTest = testGroup "client settings handling" - [ testSession "ghcide restarts shake session on config changes" $ do - void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability - void $ createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - sendNotification SMethod_WorkspaceDidChangeConfiguration - (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) - skipManyTill anyMessage restartingBuildSession - - ] - where - restartingBuildSession :: Session () - restartingBuildSession = do - FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification - guard $ "Restarting build session" `T.isInfixOf` _message - -referenceTests :: TestTree -referenceTests = testGroup "references" - [ testGroup "can get references to FOIs" - [ referenceTest "can get references to symbols" - ("References.hs", 4, 7) - YesIncludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "can get references to data constructor" - ("References.hs", 13, 2) - YesIncludeDeclaration - [ ("References.hs", 13, 2) - , ("References.hs", 16, 14) - , ("References.hs", 19, 21) - ] - - , referenceTest "getting references works in the other module" - ("OtherModule.hs", 6, 0) - YesIncludeDeclaration - [ ("OtherModule.hs", 6, 0) - , ("OtherModule.hs", 8, 16) - ] - - , referenceTest "getting references works in the Main module" - ("Main.hs", 9, 0) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 10, 4) - ] - - , referenceTest "getting references to main works" - ("Main.hs", 5, 0) - YesIncludeDeclaration - [ ("Main.hs", 4, 0) - , ("Main.hs", 5, 0) - ] - - , referenceTest "can get type references" - ("Main.hs", 9, 9) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 9, 9) - , ("Main.hs", 10, 0) - ] - - , expectFailBecause "references provider does not respect includeDeclaration parameter" $ - referenceTest "works when we ask to exclude declarations" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - ] - - , testGroup "can get references to non FOIs" - [ referenceTest "can get references to symbol defined in a module we import" - ("References.hs", 22, 4) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references in modules that import us to symbols we define" - ("OtherModule.hs", 4, 0) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references to symbol defined in a module we import transitively" - ("References.hs", 24, 4) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get references in modules that import us transitively to symbols we define" - ("OtherOtherModule.hs", 2, 0) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get type references to other modules" - ("Main.hs", 12, 10) - YesIncludeDeclaration - [ ("Main.hs", 12, 7) - , ("Main.hs", 13, 0) - , ("References.hs", 12, 5) - , ("References.hs", 16, 0) - ] - ] - ] - --- | When we ask for all references to symbol "foo", should the declaration "foo --- = 2" be among the references returned? -data IncludeDeclaration = - YesIncludeDeclaration - | NoExcludeDeclaration - -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session ([Location]) -getReferences' (file, l, c) includeDeclaration = do - doc <- openDoc file "haskell" - getReferences doc (Position l c) $ toBool includeDeclaration - where toBool YesIncludeDeclaration = True - toBool NoExcludeDeclaration = False - -referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree -referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do - -- needed to build whole project indexing - configureCheckProject True - let docs = map (dir ) $ delete thisDoc $ nubOrd docs' - -- Initial Index - docid <- openDoc thisDoc "haskell" - let - loop :: [FilePath] -> Session () - loop [] = pure () - loop docs = do - doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) - loop (delete doc docs) - loop docs - f dir - closeDoc docid - --- | Given a location, lookup the symbol and all references to it. Make sure --- they are the ones we expect. -referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree -referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ \dir -> do - actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` map (first3 (dir )) expected - where - docs = map fst3 expected - -type SymbolLocation = (FilePath, UInt, UInt) - -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion -expectSameLocations actual expected = do - let actual' = - Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line . Lens.to fromIntegral - , location ^. L.range . L.start . L.character . Lens.to fromIntegral)) - $ Set.fromList actual - expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file - return (filePathToUri fp, l, c)) - actual' @?= expected' - ----------------------------------------------------------------------- --- Utils ----------------------------------------------------------------------- - -testSession :: String -> Session () -> TestTree -testSession name = testCase name . run - -testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree -testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix - -testSession' :: String -> (FilePath -> Session ()) -> TestTree -testSession' name = testCase name . run' - -testSessionWait :: HasCallStack => String -> Session () -> TestTree -testSessionWait name = testSession name . - -- Check that any diagnostics produced were already consumed by the test case. - -- - -- If in future we add test cases where we don't care about checking the diagnostics, - -- this could move elsewhere. - -- - -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. - ( >> expectNoMoreDiagnostics 0.5) - -mkRange :: UInt -> UInt -> UInt -> UInt -> Range -mkRange a b c d = Range (Position a b) (Position c d) - -run :: Session a -> IO a -run s = run' (const s) - -runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a -runWithExtraFiles prefix s = withTempDir $ \dir -> do - copyTestDataFiles dir prefix - runInDir dir (s dir) - -copyTestDataFiles :: FilePath -> FilePath -> IO () -copyTestDataFiles dir prefix = do - -- Copy all the test data files to the temporary workspace - testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] - for_ testDataFiles $ \f -> do - createDirectoryIfMissing True $ dir takeDirectory f - copyFile ("test/data" prefix f) (dir f) - -run' :: (FilePath -> Session a) -> IO a -run' s = withTempDir $ \dir -> runInDir dir (s dir) - -runInDir :: FilePath -> Session a -> IO a -runInDir dir = runInDir' dir "." "." [] - -withLongTimeout :: IO a -> IO a -withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") - --- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. -runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a -runInDir' = runInDir'' lspTestCaps - -runInDir'' - :: ClientCapabilities - -> FilePath - -> FilePath - -> FilePath - -> [String] - -> Session b - -> IO b -runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do - - ghcideExe <- locateGhcideExecutable - let startDir = dir startExeIn - let projDir = dir startSessionIn - - createDirectoryIfMissing True startDir - createDirectoryIfMissing True projDir - -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 - -- since the package import test creates "Data/List.hs", which otherwise has no physical home - createDirectoryIfMissing True $ projDir ++ "/Data" - - shakeProfiling <- getEnv "SHAKE_PROFILING" - let cmd = unwords $ - [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir - ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] - ] ++ extraOptions - -- HIE calls getXgdDirectory which assumes that HOME is set. - -- Only sets HOME if it wasn't already set. - setEnv "HOME" "/homeless-shelter" False - conf <- getConfigFromEnv - runSessionWithConfig conf cmd lspCaps projDir $ do - configureCheckProject False - s - - -getConfigFromEnv :: IO SessionConfig -getConfigFromEnv = do - logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" - timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" - return defaultConfig - { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride - , logColor - } - where - checkEnv :: String -> IO (Maybe Bool) - checkEnv s = fmap convertVal <$> getEnv s - convertVal "0" = False - convertVal _ = True - -lspTestCaps :: ClientCapabilities -lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } - -lspTestCapsNoFileWatches :: ClientCapabilities -lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing - -openTestDataDoc :: FilePath -> Session TextDocumentIdentifier -openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "test/data" path - createDoc path "haskell" source - -unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree -unitTests recorder logger = do - testGroup "Unit" - [ testCase "empty file path does NOT work with the empty String literal" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." - , testCase "empty file path works using toNormalizedFilePath'" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" - , testCase "empty path URI" $ do - Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) - uriScheme @?= "file:" - uriPath @?= "" - , testCase "from empty path URI" $ do - let uri = Uri "file://" - uriToFilePath' uri @?= Just "" - , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do - let diag = ("", Diagnostics.ShowDiag, Diagnostic - { _codeDescription = Nothing - , _data_ = Nothing - , _range = Range - { _start = Position{_line = 0, _character = 1} - , _end = Position{_line = 2, _character = 3} - } - , _severity = Nothing - , _code = Nothing - , _source = Nothing - , _message = "" - , _relatedInformation = Nothing - , _tags = Nothing - }) - let shown = T.unpack (Diagnostics.showDiagnostics [diag]) - let expected = "1:2-3:4" - assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ - expected `isInfixOf` shown - , testCase "notification handlers run in priority order" $ do - orderRef <- newIORef [] - let plugins = pluginDescToIdePlugins $ - [ (priorityPluginDescriptor i) - { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> - liftIO $ atomicModifyIORef_ orderRef (i:) - ] - } - | i <- [1..20] - ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) - priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i} - - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do - _ <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - actualOrder <- liftIO $ reverse <$> readIORef orderRef - - -- Handlers are run in priority descending order - liftIO $ actualOrder @?= [20, 19 .. 1] - , ignoreTestBecause "The test fails sometimes showing 10000us" $ - testCase "timestamps have millisecond resolution" $ do - resolution_us <- findResolution_us 1 - let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us - assertBool msg (resolution_us <= 1000) - , Progress.tests - , FuzzySearch.tests - ] - -garbageCollectionTests :: TestTree -garbageCollectionTests = testGroup "garbage collection" - [ testGroup "dirty keys" - [ testSession' "are collected" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - doc <- generateGarbage "A" dir - closeDoc doc - garbage <- waitForGC - liftIO $ assertBool "no garbage was found" $ not $ null garbage - - , testSession' "are deleted from the state" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - docA <- generateGarbage "A" dir - keys0 <- getStoredKeys - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage - keys1 <- getStoredKeys - liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) - - , testSession' "are not regenerated unless needed" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" - docA <- generateGarbage "A" dir - _docB <- generateGarbage "B" dir - - -- garbage collect A keys - keysBeforeGC <- getStoredKeys - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage - keysAfterGC <- getStoredKeys - liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" - (length keysAfterGC < length keysBeforeGC) - - -- re-typecheck B and check that the keys for A have not materialized back - _docB <- generateGarbage "B" dir - keysB <- getStoredKeys - let regeneratedKeys = Set.filter (not . isExpected) $ - Set.intersection (Set.fromList garbage) (Set.fromList keysB) - liftIO $ regeneratedKeys @?= mempty - - , testSession' "regenerate successfully" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" - docA <- generateGarbage "A" dir - closeDoc docA - garbage <- waitForGC - liftIO $ assertBool "no garbage was found" $ not $ null garbage - let edit = T.unlines - [ "module A where" - , "a :: Bool" - , "a = ()" - ] - doc <- generateGarbage "A" dir - changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ edit] - builds <- waitForTypecheck doc - liftIO $ assertBool "it still builds" builds - expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")] - ] - ] - where - isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] - - generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier - generateGarbage modName dir = do - let fp = modName <> ".hs" - body = printf "module %s where" modName - doc <- createDoc fp "haskell" (T.pack body) - liftIO $ writeFile (dir fp) body - builds <- waitForTypecheck doc - liftIO $ assertBool "something is wrong with this test" builds - return doc - -findResolution_us :: Int -> IO Int -findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" -findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do - performGC - writeFile f "" - threadDelay delay_us - writeFile f' "" - t <- getModTime f - t' <- getModTime f' - if t /= t' then return delay_us else findResolution_us (delay_us * 10) - - -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - let projDir = "." - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session - -positionMappingTests :: Recorder (WithPriority Log) -> TestTree -positionMappingTests recorder = - testGroup "position mapping" - [ testGroup "toCurrent" - [ testCase "before" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 3) @?= PositionExact (Position 0 4) - , testCase "after, same line, decreased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 3) @?= PositionExact (Position 0 2) - , testCase "after, next line, no newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 1 0) @?= PositionExact (Position 2 0) - , testCase "after, same line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 0 4) @?= PositionExact (Position 1 2) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 0 4) @?= PositionExact (Position 2 1) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 1) @?= PositionExact (Position 0 4) - ] - , testGroup "fromCurrent" - [ testCase "before" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 3) - , testCase "after, same line, decreased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 2) @?= PositionExact (Position 0 3) - , testCase "after, next line, no newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 2 0) @?= PositionExact (Position 1 0) - , testCase "after, same line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 1 2) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 2 1) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 1) - ] - , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" - [ testProperty "fromCurrent r t <=< toCurrent r t" $ do - -- Note that it is important to use suchThatMap on all values at once - -- instead of only using it on the position. Otherwise you can get - -- into situations where there is no position that can be mapped back - -- for the edit which will result in QuickCheck looping forever. - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - oldPos <- genPosition rope - pure (range, replacement, oldPos) - forAll - (suchThatMap gen - (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ - \(range, replacement, oldPos, newPos) -> - fromCurrent range replacement newPos === PositionExact oldPos - , testProperty "toCurrent r t <=< fromCurrent r t" $ do - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - let newRope = runIdentity $ applyChange mempty rope - (TextDocumentContentChangeEvent $ InL $ #range .== range - .+ #rangeLength .== Nothing - .+ #text .== replacement) - newPos <- genPosition newRope - pure (range, replacement, newPos) - forAll - (suchThatMap gen - (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ - \(range, replacement, newPos, oldPos) -> - toCurrent range replacement oldPos === PositionExact newPos - ] - ] - -newtype PrintableText = PrintableText { getPrintableText :: T.Text } - deriving Show - -instance Arbitrary PrintableText where - arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary - - -genRope :: Gen Rope -genRope = Rope.fromText . getPrintableText <$> arbitrary - -genPosition :: Rope -> Gen Position -genPosition r = do - let rows :: Int = fromIntegral $ Rope.lengthInLines r - row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt - let columns = T.length (nthLine (fromIntegral row) r) - column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt - pure $ Position (fromIntegral row) (fromIntegral column) - -genRange :: Rope -> Gen Range -genRange r = do - let rows :: Int = fromIntegral $ Rope.lengthInLines r - startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine - endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt - let columns = T.length (nthLine (fromIntegral endLine) r) - endColumn <- - if fromIntegral startLine == endLine - then choose (fromIntegral startColumn, columns) - else choose (0, max 0 $ columns - 1) - `suchThat` inBounds @UInt - pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) - -inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool -inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) - --- | Get the ith line of a rope, starting from 0. Trailing newline not included. -nthLine :: Int -> Rope -> T.Text -nthLine i r - | Rope.null r = "" - | otherwise = Rope.lines r !! i - -getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] -getWatchedFilesSubscriptionsUntil m = do - msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m) - return - [ x - | Just TRequestMessage{_params = RegistrationParams regs} <- msgs - , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs - , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args] - ] - --- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path --- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or --- @/var@ -withTempDir :: (FilePath -> IO a) -> IO a -withTempDir f = System.IO.Extra.withTempDir $ \dir -> do - dir' <- canonicalizePath dir - f dir' - - --- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String -listOfChar :: T.Text -listOfChar | ghcVersion >= GHC90 = "String" - | otherwise = "[Char]" - --- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did -thDollarIdx :: UInt -thDollarIdx | ghcVersion >= GHC90 = 1 - | otherwise = 0 + ] \ No newline at end of file diff --git a/ghcide/test/exe/NonLspCommandLine.hs b/ghcide/test/exe/NonLspCommandLine.hs new file mode 100644 index 0000000000..51eeb95ea0 --- /dev/null +++ b/ghcide/test/exe/NonLspCommandLine.hs @@ -0,0 +1,27 @@ + +module NonLspCommandLine (tests) where + +import Development.IDE.Test.Runfiles +import System.Environment.Blank (setEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process.Extra (CreateProcess (cwd), proc, + readCreateProcessWithExitCode) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +-- A test to ensure that the command line ghcide workflow stays working +tests :: TestTree +tests = testGroup "ghcide command line" + [ testCase "works" $ withTempDir $ \dir -> do + ghcide <- locateGhcideExecutable + copyTestDataFiles dir "multi" + let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} + + setEnv "HOME" "/homeless-shelter" False + + (ec, _, _) <- readCreateProcessWithExitCode cmd "" + + ec @?= ExitSuccess + ] diff --git a/ghcide/test/exe/OpenCloseTest.hs b/ghcide/test/exe/OpenCloseTest.hs new file mode 100644 index 0000000000..2c7237fc28 --- /dev/null +++ b/ghcide/test/exe/OpenCloseTest.hs @@ -0,0 +1,18 @@ + +module OpenCloseTest (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Language.LSP.Protocol.Message +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testSession "open close" $ do + doc <- createDoc "Testing.hs" "haskell" "" + void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate) + waitForProgressBegin + closeDoc doc + waitForProgressDone diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs new file mode 100644 index 0000000000..6459e1deca --- /dev/null +++ b/ghcide/test/exe/OutlineTests.hs @@ -0,0 +1,189 @@ + +module OutlineTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup + "outline" + [ testSessionWait "type class" $ do + let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol "A a" + (R 1 0 1 30) + [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] + ] + ] + , testSessionWait "type class instance " $ do + let source = T.unlines ["class A a where", "instance A () where"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) + ] + , testSessionWait "type family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] + , testSessionWait "type family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) + ] + , testSessionWait "data family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] + , testSessionWait "data family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "data family A a" + , "data instance A () = A ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) + ] + , testSessionWait "constant" $ do + let source = T.unlines ["a = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] + , testSessionWait "pattern" $ do + let source = T.unlines ["Just foo = Just 21"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] + , testSessionWait "pattern with type signature" $ do + let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] + , testSessionWait "function" $ do + let source = T.unlines ["a _x = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] + , testSessionWait "type synonym" $ do + let source = T.unlines ["type A = Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSessionWait "datatype" $ do + let source = T.unlines ["data A = C"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolWithChildren "A" + SymbolKind_Struct + (R 0 0 0 10) + [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] + ] + , testSessionWait "record fields" $ do + let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) + , docSymbol "y" SymbolKind_Field (R 2 4 2 5) + ] + ] + ] + , testSessionWait "import" $ do + let source = T.unlines ["import Data.Maybe ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) + ] + ] + , testSessionWait "multiple import" $ do + let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) + , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) + ] + ] + , testSessionWait "foreign import" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] + , testSessionWait "foreign export" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SymbolKind_File + Nothing + Nothing + (R 0 0 maxBound 0) + loc + (Just cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SymbolKind_Interface + Nothing + Nothing + loc + loc + (Just cc) diff --git a/ghcide/test/exe/PluginParsedResultTests.hs b/ghcide/test/exe/PluginParsedResultTests.hs new file mode 100644 index 0000000000..a382f4461d --- /dev/null +++ b/ghcide/test/exe/PluginParsedResultTests.hs @@ -0,0 +1,17 @@ + +module PluginParsedResultTests (tests) where + +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = + ignoreInWindowsForGHC810 $ + ignoreForGHC92Plus "No need for this plugin anymore!" $ + testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do + _ <- openDoc (dir "RecordDot.hs") "haskell" + expectNoMoreDiagnostics 2 diff --git a/ghcide/test/exe/PluginSimpleTests.hs b/ghcide/test/exe/PluginSimpleTests.hs new file mode 100644 index 0000000000..0de051083b --- /dev/null +++ b/ghcide/test/exe/PluginSimpleTests.hs @@ -0,0 +1,51 @@ + +module PluginSimpleTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Compat (GhcVersion (..)) +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = + ignoreInWindowsForGHC810 $ + -- Build profile: -w ghc-9.4.2 -O1 + -- In order, the following will be built (use -v for more details): + -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) + -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) + -- - plugin-1.0.0 (lib) (first run) + -- Starting ghc-typelits-natnormalise-0.7.7 (lib) + -- Building ghc-typelits-natnormalise-0.7.7 (lib) + + -- Failed to build ghc-typelits-natnormalise-0.7.7. + -- Build log ( + -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log + -- ): + -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. + -- Building library for ghc-typelits-natnormalise-0.7.7.. + -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) + -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) + -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) + -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory + + -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is + -- required by plugin-1.0.0). See the build log above for details. + ignoreFor (BrokenForGHC [GHC96]) "fragile, frequently times out" $ + ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $ + testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do + _ <- openDoc (dir "KnownNat.hs") "haskell" + liftIO $ writeFile (dir"hie.yaml") + "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" + + expectDiagnostics + [ ( "KnownNat.hs", + [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")] + ) + ] diff --git a/ghcide/test/exe/PositionMappingTests.hs b/ghcide/test/exe/PositionMappingTests.hs new file mode 100644 index 0000000000..083e765db0 --- /dev/null +++ b/ghcide/test/exe/PositionMappingTests.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedLabels #-} + +module PositionMappingTests (tests) where + +import Data.Row +import qualified Data.Text as T +import Data.Text.Utf16.Rope (Rope) +import qualified Data.Text.Utf16.Rope as Rope +import Development.IDE.Core.PositionMapping (PositionResult (..), + fromCurrent, + positionResultToMaybe, + toCurrent) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.VFS (applyChange) +import Test.QuickCheck +-- import Test.QuickCheck.Instances () +import Data.Functor.Identity (runIdentity) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup "position mapping" + [ testGroup "toCurrent" + [ testCase "before" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 3) @?= PositionExact (Position 0 4) + , testCase "after, same line, decreased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 3) @?= PositionExact (Position 0 2) + , testCase "after, next line, no newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 1 0) @?= PositionExact (Position 2 0) + , testCase "after, same line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 0 4) @?= PositionExact (Position 1 2) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 0 4) @?= PositionExact (Position 2 1) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 1) @?= PositionExact (Position 0 4) + ] + , testGroup "fromCurrent" + [ testCase "before" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 3) + , testCase "after, same line, decreased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 2) @?= PositionExact (Position 0 3) + , testCase "after, next line, no newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 2 0) @?= PositionExact (Position 1 0) + , testCase "after, same line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 1 2) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 2 1) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 1) + ] + , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" + [ testProperty "fromCurrent r t <=< toCurrent r t" $ do + -- Note that it is important to use suchThatMap on all values at once + -- instead of only using it on the position. Otherwise you can get + -- into situations where there is no position that can be mapped back + -- for the edit which will result in QuickCheck looping forever. + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + oldPos <- genPosition rope + pure (range, replacement, oldPos) + forAll + (suchThatMap gen + (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ + \(range, replacement, oldPos, newPos) -> + fromCurrent range replacement newPos === PositionExact oldPos + , testProperty "toCurrent r t <=< fromCurrent r t" $ do + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + let newRope = runIdentity $ applyChange mempty rope + (TextDocumentContentChangeEvent $ InL $ #range .== range + .+ #rangeLength .== Nothing + .+ #text .== replacement) + newPos <- genPosition newRope + pure (range, replacement, newPos) + forAll + (suchThatMap gen + (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ + \(range, replacement, newPos, oldPos) -> + toCurrent range replacement oldPos === PositionExact newPos + ] + ] + +newtype PrintableText = PrintableText { getPrintableText :: T.Text } + deriving Show + +instance Arbitrary PrintableText where + arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary + +genRope :: Gen Rope +genRope = Rope.fromText . getPrintableText <$> arbitrary + +genPosition :: Rope -> Gen Position +genPosition r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral row) r) + column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt + pure $ Position (fromIntegral row) (fromIntegral column) + +genRange :: Rope -> Gen Range +genRange r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + startPos@(Position startLine startColumn) <- genPosition r + let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine + endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral endLine) r) + endColumn <- + if fromIntegral startLine == endLine + then choose (fromIntegral startColumn, columns) + else choose (0, max 0 $ columns - 1) + `suchThat` inBounds @UInt + pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) + +inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool +inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) + +-- | Get the ith line of a rope, starting from 0. Trailing newline not included. +nthLine :: Int -> Rope -> T.Text +nthLine i r + | Rope.null r = "" + | otherwise = Rope.lines r !! i diff --git a/ghcide/test/exe/PreprocessorTests.hs b/ghcide/test/exe/PreprocessorTests.hs new file mode 100644 index 0000000000..315ffd1ccb --- /dev/null +++ b/ghcide/test/exe/PreprocessorTests.hs @@ -0,0 +1,27 @@ + +module PreprocessorTests (tests) where + +import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testSessionWait "preprocessor" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" + , "module Testing where" + , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")] + ) + ] diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs new file mode 100644 index 0000000000..5abb18bfe8 --- /dev/null +++ b/ghcide/test/exe/ReferenceTests.hs @@ -0,0 +1,199 @@ + +module ReferenceTests (tests) where + +import Control.Applicative.Combinators +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.List.Extra +import qualified Data.Set as Set +import Development.IDE.Test (configureCheckProject, + referenceReady) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Data.Tuple.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "references" + [ testGroup "can get references to FOIs" + [ referenceTest "can get references to symbols" + ("References.hs", 4, 7) + YesIncludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "can get references to data constructor" + ("References.hs", 13, 2) + YesIncludeDeclaration + [ ("References.hs", 13, 2) + , ("References.hs", 16, 14) + , ("References.hs", 19, 21) + ] + + , referenceTest "getting references works in the other module" + ("OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("OtherModule.hs", 6, 0) + , ("OtherModule.hs", 8, 16) + ] + + , referenceTest "getting references works in the Main module" + ("Main.hs", 9, 0) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 10, 4) + ] + + , referenceTest "getting references to main works" + ("Main.hs", 5, 0) + YesIncludeDeclaration + [ ("Main.hs", 4, 0) + , ("Main.hs", 5, 0) + ] + + , referenceTest "can get type references" + ("Main.hs", 9, 9) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 9, 9) + , ("Main.hs", 10, 0) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + referenceTest "works when we ask to exclude declarations" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + ] + + , testGroup "can get references to non FOIs" + [ referenceTest "can get references to symbol defined in a module we import" + ("References.hs", 22, 4) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references in modules that import us to symbols we define" + ("OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references to symbol defined in a module we import transitively" + ("References.hs", 24, 4) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get references in modules that import us transitively to symbols we define" + ("OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get type references to other modules" + ("Main.hs", 12, 10) + YesIncludeDeclaration + [ ("Main.hs", 12, 7) + , ("Main.hs", 13, 0) + , ("References.hs", 12, 5) + , ("References.hs", 16, 0) + ] + ] + ] + +-- | When we ask for all references to symbol "foo", should the declaration "foo +-- = 2" be among the references returned? +data IncludeDeclaration = + YesIncludeDeclaration + | NoExcludeDeclaration + +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session ([Location]) +getReferences' (file, l, c) includeDeclaration = do + doc <- openDoc file "haskell" + getReferences doc (Position l c) $ toBool includeDeclaration + where toBool YesIncludeDeclaration = True + toBool NoExcludeDeclaration = False + +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree +referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do + -- needed to build whole project indexing + configureCheckProject True + let docs = map (dir ) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + let + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f dir + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ \dir -> do + actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + where + docs = map fst3 expected + +type SymbolLocation = (FilePath, UInt, UInt) + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +expectSameLocations actual expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line . Lens.to fromIntegral + , location ^. L.range . L.start . L.character . Lens.to fromIntegral)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected' diff --git a/ghcide/test/exe/RootUriTests.hs b/ghcide/test/exe/RootUriTests.hs new file mode 100644 index 0000000000..2237150508 --- /dev/null +++ b/ghcide/test/exe/RootUriTests.hs @@ -0,0 +1,26 @@ + +module RootUriTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +-- | checks if we use InitializeParams.rootUri for loading session +tests :: TestTree +tests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do + let bPath = dir "dirB/Foo.hs" + liftIO $ copyTestDataFiles dir "rootUri" + bSource <- liftIO $ readFileUtf8 bPath + _ <- createDoc "Foo.hs" "haskell" bSource + expectNoMoreDiagnostics 0.5 + where + -- similar to run' except we can configure where to start ghcide and session + runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () + runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) diff --git a/ghcide/test/exe/SafeTests.hs b/ghcide/test/exe/SafeTests.hs new file mode 100644 index 0000000000..4bdef3b7c1 --- /dev/null +++ b/ghcide/test/exe/SafeTests.hs @@ -0,0 +1,38 @@ + +module SafeTests (tests) where + +import qualified Data.Text as T +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test + +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = + testGroup + "SafeHaskell" + [ -- Test for https://github.com/haskell/ghcide/issues/424 + testSessionWait "load" $ do + let sourceA = + T.unlines + ["{-# LANGUAGE Trustworthy #-}" + ,"module A where" + ,"import System.IO.Unsafe" + ,"import System.IO ()" + ,"trustWorthyId :: a -> a" + ,"trustWorthyId i = unsafePerformIO $ do" + ," putStrLn \"I'm safe\"" + ," return i"] + sourceB = + T.unlines + ["{-# LANGUAGE Safe #-}" + ,"module B where" + ,"import A" + ,"safeId :: a -> a" + ,"safeId = trustWorthyId" + ] + + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectNoMoreDiagnostics 1 ] diff --git a/ghcide/test/exe/SymlinkTests.hs b/ghcide/test/exe/SymlinkTests.hs new file mode 100644 index 0000000000..19c86a5264 --- /dev/null +++ b/ghcide/test/exe/SymlinkTests.hs @@ -0,0 +1,27 @@ + +module SymlinkTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.Test (expectDiagnosticsWithTags) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath + +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +-- | Tests for projects that use symbolic links one way or another +tests :: TestTree +tests = + testGroup "Projects using Symlinks" + [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do + liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") + let fooPath = dir "src" "Foo.hs" + _ <- openDoc fooPath "haskell" + expectDiagnosticsWithTags [("src" "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])] + pure () + ] diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs new file mode 100644 index 0000000000..8b1d5a19c8 --- /dev/null +++ b/ghcide/test/exe/THTests.hs @@ -0,0 +1,194 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module THTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Util +import Development.IDE.Test (expectCurrentDiagnostics, + expectDiagnostics, + expectNoMoreDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = + testGroup + "TemplateHaskell" + [ -- Test for https://github.com/haskell/ghcide/pull/212 + testSessionWait "load" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module A where", + "import \"template-haskell\" Language.Haskell.TH", + "a :: Integer", + "a = $(litE $ IntegerL 3)" + ] + sourceB = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module B where", + "import A", + "import \"template-haskell\" Language.Haskell.TH", + "b :: Integer", + "b = $(litE $ IntegerL $ a) + n" + ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ] + , testSessionWait "newtype-closure" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE DeriveDataTypeable #-}" + ,"{-# LANGUAGE TemplateHaskell #-}" + ,"module A (a) where" + ,"import Data.Data" + ,"import Language.Haskell.TH" + ,"newtype A = A () deriving (Data)" + ,"a :: ExpQ" + ,"a = [| 0 |]"] + let sourceB = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + ,"module B where" + ,"import A" + ,"b :: Int" + ,"b = $( a )" ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + return () + , thReloadingTest False + , thLoadingTest + , thCoreTest + , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True + -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 + , thLinkingTest False + , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True + , testSessionWait "findsTHIdentifiers" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A (a) where" + , "import Language.Haskell.TH (ExpQ)" + , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic + , "a = [| glorifiedID |]" + , "glorifiedID :: a -> a" + , "glorifiedID = id" ] + let sourceB = + T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "module B where" + , "import A" + , "main = $a (putStrLn \"success!\")"] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] + , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do + + -- This test defines a TH value with the meaning "data A = A" in A.hs + -- Loads and export the template in B.hs + -- And checks wether the constructor A can be loaded in C.hs + -- This test does not fail when either A and B get manually loaded before C.hs + -- or when we remove the seemingly unnecessary TH pragma from C.hs + + let cPath = dir "C.hs" + _ <- openDoc cPath "haskell" + expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] + ] + + +-- | Test that all modules have linkables +thLoadingTest :: TestTree +thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do + let thb = dir "THB.hs" + _ <- openDoc thb "haskell" + expectNoMoreDiagnostics 1 + +thCoreTest :: TestTree +thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do + let thc = dir "THC.hs" + _ <- openDoc thc "haskell" + expectNoMoreDiagnostics 1 + +-- | test that TH is reevaluated on typecheck +thReloadingTest :: Bool -> TestTree +thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do + + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + cdoc <- createDoc cPath "haskell" cSource + + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] + + -- Change th from () to Bool + let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] + -- generate an artificial warning to avoid timing out if the TH change does not propagate + changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource <> "\nfoo=()"] + + -- Check that the change propagates to C + expectDiagnostics + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level bindin")]) + ] + + closeDoc adoc + closeDoc bdoc + closeDoc cdoc + where + name = "reloading-th-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" + +thLinkingTest :: Bool -> TestTree +thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do + + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th_a + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] + + let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] + + -- modify b too + let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ bSource'] + waitForProgressBegin + waitForAllProgressDone + + expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")] + + closeDoc adoc + closeDoc bdoc + where + name = "th-linking-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs new file mode 100644 index 0000000000..21d80cfb6e --- /dev/null +++ b/ghcide/test/exe/TestUtils.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +module TestUtils where + +import Control.Applicative.Combinators +import Control.Concurrent +import Control.Exception (bracket_, catch, finally) +import qualified Control.Lens as Lens +import qualified Control.Lens.Extras as Lens +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (toJSON) +import qualified Data.Aeson as A +import Data.Default +import Data.Foldable +import Data.List.Extra +import Data.Maybe +import Data.Proxy +import Data.Row +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Utf16.Rope (Rope) +import qualified Data.Text.Utf16.Rope as Rope +import Development.IDE.Core.PositionMapping (PositionResult (..), + fromCurrent, + positionResultToMaybe, + toCurrent) +import Development.IDE.GHC.Compat (GhcVersion (..), + ghcVersion) +import Development.IDE.GHC.Util +import qualified Development.IDE.Main as IDE +import Development.IDE.Plugin.TypeLenses (typeLensCommandId) +import Development.IDE.Spans.Common +import Development.IDE.Test (Cursor, canonicalizeUri, + configureCheckProject, + diagnostic, + expectCurrentDiagnostics, + expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + flushMessages, + getInterfaceFilesDir, + getStoredKeys, + isReferenceReady, + referenceReady, + standardizeQuotes, + waitForAction, waitForGC, + waitForTypecheck) +import Development.IDE.Test.Runfiles +import qualified Development.IDE.Types.Diagnostics as Diagnostics +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Ide.Plugin.Config +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Language.LSP.VFS (VfsLog, applyChange) +import Network.URI +import System.Directory +import System.Environment.Blank (getEnv, setEnv, unsetEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.FilePath +import System.Info.Extra (isMac, isWindows) +import qualified System.IO.Extra +import System.IO.Extra hiding (withTempDir) +import System.Mem (performGC) +import System.Process.Extra (CreateProcess (cwd), + createPipe, proc, + readCreateProcessWithExitCode) +import Test.QuickCheck +-- import Test.QuickCheck.Instances () +import Control.Concurrent.Async +import Control.Lens (to, (.~), (^.)) +import Control.Monad.Extra (whenJust) +import Data.Function ((&)) +import Data.Functor.Identity (runIdentity) +import Data.IORef +import Data.IORef.Extra (atomicModifyIORef_) +import Data.String (IsString (fromString)) +import Data.Tuple.Extra +import Development.IDE.Core.FileStore (getModTime) +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), + WaitForIdeRuleResult (..), + blockCommandId) +import qualified FuzzySearch +import GHC.Stack (emptyCallStack) +import GHC.TypeLits (symbolVal) +import qualified HieDbRetry +import Ide.Logger (Logger (Logger), + LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder, + toCologActionWithPrio) +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types +import qualified Progress +import System.Time.Extra +import qualified Test.QuickCheck.Monadic as MonadicQuickCheck +import Test.QuickCheck.Monadic (forAllM, monadicIO) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.QuickCheck +import Text.Printf (printf) +import Text.Regex.TDFA ((=~)) + +-- | Wait for the next progress begin step +waitForProgressBegin :: Session () +waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just () + _ -> Nothing + +-- | Wait for the first progress end step +-- Also implemented in hls-test-utils Test.Hls +waitForProgressDone :: Session () +waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just () + _ -> Nothing + +-- | Wait for all progress to be done +-- Needs at least one progress done notification to return +-- Also implemented in hls-test-utils Test.Hls +waitForAllProgressDone :: Session () +waitForAllProgressDone = loop + where + loop = do + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just () + _ -> Nothing + done <- null <$> getIncompleteProgressSessions + unless done loop + +run :: Session a -> IO a +run s = run' (const s) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir = runInDir' dir "." "." [] + +-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. +runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a +runInDir' = runInDir'' lspTestCaps + +runInDir'' + :: ClientCapabilities + -> FilePath + -> FilePath + -> FilePath + -> [String] + -> Session b + -> IO b +runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do + + ghcideExe <- locateGhcideExecutable + let startDir = dir startExeIn + let projDir = dir startSessionIn + + createDirectoryIfMissing True startDir + createDirectoryIfMissing True projDir + -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 + -- since the package import test creates "Data/List.hs", which otherwise has no physical home + createDirectoryIfMissing True $ projDir ++ "/Data" + + shakeProfiling <- getEnv "SHAKE_PROFILING" + let cmd = unwords $ + [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir + ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] + ] ++ extraOptions + -- HIE calls getXgdDirectory which assumes that HOME is set. + -- Only sets HOME if it wasn't already set. + setEnv "HOME" "/homeless-shelter" False + conf <- getConfigFromEnv + runSessionWithConfig conf cmd lspCaps projDir $ do + configureCheckProject False + s + +-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path +-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or +-- @/var@ +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' + +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } + +getConfigFromEnv :: IO SessionConfig +getConfigFromEnv = do + logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" + timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" + return defaultConfig + { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride + , logColor + } + where + checkEnv :: String -> IO (Maybe Bool) + checkEnv s = fmap convertVal <$> getEnv s + convertVal "0" = False + convertVal _ = True + +testSessionWait :: HasCallStack => String -> Session () -> TestTree +testSessionWait name = testSession name . + -- Check that any diagnostics produced were already consumed by the test case. + -- + -- If in future we add test cases where we don't care about checking the diagnostics, + -- this could move elsewhere. + -- + -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. + ( >> expectNoMoreDiagnostics 0.5) + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +ignoreInWindowsBecause :: String -> TestTree -> TestTree +ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) + +ignoreInWindowsForGHC810 :: TestTree -> TestTree +ignoreInWindowsForGHC810 = + ignoreFor (BrokenSpecific Windows [GHC810]) "tests are unreliable in windows for ghc 8.10" + +ignoreForGHC92Plus :: String -> TestTree -> TestTree +ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94, GHC96]) + +knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) + +data BrokenOS = Linux | MacOS | Windows deriving (Show) + +data IssueSolution = Broken | Ignore deriving (Show) + +data BrokenTarget = + BrokenSpecific BrokenOS [GhcVersion] + -- ^Broken for `BrokenOS` with `GhcVersion` + | BrokenForOS BrokenOS + -- ^Broken for `BrokenOS` + | BrokenForGHC [GhcVersion] + -- ^Broken for `GhcVersion` + deriving (Show) + +-- | Ignore test for specific os and ghc with reason. +ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree +ignoreFor = knownIssueFor Ignore + +-- | Known broken for specific os and ghc with reason. +knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree +knownBrokenFor = knownIssueFor Broken + +-- | Deal with `IssueSolution` for specific OS and GHC. +knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree +knownIssueFor solution = go . \case + BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers + BrokenForOS bos -> isTargetOS bos + BrokenForGHC vers -> isTargetGhc vers + where + isTargetOS = \case + Windows -> isWindows + MacOS -> isMac + Linux -> not isWindows && not isMac + + isTargetGhc = elem ghcVersion + + go True = case solution of + Broken -> expectFailBecause + Ignore -> ignoreTestBecause + go False = \_ -> id + +data Expect + = ExpectRange Range -- Both gotoDef and hover should report this range + | ExpectLocation Location +-- | ExpectDefRange Range -- Only gotoDef should report this range + | ExpectHoverRange Range -- Only hover should report this range + | ExpectHoverText [T.Text] -- the hover message must contain these snippets + | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets + | ExpectHoverTextRegex T.Text -- the hover message must match this pattern + | ExpectExternFail -- definition lookup in other file expected to fail + | ExpectNoDefinitions + | ExpectNoHover +-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples + deriving Eq + +mkR :: UInt -> UInt -> UInt -> UInt -> Expect +mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn + +mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect +mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn + + + +testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +testSession' :: String -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + + + +mkRange :: UInt -> UInt -> UInt -> UInt -> Range +mkRange a b c d = Range (Position a b) (Position c d) + + +runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("test/data" prefix f) (dir f) + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") + + + +lspTestCapsNoFileWatches :: ClientCapabilities +lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing + +openTestDataDoc :: FilePath -> Session TextDocumentIdentifier +openTestDataDoc path = do + source <- liftIO $ readFileUtf8 $ "test/data" path + createDoc path "haskell" source + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session () +checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where + check (ExpectRange expectedRange) = do + assertNDefinitionsFound 1 defs + assertRangeCorrect (head defs) expectedRange + check (ExpectLocation expectedLocation) = do + assertNDefinitionsFound 1 defs + liftIO $ do + canonActualLoc <- canonicalizeLocation (head defs) + canonExpectedLoc <- canonicalizeLocation expectedLocation + canonActualLoc @?= canonExpectedLoc + check ExpectNoDefinitions = do + assertNDefinitionsFound 0 defs + check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" + check _ = pure () -- all other expectations not relevant to getDefinition + + assertNDefinitionsFound :: Int -> [a] -> Session () + assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) + + assertRangeCorrect Location{_range = foundRange} expectedRange = + liftIO $ expectedRange @=? foundRange + +canonicalizeLocation :: Location -> IO Location +canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range + +defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location] +defToLocation (InL (Definition (InL l))) = [l] +defToLocation (InL (Definition (InR ls))) = ls +defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink +defToLocation (InR (InR Null)) = [] + +-- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did +thDollarIdx :: UInt +thDollarIdx | ghcVersion >= GHC90 = 1 + | otherwise = 0 diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs new file mode 100644 index 0000000000..fea2829144 --- /dev/null +++ b/ghcide/test/exe/UnitTests.hs @@ -0,0 +1,130 @@ + +module UnitTests (tests) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception (finally) +import Control.Monad.IO.Class (liftIO) +import Data.IORef +import Data.IORef.Extra (atomicModifyIORef_) +import Data.List.Extra +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Development.IDE.Core.FileStore (getModTime) +import qualified Development.IDE.Main as IDE +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import qualified Development.IDE.Types.Diagnostics as Diagnostics +import Development.IDE.Types.Location +import qualified FuzzySearch +import Ide.Logger (Logger, Recorder, + WithPriority, cmapWithPrio) +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import LogType (Log (..)) +import Network.URI +import qualified Progress +import System.Directory +import System.IO.Extra hiding (withTempDir) +import System.Mem (performGC) +import System.Process.Extra (createPipe) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import TestUtils +import Text.Printf (printf) + +tests :: Recorder (WithPriority Log) -> Logger -> TestTree +tests recorder logger = do + testGroup "Unit" + [ testCase "empty file path does NOT work with the empty String literal" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." + , testCase "empty file path works using toNormalizedFilePath'" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" + , testCase "empty path URI" $ do + Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) + uriScheme @?= "file:" + uriPath @?= "" + , testCase "from empty path URI" $ do + let uri = Uri "file://" + uriToFilePath' uri @?= Just "" + , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do + let diag = ("", Diagnostics.ShowDiag, Diagnostic + { _codeDescription = Nothing + , _data_ = Nothing + , _range = Range + { _start = Position{_line = 0, _character = 1} + , _end = Position{_line = 2, _character = 3} + } + , _severity = Nothing + , _code = Nothing + , _source = Nothing + , _message = "" + , _relatedInformation = Nothing + , _tags = Nothing + }) + let shown = T.unpack (Diagnostics.showDiagnostics [diag]) + let expected = "1:2-3:4" + assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ + expected `isInfixOf` shown + , testCase "notification handlers run in priority order" $ do + orderRef <- newIORef [] + let plugins = pluginDescToIdePlugins $ + [ (priorityPluginDescriptor i) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ atomicModifyIORef_ orderRef (i:) + ] + } + | i <- [1..20] + ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) + priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i} + + testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do + _ <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + actualOrder <- liftIO $ reverse <$> readIORef orderRef + + -- Handlers are run in priority descending order + liftIO $ actualOrder @?= [20, 19 .. 1] + , ignoreTestBecause "The test fails sometimes showing 10000us" $ + testCase "timestamps have millisecond resolution" $ do + resolution_us <- findResolution_us 1 + let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us + assertBool msg (resolution_us <= 1000) + , Progress.tests + , FuzzySearch.tests + ] + +findResolution_us :: Int -> IO Int +findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" +findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do + performGC + writeFile f "" + threadDelay delay_us + writeFile f' "" + t <- getModTime f + t' <- getModTime f' + if t /= t' then return delay_us else findResolution_us (delay_us * 10) + + +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do + config <- getConfigFromEnv + cwd <- getCurrentDirectory + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + let projDir = "." + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + } + + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session diff --git a/ghcide/test/exe/WatchedFileTests.hs b/ghcide/test/exe/WatchedFileTests.hs new file mode 100644 index 0000000000..8d33f4f5cc --- /dev/null +++ b/ghcide/test/exe/WatchedFileTests.hs @@ -0,0 +1,83 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} + +module WatchedFileTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "watched files" + [ testGroup "Subscriptions" + [ testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics + + -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle + liftIO $ length watchedFileRegs @?= 2 + + , testSession' "non workspace file" $ \sessionDir -> do + tmpDir <- liftIO getTemporaryDirectory + let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" + liftIO $ writeFile (sessionDir "hie.yaml") yaml + _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics + + -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle + liftIO $ length watchedFileRegs @?= 2 + + -- TODO add a test for didChangeWorkspaceFolder + ] + , testGroup "Changes" + [ + testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" + liftIO $ writeFile (sessionDir "B.hs") $ unlines + ["module B where" + ,"b :: Bool" + ,"b = False"] + _doc <- createDoc "A.hs" "haskell" $ T.unlines + ["module A where" + ,"import B" + ,"a :: ()" + ,"a = b" + ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] + -- modify B off editor + liftIO $ writeFile (sessionDir "B.hs") $ unlines + ["module B where" + ,"b :: Int" + ,"b = 0"] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ sessionDir "B.hs") FileChangeType_Changed ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] + ] + ] + +getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] +getWatchedFilesSubscriptionsUntil m = do + msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m) + return + [ x + | Just TRequestMessage{_params = RegistrationParams regs} <- msgs + , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs + , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args] + ] From 9bbf421dc5a9587c6ce6f7ce34bbcc6e6fe1b5e0 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 12:19:46 +0000 Subject: [PATCH 18/28] have CommandFunction use ExceptT --- ghcide/src/Development/IDE/Plugin/HLS.hs | 3 +- ghcide/src/Development/IDE/Plugin/Test.hs | 5 ++- .../src/Development/IDE/Plugin/TypeLenses.hs | 5 ++- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 4 +- hls-plugin-api/src/Ide/Types.hs | 2 +- .../src/Ide/Plugin/Class/CodeAction.hs | 39 +++++++++---------- .../src/Ide/Plugin/Class/CodeLens.hs | 5 ++- .../src/Ide/Plugin/Eval/CodeLens.hs | 4 +- .../src/Ide/Plugin/Eval/Util.hs | 13 ++++--- .../src/Ide/Plugin/ExplicitImports.hs | 6 +-- .../hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 2 +- .../src/Ide/Plugin/ModuleName.hs | 2 +- .../src/Development/IDE/Plugin/CodeAction.hs | 3 +- .../src/Ide/Plugin/RefineImports.hs | 4 +- .../src/Ide/Plugin/Retrie.hs | 12 ++---- .../src/Ide/Plugin/Splice.hs | 2 +- .../old/src/Wingman/AbstractLSP.hs | 4 +- 17 files changed, 58 insertions(+), 57 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index a7767b796d..0c40d051b6 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -12,6 +12,7 @@ module Development.IDE.Plugin.HLS import Control.Exception (SomeException) import Control.Lens ((^.)) import Control.Monad +import Control.Monad.Trans.Except (runExceptT) import qualified Data.Aeson as A import Data.Bifunctor (first) import Data.Dependent.Map (DMap) @@ -218,7 +219,7 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom Just (PluginCommand _ _ f) -> case A.fromJSON arg of A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) A.Success a -> do - (first (toResponseError . (p,)) <$> f ide a) `catchAny` -- See Note [Exception handling in plugins] + (first (toResponseError . (p,)) <$> runExceptT (f ide a)) `catchAny` -- See Note [Exception handling in plugins] (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e)) -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index c6d8de705e..a90cd875fb 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -17,6 +17,7 @@ import Control.Monad import Control.Monad.Except (ExceptT (..), throwError) import Control.Monad.IO.Class import Control.Monad.STM +import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value) import qualified Data.Aeson.Types as A @@ -172,6 +173,6 @@ blockCommandDescriptor plId = (defaultPluginDescriptor plId) { blockCommandHandler :: CommandFunction state ExecuteCommandParams blockCommandHandler _ideState _params = do - LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null + lift $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null liftIO $ threadDelay maxBound - return (Right $ InR Null) + pure $ InR Null diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 56e18fc08b..84ee6f0c67 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -18,6 +18,7 @@ import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Aeson.Types (Value, toJSON) import qualified Data.Aeson.Types as A import Data.List (find) @@ -156,8 +157,8 @@ generateLens pId _range title edit = commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do - _ <- LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right $ InR Null + _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + pure $ InR Null -------------------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index f24b82d5f9..5a0f7fa793 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -133,7 +133,7 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMeth where data_ = codeAction ^? L.data_ . _Just executeResolveCmd :: ResolveFunction ideState a 'Method_CodeActionResolve -> CommandFunction ideState CodeAction executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do - withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do + ExceptT $ withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do case A.fromJSON value of A.Error err -> throwError $ parseError (Just value) (T.pack err) A.Success (WithURI uri innerValue) -> do @@ -150,7 +150,7 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMeth "The resolve provider unexpectedly returned a code action with the following differing fields: " <> (T.pack $ show $ diffCodeActions ca ca2) _ -> throwError $ internalError "The resolve provider unexpectedly returned a result with no data field" - executeResolveCmd _ _ CodeAction{_data_= value} = runExceptT $ throwError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) + executeResolveCmd _ _ CodeAction{_data_= value} = throwError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) handleWEditCallback (Left err ) = do logWith recorder Warning (ApplyWorkspaceEditFailed err) pure () diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index e47d24c54b..cc36e6aa5d 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -899,7 +899,7 @@ data PluginCommand ideState = forall a. (FromJSON a) => type CommandFunction ideState a = ideState -> a - -> LspM Config (Either PluginError (Value |? Null)) + -> ExceptT PluginError (LspM Config) (Value |? Null) -- --------------------------------------------------------------------- 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 e4d41ff39f..18accdbc6f 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -10,7 +10,7 @@ import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Extra import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe import Data.Aeson hiding (Null) import Data.Bifunctor (second) @@ -43,25 +43,24 @@ import Language.LSP.Server addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do - caps <- getClientCapabilities - runExceptT $ do - nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) - pm <- runActionE "classplugin.addMethodPlaceholders.GetParsedModule" state - $ useE GetParsedModule nfp - (hsc_dflags . hscEnv -> df) <- runActionE "classplugin.addMethodPlaceholders.GhcSessionDeps" state - $ useE GhcSessionDeps nfp - (old, new) <- handleMaybeM (PluginInternalError "Unable to makeEditText") - $ liftIO $ runMaybeT - $ makeEditText pm df param - pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs - let edit = - if withSig - then mergeEdit (workspaceEdit caps old new) pragmaInsertion - else workspaceEdit caps old new - - void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - - pure $ InR Null + caps <- lift $ getClientCapabilities + nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + pm <- runActionE "classplugin.addMethodPlaceholders.GetParsedModule" state + $ useE GetParsedModule nfp + (hsc_dflags . hscEnv -> df) <- runActionE "classplugin.addMethodPlaceholders.GhcSessionDeps" state + $ useE GhcSessionDeps nfp + (old, new) <- handleMaybeM (PluginInternalError "Unable to makeEditText") + $ liftIO $ runMaybeT + $ makeEditText pm df param + pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs + let edit = + if withSig + then mergeEdit (workspaceEdit caps old new) pragmaInsertion + else workspaceEdit caps old new + + void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + + pure $ InR Null where toTextDocumentEdit edit = TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) [InL edit] 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 99fa3b04c0..daf5f4e2bc 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -6,6 +6,7 @@ module Ide.Plugin.Class.CodeLens where import Control.Lens ((^.)) +import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Aeson hiding (Null) import Data.Maybe (mapMaybe, maybeToList) import qualified Data.Text as T @@ -137,5 +138,5 @@ codeLens state plId CodeLensParams{..} = do codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit codeLensCommandHandler _ wedit = do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right $ InR Null + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + pure $ InR Null 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 c67a2044a6..f10dd000a4 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -235,9 +235,9 @@ runEvalCmd plId st EvalParams{..} = let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing return workspaceEdits - in perf "evalCmd" $ + in perf "evalCmd" $ ExceptT $ withIndefiniteProgress "Evaluating" Cancellable $ - response' cmd + runExceptT $ response' cmd -- | Create an HscEnv which is suitable for performing interactive evaluation. -- All necessary home modules will have linkables and the current module will 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 ef4bf0bcf9..2c1d012291 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -15,7 +15,9 @@ module Ide.Plugin.Eval.Util ( import Control.Exception (SomeException, evaluate, fromException) +import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson (Value) @@ -69,15 +71,14 @@ logLevel = Debug -- Info isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> LspM c (Either PluginError (Value |? Null)) +response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> ExceptT PluginError (LspM c) (Value |? Null) response' act = do - res <- runExceptT act + res <- ExceptT (runExceptT act `catchAny` \e -> do res <- showErr e - pure . Left . PluginInternalError $ fromString res - sequence $ flip second res $ \a -> do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) - pure $ InR Null + pure . Left . PluginInternalError $ fromString res) + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) + pure $ InR Null gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) gStrictTry op = diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index ca40dc8b12..944154a41f 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -23,7 +23,7 @@ import Control.Lens ((&), (?~)) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe import qualified Data.Aeson as A (ToJSON (toJSON)) import Data.Aeson.Types (FromJSON) @@ -104,7 +104,7 @@ descriptorForModules recorder modFilter plId = -- | The actual command handler runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState EIResolveData -runImportCommand recorder ideState eird@(ResolveOne _ _) = runExceptT $ do +runImportCommand recorder ideState eird@(ResolveOne _ _) = do wedit <- resolveWTextEdit ideState eird _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors return $ InR Null @@ -113,7 +113,7 @@ runImportCommand recorder ideState eird@(ResolveOne _ _) = runExceptT $ do pure () logErrors (Right _) = pure () runImportCommand _ _ (ResolveAll _) = do - pure $ Left $ PluginInvalidParams "Unexpected argument for command handler: ResolveAll" + throwError $ PluginInvalidParams "Unexpected argument for command handler: ResolveAll" -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index a68655c2cd..761eab7a5c 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -57,7 +57,7 @@ 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{..} = runExceptT $ withExceptT handleGhcidePluginError $ do +toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = withExceptT handleGhcidePluginError $ do nfp <- withExceptT (GhcidePluginErrors) $ getNormalizedFilePathE uri (decls, exts) <- getInRangeH98DeclsAndExts state range nfp (L ann decl) <- case decls of diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index c540e1484e..6474a4c204 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -89,7 +89,7 @@ codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdenti -- | (Quasi) Idempotent command execution: recalculate action to execute on command request command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri -command recorder state uri = runExceptT $ do +command recorder state uri = do actMaybe <- action recorder state uri forM_ actMaybe $ \Replace{..} -> let diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 4e5d1c3dba..c6615aa334 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -23,6 +23,7 @@ import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans +import Control.Monad.Trans.Except (ExceptT (ExceptT)) import Control.Monad.Trans.Maybe import Data.Char import qualified Data.DList as DL @@ -196,7 +197,7 @@ extendImportCommand = PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler extendImportHandler :: CommandFunction IdeState ExtendImport -extendImportHandler ideState edit@ExtendImport {..} = do +extendImportHandler ideState edit@ExtendImport {..} = ExceptT $ do res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do let (_, (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . M.toList diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 309ad1e71e..2241d052dc 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -102,8 +102,8 @@ refineImportCommand = runRefineImportCommand :: CommandFunction IdeState RefineImportCommandParams runRefineImportCommand _state (RefineImportCommandParams edit) = do -- This command simply triggers a workspace edit! - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - return (Right $ InR Null) + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + pure $ InR Null lensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens lensProvider diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 9752bd221d..16f981552f 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -208,11 +208,8 @@ data RunRetrieParams = RunRetrieParams restrictToOriginatingFile :: Bool } deriving (Eq, Show, Generic, FromJSON, ToJSON) -runRetrieCmd :: - IdeState -> - RunRetrieParams -> - LspM c (Either PluginError (Value |? Null)) -runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = +runRetrieCmd :: CommandFunction IdeState RunRetrieParams +runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = ExceptT $ withIndefiniteProgress description Cancellable $ do runExceptT $ do nfp <- getNormalizedFilePathE uri @@ -246,9 +243,8 @@ data RunRetrieInlineThisParams = RunRetrieInlineThisParams } deriving (Eq, Show, Generic, FromJSON, ToJSON) -runRetrieInlineThisCmd :: IdeState - -> RunRetrieInlineThisParams -> LspM c (Either PluginError (Value |? Null)) -runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = runExceptT $ do +runRetrieInlineThisCmd :: CommandFunction IdeState RunRetrieInlineThisParams +runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = do nfp <- getNormalizedFilePathE $ getLocationUri inlineIntoThisLocation nfpSource <- getNormalizedFilePathE $ getLocationUri inlineFromThisLocation -- What we do here: diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 62b108f3c0..0b71671b01 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -105,7 +105,7 @@ expandTHSplice :: -- | Inplace? ExpandStyle -> CommandFunction IdeState ExpandSpliceParams -expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do +expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = ExceptT $ do clientCapabilities <- getClientCapabilities rio <- askRunInIO let reportEditor :: ReportEditor diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index 9cc50831a4..07dd11206d 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -91,8 +91,8 @@ runContinuation -> Continuation sort a b -> CommandFunction IdeState (FileContext, b) runContinuation plId cont state (fc, b) = do - fromMaybeT - (Left $ PluginInternalError "TODO(sandy)") $ do + maybeToExceptT + (PluginInternalError "TODO(sandy)") $ do env@LspEnv{..} <- buildEnv state plId fc nfp <- getNfp $ fc_verTxtDocId le_fileContext ^. L.uri let stale a = runStaleIde "runContinuation" state nfp a From afcf19deb2eb8bbc1ce8abbe2cce812ff01b8ffc Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 17:38:00 +0300 Subject: [PATCH 19/28] add tests for exceptions and PluginError order --- ghcide/ghcide.cabal | 2 + ghcide/src/Development/IDE/Plugin/HLS.hs | 5 +- ghcide/test/exe/ExceptionTests.hs | 212 +++++++++++++++++++++++ ghcide/test/exe/LogType.hs | 4 + ghcide/test/exe/Main.hs | 2 + 5 files changed, 222 insertions(+), 3 deletions(-) create mode 100644 ghcide/test/exe/ExceptionTests.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 1e6c7b8a00..5e7523f823 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -347,6 +347,7 @@ test-suite ghcide-tests lens, list-t, lsp-test ^>= 0.15, + mtl, monoid-subclasses, network-uri, QuickCheck, @@ -383,6 +384,7 @@ test-suite ghcide-tests HieDbRetry Development.IDE.Test Development.IDE.Test.Diagnostic + ExceptionTests -- Tests that have been pulled out of the main file BootTests CodeLensTests diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 0c40d051b6..ff7aeed59c 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -311,9 +311,8 @@ runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedPro combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError combineErrors (x NE.:| []) = toResponseError x -combineErrors xs = - case NE.sortWith (toPriority . snd) xs of - (x NE.:| _) -> toResponseError x +combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs + toResponseError :: (PluginId, PluginError) -> ResponseError toResponseError (PluginId plId, err) = diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs new file mode 100644 index 0000000000..06cc195332 --- /dev/null +++ b/ghcide/test/exe/ExceptionTests.hs @@ -0,0 +1,212 @@ + +module ExceptionTests (tests) where + +import Control.Concurrent.Async +import Control.Exception (ArithException (DivideByZero), + finally, throwIO) +import Control.Lens +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Text as T +import Development.IDE.Core.Shake (IdeState (..)) +import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.Main as IDE +import Development.IDE.Plugin.Test as Test +import Development.IDE.Types.Options +import GHC.Base (coerce) +import Ide.Logger (Logger, Recorder, + WithPriority, cmapWithPrio) +import Ide.Plugin.Error +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import LogType (Log (..)) +import System.Directory +import System.Process.Extra (createPipe) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: Recorder (WithPriority Log) -> Logger -> TestTree +tests recorder logger = do + testGroup "Exceptions and PluginError" [ + testGroup "Testing that IO Exceptions are caught in..." + [ testCase "PluginHandlers" $ do + let pluginId = "plugin-handler-exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + _ <- liftIO $ throwIO DivideByZero + pure (InL []) + ] + }] + + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show lens + , testCase "Commands" $ do + let pluginId = "command-exception" + commandId = CommandId "exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginCommands = + [ PluginCommand commandId "Causes an exception" $ \_ (_::Int) -> do + _ <- liftIO $ throwIO DivideByZero + pure (InR Null) + ] + }] + + testIde recorder (testingLite recorder logger plugins) $ do + _ <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) + execParams = ExecuteCommandParams Nothing (cmd ^. L.command) (cmd ^. L.arguments) + (view L.result -> res) <- request SMethod_WorkspaceExecuteCommand execParams + case res of + Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show res + , testCase "Notification Handlers" $ do + let pluginId = "notification-exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ throwIO DivideByZero + ] + , pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + pure (InL []) + ] + } + , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] + + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Right (InL []) -> + pure () + _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] + + , testGroup "Testing PluginError order..." + [ testCase "InternalError over InvalidParams" $ do + let pluginId = "internal-error-order" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ PluginInternalError "error test" + ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ PluginInvalidParams "error test" + ] + } + , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] + + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show lens + , testCase "InvalidParams over InvalidUserState" $ do + let pluginId = "invalid-params-order" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ PluginInvalidParams "error test" + ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ PluginInvalidUserState "error test" + ] + } + , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] + + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left (ResponseError {_code = InR ErrorCodes_InvalidParams, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show lens + , testCase "InvalidUserState over RequestRefused" $ do + let pluginId = "invalid-user-state-order" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ PluginInvalidUserState "error test" + ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ PluginRequestRefused "error test" + ] + } + , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] + + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left (ResponseError {_code = InL LSPErrorCodes_RequestFailed, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show lens + ]] + +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do + config <- getConfigFromEnv + cwd <- getCurrentDirectory + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + let projDir = "." + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + } + + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session + +testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments +testingLite recorder logger plugins = + let + arguments@IDE.Arguments{ argsIdeOptions } = + IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) logger plugins + hlsPlugins = pluginDescToIdePlugins $ + idePluginsToPluginDesc plugins + ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions config sessionLoader = + let + defOptions = argsIdeOptions config sessionLoader + in + defOptions{ optTesting = IdeTesting True } + in + arguments + { IDE.argsHlsPlugins = hlsPlugins + , IDE.argsIdeOptions = ideOptions + } diff --git a/ghcide/test/exe/LogType.hs b/ghcide/test/exe/LogType.hs index 292a81c32e..476ea5bc27 100644 --- a/ghcide/test/exe/LogType.hs +++ b/ghcide/test/exe/LogType.hs @@ -1,7 +1,9 @@ module LogType (Log(..)) where +import qualified Development.IDE.LSP.Notifications as Notifications import qualified Development.IDE.Main as IDE import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide + import Ide.Logger (Pretty (pretty)) import Language.LSP.VFS (VfsLog) @@ -9,9 +11,11 @@ data Log = LogGhcIde Ghcide.Log | LogIDEMain IDE.Log | LogVfs VfsLog + | LogNotifications Notifications.Log instance Pretty Log where pretty = \case LogGhcIde log -> pretty log LogIDEMain log -> pretty log LogVfs log -> pretty log + LogNotifications log -> pretty log diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 47aa36a568..9292e3ccc9 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -75,6 +75,7 @@ import AsyncTests import ClientSettingsTests import ReferenceTests import GarbageCollectionTests +import ExceptionTests main :: IO () main = do @@ -122,4 +123,5 @@ main = do , ReferenceTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests + , ExceptionTests.tests recorder logger ] \ No newline at end of file From 77d264fa3cf9d379ba964a56f417e09853ec7678 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 17:40:00 +0300 Subject: [PATCH 20/28] fix tactics build --- plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index 07dd11206d..2276f564a4 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -10,7 +10,7 @@ module Wingman.AbstractLSP (installInteractions) where import Control.Monad (void) import Control.Monad.IO.Class import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT) +import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT, maybeToExceptT) import qualified Data.Aeson as A import Data.Coerce import Data.Foldable (traverse_) From 1a22bccf790eea8a624ab0a0c4aa64c01a50ec91 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 17:59:48 +0300 Subject: [PATCH 21/28] fix tactics try 2 --- plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index 2276f564a4..fb3f477678 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -10,7 +10,7 @@ module Wingman.AbstractLSP (installInteractions) where import Control.Monad (void) import Control.Monad.IO.Class import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT, maybeToExceptT) +import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT) import qualified Data.Aeson as A import Data.Coerce import Data.Foldable (traverse_) @@ -90,8 +90,8 @@ runContinuation => PluginId -> Continuation sort a b -> CommandFunction IdeState (FileContext, b) -runContinuation plId cont state (fc, b) = do - maybeToExceptT +runContinuation plId cont state (fc, b) = ExceptT $ do + fromMaybeT (PluginInternalError "TODO(sandy)") $ do env@LspEnv{..} <- buildEnv state plId fc nfp <- getNfp $ fc_verTxtDocId le_fileContext ^. L.uri From 28bdeccf97ae89dd8d4299e201de1b93b940b03a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 18:26:43 +0300 Subject: [PATCH 22/28] fix tactics build try 3 --- plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index fb3f477678..df8576dd46 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -10,6 +10,7 @@ module Wingman.AbstractLSP (installInteractions) where import Control.Monad (void) import Control.Monad.IO.Class import Control.Monad.Trans (lift) +import. Control.Monad.Trans.Except (ExceptT(ExceptT)) import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT) import qualified Data.Aeson as A import Data.Coerce From 1dd12d47efbc89211496941fbc5c7666468ceecf Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 19:16:50 +0300 Subject: [PATCH 23/28] fix for real this time --- plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index df8576dd46..604cbfac3e 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -10,7 +10,7 @@ module Wingman.AbstractLSP (installInteractions) where import Control.Monad (void) import Control.Monad.IO.Class import Control.Monad.Trans (lift) -import. Control.Monad.Trans.Except (ExceptT(ExceptT)) +import Control.Monad.Trans.Except (ExceptT(ExceptT)) import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT) import qualified Data.Aeson as A import Data.Coerce @@ -93,7 +93,7 @@ runContinuation -> CommandFunction IdeState (FileContext, b) runContinuation plId cont state (fc, b) = ExceptT $ do fromMaybeT - (PluginInternalError "TODO(sandy)") $ do + (Left $ PluginInternalError "TODO(sandy)") $ do env@LspEnv{..} <- buildEnv state plId fc nfp <- getNfp $ fc_verTxtDocId le_fileContext ^. L.uri let stale a = runStaleIde "runContinuation" state nfp a From ba4fa7978147dc3040bc0feadfb262fbcdc3dfe8 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 22:50:09 +0300 Subject: [PATCH 24/28] Fix hlint rules --- .hlint.yaml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/.hlint.yaml b/.hlint.yaml index 2cc24901a6..d527485da2 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -117,6 +117,10 @@ - Wingman.Judgements - Wingman.Machinery - Wingman.Tactics + - CompletionTests #Previously part of GHCIDE Main tests + - DiagnosticTests #Previously part of GHCIDE Main tests + - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests + - TestUtils #Previously part of GHCIDE Main tests - name: [Prelude.tail, Data.List.tail] within: @@ -126,6 +130,7 @@ - Development.IDE.Plugin.CodeAction.ExactPrint - Development.IDE.Session - UnificationSpec + - WatchedFileTests #Previously part of GHCIDE Main tests - name: [Prelude.last, Data.List.last] within: @@ -137,6 +142,7 @@ - Ide.PluginUtils - Ide.Plugin.Eval.Parse.Comments - Ide.Plugin.Eval.CodeLens + - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests - name: [Prelude.init, Data.List.init] within: @@ -146,6 +152,9 @@ - Wingman.Metaprogramming.Parser - Development.Benchmark.Rules - ErrorGivenPartialSignature + - IfaceTests #Previously part of GHCIDE Main tests + - THTests #Previously part of GHCIDE Main tests + - WatchedFileTests #Previously part of GHCIDE Main tests - name: Data.List.foldl1' within: [] @@ -164,6 +173,8 @@ - TErrorGivenPartialSignature - Wingman.CaseSplit - Wingman.Simplify + - InitializeResponseTests #Previously part of GHCIDE Main tests + - PositionMappingTests #Previously part of GHCIDE Main tests - name: Data.Text.head within: From 89bba81c1bac90be28c8f5be26887fe234058941 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 29 Jul 2023 22:54:39 +0300 Subject: [PATCH 25/28] hlint rule fixes try 2 --- .hlint.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.hlint.yaml b/.hlint.yaml index d527485da2..852b8060b0 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -121,6 +121,7 @@ - DiagnosticTests #Previously part of GHCIDE Main tests - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests - TestUtils #Previously part of GHCIDE Main tests + - CodeLensTests #Previously part of GHCIDE Main tests - name: [Prelude.tail, Data.List.tail] within: @@ -205,6 +206,7 @@ - Development.IDE.Graph.Internal.Profile - Development.IDE.Graph.Internal.Rules - Ide.Plugin.Class + - CodeLensTests #Previously part of GHCIDE Main tests - name: "Data.Map.!" within: From a2159041389e4bd17217d46d84448b619808fba9 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 31 Jul 2023 16:51:35 +0300 Subject: [PATCH 26/28] address michealpj's suggestions --- ghcide/src/Development/IDE/Core/Shake.hs | 8 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 42 ++++--- ghcide/test/exe/ExceptionTests.hs | 125 +++++------------- ghcide/test/exe/TestUtils.hs | 154 +++++++---------------- ghcide/test/exe/UnitTests.hs | 20 --- hls-plugin-api/src/Ide/Plugin/Error.hs | 6 +- 6 files changed, 110 insertions(+), 245 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index fbe7b5df29..c70315c2fe 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -964,7 +964,7 @@ useWithStale key file = runIdentity <$> usesWithStale key (Identity file) -- |Request a Rule result, it not available return the last computed result -- which may be stale. -- --- Throws an `BadDependency` IO exception which is caught by the rule system if +-- Throws an `BadDependency` exception which is caught by the rule system if -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead. @@ -974,7 +974,7 @@ useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) -- |Plural version of 'useWithStale_' -- --- Throws an `BadDependency` IO exception which is caught by the rule system if +-- Throws an `BadDependency` exception which is caught by the rule system if -- none available. -- -- WARNING: Not suitable for PluginHandlers. @@ -1053,7 +1053,7 @@ useNoFile key = use key emptyFilePath -- Requests a rule if available. -- --- Throws an `BadDependency` IO exception which is caught by the rule system if +-- Throws an `BadDependency` exception which is caught by the rule system if -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `useE` instead. @@ -1065,7 +1065,7 @@ useNoFile_ key = use_ key emptyFilePath -- |Plural version of `use_` -- --- Throws an `BadDependency` IO exception which is caught by the rule system if +-- Throws an `BadDependency` exception which is caught by the rule system if -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `usesE` instead. diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index ff7aeed59c..f0d794d049 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -6,6 +6,7 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin + , toResponseError , Log(..) ) where @@ -80,10 +81,17 @@ prettyResponseError err = errorCode <> ":" <+> errorBody errorCode = pretty $ show $ err ^. L.code errorBody = pretty $ err ^. L.message -pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text +pluginNotEnabled :: SMethod m -> [PluginId] -> Text pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " - <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins) + <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins) + +noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c) +noPluginEnabled recorder m fs' = do + logWith recorder Warning (LogNoPluginForMethod $ Some m) + let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing + msg = pluginNotEnabled m fs' + return $ Left err pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" @@ -113,13 +121,6 @@ logAndReturnError recorder p errCode msg = do logWith recorder Warning $ LogResponseError p err pure $ Left err --- | Logs the provider error before returning it to the caller -logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a) -logAndReturnError' recorder errCode msg = do - let err = ResponseError errCode (fromString $ show msg) Nothing - logWith recorder Warning $ msg - pure $ Left err - -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = @@ -219,8 +220,15 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom Just (PluginCommand _ _ f) -> case A.fromJSON arg of A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) A.Success a -> do - (first (toResponseError . (p,)) <$> runExceptT (f ide a)) `catchAny` -- See Note [Exception handling in plugins] - (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e)) + res <- runExceptT (f ide a) `catchAny` -- See Note [Exception handling in plugins] + (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e)) + case res of + (Left (PluginRequestRefused _)) -> + liftIO $ noPluginEnabled recorder SMethod_WorkspaceExecuteCommand (fst <$> ecs) + (Left pluginErr) -> do + liftIO $ logErrors recorder [(p, pluginErr)] + pure $ Left $ toResponseError (p, pluginErr) + (Right result) -> pure $ Right result -- --------------------------------------------------------------------- @@ -242,7 +250,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> liftIO $ noPluginEnabled m fs' + Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs') Just fs -> do let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs es <- runConcurrently exceptionInPlugin m handlers ide params @@ -255,16 +263,11 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } noRefused (_, _) = True filteredErrs = filter noRefused errs case nonEmpty filteredErrs of - Nothing -> liftIO $ noPluginEnabled m fs' + Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs') Just xs -> pure $ Left $ combineErrors xs Just xs -> do pure $ Right $ combineResponses m config caps params xs - noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c) - noPluginEnabled m fs' = do - logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing - msg = pluginNotEnabled m fs' - return $ Left err + -- --------------------------------------------------------------------- @@ -313,7 +316,6 @@ combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError combineErrors (x NE.:| []) = toResponseError x combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs - toResponseError :: (PluginId, PluginError) -> ResponseError toResponseError (PluginId plId, err) = ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 06cc195332..a528cb29ad 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -1,9 +1,8 @@ module ExceptionTests (tests) where -import Control.Concurrent.Async import Control.Exception (ArithException (DivideByZero), - finally, throwIO) + throwIO) import Control.Lens import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (liftIO) @@ -12,6 +11,7 @@ import Data.Text as T import Development.IDE.Core.Shake (IdeState (..)) import qualified Development.IDE.LSP.Notifications as Notifications import qualified Development.IDE.Main as IDE +import Development.IDE.Plugin.HLS (toResponseError) import Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import GHC.Base (coerce) @@ -30,8 +30,6 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import LogType (Log (..)) -import System.Directory -import System.Process.Extra (createPipe) import Test.Tasty import Test.Tasty.HUnit import TestUtils @@ -50,7 +48,6 @@ tests recorder logger = do pure (InL []) ] }] - testIde recorder (testingLite recorder logger plugins) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone @@ -60,6 +57,7 @@ tests recorder logger = do liftIO $ assertBool "We caught an error, but it wasn't ours!" (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) _ -> liftIO $ assertFailure $ show lens + , testCase "Commands" $ do let pluginId = "command-exception" commandId = CommandId "exception" @@ -71,7 +69,6 @@ tests recorder logger = do pure (InR Null) ] }] - testIde recorder (testingLite recorder logger plugins) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone @@ -83,6 +80,7 @@ tests recorder logger = do liftIO $ assertBool "We caught an error, but it wasn't ours!" (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) _ -> liftIO $ assertFailure $ show res + , testCase "Notification Handlers" $ do let pluginId = "notification-exception" plugins = pluginDescToIdePlugins $ @@ -95,101 +93,24 @@ tests recorder logger = do [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do pure (InL []) ] - } - , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - + }] testIde recorder (testingLite recorder logger plugins) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) case lens of Right (InL []) -> + -- We don't get error responses from notification handlers, so + -- we can only make sure that the server is still responding pure () _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] , testGroup "Testing PluginError order..." - [ testCase "InternalError over InvalidParams" $ do - let pluginId = "internal-error-order" - plugins = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId) - { pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInternalError "error test" - ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInvalidParams "error test" - ] - } - , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - - testIde recorder (testingLite recorder logger plugins) $ do - doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - case lens of - Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> - liftIO $ assertBool "We caught an error, but it wasn't ours!" - (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) - _ -> liftIO $ assertFailure $ show lens - , testCase "InvalidParams over InvalidUserState" $ do - let pluginId = "invalid-params-order" - plugins = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId) - { pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInvalidParams "error test" - ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInvalidUserState "error test" - ] - } - , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - - testIde recorder (testingLite recorder logger plugins) $ do - doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - case lens of - Left (ResponseError {_code = InR ErrorCodes_InvalidParams, _message}) -> - liftIO $ assertBool "We caught an error, but it wasn't ours!" - (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) - _ -> liftIO $ assertFailure $ show lens - , testCase "InvalidUserState over RequestRefused" $ do - let pluginId = "invalid-user-state-order" - plugins = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId) - { pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInvalidUserState "error test" - ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginRequestRefused "error test" - ] - } - , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - - testIde recorder (testingLite recorder logger plugins) $ do - doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - case lens of - Left (ResponseError {_code = InL LSPErrorCodes_RequestFailed, _message}) -> - liftIO $ assertBool "We caught an error, but it wasn't ours!" - (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) - _ -> liftIO $ assertFailure $ show lens - ]] - -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - let projDir = "." - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session + [ pluginOrderTestCase recorder logger "InternalError over InvalidParams" PluginInternalError PluginInvalidParams + , pluginOrderTestCase recorder logger "InvalidParams over InvalidUserState" PluginInvalidParams PluginInvalidUserState + , pluginOrderTestCase recorder logger "InvalidUserState over RequestRefused" PluginInvalidUserState PluginRequestRefused + ] + ] testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments testingLite recorder logger plugins = @@ -210,3 +131,25 @@ testingLite recorder logger plugins = { IDE.argsHlsPlugins = hlsPlugins , IDE.argsIdeOptions = ideOptions } + +pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> (T.Text -> PluginError) -> (T.Text -> PluginError) -> TestTree +pluginOrderTestCase recorder logger msg err1 err2 = + testCase msg $ do + let pluginId = "error-order-test" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ err1 "error test" + ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ err2 "error test" + ] + }] + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left re | toResponseError (pluginId, err1 "error test") == re -> pure () + | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!" + _ -> liftIO $ assertFailure $ show lens diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 21d80cfb6e..445a66c5f6 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -1,129 +1,52 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} module TestUtils where import Control.Applicative.Combinators -import Control.Concurrent -import Control.Exception (bracket_, catch, finally) -import qualified Control.Lens as Lens -import qualified Control.Lens.Extras as Lens +import Control.Concurrent.Async +import Control.Exception (bracket_, finally) +import Control.Lens ((.~)) +import qualified Control.Lens as Lens +import qualified Control.Lens.Extras as Lens import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (toJSON) -import qualified Data.Aeson as A -import Data.Default +import Control.Monad.IO.Class (liftIO) import Data.Foldable -import Data.List.Extra +import Data.Function ((&)) import Data.Maybe -import Data.Proxy -import Data.Row -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Utf16.Rope (Rope) -import qualified Data.Text.Utf16.Rope as Rope -import Development.IDE.Core.PositionMapping (PositionResult (..), - fromCurrent, - positionResultToMaybe, - toCurrent) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.GHC.Util -import qualified Development.IDE.Main as IDE -import Development.IDE.Plugin.TypeLenses (typeLensCommandId) -import Development.IDE.Spans.Common -import Development.IDE.Test (Cursor, canonicalizeUri, - configureCheckProject, - diagnostic, - expectCurrentDiagnostics, - expectDiagnostics, - expectDiagnosticsWithTags, - expectNoMoreDiagnostics, - flushMessages, - getInterfaceFilesDir, - getStoredKeys, - isReferenceReady, - referenceReady, - standardizeQuotes, - waitForAction, waitForGC, - waitForTypecheck) +import qualified Development.IDE.Main as IDE +import Development.IDE.Test (canonicalizeUri, + configureCheckProject, + expectNoMoreDiagnostics) import Development.IDE.Test.Runfiles -import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import Ide.Plugin.Config -import qualified Language.LSP.Protocol.Lens as L +import Development.Shake (getDirectoryFilesIO) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), - mkRange) +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) import Language.LSP.Test -import Language.LSP.VFS (VfsLog, applyChange) -import Network.URI import System.Directory -import System.Environment.Blank (getEnv, setEnv, unsetEnv) -import System.Exit (ExitCode (ExitSuccess)) +import System.Environment.Blank (getEnv, setEnv, unsetEnv) import System.FilePath -import System.Info.Extra (isMac, isWindows) +import System.Info.Extra (isMac, isWindows) import qualified System.IO.Extra -import System.IO.Extra hiding (withTempDir) -import System.Mem (performGC) -import System.Process.Extra (CreateProcess (cwd), - createPipe, proc, - readCreateProcessWithExitCode) -import Test.QuickCheck --- import Test.QuickCheck.Instances () -import Control.Concurrent.Async -import Control.Lens (to, (.~), (^.)) -import Control.Monad.Extra (whenJust) -import Data.Function ((&)) -import Data.Functor.Identity (runIdentity) -import Data.IORef -import Data.IORef.Extra (atomicModifyIORef_) -import Data.String (IsString (fromString)) -import Data.Tuple.Extra -import Development.IDE.Core.FileStore (getModTime) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), - WaitForIdeRuleResult (..), - blockCommandId) -import qualified FuzzySearch -import GHC.Stack (emptyCallStack) -import GHC.TypeLits (symbolVal) -import qualified HieDbRetry -import Ide.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), - Pretty (pretty), - Priority (Debug), - Recorder (Recorder, logger_), - WithPriority (WithPriority, priority), - cfilter, cmapWithPrio, - makeDefaultStderrRecorder, - toCologActionWithPrio) -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types -import qualified Progress -import System.Time.Extra -import qualified Test.QuickCheck.Monadic as MonadicQuickCheck -import Test.QuickCheck.Monadic (forAllM, monadicIO) +import System.Process.Extra (createPipe) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.QuickCheck -import Text.Printf (printf) -import Text.Regex.TDFA ((=~)) + +import LogType -- | Wait for the next progress begin step waitForProgressBegin :: Session () @@ -389,3 +312,18 @@ defToLocation (InR (InR Null)) = [] thDollarIdx :: UInt thDollarIdx | ghcVersion >= GHC90 = 1 | otherwise = 0 + +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do + config <- getConfigFromEnv + cwd <- getCurrentDirectory + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + let projDir = "." + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + } + + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index fea2829144..d76e24372e 100644 --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -2,8 +2,6 @@ module UnitTests (tests) where import Control.Concurrent -import Control.Concurrent.Async -import Control.Exception (finally) import Control.Monad.IO.Class (liftIO) import Data.IORef import Data.IORef.Extra (atomicModifyIORef_) @@ -30,10 +28,8 @@ import Language.LSP.Test import LogType (Log (..)) import Network.URI import qualified Progress -import System.Directory import System.IO.Extra hiding (withTempDir) import System.Mem (performGC) -import System.Process.Extra (createPipe) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit @@ -112,19 +108,3 @@ findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do t <- getModTime f t' <- getModTime f' if t /= t' then return delay_us else findResolution_us (delay_us * 10) - - -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - let projDir = "." - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index 877dc02188..0536f27cee 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -48,8 +48,10 @@ import Language.LSP.Protocol.Types -- and then returning PluginRequestRefused should be the same as if no plugins -- passed the `pluginEnabled` stage. data PluginError - = -- |PluginInternalError should be used if something has gone horribly wrong. - -- All uncaught exceptions will be caught and converted to this error. + = -- |PluginInternalError should be used if an error has occurred. This + -- should only rarely be returned. As it's logged with Error, it will be + -- shown by the client to the user via `showWindow`. All uncaught exceptions + -- will be caught and converted to this error. -- -- This error will be be converted into an InternalError response code. It -- will be logged with Error and takes the highest precedence (1) in being From f15ea4514855cf6f1f8ac828bc10604819d11f4c Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 31 Jul 2023 17:05:43 +0300 Subject: [PATCH 27/28] Add haddocks --- hls-plugin-api/src/Ide/Plugin/Error.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index 0536f27cee..ce874b744a 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -112,6 +112,7 @@ instance Pretty PluginError where PluginInvalidUserState text -> "Invalid User State:" <+> pretty text PluginRequestRefused msg -> "Request Refused: " <+> pretty msg +-- |Converts to ErrorCode used in LSP ResponseErrors toErrorCode :: PluginError -> (LSPErrorCodes |? ErrorCodes) toErrorCode (PluginInternalError _) = InR ErrorCodes_InternalError toErrorCode (PluginInvalidParams _) = InR ErrorCodes_InvalidParams @@ -123,6 +124,9 @@ toErrorCode (PluginRequestRefused _) = InR ErrorCodes_MethodNotFound toErrorCode (PluginRuleFailed _) = InL LSPErrorCodes_RequestFailed toErrorCode PluginStaleResolve = InL LSPErrorCodes_ContentModified +-- |Converts to a logging priority. In addition to being used by the logger, +-- `combineResponses` currently uses this to choose which response to return, +-- so care should be taken in changing it. toPriority :: PluginError -> Priority toPriority (PluginInternalError _) = Error toPriority (PluginInvalidParams _) = Warning From 8329b900ce10c7fbc097e491786253c25404593d Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 31 Jul 2023 23:36:52 +0300 Subject: [PATCH 28/28] Update HLS.hs --- ghcide/src/Development/IDE/Plugin/HLS.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index f0d794d049..7ef7eeed65 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -81,18 +81,17 @@ prettyResponseError err = errorCode <> ":" <+> errorBody errorCode = pretty $ show $ err ^. L.code errorBody = pretty $ err ^. L.message -pluginNotEnabled :: SMethod m -> [PluginId] -> Text -pluginNotEnabled method availPlugins = - "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " - <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins) - noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c) noPluginEnabled recorder m fs' = do logWith recorder Warning (LogNoPluginForMethod $ Some m) let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing msg = pluginNotEnabled m fs' return $ Left err - + where pluginNotEnabled :: SMethod m -> [PluginId] -> Text + pluginNotEnabled method availPlugins = + "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " + <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins) + pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist"