Emit holes as diagnostics (#1653)

* ExactPrint with annotations

* Implement getAllHoles method

* setup hole diagnostics

* Get hole diagnostics working

* Use config in the hole rule

* Chop out old ideas

* Tidying

* Not sure where this discrepancy comes from, but yolo

* Try bumping bounds to 8.10

* ahhhh

* Add getDiagnosticsAction

* Maybe better way of getting the severity?

* Put property support in ghcide

* Minor tidying

* Hlint + bad merge double whammy of annoyingness

* Remove getDiagnosticsAction

Author: isovector

ghcide/src/Development/IDE/Core/Rules.hs

@@ -27,6 +27,7 @@ module Development.IDE.Core.Rules(
     getParsedModule,
     getParsedModuleWithComments,
     getClientConfigAction,
+    usePropertyAction,
     -- * Rules
     CompiledLinkables(..),
     IsHiFileStable(..),
@@ -139,7 +140,12 @@ import           Language.LSP.Types                           (SMethod (SCustomM
 import           Language.LSP.VFS
 import           Module
 import           TcRnMonad                                    (tcg_dependent_files)
-import Control.Applicative
+
+import           Ide.Plugin.Properties (HasProperty, KeyNameProxy, Properties, ToHsType, useProperty)
+import           Ide.Types (PluginId)
+import           Data.Default (def)
+import           Ide.PluginUtils (configForPlugin)
+import           Control.Applicative
 
 -- | This is useful for rules to convert rules that can only produce errors or
 -- a result into the more general IdeResult type that supports producing
@@ -940,6 +946,19 @@ getClientConfigAction defValue = do
     Just (Success c) -> return c
     _                -> return defValue
 
+usePropertyAction ::
+  (HasProperty s k t r) =>
+  KeyNameProxy s ->
+  PluginId ->
+  Properties r ->
+  Action (ToHsType t)
+usePropertyAction kn plId p = do
+  config <- getClientConfigAction def
+  let pluginConfig = configForPlugin config plId
+  pure $ useProperty kn p $ plcConfig pluginConfig
+
+-- ---------------------------------------------------------------------
+
 -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH
 getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
 getLinkableType f = use_ NeedsCompilation f

plugins/hls-tactics-plugin/hls-tactics-plugin.cabal

@@ -81,6 +81,7 @@ library
     , text
     , transformers
     , deepseq
+    , unordered-containers
 
   default-language: Haskell2010
   default-extensions:

plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies      #-}
 
 module Wingman.LanguageServer where
 
@@ -12,25 +13,30 @@ import           Data.Coerce
 import           Data.Functor ((<&>))
 import           Data.Generics.Aliases (mkQ)
 import           Data.Generics.Schemes (everything)
+import qualified Data.HashMap.Strict as Map
 import           Data.IORef (readIORef)
 import qualified Data.Map as M
 import           Data.Maybe
 import           Data.Monoid
 import qualified Data.Set  as S
 import qualified Data.Text as T
 import           Data.Traversable
+import           Development.IDE (getFilesOfInterest, ShowDiagnostic (ShowDiag), srcSpanToRange)
 import           Development.IDE (hscEnv)
+import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes
+import           Development.IDE.Core.Rules (usePropertyAction)
 import           Development.IDE.Core.Service (runAction)
-import           Development.IDE.Core.Shake (IdeState (..), use)
+import           Development.IDE.Core.Shake (IdeState (..), uses, define, use)
 import qualified Development.IDE.Core.Shake as IDE
 import           Development.IDE.Core.UseStale
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Error (realSrcSpanToRange)
 import           Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings)
-import           Development.Shake (Action, RuleResult)
+import           Development.Shake (Action, RuleResult, Rules, action)
 import           Development.Shake.Classes (Typeable, Binary, Hashable, NFData)
 import qualified FastString
+import           GHC.Generics (Generic)
 import           GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope, ExternalPackageState, HscEnv (hsc_EPS), liftIO)
 import qualified Ide.Plugin.Config as Plugin
 import           Ide.Plugin.Properties
@@ -109,7 +115,8 @@ unsafeRunStaleIde state nfp a = do
 ------------------------------------------------------------------------------
 
 properties :: Properties
-  '[ 'PropertyKey "max_use_ctor_actions" 'TInteger
+  '[ 'PropertyKey "hole_severity" ('TEnum (Maybe DiagnosticSeverity))
+   , 'PropertyKey "max_use_ctor_actions" 'TInteger
    , 'PropertyKey "features" 'TString
    , 'PropertyKey "timeout_duration" 'TInteger
    ]
@@ -120,6 +127,15 @@ properties = emptyProperties
     "Feature set used by Wingman" ""
   & defineIntegerProperty #max_use_ctor_actions
     "Maximum number of `Use constructor <x>` code actions that can appear" 5
+  & defineEnumProperty #hole_severity
+    "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities."
+    [ (Just DsError,   "error")
+    , (Just DsWarning, "warning")
+    , (Just DsInfo,    "info")
+    , (Just DsHint,    "hint")
+    , (Nothing,        "none")
+    ]
+    Nothing
 
 
 -- | Get the the plugin config
@@ -421,3 +437,61 @@ mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show uf
 showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m ()
 showLspMessage = sendNotification SWindowShowMessage
 
+
+-- This rule only exists for generating file diagnostics
+-- so the RuleResult is empty
+data WriteDiagnostics = WriteDiagnostics
+    deriving (Eq, Show, Typeable, Generic)
+
+instance Hashable WriteDiagnostics
+instance NFData   WriteDiagnostics
+instance Binary   WriteDiagnostics
+
+type instance RuleResult WriteDiagnostics = ()
+
+wingmanRules :: PluginId -> Rules ()
+wingmanRules plId = do
+  define $ \WriteDiagnostics nfp ->
+    usePropertyAction #hole_severity plId properties >>= \case
+      Nothing -> pure (mempty, Just ())
+      Just severity ->
+        use GetParsedModule nfp >>= \case
+          Nothing ->
+            pure ([], Nothing)
+          Just pm -> do
+            let holes :: [Range]
+                holes =
+                  everything (<>)
+                    (mkQ mempty $ \case
+                      L span (HsVar _ (L _ name))
+                        | isHole (occName name) ->
+                            maybeToList $ srcSpanToRange span
+                      L span (HsUnboundVar _ (TrueExprHole occ))
+                        | isHole occ ->
+                            maybeToList $ srcSpanToRange span
+#if __GLASGOW_HASKELL__ <= 808
+                      L span (EWildPat _) ->
+                        maybeToList $ srcSpanToRange span
+#endif
+                      (_ :: LHsExpr GhcPs) -> mempty
+                    ) $ pm_parsed_source pm
+            pure
+              ( fmap (\r -> (nfp, ShowDiag, mkDiagnostic severity r)) holes
+              , Just ()
+              )
+
+  action $ do
+    files <- getFilesOfInterest
+    void $ uses WriteDiagnostics $ Map.keys files
+
+
+mkDiagnostic :: DiagnosticSeverity -> Range -> Diagnostic
+mkDiagnostic severity r =
+  Diagnostic r
+    (Just severity)
+    (Just $ InR "hole")
+    (Just "wingman")
+    "Hole"
+    (Just $ List [DtUnnecessary])
+    Nothing
+

plugins/hls-tactics-plugin/src/Wingman/Plugin.hs

@@ -49,6 +49,7 @@ descriptor plId = (defaultPluginDescriptor plId)
             [minBound .. maxBound]
   , pluginHandlers =
       mkPluginHandler STextDocumentCodeAction codeActionProvider
+  , pluginRules = wingmanRules plId
   , pluginCustomConfig =
       mkCustomConfig properties
   }