diff --git a/hls-class-plugin.cabal b/hls-class-plugin.cabal --- a/hls-class-plugin.cabal +++ b/hls-class-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-class-plugin -version: 2.0.0.1 +version: 2.1.0.0 synopsis: Class/instance management plugin for Haskell Language Server @@ -39,12 +39,13 @@ , deepseq , extra , ghc - , ghcide == 2.0.0.1 + , ghcide == 2.1.0.0 , ghc-boot-th , hls-graph - , hls-plugin-api == 2.0.0.1 + , hls-plugin-api == 2.1.0.0 , lens , lsp + , mtl , text , transformers @@ -74,7 +75,8 @@ , ghcide , hls-class-plugin , hls-plugin-api - , hls-test-utils == 2.0.0.1 + , hls-test-utils == 2.1.0.0 , lens , lsp-types + , row-types , text diff --git a/src/Ide/Plugin/Class.hs b/src/Ide/Plugin/Class.hs --- a/src/Ide/Plugin/Class.hs +++ b/src/Ide/Plugin/Class.hs @@ -1,18 +1,18 @@ module Ide.Plugin.Class (descriptor, Log(..)) where -import Development.IDE (IdeState, Recorder, WithPriority) +import Development.IDE (IdeState, Recorder, + WithPriority) import Ide.Plugin.Class.CodeAction import Ide.Plugin.Class.CodeLens import Ide.Plugin.Class.Types import Ide.Types -import Language.LSP.Types - +import Language.LSP.Protocol.Message descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginCommands = commands plId , pluginRules = rules recorder - , pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeAction recorder) - <> mkPluginHandler STextDocumentCodeLens codeLens + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder) + <> mkPluginHandler SMethod_TextDocumentCodeLens codeLens } commands :: PluginId -> [PluginCommand IdeState] diff --git a/src/Ide/Plugin/Class/CodeAction.hs b/src/Ide/Plugin/Class/CodeAction.hs --- a/src/Ide/Plugin/Class/CodeAction.hs +++ b/src/Ide/Plugin/Class/CodeAction.hs @@ -5,14 +5,14 @@ module Ide.Plugin.Class.CodeAction where -import Control.Applicative (liftA2) import Control.Lens hiding (List, use) +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, throwE) +import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe -import Data.Aeson +import Data.Aeson hiding (Null) import Data.Bifunctor (second) import Data.Either.Extra (rights) import Data.List @@ -23,94 +23,89 @@ import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.Compile (sourceTypecheck) +import Development.IDE.Core.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 import qualified Ide.Plugin.Config +import Ide.Plugin.Error import Ide.PluginUtils 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 -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as J addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do - caps <- getClientCapabilities - pluginResponse $ do - nfp <- getNormalizedFilePath 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" - $ 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 + 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 SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - pure Null + pure $ InR Null where toTextDocumentEdit edit = - TextDocumentEdit (VersionedTextDocumentIdentifier uri (Just 0)) (List [InL edit]) + TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) [InL edit] mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit { _documentChanges = - (\(List x) -> List $ x ++ map (InL . toTextDocumentEdit) edits) + (\x -> x ++ map (InL . toTextDocumentEdit) edits) <$> _documentChanges , .. } workspaceEdit caps old new - = diffText caps (uri, old) new IncludeDeletions + = diffText caps (verTxtDocId, old) new IncludeDeletions -- | -- 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 - nfp <- getNormalizedFilePath uri - actions <- join <$> mapM (mkActions nfp) methodDiags - pure $ List actions +codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do + verTxtDocId <- lift $ getVersionedTextDoc docId + nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags + pure $ InL actions where - uri = docId ^. J.uri - List diags = context ^. J.diagnostics + diags = context ^. L.diagnostics - ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags - methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags + ghcDiags = filter (\d -> d ^. L.source == Just sourceTypecheck) diags + methodDiags = filter (\d -> isClassMethodWarning (d ^. L.message)) ghcDiags mkActions :: NormalizedFilePath + -> VersionedTextDocumentIdentifier -> Diagnostic - -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] - mkActions docPath diag = do - (HAR {hieAst = ast}, pmap) <- handleMaybeM "Unable to GetHieAst" - . liftIO - . runAction "classplugin.findClassIdentifier.GetHieAst" state - $ useWithStale GetHieAst docPath - instancePosition <- handleMaybe "No range" $ - fromCurrentRange pmap range ^? _Just . J.start - & fmap (J.character -~ 1) + -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] + mkActions docPath verTxtDocId diag = do + (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state + $ useWithStaleE GetHieAst docPath + instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $ + fromCurrentRange pmap range ^? _Just . L.start + & fmap (L.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 <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state + $ useE GetInstanceBindTypeSigs docPath implemented <- findImplementedMethods ast instancePosition logWith recorder Info (LogImplementedMethods cls implemented) pure @@ -120,7 +115,7 @@ $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented))) $ mkMethodGroups range sigs cls where - range = diag ^. J.range + range = diag ^. L.range mkMethodGroups :: Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup] mkMethodGroups range sigs cls = minimalDef <> [allClassMethods] @@ -141,15 +136,16 @@ title = "Add placeholders for " <> name titleWithSig = title <> " with signature(s)" + mkCmdParams :: [(T.Text, T.Text)] -> Bool -> [Value] mkCmdParams methodGroup withSig = - [toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)] + [toJSON (AddMinimalMethodsParams verTxtDocId range methodGroup withSig)] mkCodeAction title cmd = InR $ CodeAction title - (Just CodeActionQuickFix) - (Just (List [])) + (Just CodeActionKind_QuickFix) + (Just []) Nothing Nothing Nothing @@ -157,7 +153,7 @@ Nothing findClassIdentifier hf instancePosition = - handleMaybe "No Identifier found" + handleMaybe (PluginInternalError "No Identifier found") $ listToMaybe $ mapMaybe listToMaybe $ pointCommand hf instancePosition @@ -168,7 +164,7 @@ findImplementedMethods :: HieASTs a -> Position - -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [T.Text] + -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [T.Text] findImplementedMethods asts instancePosition = do pure $ concat @@ -185,15 +181,11 @@ 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, _) <- 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 @@ -202,7 +194,7 @@ 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 _) = throwError (PluginInternalError "Ide.Plugin.Class.findClassIdentifier") isClassNodeIdentifier :: IdentifierDetails a -> Bool isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` identInfo ident diff --git a/src/Ide/Plugin/Class/CodeLens.hs b/src/Ide/Plugin/Class/CodeLens.hs --- a/src/Ide/Plugin/Class/CodeLens.hs +++ b/src/Ide/Plugin/Class/CodeLens.hs @@ -6,41 +6,38 @@ module Ide.Plugin.Class.CodeLens where import Control.Lens ((^.)) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Aeson hiding (Null) import Data.Maybe (mapMaybe, maybeToList) import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.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.Plugin.Error import Ide.PluginUtils 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 (sendRequest) -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 :: PluginMethodHandler IdeState Method_TextDocumentCodeLens +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 -- this means the lenses don't 'flicker' - $ useWithStale TypeCheck nfp + $ useWithStaleE TypeCheck nfp -- All instance binds - (InstanceBindTypeSigsResult allBinds, mp) <- - handleMaybeM "Unable to get InstanceBindTypeSigsResult" - $ liftIO - $ 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' - $ useWithStale GetInstanceBindTypeSigs nfp + $ useWithStaleE GetInstanceBindTypeSigs nfp pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs @@ -60,9 +57,9 @@ $ makeEdit range title mp codeLens = makeLens <$> mapMaybe getRangeWithSig targetSigs - pure $ List codeLens + pure $ InL codeLens where - uri = _textDocument ^. J.uri + uri = _textDocument ^. L.uri -- Match Binds with their signatures -- We try to give every `InstanceBindTypeSig` a `SrcSpan`, @@ -121,7 +118,7 @@ workspaceEdit pragmaInsertion edits = WorkspaceEdit - (pure [(uri, List $ edits ++ pragmaInsertion)]) + (pure [(uri, edits ++ pragmaInsertion)]) Nothing Nothing @@ -132,8 +129,8 @@ makeEdit :: Range -> T.Text -> PositionMapping -> [TextEdit] makeEdit range bind mp = - let startPos = range ^. J.start - insertChar = startPos ^. J.character + let startPos = range ^. L.start + insertChar = startPos ^. L.character insertRange = Range startPos startPos in case toCurrentRange mp insertRange of Just rg -> [TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")] @@ -141,5 +138,5 @@ codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit codeLensCommandHandler _ wedit = do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + pure $ InR Null diff --git a/src/Ide/Plugin/Class/ExactPrint.hs b/src/Ide/Plugin/Class/ExactPrint.hs --- a/src/Ide/Plugin/Class/ExactPrint.hs +++ b/src/Ide/Plugin/Class/ExactPrint.hs @@ -12,7 +12,6 @@ import Ide.Plugin.Class.Utils import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers -import Language.LSP.Types #if MIN_VERSION_ghc(9,2,0) import Data.Either.Extra (eitherToMaybe) @@ -22,13 +21,14 @@ import qualified Data.Map.Strict as Map import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) import Language.Haskell.GHC.ExactPrint.Utils (rs) +import Language.LSP.Protocol.Types (Range) #endif makeEditText :: Monad m => ParsedModule -> DynFlags -> AddMinimalMethodsParams -> MaybeT m (T.Text, T.Text) -- addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located HsModule) #if MIN_VERSION_ghc(9,2,0) makeEditText pm df AddMinimalMethodsParams{..} = do - List mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup let ps = makeDeltaAst $ pm_parsed_source pm old = T.pack $ exactPrint ps (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig) @@ -76,7 +76,7 @@ #else makeEditText pm df AddMinimalMethodsParams{..} = do - List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup let ps = pm_parsed_source pm anns = relativiseApiAnns ps (pm_annotations pm) old = T.pack $ exactPrint ps anns diff --git a/src/Ide/Plugin/Class/Types.hs b/src/Ide/Plugin/Class/Types.hs --- a/src/Ide/Plugin/Class/Types.hs +++ b/src/Ide/Plugin/Class/Types.hs @@ -4,7 +4,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE BangPatterns #-} module Ide.Plugin.Class.Types where @@ -21,6 +20,7 @@ import GHC.Generics import Ide.Plugin.Class.Utils import Ide.Types +import Language.LSP.Protocol.Types (VersionedTextDocumentIdentifier) typeLensCommandId :: CommandId typeLensCommandId = "classplugin.typelens" @@ -33,9 +33,9 @@ defaultIndent = 2 data AddMinimalMethodsParams = AddMinimalMethodsParams - { uri :: Uri + { verTxtDocId :: VersionedTextDocumentIdentifier , range :: Range - , methodGroup :: List (T.Text, T.Text) + , methodGroup :: [(T.Text, T.Text)] -- ^ (name text, signature text) , withSig :: Bool } diff --git a/src/Ide/Plugin/Class/Utils.hs b/src/Ide/Plugin/Class/Utils.hs --- a/src/Ide/Plugin/Class/Utils.hs +++ b/src/Ide/Plugin/Class/Utils.hs @@ -2,19 +2,21 @@ 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 Development.IDE.Core.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.Plugin.Error import Ide.PluginUtils -import Language.LSP.Types +import Language.LSP.Protocol.Types -- | All instance bindings are started with `$c` bindingPrefix :: IsString s => s @@ -54,19 +56,14 @@ => IdeState -> NormalizedFilePath -> Extension - -> ExceptT String m [TextEdit] + -> ExceptT PluginError 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, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GhcSession" state + $ useWithStaleE GhcSession nfp + (_, fileContents) <- liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state $ getFileContents nfp - (pm, _) <- handleMaybeM "Unable to GetParsedModuleWithComments" - $ liftIO - $ runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state - $ 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/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -9,12 +10,16 @@ ( main ) where -import Control.Lens (Prism', prism', (^.), (^..), (^?)) -import Control.Monad (void) +import Control.Lens (Prism', prism', (^.), (^..), + (^?)) +import Control.Monad (void) import Data.Maybe -import qualified Data.Text as T -import qualified Ide.Plugin.Class as Class -import qualified Language.LSP.Types.Lens as J +import Data.Row ((.==)) +import qualified Data.Text as T +import Development.IDE.Core.Compile (sourceTypecheck) +import qualified Ide.Plugin.Class as Class +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message import System.FilePath import Test.Hls @@ -76,6 +81,28 @@ [ "Add placeholders for 'f','g'" , "Add placeholders for 'f','g' with signature(s)" ] + , testCase "Update text document version" $ runSessionWithServer classPlugin testDataDir $ do + doc <- createDoc "Version.hs" "haskell" "module Version where" + ver1 <- (^. L.version) <$> getVersionedDoc doc + liftIO $ ver1 @?= 0 + + -- Change the doc to ensure the version is not 0 + changeDoc doc + [ TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module Version where", "data A a = A a", "instance Functor A where"] + ] + ver2 <- (^. L.version) <$> getVersionedDoc doc + _ <- waitForDiagnostics + liftIO $ ver2 @?= 1 + + -- Execute the action and see what the version is + action <- head . concatMap (^.. _CACodeAction) <$> getAllCodeActions doc + executeCodeAction action + _ <- waitForDiagnostics + -- TODO: uncomment this after lsp-test fixed + -- ver3 <- (^.J.version) <$> getVersionedDoc doc + -- liftIO $ ver3 @?= Just 3 + pure mempty ] codeLensTests :: TestTree @@ -85,7 +112,7 @@ runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "CodeLensSimple.hs" "haskell" lens <- getCodeLenses doc - let titles = map (^. J.title) $ mapMaybe (^. J.command) lens + let titles = map (^. L.title) $ mapMaybe (^. L.command) lens liftIO $ titles @?= [ "(==) :: B -> B -> Bool" , "(==) :: A -> A -> Bool" @@ -122,13 +149,13 @@ goldenCodeLens title path idx = goldenWithHaskellDoc classPlugin title testDataDir path "expected" "hs" $ \doc -> do lens <- getCodeLenses doc - executeCommand $ fromJust $ (lens !! idx) ^. J.command - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + executeCommand $ fromJust $ (lens !! idx) ^. L.command + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree goldenWithClass title path desc act = goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do - _ <- waitForDiagnosticsFromSource doc "typecheck" + _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc act actions void $ skipManyTill anyMessage (getDocumentEdit doc) @@ -138,9 +165,9 @@ testCase title $ do runSessionWithServer classPlugin testDataDir $ do doc <- openDoc (path <.> "hs") "haskell" - _ <- waitForDiagnosticsFromSource doc "typecheck" + _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) caResults <- getAllCodeActions doc - liftIO $ map (^? _CACodeAction . J.title) caResults + liftIO $ map (^? _CACodeAction . L.title) caResults @?= expectedActions where expectedActions = Just <$> actionTitles