refact: extract AddArgument logic

Author: Santiago Weight

plugins/hls-refactor-plugin/hls-refactor-plugin.cabal

@@ -34,6 +34,8 @@ library
   other-modules:    Development.IDE.Plugin.CodeAction.Args
                     Development.IDE.Plugin.CodeAction.ExactPrint
                     Development.IDE.Plugin.CodeAction.PositionIndexed
+                    Development.IDE.Plugin.Plugins.AddArgument
+                    Development.IDE.Plugin.Plugins.Diagnostic
   default-extensions:
     BangPatterns
     CPP

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

@@ -38,7 +38,6 @@ import           Data.Ord                                          (comparing)
 import qualified Data.Set                                          as S
 import qualified Data.Text                                         as T
 import qualified Data.Text.Utf16.Rope                              as Rope
-import           Data.Tuple.Extra                                  (first)
 import           Development.IDE.Core.Rules
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service
@@ -57,6 +56,7 @@ import           Development.IDE.Plugin.CodeAction.ExactPrint
 import           Development.IDE.Plugin.CodeAction.PositionIndexed
 import           Development.IDE.Plugin.CodeAction.Util
 import           Development.IDE.Plugin.Completions.Types
+import qualified Development.IDE.Plugin.Plugins.AddArgument
 import           Development.IDE.Plugin.TypeLenses                 (suggestSignature)
 import           Development.IDE.Types.Exports
 import           Development.IDE.Types.Location
@@ -65,8 +65,7 @@ import           Development.IDE.Types.Logger                      hiding
 import           Development.IDE.Types.Options
 import           GHC.Exts                                          (fromList)
 import qualified GHC.LanguageExtensions                            as Lang
