Revert "Migrate hls-class-plugin to use StructuredMessage"

This reverts commit 51515ff.

Author: fendor

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

@@ -1,15 +1,10 @@
 {-# LANGUAGE GADTs           #-}
-{-# LANGUAGE LambdaCase      #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns    #-}
 
-module Ide.Plugin.Class.CodeAction (
-    addMethodPlaceholders,
-    codeAction,
-) where
+module Ide.Plugin.Class.CodeAction where
 
-import           Control.Arrow                        ((>>>))
 import           Control.Lens                         hiding (List, use)
 import           Control.Monad.Error.Class            (MonadError (throwError))
 import           Control.Monad.Extra
@@ -18,6 +13,8 @@ import           Control.Monad.Trans.Class            (lift)
 import           Control.Monad.Trans.Except           (ExceptT)
 import           Control.Monad.Trans.Maybe
 import           Data.Aeson                           hiding (Null)
+import           Data.Bifunctor                       (second)
+import           Data.Either.Extra                    (rights)
 import           Data.List
 import           Data.List.Extra                      (nubOrdOn)
 import qualified Data.Map.Strict                      as Map
@@ -26,14 +23,11 @@ import           Data.Maybe                           (isNothing, listToMaybe,
 import qualified Data.Set                             as Set
 import qualified Data.Text                            as T
 import           Development.IDE
+import           Development.IDE.Core.Compile         (sourceTypecheck)
 import           Development.IDE.Core.FileStore       (getVersionedTextDoc)
 import           Development.IDE.Core.PluginUtils
 import           Development.IDE.Core.PositionMapping (fromCurrentRange)
 import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Compat.Error     (TcRnMessage (..),
-                                                       _TcRnMessage,
-                                                       stripTcRnMessageContext,
-                                                       msgEnvelopeErrorL)
 import           Development.IDE.GHC.Compat.Util
 import           Development.IDE.Spans.AtPoint        (pointCommand)
 import           Ide.Plugin.Class.ExactPrint
@@ -86,25 +80,23 @@ addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do
 -- 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 Method_TextDocumentCodeAction
-codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do
+codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do
     verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId
     nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)
-    activeDiagnosticsInRange (shakeExtras state) nfp caRange
-        >>= \case
-        Nothing -> pure $ InL []
-        Just fileDiags -> do
-            actions <- join <$> mapM (mkActions nfp verTxtDocId) (methodDiags fileDiags)
-            pure $ InL actions
+    actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags
+    pure $ InL actions
     where
-        methodDiags fileDiags =
-            mapMaybe (\d -> (d,) <$> isClassMethodWarning (d ^. fdStructuredMessageL)) fileDiags
+        diags = context ^. L.diagnostics
+
+        ghcDiags = filter (\d -> d ^. L.source == Just sourceTypecheck) diags
+        methodDiags = filter (\d -> isClassMethodWarning (d ^. L.message)) ghcDiags
 
         mkActions
             :: NormalizedFilePath
             -> VersionedTextDocumentIdentifier
-            -> (FileDiagnostic, ClassMinimalDef)
+            -> Diagnostic
             -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction]
-        mkActions docPath verTxtDocId (diag, classMinDef) = do
+        mkActions docPath verTxtDocId diag = do
             (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state
                 $ useWithStaleE GetHieAst docPath
             instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $
@@ -116,19 +108,21 @@ codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do
                 $ useE GetInstanceBindTypeSigs docPath
             (tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath
             (hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath
-            logWith recorder Debug (LogImplementedMethods cls classMinDef)
+            implemented <- findImplementedMethods ast instancePosition
+            logWith recorder Info (LogImplementedMethods cls implemented)
             pure
                 $ concatMap mkAction
                 $ nubOrdOn snd
                 $ filter ((/=) mempty . snd)
-                $ mkMethodGroups hsc gblEnv range sigs classMinDef
+                $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))
+                $ mkMethodGroups hsc gblEnv range sigs cls
             where
-                range = diag ^. fdLspDiagnosticL . L.range
+                range = diag ^. L.range
 
-                mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup]
-                mkMethodGroups hsc gblEnv range sigs classMinDef = minimalDef <> [allClassMethods]
+                mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
+                mkMethodGroups hsc gblEnv range sigs cls = minimalDef <> [allClassMethods]
                     where
-                        minimalDef = minDefToMethodGroups hsc gblEnv range sigs classMinDef
+                        minimalDef = minDefToMethodGroups hsc gblEnv range sigs $ classMinimalDef cls
                         allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs)
 
                 mkAction :: MethodGroup -> [Command |? CodeAction]
@@ -169,6 +163,25 @@ codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do
                         <=< nodeChildren
                     )
 
+        findImplementedMethods
+            :: HieASTs a
+            -> Position
+            -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [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, _) <- runActionE "classplugin.findClassFromIdentifier.GhcSessionDeps" state
                 $ useWithStaleE GhcSessionDeps docPath
@@ -190,15 +203,12 @@ isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool
 isClassNodeIdentifier (Right i) ident  | 'C':':':_ <- unpackFS $ occNameFS $ occName i = (isNothing . identType) ident && Use `Set.member` identInfo ident
 isClassNodeIdentifier _ _ = False
 
-isClassMethodWarning :: StructuredMessage -> Maybe ClassMinimalDef
-isClassMethodWarning message = case message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of
-    Nothing          -> Nothing
-    Just tcRnMessage -> isUnsatisfiedMinimalDefWarning tcRnMessage
+isClassMethodWarning :: T.Text -> Bool
+isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"
 
-isUnsatisfiedMinimalDefWarning :: TcRnMessage -> Maybe ClassMinimalDef
-isUnsatisfiedMinimalDefWarning = stripTcRnMessageContext >>> \case
-    TcRnUnsatisfiedMinimalDef classMinDef -> Just classMinDef
-    _ -> Nothing
+isInstanceValBind :: ContextInfo -> Bool
+isInstanceValBind (ValBind InstanceBind _ _) = True
+isInstanceValBind _                          = False
 
 type MethodSignature = T.Text
 type MethodName = T.Text

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

@@ -112,15 +112,15 @@ instance NFData InstanceBindLensResult where
 type instance RuleResult GetInstanceBindLens = InstanceBindLensResult
 
 data Log
-  = LogImplementedMethods Class ClassMinimalDef
+  = LogImplementedMethods Class [T.Text]
   | LogShake Shake.Log
 
 instance Pretty Log where
   pretty = \case
     LogImplementedMethods cls methods ->
-      pretty ("The following methods are missing" :: String)
+      pretty ("Detected implemented methods for class" :: String)
         <+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name
-        <+> pretty (showSDocUnsafe $ ppr methods)
+        <+> pretty methods
     LogShake log -> pretty log
 
 data BindInfo = BindInfo