Use hole fit plugins to record holes instead of parsing error messages

src/Development/IDE/Core/Compile.hs

@@ -71,6 +71,7 @@ import           StringBuffer                   as SB
 import           TcRnMonad
 import           TcIface                        (typecheckIface)
 import           TidyPgm
+import Constraint
 
 import Control.Exception.Safe
 import Control.Monad.Extra
@@ -94,6 +95,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import PrelNames
 import HeaderInfo
 import Maybes (orElse)
+import TcHoleErrors
 
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
 parseModule
@@ -125,7 +127,7 @@ typecheckModule :: IdeDefer
                 -> HscEnv
                 -> [Linkable] -- ^ linkables not to unload
                 -> ParsedModule
-                -> IO (IdeResult TcModuleResult)
+                -> IO (IdeResult (TcModuleResult, [(SrcSpan,HoleFit)]))
 typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
     fmap (either (,Nothing) id) $
       catchSrcErrors (hsc_dflags hsc) "typecheck" $ do
@@ -134,32 +136,44 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
             dflags = ms_hspp_opts modSummary
 
         modSummary' <- initPlugins hsc modSummary
-        (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
+        (warnings, (tcm, holes)) <- withWarnings "typecheck" $ \tweak ->
             tcRnModule hsc keep_lbls $ enableTopLevelWarnings
                                      $ enableUnnecessaryAndDeprecationWarnings
                                      $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
         let errorPipeline = unDefer . hideDiag dflags . tagDiag
             diags = map errorPipeline warnings
             deferedError = any fst diags
-        return (map snd diags, Just $ tcm{tmrDeferedError = deferedError})
+        return (map snd diags, Just $ (tcm{tmrDeferedError = deferedError}, holes))
     where
         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
 
-tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult
+tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO (TcModuleResult,[(SrcSpan,HoleFit)])
 tcRnModule hsc_env keep_lbls pmod = do
+  holesRef <- newIORef []
   let ms = pm_mod_summary pmod
-      hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
-
+      hsc_env_tmp = hsc_env { hsc_dflags = (ms_hspp_opts ms){staticPlugins = staticPlugins (ms_hspp_opts ms) ++ [holesPlugin]} }
+      holesPlugin = StaticPlugin $ PluginWithArgs (defaultPlugin { holeFitPlugin = pluginWorker }) []
+      pluginWorker _ = Just $ HoleFitPluginR
+        { hfPluginInit = liftIO $ newIORef ()
+        , hfPluginRun = const $ HoleFitPlugin (\_ cs -> pure cs) $ \hole fits -> do
+            let span = case tyHCt hole of
+                  Just (ctLocSpan . ctLoc -> span) -> RealSrcSpan span
+                  Nothing -> noSrcSpan
+            liftIO $ modifyIORef holesRef $ (map (span,) fits ++)
+            pure fits
+        , hfPluginStop = const (pure ())
+        }
   unload hsc_env_tmp keep_lbls
   (tc_gbl_env, mrn_info) <-
       hscTypecheckRename hsc_env_tmp ms $
                 HsParsedModule { hpm_module = parsedSource pmod,
                                  hpm_src_files = pm_extra_src_files pmod,
                                  hpm_annotations = pm_annotations pmod }
+  holes <- readIORef holesRef
   let rn_info = case mrn_info of
         Just x -> x
         Nothing -> error "no renamed info tcRnModule"
-  pure (TcModuleResult pmod rn_info tc_gbl_env False)
+  pure (TcModuleResult pmod rn_info tc_gbl_env False, holes)
 
 mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
 mkHiFileResultNoCompile session tcm = do

src/Development/IDE/Core/Rules.hs

@@ -205,7 +205,7 @@ getHomeHieFile f = do
       wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do
         hsc <- hscEnv <$> use_ GhcSession f
         pm <- use_ GetParsedModule f
-        (_, mtm)<- typeCheckRuleDefinition hsc pm
+        (_, mtm)<- typeCheckRuleDefinition hsc f pm
         mapM_ (getHieAstRuleDefinition f hsc) mtm -- Write the HiFile to disk
       _ <- MaybeT $ liftIO $ timeout 1 wait
       ncu <- mkUpdater
@@ -576,7 +576,7 @@ typeCheckRule :: Rules ()
 typeCheckRule = define $ \TypeCheck file -> do
     pm <- use_ GetParsedModule file
     hsc  <- hscEnv <$> use_ GhcSessionDeps file
-    typeCheckRuleDefinition hsc pm
+    typeCheckRuleDefinition hsc file pm
 
 knownFilesRule :: Rules ()
 knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do
@@ -596,9 +596,10 @@ getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do
 -- retain the information forever in the shake graph.
 typeCheckRuleDefinition
     :: HscEnv
+    -> NormalizedFilePath
     -> ParsedModule
     -> Action (IdeResult TcModuleResult)
-typeCheckRuleDefinition hsc pm = do
+typeCheckRuleDefinition hsc fp pm = do
   setPriority priorityTypeCheck
   IdeOptions { optDefer = defer } <- getIdeOptions
 
@@ -607,13 +608,15 @@ typeCheckRuleDefinition hsc pm = do
   addUsageDependencies $ liftIO $
     typecheckModule defer hsc linkables_to_keep pm
   where
-    addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
+    -- addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
     addUsageDependencies a = do
+      ShakeExtras {holesMap} <- getShakeExtras
       r@(_, mtc) <- a
-      forM_ mtc $ \tc -> do
+      forM_ mtc $ \(tc, hfs) -> do
         used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc
         void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)