-import           Ide.PluginUtils                                   (makeDiffTextEdit,
-                                                                    subRange)
+import           Ide.PluginUtils                                   (subRange)
 import           Ide.Types
 import qualified Language.LSP.Server                               as LSP
 import           Language.LSP.Types                                (ApplyWorkspaceEditParams (..),
@@ -92,15 +91,8 @@ import           Language.LSP.VFS                                  (VirtualFile,
 import qualified Text.Fuzzy.Parallel                               as TFP
 import           Text.Regex.TDFA                                   (mrAfter,
                                                                     (=~), (=~~))
-#if MIN_VERSION_ghc(9,2,1)
-import           Data.Either.Extra                                 (maybeToEither)
-import           GHC.Types.SrcLoc                                  (generatedSrcSpan)
-import           Language.Haskell.GHC.ExactPrint                   (noAnnSrcSpanDP1,
-                                                                    runTransformT)
-#endif
 #if MIN_VERSION_ghc(9,2,0)
-import           Control.Monad.Except                              (lift)
-import           Debug.Trace
+import           Development.IDE.Plugin.Plugins.Diagnostic
 import           GHC                                               (AddEpAnn (AddEpAnn),
                                                                     Anchor (anchor_op),
                                                                     AnchorOperation (..),
@@ -109,17 +101,7 @@ import           GHC                                               (AddEpAnn (Ad
                                                                     EpAnn (..),
                                                                     EpaLocation (..),
                                                                     LEpaComment,
-                                                                    LocatedA,
-                                                                    SrcSpanAnn' (SrcSpanAnn),
-                                                                    SrcSpanAnnA,
-                                                                    SrcSpanAnnN,
-                                                                    TrailingAnn (..),
-                                                                    addTrailingAnnToA,
-                                                                    emptyComments,
-                                                                    noAnn)
-import           GHC.Hs                                            (IsUnicodeSyntax (..))
-import           Language.Haskell.GHC.ExactPrint.Transform         (d1)
-
+                                                                    LocatedA)
 #else
 import           Language.Haskell.GHC.ExactPrint.Types             (Annotation (annsDP),
                                                                     DeltaPos,
@@ -190,7 +172,7 @@ bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
 #endif
     , wrap suggestNewDefinition
 #if MIN_VERSION_ghc(9,2,1)
-    , wrap suggestAddArgument
+    , wrap Development.IDE.Plugin.Plugins.AddArgument.plugin
 #endif
     , wrap suggestDeleteUnusedBinding
     ]
@@ -905,34 +887,6 @@ suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
         = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
     | otherwise = []
 
-matchVariableNotInScope :: T.Text -> Maybe (T.Text, Maybe T.Text)
-matchVariableNotInScope message
-  --     * Variable not in scope:
-  --         suggestAcion :: Maybe T.Text -> Range -> Range
-  --     * Variable not in scope:
-  --         suggestAcion
-  | Just (name, typ) <- matchVariableNotInScopeTyped message = Just (name, Just typ)
-  | Just name <- matchVariableNotInScopeUntyped message = Just (name, Nothing)
-  | otherwise = Nothing
-  where
-    matchVariableNotInScopeTyped message
-      | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" =
-          Just (name, typ)
-      | otherwise = Nothing
-    matchVariableNotInScopeUntyped message
-      | Just [name] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+)" =
-          Just name
-      | otherwise = Nothing
-
-matchFoundHole :: T.Text -> Maybe (T.Text, T.Text)
-matchFoundHole message
-  | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" =
-      Just (name, typ)
-  | otherwise = Nothing
-
-matchFoundHoleIncludeUnderscore :: T.Text -> Maybe (T.Text, T.Text)
-matchFoundHoleIncludeUnderscore message = first ("_" <>) <$> matchFoundHole message
-
 suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestNewDefinition ideOptions parsedModule contents Diagnostic {_message, _range}
   | Just (name, typ) <- matchVariableNotInScope message =
@@ -962,121 +916,6 @@ newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ
     sig = name <> colon <> T.dropWhileEnd isSpace (fromMaybe "_" typ)
     ParsedModule {pm_parsed_source = L _ HsModule {hsmodDecls}} = parsedModule
 
-#if MIN_VERSION_ghc(9,2,1)
--- When GHC tells us that a variable is not bound, it will tell us either:
---  - there is an unbound variable with a given type
---  - there is an unbound variable (GHC provides no type suggestion)
---
--- When we receive either of these errors, we produce a text edit that will add a new argument (as a new pattern in the
--- last position of each LHS of the top-level bindings for this HsDecl).
---
--- NOTE When adding a new argument to a declaration, the corresponding argument's type in declaration's signature might
---      not be the last type in the signature, such as:
---         foo :: a -> b -> c -> d
---         foo a b = \c -> ...
---      In this case a new argument would have to add its type between b and c in the signature.
-suggestAddArgument :: ParsedModule -> Diagnostic -> Either ResponseError [(T.Text, [TextEdit])]
-suggestAddArgument parsedModule Diagnostic {_message, _range}
-  | Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ
-  | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ)
-  | otherwise = pure []
-  where
-    message = unifySpaces _message
-
--- Given a name for the new binding, add a new pattern to the match in the last position,
--- returning how many patterns there were in this match prior to the transformation:
---      addArgToMatch "foo" `bar arg1 arg2 = ...`
---   => (`bar arg1 arg2 foo = ...`, 2)
-addArgToMatch :: T.Text -> GenLocated l (Match GhcPs body) -> (GenLocated l (Match GhcPs body), Int)
-addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) =
-  let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name
-      newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName)
-  in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) rhs), length pats)
-
--- Attempt to insert a binding pattern into each match for the given LHsDecl; succeeds only if the function is a FunBind.
--- Also return:
---   - the declaration's name
---   - the number of bound patterns in the declaration's matches prior to the transformation
---
--- For example:
---    insertArg "new_pat" `foo bar baz = 1`
--- => (`foo bar baz new_pat = 1`, Just ("foo", 2))
-appendFinalPatToMatches :: T.Text -> LHsDecl GhcPs -> TransformT (Either ResponseError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int))
-appendFinalPatToMatches name = \case
-  (L locDecl (ValD xVal (FunBind xFunBind idFunBind mg coreFunBind))) -> do
-    (mg', numPatsMay) <- modifyMgMatchesT' mg (pure . second Just . addArgToMatch name) Nothing combineMatchNumPats
-    numPats <- lift $ maybeToEither (responseError "Unexpected empty match group in HsDecl") numPatsMay
-    let decl' = L locDecl (ValD xVal (FunBind xFunBind idFunBind mg' coreFunBind))
-    pure (decl', Just (idFunBind, numPats))
-  decl -> pure (decl, Nothing)
-  where
-    combineMatchNumPats  Nothing other = pure other
-    combineMatchNumPats  other Nothing = pure other
-    combineMatchNumPats  (Just l) (Just r)
-      | l == r = pure (Just l)
-      | otherwise = Left $ responseError "Unexpected different numbers of patterns in HsDecl MatchGroup"
-
--- The add argument works as follows:
---  1. Attempt to add the given name as the last pattern of the declaration that contains `range`.
---  2. If such a declaration exists, use that declaration's name to modify the signature of said declaration, if it
---     has a type signature.
---
--- NOTE For the following situation, the type signature is not updated (it's unclear what should happen):
---   type FunctionTySyn = () -> Int
---   foo :: FunctionTySyn
---   foo () = new_def
---
--- TODO instead of inserting a typed hole; use GHC's suggested type from the error
-addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])]
-addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do
-    (newSource, _, _) <- runTransformT $ do
-      (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl (makeDeltaAst moduleSrc)
-      case matchedDeclNameMay of
-          Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc'
-          Nothing -> pure moduleSrc'
-    let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource)
-    pure [("Add argument ‘" <> name <> "’ to function", fromLspList diff)]
-  where
-    addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg
-    addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name
-
-    spanContainsRangeOrErr = maybeToEither (responseError "SrcSpan was not valid range") . (`spanContainsRange` range)
-
--- Transform an LHsType into a list of arguments and return type, to make transformations easier.
-hsTypeToFunTypeAsList :: LHsType GhcPs -> ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs)
-hsTypeToFunTypeAsList = \case
-  L spanAnnA (HsFunTy xFunTy arrow lhs rhs) ->
-    let (rhsArgs, rhsRes) = hsTypeToFunTypeAsList rhs
-    in ((spanAnnA, xFunTy, arrow, lhs):rhsArgs, rhsRes)
-  ty -> ([], ty)
-
--- The inverse of `hsTypeToFunTypeAsList`
-hsTypeFromFunTypeAsList :: ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs) -> LHsType GhcPs
-hsTypeFromFunTypeAsList (args, res) =
-  foldr (\(spanAnnA, xFunTy, arrow, argTy) res -> L spanAnnA $ HsFunTy xFunTy arrow argTy res) res args
-
--- Add a typed hole to a type signature in the given argument position:
---   0 `foo :: ()` => foo :: _ -> ()
---   2 `foo :: FunctionTySyn` => foo :: FunctionTySyn
---   1 `foo :: () -> () -> Int` => foo :: () -> _ -> () -> Int
-addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> (LHsSigType GhcPs)
-addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) =
-    let (args, res) = hsTypeToFunTypeAsList lsigTy
-        wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem [AddRarrowAnn d1]) emptyComments) generatedSrcSpan
-        newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow NormalSyntax, L wildCardAnn $ HsWildCardTy noExtField)
-        -- NOTE if the location that the argument wants to be placed at is not one more than the number of arguments
-        --      in the signature, then we return the original type signature.
-        --      This situation most likely occurs due to a function type synonym in the signature
-        insertArg n _ | n < 0 = error "Not possible"
-        insertArg 0 as = newArg:as
-        insertArg _ [] = []
-        insertArg n (a:as) = a : insertArg (n - 1) as
-        lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res)
-    in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy')
-
-fromLspList :: List a -> [a]
-fromLspList (List a) = a
-#endif
 
 suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]
 suggestFillTypeWildcard Diagnostic{_range=_range,..}
@@ -2169,29 +2008,16 @@ rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _  inners))
 #endif
 rangesForBinding' _ _ = []
 
--- | 'matchRegex' combined with 'unifySpaces'
-matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]
-matchRegexUnifySpaces message = matchRegex (unifySpaces message)
-
 -- | 'allMatchRegex' combined with 'unifySpaces'
 allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]]
 allMatchRegexUnifySpaces message =
     allMatchRegex (unifySpaces message)
 
--- | Returns Just (the submatches) for the first capture, or Nothing.
-matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
-matchRegex message regex = case message =~~ regex of
-    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
-    Nothing                                                -> Nothing
-
 -- | Returns Just (all matches) for the first capture, or Nothing.
 allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]]
 allMatchRegex message regex = message =~~ regex
 
 
-unifySpaces :: T.Text -> T.Text
-unifySpaces    = T.unwords . T.words
-
 -- functions to help parse multiple import suggestions
 
 -- | Returns the first match if found