hls-class-plugin 1.0.3.0 → 1.1.0.0
raw patch · 35 files changed
+1021/−276 lines, 35 filesdep +deepseqdep +extradep +ghc-boot-thdep ~ghc-exactprintdep ~ghcidedep ~hls-plugin-apiPVP ok
version bump matches the API change (PVP)
Dependencies added: deepseq, extra, ghc-boot-th, hls-graph
Dependency ranges changed: ghc-exactprint, ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
- Ide.Plugin.Class: instance Data.Aeson.Types.FromJSON.FromJSON Ide.Plugin.Class.AddMinimalMethodsParams
- Ide.Plugin.Class: instance Data.Aeson.Types.ToJSON.ToJSON Ide.Plugin.Class.AddMinimalMethodsParams
- Ide.Plugin.Class: instance GHC.Classes.Eq Ide.Plugin.Class.AddMinimalMethodsParams
- Ide.Plugin.Class: instance GHC.Generics.Generic Ide.Plugin.Class.AddMinimalMethodsParams
- Ide.Plugin.Class: instance GHC.Show.Show Ide.Plugin.Class.AddMinimalMethodsParams
+ Ide.Plugin.Class: LogImplementedMethods :: Class -> [Text] -> Log
+ Ide.Plugin.Class: LogShake :: Log -> Log
+ Ide.Plugin.Class: data Log
- Ide.Plugin.Class: descriptor :: PluginId -> PluginDescriptor IdeState
+ Ide.Plugin.Class: descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
Files
- hls-class-plugin.cabal +31/−6
- src/Ide/Plugin/Class.hs +18/−249
- src/Ide/Plugin/Class/CodeAction.hs +225/−0
- src/Ide/Plugin/Class/CodeLens.hs +131/−0
- src/Ide/Plugin/Class/ExactPrint.hs +121/−0
- src/Ide/Plugin/Class/Types.hs +109/−0
- src/Ide/Plugin/Class/Utils.hs +69/−0
- test/Main.hs +81/−21
- test/testdata/CodeLensSimple.expected.hs +11/−0
- test/testdata/CodeLensSimple.hs +9/−0
- test/testdata/CodeLensWithGHC2021.expected.hs +7/−0
- test/testdata/CodeLensWithGHC2021.hs +6/−0
- test/testdata/CodeLensWithPragma.expected.hs +7/−0
- test/testdata/CodeLensWithPragma.hs +6/−0
- test/testdata/Inline.expected.hs +6/−0
- test/testdata/Inline.hs +4/−0
- test/testdata/InsertPragmaOnce.expected.hs +9/−0
- test/testdata/InsertPragmaOnce.hs +4/−0
- test/testdata/InsertWithGHC2021Enabled.expected.hs +7/−0
- test/testdata/InsertWithGHC2021Enabled.hs +5/−0
- test/testdata/InsertWithPragma.expected.hs +7/−0
- test/testdata/InsertWithPragma.hs +5/−0
- test/testdata/InsertWithoutPragma.expected.hs +7/−0
- test/testdata/InsertWithoutPragma.hs +4/−0
- test/testdata/LocalClassDefine.expected.hs +10/−0
- test/testdata/LocalClassDefine.hs +8/−0
- test/testdata/Qualified.expected.hs +10/−0
- test/testdata/Qualified.hs +8/−0
- test/testdata/QualifiedA.hs +3/−0
- test/testdata/T6.1.expected.hs +22/−0
- test/testdata/T6.2.expected.hs +23/−0
- test/testdata/T6.expected.hs +7/−0
- test/testdata/T6.hs +21/−0
- test/testdata/TypeFamily.expected.hs +11/−0
- test/testdata/TypeFamily.hs +9/−0
hls-class-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-class-plugin-version: 1.0.3.0+version: 1.1.0.0 synopsis: Class/instance management plugin for Haskell Language Server @@ -21,38 +21,63 @@ test/testdata/*.hs 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+ , Ide.Plugin.Class.ExactPrint+ , Ide.Plugin.Class.Types+ , Ide.Plugin.Class.Utils hs-source-dirs: src build-depends: , aeson , base >=4.12 && <5 , containers+ , deepseq+ , extra , ghc- , ghc-exactprint >= 0.6.4- , ghcide ^>=1.7- , hls-plugin-api ^>=1.4+ , ghcide ^>=1.8+ , ghc-boot-th+ , hls-graph+ , hls-plugin-api ^>=1.5 , lens , lsp , text , transformers + if impl(ghc >=9.2.1)+ build-depends: ghc-exactprint ^>= 1.5+ else+ build-depends: ghc-exactprint >= 0.6.4 && <1.1+ default-language: Haskell2010 default-extensions: DataKinds TypeOperators+ OverloadedStrings - ghc-options: -Wno-unticked-promoted-constructors+ 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 main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends:+ , aeson , base , filepath+ , ghcide , hls-class-plugin- , hls-test-utils ^>=1.3+ , hls-plugin-api+ , hls-test-utils ^>=1.4 , lens , lsp-types
src/Ide/Plugin/Class.hs view
@@ -1,255 +1,24 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-module Ide.Plugin.Class- ( descriptor- ) where+module Ide.Plugin.Class (descriptor, Log(..)) where -import Control.Applicative-import Control.Lens hiding (List, use)-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe-import Data.Aeson-import Data.Char-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 as Compat hiding (locA)-import Development.IDE.GHC.Compat.Util-import Development.IDE.Spans.AtPoint-import qualified GHC.Generics as Generics-import Ide.PluginUtils+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.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl)-import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, Parens)-import Language.Haskell.GHC.ExactPrint.Utils (rs)-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- , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction- }+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+ } -commands :: [PluginCommand IdeState]-commands- = [ PluginCommand "addMinimalMethodPlaceholders" "add placeholders for minimal methods" addMethodPlaceholders+commands :: PluginId -> [PluginCommand IdeState]+commands plId+ = [ PluginCommand codeActionCommandId+ "add placeholders for minimal methods" (addMethodPlaceholders plId)+ , PluginCommand typeLensCommandId+ "add type signatures for instance methods" codeLensCommandHandler ]---- | Parameter for the addMethods PluginCommand.-data AddMinimalMethodsParams = AddMinimalMethodsParams- { uri :: Uri- , range :: Range- , methodGroup :: List T.Text- }- deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)--addMethodPlaceholders :: CommandFunction IdeState AddMinimalMethodsParams-addMethodPlaceholders state AddMinimalMethodsParams{..} = do- caps <- getClientCapabilities- medit <- liftIO $ runMaybeT $ do- docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri- pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath- (hsc_dflags . hscEnv -> df) <- MaybeT . runAction "classplugin" state $ use GhcSessionDeps docPath- (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-- addMethodDecls ps mDecls = do- d <- findInstDecl ps- newSpan <- uniqueSrcSpanT- let- annKey = mkAnnKey d- newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds")- addWhere mkds@(Map.lookup annKey -> Just ann)- = Map.insert newAnnKey ann2 mkds2- where- ann1 = ann- { annsDP = annsDP ann ++ [(G AnnWhere, DP (0, 1))]- , annCapturedSpan = Just newAnnKey- , annSortKey = Just (fmap (rs . getLoc) mDecls)- }- mkds2 = Map.insert annKey ann1 mkds- ann2 = annNone- { annEntryDelta = DP (1, indent)- }- addWhere _ = panic "Ide.Plugin.Class.addMethodPlaceholder"- modifyAnnsT addWhere- modifyAnnsT (captureOrderAnnKey newAnnKey mDecls)- foldM (insertAfter d) ps (reverse mDecls)-- findInstDecl :: ParsedSource -> Transform (LHsDecl GhcPs)- findInstDecl ps = head . filter (containRange range . getLoc) <$> hsDecls ps-#endif---- |--- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is--- sensitive to the format of diagnostic messages from GHC.-codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction-codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do- docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri- actions <- join <$> mapM (mkActions docPath) methodDiags- pure . Right . List $ actions- where- errorResult = Right (List [])- uri = docId ^. J.uri- List diags = context ^. J.diagnostics-- ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags- methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags-- mkActions docPath diag = do- ident <- findClassIdentifier docPath range- cls <- findClassFromIdentifier docPath ident- lift . traverse mkAction . minDefToMethodGroups . classMinimalDef $ cls- where- range = diag ^. J.range-- mkAction methodGroup- = pure $ mkCodeAction title $ mkLspCommand plId "addMinimalMethodPlaceholders" title (Just cmdParams)- where- title = mkTitle methodGroup- cmdParams = mkCmdParams methodGroup-- mkTitle methodGroup- = "Add placeholders for "- <> mconcat (intersperse ", " (fmap (\m -> "'" <> m <> "'") methodGroup))-- mkCmdParams methodGroup = [toJSON (AddMinimalMethodsParams uri range (List methodGroup))]-- mkCodeAction title cmd- = InR- $ CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing (Just cmd) Nothing-- findClassIdentifier docPath range = do- (hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath- case hieAstResult of- HAR {hieAst = hf} ->- pure- $ head . head- $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1)- ( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds)- <=< nodeChildren- )-- findClassFromIdentifier docPath (Right name) = do- (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath- (tmrTypechecked -> thisMod, _) <- MaybeT . runAction "classplugin" state $ useWithStale TypeCheck docPath- MaybeT . fmap snd . initTcWithGbl hscenv thisMod ghostSpan $ do- tcthing <- tcLookup name- case tcthing of- AGlobal (AConLike (RealDataCon con))- | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls- _ -> panic "Ide.Plugin.Class.findClassFromIdentifier"- findClassFromIdentifier _ (Left _) = panic "Ide.Plugin.Class.findClassIdentifier"--ghostSpan :: RealSrcSpan-ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<haskell-language-sever>") 1 1--containRange :: Range -> SrcSpan -> Bool-containRange range x = isInsideSrcSpan (range ^. J.start) x || isInsideSrcSpan (range ^. J.end) x--isClassNodeIdentifier :: IdentifierDetails a -> Bool-isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` (identInfo ident)--isClassMethodWarning :: T.Text -> Bool-isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"--minDefToMethodGroups :: BooleanFormula Name -> [[T.Text]]-minDefToMethodGroups = go- where- go (Var mn) = [[T.pack . occNameString . occName $ mn]]- go (Or ms) = concatMap (go . unLoc) ms- go (And ms) = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms)- go (Parens m) = go (unLoc m)
+ src/Ide/Plugin/Class/CodeAction.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Ide.Plugin.Class.CodeAction where++import Control.Applicative (liftA2)+import Control.Lens hiding (List, use)+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.Maybe+import Data.Aeson+import Data.Either.Extra (rights)+import Data.List+import qualified Data.Map.Strict as Map+import Data.Maybe (isNothing, listToMaybe,+ mapMaybe)+import qualified Data.Set as Set+import qualified Data.Text as T+import Development.IDE+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.PluginUtils+import Ide.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++ void $ lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())++ pure Null+ where+ toTextDocunemtEdit 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)+ <$> _documentChanges+ , ..+ }++ workspaceEdit caps old new+ = diffText caps (uri, 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+ where+ uri = docId ^. J.uri+ List diags = context ^. J.diagnostics++ ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags+ methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags++ mkActions+ :: NormalizedFilePath+ -> 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)+ ident <- findClassIdentifier ast instancePosition+ cls <- findClassFromIdentifier docPath ident+ InstanceBindTypeSigsResult sigs <- handleMaybeM "Unable to GetInstanceBindTypeSigs"+ $ liftIO+ $ runAction "classplugin.codeAction.GetInstanceBindTypeSigs" state+ $ use GetInstanceBindTypeSigs docPath+ implemented <- findImplementedMethods ast instancePosition+ logWith recorder Info (LogImplementedMethods cls implemented)+ pure+ $ concatMap mkAction+ $ fmap (filter (\(bind, _) -> bind `notElem` implemented))+ $ minDefToMethodGroups range sigs+ $ classMinimalDef cls+ where+ range = diag ^. J.range++ mkAction :: [(T.Text, T.Text)] -> [Command |? CodeAction]+ mkAction methodGroup+ = [ mkCodeAction title+ $ mkLspCommand plId codeActionCommandId title+ (Just $ mkCmdParams methodGroup False)+ , mkCodeAction titleWithSig+ $ mkLspCommand plId codeActionCommandId titleWithSig+ (Just $ mkCmdParams methodGroup True)+ ]+ where+ title = mkTitle $ fst <$> methodGroup+ titleWithSig = mkTitleWithSig $ fst <$> methodGroup++ mkTitle methodGroup+ = "Add placeholders for "+ <> mconcat (intersperse ", " (fmap (\m -> "'" <> m <> "'") methodGroup))++ mkTitleWithSig methodGroup = mkTitle methodGroup <> " with signature(s)"++ mkCmdParams methodGroup withSig =+ [toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)]++ mkCodeAction title cmd+ = InR+ $ CodeAction+ title+ (Just CodeActionQuickFix)+ (Just (List []))+ Nothing+ Nothing+ Nothing+ (Just cmd)+ Nothing++ findClassIdentifier hf instancePosition =+ handleMaybe "No Identifier found"+ $ listToMaybe+ $ mapMaybe listToMaybe+ $ pointCommand hf instancePosition+ ( (Map.keys . Map.filter isClassNodeIdentifier . getNodeIds)+ <=< nodeChildren+ )++ findImplementedMethods+ :: HieASTs a+ -> Position+ -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [T.Text]+ findImplementedMethods asts instancePosition = do+ pure+ $ concat+ $ pointCommand asts instancePosition+ $ map (T.pack . getOccString) . rights . findInstanceValBindIdentifiers++ -- | Recurses through the given AST to find identifiers which are+ -- 'InstanceValBind's.+ findInstanceValBindIdentifiers :: HieAST a -> [Identifier]+ findInstanceValBindIdentifiers ast =+ let valBindIds = Map.keys+ . Map.filter (any isInstanceValBind . identInfo)+ $ getNodeIds ast+ 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 "Error in TcEnv"+ . liftIO+ . fmap snd+ . initTcWithGbl hscenv thisMod ghostSpan $ do+ tcthing <- tcLookup name+ case tcthing of+ AGlobal (AConLike (RealDataCon con))+ | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls+ _ -> fail "Ide.Plugin.Class.findClassFromIdentifier"+ findClassFromIdentifier _ (Left _) = throwE "Ide.Plugin.Class.findClassIdentifier"++isClassNodeIdentifier :: IdentifierDetails a -> Bool+isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` identInfo ident++isClassMethodWarning :: T.Text -> Bool+isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"++isInstanceValBind :: ContextInfo -> Bool+isInstanceValBind (ValBind InstanceBind _ _) = True+isInstanceValBind _ = False++-- Return (name text, signature text)+minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [[(T.Text, T.Text)]]+minDefToMethodGroups range sigs = go+ where+ go (Var mn) = [[ (T.pack . occNameString . occName $ mn, bindRendered sig)+ | sig <- sigs+ , inRange range (getSrcSpan $ bindName sig)+ , printOutputable mn == T.drop (T.length bindingPrefix) (printOutputable (bindName sig))+ ]]+ go (Or ms) = concatMap (go . unLoc) ms+ go (And ms) = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms)+ go (Parens m) = go (unLoc m)
+ src/Ide/Plugin/Class/CodeLens.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}++module Ide.Plugin.Class.CodeLens where++import Control.Lens ((^.))+import Control.Monad.IO.Class (liftIO)+import Data.Aeson+import Data.Maybe (mapMaybe, maybeToList)+import qualified Data.Text as T+import Development.IDE+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.PluginUtils+import Ide.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+ $ use TypeCheck nfp++ -- All instance binds+ InstanceBindTypeSigsResult allBinds <-+ handleMaybeM "Unable to get InstanceBindTypeSigsResult"+ $ liftIO+ $ runAction "classplugin.GetInstanceBindTypeSigs" state+ $ use GetInstanceBindTypeSigs nfp++ pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs++ let (hsGroup, _, _, _) = tmrRenamed tmr+ tycls = hs_tyclds hsGroup+ -- declared instance methods without signatures+ bindInfos = [ bind+ | instds <- map group_instds tycls -- class instance decls+ , instd <- instds+ , inst <- maybeToList $ getClsInstD (unLoc instd)+ , bind <- getBindSpanWithoutSig inst+ ]+ targetSigs = matchBind bindInfos allBinds+ makeLens (range, title) =+ generateLens plId range title+ $ workspaceEdit pragmaInsertion+ $ makeEdit range title+ codeLens = makeLens <$> mapMaybe getRangeWithSig targetSigs++ pure $ List codeLens+ where+ uri = _textDocument ^. J.uri++ -- Match Binds with their signatures+ -- We try to give every `InstanceBindTypeSig` a `SrcSpan`,+ -- hence we can display signatures for `InstanceBindTypeSig` with span later.+ matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [InstanceBindTypeSig]+ matchBind existedBinds allBindWithSigs =+ [foldl go bindSig existedBinds | bindSig <- allBindWithSigs]+ where+ -- | The `bindDefSpan` of the bind is `Nothing` before,+ -- we update it with the span where binding occurs.+ -- Hence, we can infer the place to display the signature later.+ update :: InstanceBindTypeSig -> SrcSpan -> InstanceBindTypeSig+ update bind sp = bind {bindDefSpan = Just sp}++ go :: InstanceBindTypeSig -> BindInfo -> InstanceBindTypeSig+ go bindSig bind = case (srcSpanToRange . bindNameSpan) bind of+ Nothing -> bindSig+ Just range ->+ if inRange range (getSrcSpan $ bindName bindSig)+ then update bindSig (bindSpan bind)+ else bindSig++ getClsInstD (ClsInstD _ d) = Just d+ getClsInstD _ = Nothing++ getSigName (ClassOpSig _ _ sigNames _) = Just $ map unLoc sigNames+ getSigName _ = Nothing++ getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo]+ getBindSpanWithoutSig ClsInstDecl{..} =+ let bindNames = mapMaybe go (bagToList cid_binds)+ go (L l bind) = case bind of+ FunBind{..} -> Just $ L l fun_id+ _ -> Nothing+ -- Existed signatures' name+ sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs+ toBindInfo (L l (L l' _)) = BindInfo+ (locA l) -- bindSpan+ (locA l') -- bindNameSpan+ in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` sigNames) bindNames+ getBindSpanWithoutSig _ = []++ -- Get bind definition range with its rendered signature text+ getRangeWithSig :: InstanceBindTypeSig -> Maybe (Range, T.Text)+ getRangeWithSig bind = do+ span <- bindDefSpan bind+ range <- srcSpanToRange span+ pure (range, bindRendered bind)++ workspaceEdit pragmaInsertion edits =+ WorkspaceEdit+ (pure [(uri, List $ edits ++ pragmaInsertion)])+ Nothing+ Nothing++ generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens+ generateLens plId range title edit =+ let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON edit])+ in CodeLens range (Just cmd) Nothing++ makeEdit :: Range -> T.Text -> [TextEdit]+ makeEdit range bind =+ let startPos = range ^. J.start+ insertChar = startPos ^. J.character+ insertRange = Range startPos startPos+ in [TextEdit insertRange (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")]++codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit+codeLensCommandHandler _ wedit = do+ _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+ return $ Right Null
+ src/Ide/Plugin/Class/ExactPrint.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Ide.Plugin.Class.ExactPrint where++import Control.Monad.Trans.Maybe+import qualified Data.Text as T+import Development.IDE.GHC.Compat+import Ide.Plugin.Class.Types+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)+import GHC.Parser.Annotation+#else+import Control.Monad (foldM)+import qualified Data.Map.Strict as Map+import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs)+import Language.Haskell.GHC.ExactPrint.Utils (rs)+#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+ let ps = makeDeltaAst $ pm_parsed_source pm+ old = T.pack $ exactPrint ps+ (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig)+ new = T.pack $ exactPrint ps'+ pure (old, new)++makeMethodDecl :: DynFlags -> (T.Text, T.Text) -> Maybe (LHsDecl GhcPs, LHsDecl GhcPs)+makeMethodDecl df (mName, sig) = do+ name <- eitherToMaybe $ parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _"+ sig' <- eitherToMaybe $ parseDecl df (T.unpack sig) $ T.unpack sig+ pure (name, sig')++addMethodDecls ps mDecls range withSig+ | withSig = go (concatMap (\(decl, sig) -> [sig, decl]) mDecls)+ | otherwise = go (map fst mDecls)+ where+ go inserting = do+ allDecls <- hsDecls ps+ let (before, ((L l inst): after)) = break (inRange range . getLoc) allDecls+ replaceDecls ps (before ++ (L l (addWhere inst)): (map newLine inserting ++ after))+ -- 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 defaultIndent+ in L (noAnnSrcSpanDP (getLoc l) dp <> l) e++#else++makeEditText pm df AddMinimalMethodsParams{..} = 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 range withSig)+ new = T.pack $ exactPrint ps' anns'+ pure (old, new)++makeMethodDecl :: DynFlags -> (T.Text, T.Text) -> Maybe (Anns, (LHsDecl GhcPs, LHsDecl GhcPs))+makeMethodDecl df (mName, sig) = do+ (nameAnn, name) <- case parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" of+ Right (ann, d) -> Just (setPrecedingLines d 1 defaultIndent ann, d)+ Left _ -> Nothing+ (sigAnn, sig) <- case parseDecl df (T.unpack sig) $ T.unpack sig of+ Right (ann, d) -> Just (setPrecedingLines d 1 defaultIndent ann, d)+ Left _ -> Nothing+ pure (mergeAnnList [nameAnn, sigAnn], (name, sig))++addMethodDecls ps mDecls range withSig = do+ d <- findInstDecl ps range+ newSpan <- uniqueSrcSpanT+ let decls = if withSig then concatMap (\(decl, sig) -> [sig, decl]) mDecls else map fst mDecls+ annKey = mkAnnKey d+ newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds")+ addWhere mkds@(Map.lookup annKey -> Just ann) = Map.insert newAnnKey ann2 mkds2+ where+ ann1 = ann+ { annsDP = annsDP ann ++ [(G AnnWhere, DP (0, 1))]+ , annCapturedSpan = Just newAnnKey+ , annSortKey = Just (fmap (rs . getLoc) decls)+ }+ mkds2 = Map.insert annKey ann1 mkds+ ann2 = annNone+ { annEntryDelta = DP (1, defaultIndent)+ }+ addWhere _ = panic "Ide.Plugin.Class.addMethodPlaceholder"+ modifyAnnsT addWhere+ modifyAnnsT (captureOrderAnnKey newAnnKey decls)+ foldM (insertAfter d) ps (reverse decls)++findInstDecl :: ParsedSource -> Range -> Transform (LHsDecl GhcPs)+findInstDecl ps range = head . filter (inRange range . getLoc) <$> hsDecls ps+#endif
+ src/Ide/Plugin/Class/Types.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Ide.Plugin.Class.Types where++import Control.DeepSeq (rwhnf)+import Control.Monad.Extra (whenMaybe)+import Control.Monad.IO.Class (liftIO)+import Data.Aeson+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import Development.IDE+import qualified Development.IDE.Core.Shake as Shake+import Development.IDE.GHC.Compat hiding ((<+>))+import Development.IDE.Graph.Classes+import GHC.Generics+import Ide.Plugin.Class.Utils+import Ide.Types++typeLensCommandId :: CommandId+typeLensCommandId = "classplugin.typelens"++codeActionCommandId :: CommandId+codeActionCommandId = "classplugin.codeaction"++-- | Default indent size for inserting+defaultIndent :: Int+defaultIndent = 2++data AddMinimalMethodsParams = AddMinimalMethodsParams+ { uri :: Uri+ , range :: Range+ , methodGroup :: List (T.Text, T.Text)+ -- ^ (name text, signature text)+ , withSig :: Bool+ }+ deriving (Show, Eq, Generic, ToJSON, FromJSON)++data GetInstanceBindTypeSigs = GetInstanceBindTypeSigs+ deriving (Generic, Show, Eq, Ord, Hashable, NFData)++data InstanceBindTypeSig = InstanceBindTypeSig+ { bindName :: Name+ , bindRendered :: T.Text+ , bindDefSpan :: Maybe SrcSpan+ -- ^SrcSpan for the bind definition+ }++newtype InstanceBindTypeSigsResult =+ InstanceBindTypeSigsResult [InstanceBindTypeSig]++instance Show InstanceBindTypeSigsResult where+ show _ = "<InstanceBindTypeSigs>"++instance NFData InstanceBindTypeSigsResult where+ rnf = rwhnf++type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult++data Log+ = LogImplementedMethods Class [T.Text]+ | LogShake Shake.Log++instance Pretty Log where+ pretty = \case+ LogImplementedMethods cls methods ->+ pretty ("Detected implmented 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++data BindInfo = BindInfo+ { bindSpan :: SrcSpan+ -- ^ SrcSpan of the whole binding+ , bindNameSpan :: SrcSpan+ -- ^ SrcSpan of the binding name+ }++rules :: Recorder (WithPriority Log) -> Rules ()+rules recorder = do+ define (cmapWithPrio LogShake recorder) $ \GetInstanceBindTypeSigs nfp -> do+ tmr <- use TypeCheck nfp+ hsc <- use GhcSession nfp+ result <- liftIO $ instanceBindType (hscEnv <$> hsc) (tmrTypechecked <$> tmr)+ pure ([], result)+ where+ instanceBindType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe InstanceBindTypeSigsResult)+ instanceBindType (Just hsc) (Just gblEnv) = do+ let binds = collectHsBindsBinders $ tcg_binds gblEnv+ (_, maybe [] catMaybes -> instanceBinds) <-+ initTcWithGbl hsc gblEnv ghostSpan $ traverse bindToSig binds+ pure $ Just $ InstanceBindTypeSigsResult instanceBinds+ where+ rdrEnv = tcg_rdr_env gblEnv+ showDoc ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc rdrEnv) (pprSigmaType ty)++ bindToSig id = do+ let name = idName id+ whenMaybe (isBindingName name) $ do+ env <- tcInitTidyEnv+ let (_, ty) = tidyOpenType env (idType id)+ pure $ InstanceBindTypeSig name+ (prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc ty))+ Nothing+ instanceBindType _ _ = pure Nothing
+ src/Ide/Plugin/Class/Utils.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ViewPatterns #-}++module Ide.Plugin.Class.Utils where++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 Development.IDE+import Development.IDE.GHC.Compat+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++-- | All instance bindings are started with `$c`+bindingPrefix :: IsString s => s+bindingPrefix = "$c"++isBindingName :: Name -> Bool+isBindingName name = isPrefixOf bindingPrefix $ occNameString $ nameOccName name++-- | Check if some `HasSrcSpan` value in the given range+inRange :: Range -> SrcSpan -> Bool+inRange range s = maybe False (subRange range) (srcSpanToRange s)++ghostSpan :: RealSrcSpan+ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<haskell-language-sever>") 1 1++-- | "$cname" ==> "name"+prettyBindingNameString :: T.Text -> T.Text+prettyBindingNameString name+ | T.isPrefixOf bindingPrefix name =+ toMethodName $ T.drop (T.length bindingPrefix) name+ | otherwise = name++-- | Paren the name for pretty display if necessary+toMethodName :: T.Text -> T.Text+toMethodName n+ | Just (h, _) <- T.uncons n+ , not (isAlpha h || h == '_')+ = "(" <> n <> ")"+ | otherwise+ = n++insertPragmaIfNotPresent :: (MonadIO m)+ => IdeState+ -> NormalizedFilePath+ -> Extension+ -> ExceptT String 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+ $ getFileContents nfp+ pm <- handleMaybeM "Unable to GetParsedModuleWithComments"+ $ liftIO+ $ runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state+ $ use GetParsedModuleWithComments nfp+ let exts = (toList . extensionFlags . ms_hspp_opts . pm_mod_summary) pm+ info = getNextPragmaInfo sessionDynFlags fileContents+ pure [insertNewPragma info pragma | pragma `notElem` exts]
test/Main.hs view
@@ -1,63 +1,123 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-}- {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module Main ( main ) where -import Control.Lens (Prism', prism', (^..), (^?))-import Control.Monad (void)-import qualified Ide.Plugin.Class as Class-import qualified Language.LSP.Types.Lens as J+import Control.Lens (Prism', prism', (^.), (^..),+ (^?))+import Control.Monad (void)+import Data.Aeson (toJSON, (.=))+import Data.Functor.Contravariant (contramap)+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 System.FilePath import Test.Hls main :: IO ()-main = defaultTestRunner tests+main = do+ recorder <- makeDefaultStderrRecorder Nothing Debug+ defaultTestRunner . tests $ contramap (fmap pretty) recorder -classPlugin :: PluginDescriptor IdeState-classPlugin = Class.descriptor "class"+classPlugin :: Recorder (WithPriority Class.Log) -> PluginDescriptor IdeState+classPlugin recorder = Class.descriptor recorder "class" -tests :: TestTree-tests = testGroup+tests :: Recorder (WithPriority Class.Log) -> TestTree+tests recorder = testGroup "class"+ [codeActionTests recorder , codeLensTests recorder]++codeActionTests :: Recorder (WithPriority Class.Log) -> TestTree+codeActionTests recorder = testGroup+ "code actions" [ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do- runSessionWithServer classPlugin testDataDir $ do+ runSessionWithServer (classPlugin recorder) testDataDir $ do doc <- openDoc "T1.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" caResults <- getAllCodeActions doc liftIO $ map (^? _CACodeAction . J.title) caResults @?= [ Just "Add placeholders for '=='"+ , Just "Add placeholders for '==' with signature(s)" , Just "Add placeholders for '/='"+ , Just "Add placeholders for '/=' with signature(s)" ]- , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do+ , goldenWithClass recorder "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do executeCodeAction eqAction- , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:neAction:_) -> do+ , goldenWithClass recorder "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do executeCodeAction neAction- , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:fmapAction:_) -> do+ , goldenWithClass recorder "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do executeCodeAction fmapAction- , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do+ , goldenWithClass recorder "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do executeCodeAction mmAction- , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do+ , goldenWithClass recorder "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:_:mmAction:_) -> do executeCodeAction mmAction- , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do+ , goldenWithClass recorder "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do executeCodeAction _fAction- , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do+ , goldenWithClass recorder "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+ executeCodeAction gAction+ , goldenWithClass recorder "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+ executeCodeAction eqWithSig+ , goldenWithClass recorder "Insert pragma if not exist" "InsertWithoutPragma" "" $ \(_:eqWithSig:_) -> do+ executeCodeAction eqWithSig+ , goldenWithClass recorder "Don't insert pragma if exist" "InsertWithPragma" "" $ \(_:eqWithSig:_) -> do+ executeCodeAction eqWithSig+ , goldenWithClass recorder "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do+ executeCodeAction multi ] +codeLensTests :: Recorder (WithPriority Class.Log) -> TestTree+codeLensTests recorder = testGroup+ "code lens"+ [ testCase "Has code lens" $ do+ runSessionWithServer (classPlugin recorder) testDataDir $ do+ doc <- openDoc "CodeLensSimple.hs" "haskell"+ lens <- getCodeLenses doc+ let titles = map (^. J.title) $ mapMaybe (^. J.command) lens+ liftIO $ titles @?=+ [ "(==) :: 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+ ]+ _CACodeAction :: Prism' (Command |? CodeAction) CodeAction _CACodeAction = prism' InR $ \case InR action -> Just action _ -> Nothing -goldenWithClass :: TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree-goldenWithClass title path desc act =- goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do++goldenCodeLens :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> Int -> TestTree+goldenCodeLens recorder title path idx =+ goldenWithHaskellDoc (classPlugin recorder) 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 _ <- waitForDiagnosticsFromSource doc "typecheck" actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc act actions
+ test/testdata/CodeLensSimple.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE InstanceSigs #-}+module CodeLensSimple where++data A+instance Eq A where+ (==) :: A -> A -> Bool+ (==) = _++data B+instance Eq B where+ (==)= _
+ test/testdata/CodeLensSimple.hs view
@@ -0,0 +1,9 @@+module CodeLensSimple where++data A+instance Eq A where+ (==) = _++data B+instance Eq B where+ (==)= _
+ test/testdata/CodeLensWithGHC2021.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GHC2021 #-}+module CodeLensWithGHC2021 where++data A+instance Eq A where+ (==) :: A -> A -> Bool+ (==) = _
+ test/testdata/CodeLensWithGHC2021.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE GHC2021 #-}+module CodeLensWithGHC2021 where++data A+instance Eq A where+ (==) = _
+ test/testdata/CodeLensWithPragma.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE InstanceSigs #-}+module CodeLensWithPragma where++data A+instance Eq A where+ (==) :: A -> A -> Bool+ (==) = _
+ test/testdata/CodeLensWithPragma.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE InstanceSigs #-}+module CodeLensWithPragma where++data A+instance Eq A where+ (==) = _
+ test/testdata/Inline.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE InstanceSigs #-}+module Inline where++data A+instance Eq A where (==) :: A -> A -> Bool+ (==) = _
+ test/testdata/Inline.hs view
@@ -0,0 +1,4 @@+module Inline where++data A+instance Eq A where (==) = _
+ test/testdata/InsertPragmaOnce.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE InstanceSigs #-}+module InsertPragmaOnce where++data A aaa+instance Applicative A where+ pure :: a -> A a+ pure = _+ (<*>) :: A (a -> b) -> A a -> A b+ (<*>) = _
+ test/testdata/InsertPragmaOnce.hs view
@@ -0,0 +1,4 @@+module InsertPragmaOnce where++data A aaa+instance Applicative A
+ test/testdata/InsertWithGHC2021Enabled.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GHC2021#-}+module InsertWithGHC2021Enabled where++data A+instance Eq A where+ (==) :: A -> A -> Bool+ (==) = _
+ test/testdata/InsertWithGHC2021Enabled.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE GHC2021#-}+module InsertWithGHC2021Enabled where++data A+instance Eq A
+ test/testdata/InsertWithPragma.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE InstanceSigs #-}+module InsertWithPragma where++data A+instance Eq A where+ (==) :: A -> A -> Bool+ (==) = _
+ test/testdata/InsertWithPragma.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE InstanceSigs #-}+module InsertWithPragma where++data A+instance Eq A
+ test/testdata/InsertWithoutPragma.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE InstanceSigs #-}+module InsertWithoutPragma where++data A+instance Eq A where+ (==) :: A -> A -> Bool+ (==) = _
+ test/testdata/InsertWithoutPragma.hs view
@@ -0,0 +1,4 @@+module InsertWithoutPragma where++data A+instance Eq A
+ test/testdata/LocalClassDefine.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE InstanceSigs #-}+module LocalClassDefine where++data A+class F a where+ f :: a -> Int++instance F A where+ f :: A -> Int+ f = _
+ test/testdata/LocalClassDefine.hs view
@@ -0,0 +1,8 @@+module LocalClassDefine where++data A+class F a where+ f :: a -> Int++instance F A where+ f = _
+ test/testdata/Qualified.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE InstanceSigs #-}+module Qualified where+import qualified QualifiedA++class F a where+ f :: a++instance F QualifiedA.A where+ f :: QualifiedA.A+ f = undefined
+ test/testdata/Qualified.hs view
@@ -0,0 +1,8 @@+module Qualified where+import qualified QualifiedA++class F a where+ f :: a++instance F QualifiedA.A where+ f = undefined
+ test/testdata/QualifiedA.hs view
@@ -0,0 +1,3 @@+module QualifiedA where++data A
+ test/testdata/T6.1.expected.hs view
@@ -0,0 +1,22 @@+module T6 where++data X = X | Y++class Test a where+ f :: a -> a+ f = h++ g :: a++ h :: a -> a+ h = f++ i :: a++ {-# MINIMAL f, g, i | g, h #-}++instance Test X where+ f X = X+ f Y = Y+ i = undefined+ g = _
+ test/testdata/T6.2.expected.hs view
@@ -0,0 +1,23 @@+module T6 where++data X = X | Y++class Test a where+ f :: a -> a+ f = h++ g :: a++ h :: a -> a+ h = f++ i :: a++ {-# MINIMAL f, g, i | g, h #-}++instance Test X where+ f X = X+ f Y = Y+ i = undefined+ g = _+ h = _
+ test/testdata/T6.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GHC2021#-}+module T6 where++data A+instance Eq A where+ (==) :: A -> A -> Bool+ (==) = _
+ test/testdata/T6.hs view
@@ -0,0 +1,21 @@+module T6 where++data X = X | Y++class Test a where+ f :: a -> a+ f = h++ g :: a++ h :: a -> a+ h = f++ i :: a++ {-# MINIMAL f, g, i | g, h #-}++instance Test X where+ f X = X+ f Y = Y+ i = undefined
+ test/testdata/TypeFamily.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE InstanceSigs #-}+module TypeFamily where++class F a where+ type Elem a+ f :: Elem a -> a++instance Eq a => F [a] where+ f :: Eq a => Elem [a] -> [a]+ f = _
+ test/testdata/TypeFamily.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TypeFamilies #-}+module TypeFamily where++class F a where+ type Elem a+ f :: Elem a -> a++instance Eq a => F [a] where+ f = _