-      return r
+        liftIO $ modifyVar_ holesMap $ \(HolesMap m) -> pure $ HolesMap $ HM.insert (filePathToUri' fp) hfs m
+      return $ second (fmap fst) r
 
 -- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload.
 -- Doesn't actually contain the code, since we don't need it to unload
@@ -849,7 +852,7 @@ regenerateHiFile sess f ms compNeeded = do
         Just pm -> do
             -- Invoke typechecking directly to update it without incurring a dependency
             -- on the parsed module and the typecheck rules
-            (diags', mtmr) <- typeCheckRuleDefinition hsc pm
+            (diags', mtmr) <- typeCheckRuleDefinition hsc f pm
             case mtmr of
               Nothing -> pure (diags', Nothing)
               Just tmr -> do

src/Development/IDE/Core/Shake.hs

@@ -46,6 +46,7 @@ module Development.IDE.Core.Shake(
     getIdeOptions,
     getIdeOptionsIO,
     GlobalIdeOptions(..),
+    HolesMap(..),
     garbageCollect,
     knownTargets,
     setPriority,
@@ -84,7 +85,7 @@ import qualified Data.Text as T
 import Data.Tuple.Extra
 import Data.Unique
 import Development.IDE.Core.Debouncer
-import Development.IDE.GHC.Compat (ModuleName, NameCacheUpdater(..), upNameCache )
+import Development.IDE.GHC.Compat (ModuleName, NameCacheUpdater(..), upNameCache, SrcSpan)
 import Development.IDE.GHC.Orphans ()
 import Development.IDE.Core.PositionMapping
 import Development.IDE.Types.Action
@@ -126,6 +127,7 @@ import UniqSupply
 import PrelInfo
 import Data.Int (Int64)
 import qualified Data.HashSet as HSet
+import TcHoleErrors
 
 -- information we stash inside the shakeExtra field
 data ShakeExtras = ShakeExtras
@@ -164,8 +166,14 @@ data ShakeExtras = ShakeExtras
     ,exportsMap :: Var ExportsMap
     -- | A work queue for actions added via 'runInShakeSession'
     ,actionQueue :: ActionQueue
+    -- | A list of hole fits for each file. Updated on typecheck
+    ,holesMap :: Var HolesMap
     }
 
+
+newtype HolesMap = HolesMap
+    {getHoleFits :: HashMap NormalizedUri [(SrcSpan,HoleFit)]}
+
 -- | A mapping of module name to known files
 type KnownTargets = HashMap Target [NormalizedFilePath]
 
@@ -434,6 +442,8 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
 
         actionQueue <- newQueue
 
+        holesMap <- newVar $ HolesMap mempty
+
         pure (ShakeExtras{..}, cancel progressAsync)
     (shakeDbM, shakeClose) <-
         shakeOpenDatabase

src/Development/IDE/Plugin/CodeAction.hs

@@ -52,8 +52,8 @@ import qualified Data.Text as T
 import Data.Tuple.Extra ((&&&))
 import HscTypes
 import Parser
-import Text.Regex.TDFA (mrAfter, (=~), (=~~))
-import Outputable (ppr, showSDocUnsafe)
+import Text.Regex.TDFA ((=~), (=~~))
+import Outputable (ppr, showSDocUnsafe, showSDoc, parens, cparen, sep, text, (<+>))
 import DynFlags (xFlags, FlagSpec(..))
 import GHC.LanguageExtensions.Type (Extension)
 import Data.Function
@@ -64,6 +64,8 @@ import Safe (atMay)
 import Bag (isEmptyBag)
 import qualified Data.HashSet as Set
 import Control.Concurrent.Extra (threadDelay, readVar)
+import TcHoleErrors
+import StringBuffer
 
 plugin :: Plugin c
 plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
@@ -99,12 +101,15 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
     pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env
     localExports <- readVar (exportsMap $ shakeExtras state)
     let exportsMap = localExports <> fromMaybe mempty pkgExports
+    holeFitsMap <- readVar (holesMap $ shakeExtras state)
+    let holeFits = Map.findWithDefault [] (toNormalizedUri uri) $ getHoleFits holeFitsMap
     let dflags = hsc_dflags . hscEnv <$> env
     pure . Right $
         [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
         | x <- xs, (title, tedit) <- suggestAction dflags exportsMap ideOptions parsedModule text x
         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
         ] <> caRemoveRedundantImports parsedModule text diag xs uri
+          <> suggestHoleFits dflags uri (ms_hspp_buf =<< pm_mod_summary <$> parsedModule) holeFits
 
 -- | Generate code lenses.
 codeLens
@@ -152,6 +157,34 @@ commandHandler lsp _ideState ExecuteCommandParams{..}
     | otherwise
     = return (Right Null, Nothing)
 
+suggestHoleFits
+  :: Maybe DynFlags
+  -> Uri
+  -> Maybe StringBuffer
+  -> [(SrcSpan,HoleFit)]
+  -> [CAResult]
+suggestHoleFits Nothing uri contents xs = []
+suggestHoleFits (Just dflags) uri contents xs =
+  [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) Nothing (Just edit) Nothing
+  | (RealSrcSpan range, hole) <- xs
+  , let hname = getSB range
+  , let (title,diff) = go hname hole
+  , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List [TextEdit (realSrcSpanToRange range) diff]) Nothing
+  ]
+  where
+    getSB :: RealSrcSpan -> T.Text
+    getSB sp = case atLine (srcSpanStartLine sp) =<< contents of
+      Nothing -> "_"
+      Just sb -> T.pack $ lexemeToString (offsetBytes (srcSpanStartCol sp - 1) sb) (srcSpanEndCol sp - srcSpanStartCol sp)
+    go :: T.Text -> HoleFit -> (T.Text,T.Text)
+    go name hole  = ("replace " <> name <> " with " <> edit, edit)
+      where edit = T.pack $ showSDoc dflags $ case hole of
+              RawHoleFit sdoc -> parens sdoc
+              HoleFit _ cand ty _ _ mtchs _ ->
+                let name = ppr $ getName cand
+                    holes = sep $ map (const $ text "_") mtchs
+                in cparen (not $ null $ mtchs) $ name <+> holes
+
 suggestAction
   :: Maybe DynFlags
   -> ExportsMap
@@ -178,9 +211,7 @@ suggestAction dflags packageExports ideOptions parsedModule text diag = concat
     ++ suggestDeleteUnusedBinding pm text diag
     ++ suggestExportUnusedTopBinding text pm diag
     | Just pm <- [parsedModule]
-    ] ++
-    suggestFillHole diag                   -- Lowest priority
-
+    ]
 
 suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}
