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: 1.1.0.0 +version: 1.1.1.0 synopsis: Class/instance management plugin for Haskell Language Server @@ -20,11 +20,11 @@ LICENSE test/testdata/*.hs +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server.git + library - if impl(ghc >= 9.3) - buildable: False - else - buildable: True exposed-modules: Ide.Plugin.Class other-modules: Ide.Plugin.Class.CodeAction , Ide.Plugin.Class.CodeLens @@ -39,19 +39,19 @@ , deepseq , extra , ghc - , ghcide ^>=1.8 + , ghcide ^>=1.9 , ghc-boot-th , hls-graph - , hls-plugin-api ^>=1.5 + , hls-plugin-api ^>=1.6 , lens , lsp , text , transformers if impl(ghc >=9.2.1) - build-depends: ghc-exactprint ^>= 1.5 + build-depends: ghc-exactprint >= 1.5 else - build-depends: ghc-exactprint >= 0.6.4 && <1.1 + build-depends: ghc-exactprint >= 0.6.4 && <1.1 default-language: Haskell2010 default-extensions: @@ -62,10 +62,6 @@ ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-name-shadowing test-suite tests - if impl(ghc >= 9.3) - buildable: False - else - buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test @@ -78,6 +74,6 @@ , ghcide , hls-class-plugin , hls-plugin-api - , hls-test-utils ^>=1.4 + , hls-test-utils ^>=1.5 , lens , lsp-types 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 @@ -62,13 +62,13 @@ pure Null where - toTextDocunemtEdit edit = + toTextDocumentEdit edit = TextDocumentEdit (VersionedTextDocumentIdentifier uri (Just 0)) (List [InL edit]) mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit { _documentChanges = - (\(List x) -> List $ x ++ map (InL . toTextDocunemtEdit) edits) + (\(List x) -> List $ x ++ map (InL . toTextDocumentEdit) edits) <$> _documentChanges , .. } @@ -190,7 +190,7 @@ . liftIO . runAction "classplugin.findClassFromIdentifier.TypeCheck" state $ useWithStale TypeCheck docPath - handleMaybeM "Error in TcEnv" + handleMaybeM "TcEnv" . liftIO . fmap snd . initTcWithGbl hscenv thisMod ghostSpan $ do 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,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} module Ide.Plugin.Class.Types where @@ -45,7 +46,7 @@ data InstanceBindTypeSig = InstanceBindTypeSig { bindName :: Name - , bindRendered :: T.Text + , bindRendered :: !T.Text , bindDefSpan :: Maybe SrcSpan -- ^SrcSpan for the bind definition } @@ -68,7 +69,7 @@ instance Pretty Log where pretty = \case LogImplementedMethods cls methods -> - pretty ("Detected implmented methods for class" :: String) + pretty ("Detected implemented methods for class" :: String) <+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name <+> pretty methods LogShake log -> pretty log 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 @@ -13,7 +13,6 @@ import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.Pragmas (getNextPragmaInfo, insertNewPragma) -import GHC.LanguageExtensions.Type (Extension) import Ide.PluginUtils import Language.LSP.Types @@ -64,6 +63,6 @@ $ liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state $ use GetParsedModuleWithComments nfp - let exts = (toList . extensionFlags . ms_hspp_opts . pm_mod_summary) pm + 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 @@ -9,38 +9,30 @@ ( main ) where -import Control.Lens (Prism', prism', (^.), (^..), - (^?)) -import Control.Monad (void) -import Data.Aeson (toJSON, (.=)) -import Data.Functor.Contravariant (contramap) +import Control.Lens (Prism', prism', (^.), (^..), (^?)) +import Control.Monad (void) import Data.Maybe -import Development.IDE.Types.Logger -import qualified Ide.Plugin.Class as Class -import Ide.Plugin.Config (PluginConfig (plcConfig)) -import qualified Ide.Plugin.Config as Plugin -import qualified Language.LSP.Types.Lens as J +import qualified Ide.Plugin.Class as Class +import qualified Language.LSP.Types.Lens as J import System.FilePath import Test.Hls main :: IO () -main = do - recorder <- makeDefaultStderrRecorder Nothing Debug - defaultTestRunner . tests $ contramap (fmap pretty) recorder +main = defaultTestRunner tests -classPlugin :: Recorder (WithPriority Class.Log) -> PluginDescriptor IdeState -classPlugin recorder = Class.descriptor recorder "class" +classPlugin :: PluginTestDescriptor Class.Log +classPlugin = mkPluginTestDescriptor Class.descriptor "class" -tests :: Recorder (WithPriority Class.Log) -> TestTree -tests recorder = testGroup +tests :: TestTree +tests = testGroup "class" - [codeActionTests recorder , codeLensTests recorder] + [codeActionTests, codeLensTests] -codeActionTests :: Recorder (WithPriority Class.Log) -> TestTree -codeActionTests recorder = testGroup +codeActionTests :: TestTree +codeActionTests = testGroup "code actions" [ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do - runSessionWithServer (classPlugin recorder) testDataDir $ do + runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "T1.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" caResults <- getAllCodeActions doc @@ -51,40 +43,40 @@ , Just "Add placeholders for '/='" , Just "Add placeholders for '/=' with signature(s)" ] - , goldenWithClass recorder "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do + , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do executeCodeAction eqAction - , goldenWithClass recorder "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do + , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do executeCodeAction neAction - , goldenWithClass recorder "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do + , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do executeCodeAction fmapAction - , goldenWithClass recorder "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do + , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do executeCodeAction mmAction - , goldenWithClass recorder "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:_:mmAction:_) -> do + , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:_:mmAction:_) -> do executeCodeAction mmAction - , goldenWithClass recorder "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do + , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do executeCodeAction _fAction - , goldenWithClass recorder "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do + , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do executeCodeAction eqAction - , goldenWithClass recorder "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do + , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do executeCodeAction gAction - , goldenWithClass recorder "Creates a placeholder for other two methods" "T6" "2" $ \(_:_:ghAction:_) -> do + , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $ \(_:_:ghAction:_) -> do executeCodeAction ghAction - , onlyRunForGhcVersions [GHC92] "Only ghc-9.2 enabled GHC2021 implicitly" $ - goldenWithClass recorder "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ \(_:eqWithSig:_) -> do + , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ + goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ \(_:eqWithSig:_) -> do executeCodeAction eqWithSig - , goldenWithClass recorder "Insert pragma if not exist" "InsertWithoutPragma" "" $ \(_:eqWithSig:_) -> do + , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $ \(_:eqWithSig:_) -> do executeCodeAction eqWithSig - , goldenWithClass recorder "Don't insert pragma if exist" "InsertWithPragma" "" $ \(_:eqWithSig:_) -> do + , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $ \(_:eqWithSig:_) -> do executeCodeAction eqWithSig - , goldenWithClass recorder "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do + , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do executeCodeAction multi ] -codeLensTests :: Recorder (WithPriority Class.Log) -> TestTree -codeLensTests recorder = testGroup +codeLensTests :: TestTree +codeLensTests = testGroup "code lens" [ testCase "Has code lens" $ do - runSessionWithServer (classPlugin recorder) testDataDir $ do + runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "CodeLensSimple.hs" "haskell" lens <- getCodeLenses doc let titles = map (^. J.title) $ mapMaybe (^. J.command) lens @@ -92,14 +84,14 @@ [ "(==) :: B -> B -> Bool" , "(==) :: A -> A -> Bool" ] - , goldenCodeLens recorder "Apply code lens" "CodeLensSimple" 1 - , goldenCodeLens recorder "Apply code lens for local class" "LocalClassDefine" 0 - , goldenCodeLens recorder "Apply code lens on the same line" "Inline" 0 - , goldenCodeLens recorder "Don't insert pragma while existing" "CodeLensWithPragma" 0 - , onlyRunForGhcVersions [GHC92] "Only ghc-9.2 enabled GHC2021 implicitly" $ - goldenCodeLens recorder "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0 - , goldenCodeLens recorder "Qualified name" "Qualified" 0 - , goldenCodeLens recorder "Type family" "TypeFamily" 0 + , goldenCodeLens "Apply code lens" "CodeLensSimple" 1 + , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0 + , goldenCodeLens "Apply code lens on the same line" "Inline" 0 + , goldenCodeLens "Don't insert pragma while existing" "CodeLensWithPragma" 0 + , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ + goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0 + , goldenCodeLens "Qualified name" "Qualified" 0 + , goldenCodeLens "Type family" "TypeFamily" 0 ] _CACodeAction :: Prism' (Command |? CodeAction) CodeAction @@ -108,16 +100,16 @@ _ -> Nothing -goldenCodeLens :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> Int -> TestTree -goldenCodeLens recorder title path idx = - goldenWithHaskellDoc (classPlugin recorder) title testDataDir path "expected" "hs" $ \doc -> do +goldenCodeLens :: TestName -> FilePath -> Int -> TestTree +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) -goldenWithClass :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree -goldenWithClass recorder title path desc act = - goldenWithHaskellDoc (classPlugin recorder) title testDataDir path (desc <.> "expected") "hs" $ \doc -> do +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" actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc act actions