From e29f61f17d3612517081941277476d1401744424 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Mon, 7 Mar 2022 00:15:23 +0800 Subject: [PATCH] Fix hls-class-plugin on ghc-9.2 (#2733) * Fix codeAction on 9.2 * Enable test * pointCommand: MIN_VERSION_ghc to 9.2 * Specify version * Fix edit command * Enable class plugin in cabal * Comment addWhere * Unify the method of obtaining identifiers * Remove CPP * Remove compile flag * Rewrite filter with more restricts Co-authored-by: Pepe Iborra --- .github/workflows/test.yml | 2 +- cabal-ghc921.project | 1 - .../hls-class-plugin/src/Ide/Plugin/Class.hs | 104 +++++++++++++----- plugins/hls-class-plugin/test/Main.hs | 3 + .../test/testdata/T5.expected.hs | 8 ++ plugins/hls-class-plugin/test/testdata/T5.hs | 7 ++ stack-9.2.1.yaml | 3 +- 7 files changed, 94 insertions(+), 34 deletions(-) create mode 100644 plugins/hls-class-plugin/test/testdata/T5.expected.hs create mode 100644 plugins/hls-class-plugin/test/testdata/T5.hs diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index ef51c971a9..a8e108b80e 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -164,7 +164,7 @@ jobs: name: Test hls-floskell-plugin run: cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-floskell-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '9.2.1' + - if: matrix.test name: Test hls-class-plugin run: cabal test hls-class-plugin --test-options="$TEST_OPTS" || cabal test hls-class-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-class-plugin --test-options="$TEST_OPTS" diff --git a/cabal-ghc921.project b/cabal-ghc921.project index 8e6da76e6f..bb7da223ba 100644 --- a/cabal-ghc921.project +++ b/cabal-ghc921.project @@ -46,7 +46,6 @@ constraints: haskell-language-server +ignore-plugins-ghc-bounds -brittany - -class -haddockComments -hlint -retrie diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 215a15ff8d..c545f6027a 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -21,10 +21,11 @@ import Data.List import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T +import qualified Data.Set as Set import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping (fromCurrentRange, toCurrentRange) -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat as Compat hiding (locA) import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.AtPoint import qualified GHC.Generics as Generics @@ -38,6 +39,11 @@ import Language.LSP.Server import Language.LSP.Types import qualified Language.LSP.Types.Lens as J +#if MIN_VERSION_ghc(9,2,0) +import GHC.Hs (AnnsModule(AnnsModule)) +import GHC.Parser.Annotation +#endif + descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = commands @@ -63,25 +69,78 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do medit <- liftIO $ runMaybeT $ do docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath - let - ps = pm_parsed_source pm - anns = relativiseApiAnns ps (pm_annotations pm) - old = T.pack $ exactPrint ps anns - (hsc_dflags . hscEnv -> df) <- MaybeT . runAction "classplugin" state $ use GhcSessionDeps docPath - List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup - let - (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls) - new = T.pack $ exactPrint ps' anns' - + (old, new) <- makeEditText pm df pure (workspaceEdit caps old new) + forM_ medit $ \edit -> sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) pure (Right Null) where - indent = 2 + workspaceEdit caps old new + = diffText caps (uri, old) new IncludeDeletions + + toMethodName n + | Just (h, _) <- T.uncons n + , not (isAlpha h || h == '_') + = "(" <> n <> ")" + | otherwise + = n + +#if MIN_VERSION_ghc(9,2,0) + makeEditText pm df = do + List mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + let ps = makeDeltaAst $ pm_parsed_source pm + old = T.pack $ exactPrint ps + (ps', _, _) = runTransform (addMethodDecls ps mDecls) + new = T.pack $ exactPrint ps' + pure (old, new) + + makeMethodDecl df mName = + either (const Nothing) Just . parseDecl df (T.unpack mName) . T.unpack + $ toMethodName mName <> " = _" + + addMethodDecls ps mDecls = do + allDecls <- hsDecls ps + let (before, ((L l inst): after)) = break (containRange range . getLoc) allDecls + replaceDecls ps (before ++ (L l (addWhere inst)): (map newLine mDecls ++ after)) + where + -- Add `where` keyword for `instance X where` if `where` is missing. + -- + -- The `where` in ghc-9.2 is now stored in the instance declaration + -- directly. More precisely, giving an `HsDecl GhcPs`, we have: + -- InstD --> ClsInstD --> ClsInstDecl --> XCClsInstDecl --> (EpAnn [AddEpAnn], AnnSortKey), + -- here `AnnEpAnn` keeps the track of Anns. + -- + -- See the link for the original definition: + -- https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl + addWhere (InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = + let ((EpAnn entry anns comments), key) = cid_ext + in InstD xInstD (ClsInstD ext decl { + cid_ext = (EpAnn + entry + (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns) + comments + , key) + }) + addWhere decl = decl + + newLine (L l e) = + let dp = deltaPos 1 (indent + 1) -- Not sure why there need one more space + in L (noAnnSrcSpanDP (locA l) dp <> l) e + +#else + makeEditText pm df = do + List (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 + (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls) + new = T.pack $ exactPrint ps' anns' + pure (old, new) + makeMethodDecl df mName = case parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" of Right (ann, d) -> Just (setPrecedingLines d 1 indent ann, d) @@ -112,16 +171,7 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do findInstDecl :: ParsedSource -> Transform (LHsDecl GhcPs) findInstDecl ps = head . filter (containRange range . getLoc) <$> hsDecls ps - - workspaceEdit caps old new - = diffText caps (uri, old) new IncludeDeletions - - toMethodName n - | Just (h, _) <- T.uncons n - , not (isAlpha h || h == '_') - = "(" <> n <> ")" - | otherwise - = n +#endif -- | -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is @@ -169,15 +219,9 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr pure $ head . head $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1) -#if !MIN_VERSION_ghc(9,0,0) - ( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo) + ( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds) <=< nodeChildren ) -#else - ( (Map.keys . Map.filter isClassNodeIdentifier . sourcedNodeIdents . sourcedNodeInfo) - <=< nodeChildren - ) -#endif findClassFromIdentifier docPath (Right name) = do (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath @@ -197,7 +241,7 @@ containRange :: Range -> SrcSpan -> Bool containRange range x = isInsideSrcSpan (range ^. J.start) x || isInsideSrcSpan (range ^. J.end) x isClassNodeIdentifier :: IdentifierDetails a -> Bool -isClassNodeIdentifier = isNothing . identType +isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` (identInfo ident) isClassMethodWarning :: T.Text -> Bool isClassMethodWarning = T.isPrefixOf "• No explicit implementation for" diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 9a69255030..ff2ca5a2cc 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Main ( main ) where @@ -45,6 +46,8 @@ tests = testGroup executeCodeAction mmAction , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do executeCodeAction _fAction + , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do + executeCodeAction eqAction ] _CACodeAction :: Prism' (Command |? CodeAction) CodeAction diff --git a/plugins/hls-class-plugin/test/testdata/T5.expected.hs b/plugins/hls-class-plugin/test/testdata/T5.expected.hs new file mode 100644 index 0000000000..6c26425f34 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T5.expected.hs @@ -0,0 +1,8 @@ +module T1 where + +data X = X + +instance Eq X where + (==) = _ + +x = () diff --git a/plugins/hls-class-plugin/test/testdata/T5.hs b/plugins/hls-class-plugin/test/testdata/T5.hs new file mode 100644 index 0000000000..e7dc1d4da3 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T5.hs @@ -0,0 +1,7 @@ +module T1 where + +data X = X + +instance Eq X where + +x = () diff --git a/stack-9.2.1.yaml b/stack-9.2.1.yaml index 5cad2e5a5d..66c23a48c2 100644 --- a/stack-9.2.1.yaml +++ b/stack-9.2.1.yaml @@ -10,7 +10,7 @@ packages: - ./hls-test-utils - ./shake-bench - ./plugins/hls-call-hierarchy-plugin -# - ./plugins/hls-class-plugin +- ./plugins/hls-class-plugin # - ./plugins/hls-haddock-comments-plugin # - ./plugins/hls-eval-plugin - ./plugins/hls-explicit-imports-plugin @@ -116,7 +116,6 @@ flags: ignore-plugins-ghc-bounds: true alternateNumberFormat: false brittany: false - class: false eval: false haddockComments: false hlint: false