@@ -561,80 +592,6 @@ suggestModuleTypo Diagnostic{_range=_range,..}
       in map proposeModule $ nubOrd $ findSuggestedModules _message
     | otherwise = []
 
-suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
-suggestFillHole Diagnostic{_range=_range,..}
-    | Just holeName <- extractHoleName _message
-    , (holeFits, refFits) <- processHoleSuggestions (T.lines _message)
-    = map (proposeHoleFit holeName False) holeFits
-    ++ map (proposeHoleFit holeName True) refFits
-    | otherwise = []
-    where
-      extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"
-      proposeHoleFit holeName parenthise name =
-          ( "replace " <> holeName <> " with " <> name
-          , [TextEdit _range $ if parenthise then parens name else name])
-      parens x = "(" <> x <> ")"
-
-processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])
-processHoleSuggestions mm = (holeSuggestions, refSuggestions)
-{-
-    • Found hole: _ :: LSP.Handlers
-
-      Valid hole fits include def
-      Valid refinement hole fits include
-        fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)
-        fromJust (_ :: Maybe LSP.Handlers)
-        haskell-lsp-types-0.22.0.0:Language.Haskell.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams
-                                                                                                        LSP.Handlers)
-        T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)
-                (_ :: LSP.Handlers)
-                (_ :: T.Text)
-        T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)
-                 (_ :: LSP.Handlers)
-                 (_ :: T.Text)
--}
-  where
-    t = id @T.Text
-    holeSuggestions = do
-      -- get the text indented under Valid hole fits
-      validHolesSection <-
-        getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm
-      -- the Valid hole fits line can contain a hole fit
-      holeFitLine <-
-        mapHead
-            (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))
-            validHolesSection
-      let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine
-      guard (not $ T.null holeFit)
-      return holeFit
-    refSuggestions = do -- @[]
-      -- get the text indented under Valid refinement hole fits
-      refinementSection <-
-        getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm
-      -- get the text for each hole fit
-      holeFitLines <- getIndentedGroups (tail refinementSection)
-      let holeFit = T.strip $ T.unwords holeFitLines
-      guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"
-      return holeFit
-
-    mapHead f (a:aa) = f a : aa
-    mapHead _ [] = []
-
--- > getIndentedGroups [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1,", "  l1", "  l2"], [" H2", "  l3"]]
-getIndentedGroups :: [T.Text] -> [[T.Text]]
-getIndentedGroups [] = []
-getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll
--- |
--- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1", "  l1", "  l2"], [" H2", "  l3"]]
-getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]
-getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of
-    (l:ll) -> case span (\l' -> indentation l < indentation l') ll of
-        (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest
-    _ -> []
-
-indentation :: T.Text -> Int
-indentation = T.length . T.takeWhile isSpace
-
 suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}
     | Just [binding, mod, srcspan] <-

test/exe/Main.hs

@@ -1633,7 +1633,7 @@ fillTypedHoleTests = let
   , check "replace _c with parameterInt"
           "_a" "_b" "_c"
           "_a" "_b"  "parameterInt"
-  , check "replace _ with foo _"
+  , check "replace _ with (foo _)"
           "_" "n" "n"
           "(foo _)" "n" "n"
   ]