hls-class-plugin 1.0.2.0 → 1.0.3.0
raw patch · 5 files changed
+97/−35 lines, 5 filesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
Files
- hls-class-plugin.cabal +5/−5
- src/Ide/Plugin/Class.hs +74/−30
- test/Main.hs +3/−0
- test/testdata/T5.expected.hs +8/−0
- test/testdata/T5.hs +7/−0
hls-class-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-class-plugin-version: 1.0.2.0+version: 1.0.3.0 synopsis: Class/instance management plugin for Haskell Language Server @@ -28,9 +28,9 @@ , base >=4.12 && <5 , containers , ghc- , ghc-exactprint- , ghcide ^>=1.6- , hls-plugin-api ^>=1.3+ , ghc-exactprint >= 0.6.4+ , ghcide ^>=1.7+ , hls-plugin-api ^>=1.4 , lens , lsp , text@@ -53,6 +53,6 @@ , base , filepath , hls-class-plugin- , hls-test-utils ^>=1.2+ , hls-test-utils ^>=1.3 , lens , lsp-types
src/Ide/Plugin/Class.hs view
@@ -21,10 +21,11 @@ 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.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,26 +69,79 @@ 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) Left _ -> Nothing@@ -112,16 +171,7 @@ 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 @@ 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)- <=< nodeChildren- )-#else- ( (Map.keys . Map.filter isClassNodeIdentifier . sourcedNodeIdents . sourcedNodeInfo)+ ( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds) <=< nodeChildren )-#endif findClassFromIdentifier docPath (Right name) = do (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath@@ -197,7 +241,7 @@ 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"
test/Main.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Main ( main ) where@@ -45,6 +46,8 @@ 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
+ test/testdata/T5.expected.hs view
@@ -0,0 +1,8 @@+module T1 where++data X = X++instance Eq X where+ (==) = _++x = ()
+ test/testdata/T5.hs view
@@ -0,0 +1,7 @@+module T1 where++data X = X++instance Eq X where++x = ()