hls-tactics-plugin 2.0.0.1 → 2.1.0.0
raw patch · 16 files changed
+126/−122 lines, 16 filesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utils
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
Files
- hls-tactics-plugin.cabal +4/−4
- new/src/Wingman/LanguageServer.hs +1/−1
- new/src/Wingman/Metaprogramming/Parser/Documentation.hs +2/−2
- new/src/Wingman/Metaprogramming/ProofState.hs +2/−2
- new/src/Wingman/Plugin.hs +2/−2
- old/src/Wingman/AbstractLSP.hs +34/−37
- old/src/Wingman/AbstractLSP/TacticActions.hs +3/−1
- old/src/Wingman/AbstractLSP/Types.hs +7/−5
- old/src/Wingman/EmptyCase.hs +6/−4
- old/src/Wingman/LanguageServer.hs +20/−20
- old/src/Wingman/LanguageServer/Metaprogram.hs +18/−18
- old/src/Wingman/LanguageServer/TacticProviders.hs +2/−2
- old/src/Wingman/Metaprogramming/Parser/Documentation.hs +2/−2
- old/src/Wingman/Metaprogramming/ProofState.hs +3/−3
- old/src/Wingman/Plugin.hs +4/−4
- old/test/Utils.hs +16/−15
hls-tactics-plugin.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 category: Development name: hls-tactics-plugin-version: 2.0.0.1+version: 2.1.0.0 synopsis: Wingman plugin for Haskell Language Server description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -99,9 +99,9 @@ , ghc-boot-th , ghc-exactprint , ghc-source-gen ^>=0.4.1- , ghcide == 2.0.0.1+ , ghcide == 2.1.0.0 , hls-graph- , hls-plugin-api == 2.0.0.1+ , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin , hyphenation , lens@@ -185,7 +185,7 @@ , ghcide , hls-plugin-api , hls-tactics-plugin- , hls-test-utils == 2.0.0.1+ , hls-test-utils == 2.1.0.0 , hspec , hspec-expectations , lens
new/src/Wingman/LanguageServer.hs view
@@ -64,7 +64,7 @@ import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types-import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty))+import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) import qualified Development.IDE.Core.Shake as Shake
new/src/Wingman/Metaprogramming/Parser/Documentation.hs view
@@ -7,8 +7,8 @@ import Data.List (sortOn) import Data.String (IsString) import Data.Text (Text)-import Data.Text.Prettyprint.Doc hiding (parens)-import Data.Text.Prettyprint.Doc.Render.String (renderString)+import Prettyprinter hiding (parens)+import Prettyprinter.Render.String (renderString) import Development.IDE.GHC.Compat (OccName) import qualified Text.Megaparsec as P import Wingman.Metaprogramming.Lexer (Parser, identifier, variable, parens)
new/src/Wingman/Metaprogramming/ProofState.hs view
@@ -8,8 +8,8 @@ import Data.Bool (bool) import Data.Functor ((<&>)) import qualified Data.Text as T-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Util.Panic+import Prettyprinter+import Prettyprinter.Render.Util.Panic import Language.LSP.Types (sectionSeparator) import Wingman.Judgements (jHypothesis) import Wingman.Types
new/src/Wingman/Plugin.hs view
@@ -15,10 +15,10 @@ import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin-import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty))+import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) data Log- = LogWingmanLanguageServer WingmanLanguageServer.Log + = LogWingmanLanguageServer WingmanLanguageServer.Log | LogExactPrint E.Log deriving Show
old/src/Wingman/AbstractLSP.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE RecordWildCards #-}-+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# OPTIONS_GHC -Wno-orphans #-}@@ -10,7 +10,8 @@ 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.Except (ExceptT(ExceptT))+import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT, runMaybeT) import qualified Data.Aeson as A import Data.Coerce import Data.Foldable (traverse_)@@ -21,16 +22,20 @@ 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)-import qualified Language.LSP.Types as LSP-import Language.LSP.Types hiding (CodeLens, CodeAction)+import Language.LSP.Server (LspM, sendRequest, getClientCapabilities, getVersionedTextDoc)+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Protocol.Types hiding (CodeLens, CodeAction) import Wingman.AbstractLSP.Types import Wingman.EmptyCase (fromMaybeT) import Wingman.LanguageServer (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams) import Wingman.StaticPlugin (enableQuasiQuotes) import Wingman.Types+import Control.Lens ((^.)) ------------------------------------------------------------------------------@@ -59,9 +64,9 @@ flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) -> case c_makeCommand c of SynthesizeCodeAction k ->- mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k+ mkPluginHandler SMethod_TextDocumentCodeAction $ codeActionProvider @target (c_sort c) k SynthesizeCodeLens k ->- mkPluginHandler STextDocumentCodeLens $ codeLensProvider @target (c_sort c) k+ mkPluginHandler SMethod_TextDocumentCodeLens $ codeLensProvider @target (c_sort c) k ------------------------------------------------------------------------------@@ -86,21 +91,17 @@ => PluginId -> Continuation sort a b -> CommandFunction IdeState (FileContext, b)-runContinuation plId cont state (fc, b) = do+runContinuation plId cont state (fc, b) = ExceptT $ do fromMaybeT- (Left $ ResponseError- { _code = InternalError- , _message = T.pack "TODO(sandy)"- , _xdata = Nothing- } ) $ do+ (Left $ PluginInternalError "TODO(sandy)") $ do env@LspEnv{..} <- buildEnv state plId fc- nfp <- getNfp $ fc_uri le_fileContext+ nfp <- getNfp $ fc_verTxtDocId le_fileContext ^. L.uri let stale a = runStaleIde "runContinuation" state nfp a args <- fetchTargetArgs @a env res <- c_runCommand cont env args fc b -- This block returns a maybe error.- fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $+ fmap (maybe (Right $ InR Null) Left . coerce . foldMap Last) $ for res $ \case ErrorMessages errs -> do traverse_ showUserFacingMessage errs@@ -111,13 +112,9 @@ GraftEdit gr -> do ccs <- lift getClientCapabilities TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource- case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of+ case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_verTxtDocId le_fileContext) (unTrack pm) gr of Left errs ->- pure $ Just $ ResponseError- { _code = InternalError- , _message = T.pack $ show errs- , _xdata = Nothing- }+ pure $ Just $ PluginInternalError (T.pack $ show errs) Right edits -> do sendEdits edits pure Nothing@@ -129,7 +126,7 @@ sendEdits edits = void $ lift $ sendRequest- SWorkspaceApplyEdit+ SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (const $ pure ()) @@ -153,7 +150,7 @@ -> MaybeT (LspM Plugin.Config) LspEnv buildEnv state plId fc = do cfg <- liftIO $ runIde "plugin" "config" state $ getTacticConfigAction plId- nfp <- getNfp $ fc_uri fc+ nfp <- getNfp $ fc_verTxtDocId fc ^. L.uri dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp pure $ LspEnv { le_ideState = state@@ -174,20 +171,20 @@ -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Metadata, b)] )- -> PluginMethodHandler IdeState TextDocumentCodeAction+ -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider sort k state plId- (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do- fromMaybeT (Right $ List []) $ do+ (CodeActionParams _ _ docId range _) = do+ verTxtDocId <- lift $ getVersionedTextDoc docId+ handleMaybeM (PluginInvalidUserState "codeActionProvider") $ runMaybeT $ do let fc = FileContext- { fc_uri = uri+ { fc_verTxtDocId = verTxtDocId , fc_range = Just $ unsafeMkCurrent range } env <- buildEnv state plId fc args <- fetchTargetArgs @target env actions <- k env args pure- $ Right- $ List+ $ InL $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions @@ -201,20 +198,20 @@ -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] )- -> PluginMethodHandler IdeState TextDocumentCodeLens+ -> PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider sort k state plId- (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do- fromMaybeT (Right $ List []) $ do+ (CodeLensParams _ _ docId) = do+ verTxtDocId <- lift $ getVersionedTextDoc docId+ handleMaybeM (PluginInvalidUserState "codeLensProvider") $ runMaybeT $ do let fc = FileContext- { fc_uri = uri+ { fc_verTxtDocId = verTxtDocId , fc_range = Nothing } env <- buildEnv state plId fc args <- fetchTargetArgs @target env actions <- k env args pure- $ Right- $ List+ $ InL $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions @@ -239,7 +236,7 @@ , _disabled = Nothing , _edit = Nothing , _command = Just cmd- , _xdata = Nothing+ , _data_ = Nothing } @@ -261,6 +258,6 @@ in LSP.CodeLens { _range = range , _command = Just cmd- , _xdata = Nothing+ , _data_ = Nothing }
old/src/Wingman/AbstractLSP/TacticActions.hs view
@@ -4,6 +4,7 @@ module Wingman.AbstractLSP.TacticActions where +import Control.Lens ((^.)) import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans (lift)@@ -16,6 +17,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Generics.SYB.GHC (mkBindListT, everywhereM')+import qualified Language.LSP.Protocol.Lens as L import Wingman.AbstractLSP.Types import Wingman.CaseSplit import Wingman.GHC (liftMaybe, isHole, pattern AMatch)@@ -45,7 +47,7 @@ } ) $ \LspEnv{..} HoleJudgment{..} FileContext{..} var_name -> do- nfp <- getNfp fc_uri+ nfp <- getNfp (fc_verTxtDocId ^. L.uri) let stale a = runStaleIde "tacticCmd" le_ideState nfp a let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) hj_range
old/src/Wingman/AbstractLSP/Types.hs view
@@ -9,6 +9,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT (MaybeT), mapMaybeT)+import Control.Lens ((^.)) import qualified Data.Aeson as A import Data.Text (Text) import Development.IDE (IdeState)@@ -19,7 +20,8 @@ import qualified Ide.Plugin.Config as Plugin import Ide.Types hiding (Config) import Language.LSP.Server (LspM)-import Language.LSP.Types hiding (CodeLens, CodeAction)+import Language.LSP.Protocol.Types hiding (CodeLens, CodeAction)+import qualified Language.LSP.Protocol.Lens as L import Wingman.LanguageServer (judgementForHole) import Wingman.Types @@ -120,12 +122,12 @@ ------------------------------------------------------------------------------ -- | What file are we looking at, and what bit of it? data FileContext = FileContext- { fc_uri :: Uri- , fc_range :: Maybe (Tracked 'Current Range)+ { fc_verTxtDocId :: VersionedTextDocumentIdentifier+ , fc_range :: Maybe (Tracked 'Current Range) -- ^ For code actions, this is 'Just'. For code lenses, you'll get -- a 'Nothing' in the request, and a 'Just' in the response. }- deriving stock (Eq, Ord, Show, Generic)+ deriving stock (Eq, Show, Generic) deriving anyclass (A.ToJSON, A.FromJSON) @@ -164,6 +166,6 @@ fetchTargetArgs LspEnv{..} = do let FileContext{..} = le_fileContext range <- MaybeT $ pure fc_range- nfp <- getNfp fc_uri+ nfp <- getNfp (fc_verTxtDocId ^. L.uri) mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config
old/src/Wingman/EmptyCase.hs view
@@ -7,6 +7,7 @@ module Wingman.EmptyCase where import Control.Applicative (empty)+import Control.Lens import Control.Monad import Control.Monad.Except (runExcept) import Control.Monad.Trans@@ -26,7 +27,8 @@ import Development.IDE.Spans.LocalBindings (getLocalScope) import Ide.Types import Language.LSP.Server-import Language.LSP.Types+import Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Types import Prelude hiding (span) import Wingman.AbstractLSP.Types import Wingman.CodeGen (destructionFor)@@ -50,7 +52,7 @@ Continuation @EmptyCaseT @EmptyCaseT @WorkspaceEdit EmptyCaseT (SynthesizeCodeLens $ \LspEnv{..} _ -> do let FileContext{..} = le_fileContext- nfp <- getNfp fc_uri+ nfp <- getNfp (fc_verTxtDocId ^. L.uri) let stale a = runStaleIde "codeLensProvider" le_ideState nfp a @@ -69,14 +71,14 @@ (foldMap (hySingleton . occName . fst) bindings) ty edits <- liftMaybe $ hush $- mkWorkspaceEdits le_dflags ccs fc_uri (unTrack pm) $+ mkWorkspaceEdits le_dflags ccs fc_verTxtDocId (unTrack pm) $ graftMatchGroup (RealSrcSpan (unTrack ss) Nothing) $ noLoc matches pure ( range , Metadata (mkEmptyCaseLensDesc ty)- (CodeActionUnknown "refactor.wingman.completeEmptyCase")+ (CodeActionKind_Custom "refactor.wingman.completeEmptyCase") False , edits )
old/src/Wingman/LanguageServer.hs view
@@ -47,11 +47,9 @@ import Ide.Types (PluginId) import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty) import Language.LSP.Server (MonadLsp, sendNotification)-import Language.LSP.Types hiding- (SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length),- SemanticTokensEdit (_start))-import Language.LSP.Types.Capabilities+import Language.LSP.Protocol.Types hiding+ (SemanticTokensEdit (_start))+import Language.LSP.Protocol.Message import Prelude hiding (span) import Retrie (transformA) import Wingman.Context@@ -62,7 +60,7 @@ import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types-import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty))+import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) import qualified Development.IDE.Core.Shake as Shake @@ -172,10 +170,10 @@ "Maximum number of `Use constructor <x>` code actions that can appear" 5 & defineEnumProperty #hole_severity "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities."- [ (Just DsError, "error")- , (Just DsWarning, "warning")- , (Just DsInfo, "info")- , (Just DsHint, "hint")+ [ (Just DiagnosticSeverity_Error, "error")+ , (Just DiagnosticSeverity_Warning, "warning")+ , (Just DiagnosticSeverity_Information, "info")+ , (Just DiagnosticSeverity_Hint, "hint") , (Nothing, "none") ] Nothing@@ -521,11 +519,11 @@ ufmSeverity :: UserFacingMessage -> MessageType-ufmSeverity NotEnoughGas = MtInfo-ufmSeverity TacticErrors = MtError-ufmSeverity TimedOut = MtInfo-ufmSeverity NothingToDo = MtInfo-ufmSeverity (InfrastructureError _) = MtError+ufmSeverity NotEnoughGas = MessageType_Info+ufmSeverity TacticErrors = MessageType_Error+ufmSeverity TimedOut = MessageType_Info+ufmSeverity NothingToDo = MessageType_Info+ufmSeverity (InfrastructureError _) = MessageType_Error mkShowMessageParams :: UserFacingMessage -> ShowMessageParams@@ -533,7 +531,7 @@ showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m ()-showLspMessage = sendNotification SWindowShowMessage+showLspMessage = sendNotification SMethod_WindowShowMessage -- This rule only exists for generating file diagnostics@@ -610,10 +608,12 @@ Diagnostic r (Just severity) (Just $ InR "hole")+ Nothing (Just "wingman") "Hole"- (Just $ List [DtUnnecessary])+ (Just [DiagnosticTag_Unnecessary]) Nothing+ Nothing ------------------------------------------------------------------------------@@ -621,13 +621,13 @@ mkWorkspaceEdits :: DynFlags -> ClientCapabilities- -> Uri+ -> VersionedTextDocumentIdentifier -> Annotated ParsedSource -> Graft (Either String) ParsedSource -> Either UserFacingMessage WorkspaceEdit-mkWorkspaceEdits dflags ccs uri pm g = do+mkWorkspaceEdits dflags ccs verTxtDocId pm g = do let pm' = runIdentity $ transformA pm annotateMetaprograms- let response = transform dflags ccs uri g pm'+ let response = transform dflags ccs verTxtDocId g pm' in first (InfrastructureError . T.pack) response
old/src/Wingman/LanguageServer/Metaprogram.hs view
@@ -20,7 +20,8 @@ import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (empty) import Ide.Types-import Language.LSP.Types+import Language.LSP.Protocol.Types+import Language.LSP.Protocol.Message import Prelude hiding (span) import Wingman.LanguageServer import Wingman.Metaprogramming.Parser (attempt_it)@@ -29,31 +30,30 @@ ------------------------------------------------------------------------------ -- | Provide the "empty case completion" code lens-hoverProvider :: PluginMethodHandler IdeState TextDocumentHover+hoverProvider :: PluginMethodHandler IdeState Method_TextDocumentHover hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos stale = unsafeRunStaleIdeFast "hoverProvider" state nfp cfg <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId)- 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 = HoverContents- $ MarkupContent MkMarkdown- $ either T.pack T.pack z- , _range = Just $ unTrack tr_range- }- Nothing -> empty-hoverProvider _ _ _ = pure $ Right Nothing+ 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
old/src/Wingman/LanguageServer/TacticProviders.hs view
@@ -17,7 +17,7 @@ import qualified Data.Text as T import Development.IDE.GHC.Compat import Ide.Types hiding (Config)-import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..))+import Language.LSP.Protocol.Types import Prelude hiding (span) import Wingman.AbstractLSP.Types import Wingman.Auto@@ -86,7 +86,7 @@ mkTacticKind :: TacticCommand -> CodeActionKind mkTacticKind =- CodeActionUnknown . mappend "refactor.wingman." . tacticKind+ CodeActionKind_Custom . mappend "refactor.wingman." . tacticKind ------------------------------------------------------------------------------
old/src/Wingman/Metaprogramming/Parser/Documentation.hs view
@@ -7,8 +7,8 @@ import Data.List (sortOn) import Data.String (IsString) import Data.Text (Text)-import Data.Text.Prettyprint.Doc hiding (parens)-import Data.Text.Prettyprint.Doc.Render.String (renderString)+import Prettyprinter hiding (parens)+import Prettyprinter.Render.String (renderString) import Development.IDE.GHC.Compat (OccName) import qualified Text.Megaparsec as P import Wingman.Metaprogramming.Lexer (Parser, identifier, variable, parens)
old/src/Wingman/Metaprogramming/ProofState.hs view
@@ -8,9 +8,9 @@ import Data.Bool (bool) import Data.Functor ((<&>)) import qualified Data.Text as T-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Util.Panic-import Language.LSP.Types (sectionSeparator)+import Prettyprinter+import Prettyprinter.Render.Util.Panic+import Language.LSP.Protocol.Types (sectionSeparator) import Wingman.Judgements (jHypothesis) import Wingman.Types
old/src/Wingman/Plugin.hs view
@@ -6,7 +6,7 @@ import Development.IDE.Plugin.CodeAction import qualified Development.IDE.GHC.ExactPrint as E import Ide.Types-import Language.LSP.Types+import Language.LSP.Protocol.Message import Prelude hiding (span) import Wingman.AbstractLSP import Wingman.AbstractLSP.TacticActions (makeTacticInteraction)@@ -15,10 +15,10 @@ import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin-import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty))+import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) data Log- = LogWingmanLanguageServer WingmanLanguageServer.Log + = LogWingmanLanguageServer WingmanLanguageServer.Log | LogExactPrint E.Log deriving Show @@ -35,7 +35,7 @@ : fmap makeTacticInteraction [minBound .. maxBound] ) $ (defaultPluginDescriptor plId)- { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider+ { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hoverProvider , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId , pluginConfigDescriptor = defaultConfigDescriptor
old/test/Utils.hs view
@@ -23,9 +23,9 @@ import qualified Data.Text.IO as T import Ide.Plugin.Tactic as Tactic import Ide.Types (IdePlugins(..))-import Language.LSP.Types-import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title)-import qualified Language.LSP.Types.Lens as J+import Language.LSP.Protocol.Types+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title, error) import System.Directory (doesFileExist) import System.FilePath import Test.Hls@@ -87,19 +87,20 @@ -> 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@@ -118,7 +119,7 @@ case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do executeCommand c- void $ skipManyTill anyMessage $ message SWorkspaceApplyEdit+ void $ skipManyTill anyMessage $ message SMethod_WorkspaceApplyEdit _ -> error $ show actions @@ -154,7 +155,7 @@ lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc for_ lenses $ \(CodeLens _ (Just cmd) _) -> executeCommand cmd- _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)+ _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) edited <- documentContents doc let expected_name = input <.> "expected" <.> "hs" -- Write golden tests if they don't already exist@@ -204,7 +205,7 @@ Just (InR CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions executeCommand c- NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage)+ TNotificationMessage _ _ err <- skipManyTill anyMessage (message SMethod_WindowShowMessage) liftIO $ err `shouldBe` mkShowMessageParams ufm @@ -258,9 +259,9 @@ tacticPath = "old/test/golden" -executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteCommand)+executeCommandWithResp :: Command -> Session (TResponseMessage 'Method_WorkspaceExecuteCommand) executeCommandWithResp cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams Nothing (cmd ^. command) args- request SWorkspaceExecuteCommand execParams+ request SMethod_WorkspaceExecuteCommand execParams