hls-class-plugin enhancement

exe/Plugins.hs

@@ -160,7 +160,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
       CallHierarchy.descriptor :
 #endif
 #if class
-      Class.descriptor "class" :
+      Class.descriptor pluginRecorder "class" :
 #endif
 #if haddockComments
       HaddockComments.descriptor "haddockComments" :

plugins/hls-class-plugin/README.md

@@ -0,0 +1,12 @@
+# Class Plugin
+
+The class plugin provides handy operations about class, includes:
+
+1. Code action to add minimul class definition methods.
+2. Type lens about missing type signatures for instance methods.
+
+## Demo
+
+![Code Actions](codeactions.gif)
+
+![Code Lens](codelens.gif)

plugins/hls-class-plugin/hls-class-plugin.cabal

@@ -22,13 +22,22 @@ extra-source-files:
 
 library
   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
     , ghcide          ^>=1.7
+    , ghc-boot-th
+    , hls-graph
     , hls-plugin-api  ^>=1.4
     , lens
     , lsp
@@ -44,8 +53,9 @@ library
   default-extensions:
     DataKinds
     TypeOperators
+    OverloadedStrings
 
-  ghc-options:        -Wno-unticked-promoted-constructors
+  ghc-options:        -Wall -Wno-unticked-promoted-constructors -Wno-name-shadowing
 
 test-suite tests
   type:             exitcode-stdio-1.0
@@ -54,9 +64,11 @@ test-suite tests
   main-is:          Main.hs
   ghc-options:      -threaded -rtsopts -with-rtsopts=-N
   build-depends:
+    , aeson
     , base
     , filepath
     , hls-class-plugin
+    , hls-plugin-api
     , hls-test-utils     ^>=1.3
     , lens
     , lsp-types

plugins/hls-class-plugin/src/Ide/Plugin/Class.hs

@@ -1,255 +1,26 @@
-{-# 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) 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
-  }
-
-commands :: [PluginCommand IdeState]
-commands
-  = [ PluginCommand "addMinimalMethodPlaceholders" "add placeholders for minimal methods" addMethodPlaceholders
+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder plId = (defaultPluginDescriptor plId)
+    { pluginCommands = commands plId
+    , pluginRules = rules recorder
+    , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction
+        <> mkPluginHandler STextDocumentCodeLens codeLens
+    , pluginConfigDescriptor =
+        defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties }
+    }
+
+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
-          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)