support "add argument" action (#3149)

* support add-argument action * respond to review comments * review: add ability to report errors in CodeAction api * review: use already-defined function * attempts at cpp * fix format error * fix broken test * doc: add self to codeowners; add doc to features.md * formatting * formatting * fix an import * review * formatting * add testcase with comments * fix build error Co-authored-by: Santiago Weight <[email protected]> Co-authored-by: Pepe Iborra <[email protected]> Co-authored-by: Michael Peyton Jones <[email protected]>
haskell · Nov 6, 2022 · 9d70df0 · 9d70df0
1 parent d17d9fd
commit 9d70df0
Show file tree

Hide file tree

Showing 9 changed files with 444 additions and 57 deletions.
diff --git a/CODEOWNERS b/CODEOWNERS
@@ -24,6 +24,7 @@
 /plugins/hls-qualify-imported-names-plugin @eddiemundo
 /plugins/hls-refine-imports-plugin
 /plugins/hls-rename-plugin @OliverMadine
+/plugins/hls-refactor-plugin @santiweight
 /plugins/hls-retrie-plugin @pepeiborra
 /plugins/hls-code-range-plugin @kokobd
 /plugins/hls-splice-plugin @konn

diff --git a/docs/features.md b/docs/features.md
@@ -271,6 +271,14 @@ Known Limitations:
 
 ![Link to Docs](../plugins/hls-change-type-signature-plugin/README.md)
 
+### Add argument to function
+
+Provided by: `hls-refactor-plugin`
+
+Code action kind: `quickfix`
+
+Add an undefined variable as an argument to the top-level binding.
+
 ### Convert to GADT syntax
 
 Provided by: `hls-gadt-plugin`

diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs
@@ -24,6 +24,7 @@ module Development.IDE.GHC.Error
   , zeroSpan
   , realSpan
   , isInsideSrcSpan
+  , spanContainsRange
   , noSpan
 
   -- * utilities working with severities
@@ -43,6 +44,7 @@ import           Development.IDE.GHC.Orphans       ()
 import           Development.IDE.Types.Diagnostics as D
 import           Development.IDE.Types.Location
 import           GHC
+import           Language.LSP.Types                (isSubrangeOf)
 
 
 diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
@@ -119,6 +121,10 @@ p `isInsideSrcSpan` r = case srcSpanToRange r of
   Just (Range sp ep) -> sp <= p && p <= ep
   _                  -> False
 
+-- Returns Nothing if the SrcSpan does not represent a valid range
+spanContainsRange :: SrcSpan -> Range -> Maybe Bool
+spanContainsRange srcSpan range = (range `isSubrangeOf`) <$> srcSpanToRange srcSpan
+
 -- | Convert a GHC severity to a DAML compiler Severity. Severities below
 -- "Warning" level are dropped (returning Nothing).
 toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity

diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs
@@ -18,9 +18,10 @@ import qualified Data.HashMap.Strict               as HashMap
 import           Data.List                         (sortOn)
 import qualified Data.List                         as List
 import qualified Data.Map.Strict                   as Map
-import           Data.Maybe                        (mapMaybe)
+import           Data.Maybe                        (fromMaybe, mapMaybe)
 import           Data.Text                         (Text)
 import qualified Data.Text                         as Text
+import           Development.IDE                   (spanContainsRange)
 import           Development.IDE.Core.RuleTypes    (GetFileContents (GetFileContents),
                                                     GetHieAst (GetHieAst),
                                                     HieAstResult (HAR, refMap),
@@ -87,16 +88,12 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) {
     ]
 }
 
-isRangeWithinSrcSpan :: Range -> SrcSpan -> Bool
-isRangeWithinSrcSpan (Range start end) srcSpan =
-  isInsideSrcSpan start srcSpan && isInsideSrcSpan end srcSpan
-
 findLImportDeclAt :: Range -> ParsedModule -> Maybe (LImportDecl GhcPs)
 findLImportDeclAt range parsedModule
   | ParsedModule {..} <- parsedModule
   , L _ hsModule <- pm_parsed_source
   , locatedImportDecls <- hsmodImports hsModule =
-      find (\ (L (locA -> srcSpan) _) -> isRangeWithinSrcSpan range srcSpan) locatedImportDecls
+      find (\ (L (locA -> srcSpan) _) -> fromMaybe False $ srcSpan `spanContainsRange` range) locatedImportDecls
 
 makeCodeActions :: Uri -> [TextEdit] -> [a |? CodeAction]
 makeCodeActions uri textEdits = [InR CodeAction {..} | not (null textEdits)]
@@ -132,7 +129,7 @@ data ImportedBy = ImportedBy {
 }
 
 isRangeWithinImportedBy :: Range -> ImportedBy -> Bool
-isRangeWithinImportedBy range (ImportedBy _ srcSpan) = isRangeWithinSrcSpan range srcSpan
+isRangeWithinImportedBy range (ImportedBy _ srcSpan) = fromMaybe False $ spanContainsRange srcSpan range
 
 globalRdrEnvToNameToImportedByMap :: GlobalRdrEnv -> NameEnv [ImportedBy]
 globalRdrEnvToNameToImportedByMap =

diff --git a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal
@@ -113,6 +113,8 @@ test-suite tests
     , extra
     , text-rope
     , containers
+    -- ghc is included to enable the MIN_VERSION_ghc macro
+    , ghc
     , ghcide
     , ghcide-test-utils
     , shake

diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs
@@ -20,6 +20,10 @@ module Development.IDE.GHC.ExactPrint
       transform,
       transformM,
       ExactPrint(..),
+#if MIN_VERSION_ghc(9,2,1)
+      modifySmallestDeclWithM,
+      modifyMgMatchesT,
+#endif
 #if !MIN_VERSION_ghc(9,2,0)
       Anns,
       Annotate,
@@ -438,6 +442,41 @@ graftDecls dst decs0 = Graft $ \dflags a -> do
             | otherwise = DL.singleton (L src e) <> go rest
     modifyDeclsT (pure . DL.toList . go) a
 
+#if MIN_VERSION_ghc(9,2,1)
+
+-- | Replace the smallest declaration whose SrcSpan satisfies the given condition with a new
+-- list of declarations.
+--
+-- For example, if you would like to move a where-clause-defined variable to the same
+-- level as its parent HsDecl, you could use this function.
+modifySmallestDeclWithM ::
+  forall a m.
+  (HasDecls a, Monad m) =>
+  (SrcSpan -> m Bool) ->
+  (LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]) ->
+  a ->
+  TransformT m a
+modifySmallestDeclWithM validSpan f a = do
+  let modifyMatchingDecl [] = pure DL.empty
+      modifyMatchingDecl (e@(L src _) : rest) =
+        lift (validSpan $ locA src) >>= \case
+            True -> do
+              decs' <- f e
+              pure $ DL.fromList decs' <> DL.fromList rest
+            False -> (DL.singleton e <>) <$> modifyMatchingDecl rest
+  modifyDeclsT (fmap DL.toList . modifyMatchingDecl) a
+
+-- | Modify the each LMatch in a MatchGroup
+modifyMgMatchesT ::
+  Monad m =>
+  MatchGroup GhcPs (LHsExpr GhcPs) ->
+  (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))) ->
+  TransformT m (MatchGroup GhcPs (LHsExpr GhcPs))
+modifyMgMatchesT (MG xMg (L locMatches matches) originMg) f = do
+  matches' <- mapM f matches
+  pure $ MG xMg (L locMatches matches') originMg
+#endif
+
 graftSmallestDeclsWithM ::
     forall a.
     (HasDecls a) =>

diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs
@@ -38,6 +38,7 @@ 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
@@ -63,7 +64,8 @@ import           Development.IDE.Types.Logger                      hiding
 import           Development.IDE.Types.Options
 import           GHC.Exts                                          (fromList)
 import qualified GHC.LanguageExtensions                            as Lang
-import           Ide.PluginUtils                                   (subRange)
+import           Ide.PluginUtils                                   (makeDiffTextEdit,
+                                                                    subRange)
 import           Ide.Types
 import qualified Language.LSP.Server                               as LSP
 import           Language.LSP.Types                                (ApplyWorkspaceEditParams (..),
@@ -89,7 +91,13 @@ 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           GHC.Types.SrcLoc                                  (generatedSrcSpan)
+import           Language.Haskell.GHC.ExactPrint                   (noAnnSrcSpanDP1,
+                                                                    runTransformT)
+#endif
 #if MIN_VERSION_ghc(9,2,0)
+import           Extra                                             (maybeToEither)
 import           GHC                                               (AddEpAnn (AddEpAnn),
                                                                     Anchor (anchor_op),
                                                                     AnchorOperation (..),
@@ -168,6 +176,9 @@ bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
     , wrap suggestImplicitParameter
 #endif
     , wrap suggestNewDefinition
+#if MIN_VERSION_ghc(9,2,1)
+    , wrap suggestAddArgument
+#endif
     , wrap suggestDeleteUnusedBinding
     ]
     plId
@@ -243,7 +254,7 @@ extendImportHandler' ideState ExtendImport {..}
                   Nothing -> newThing
                   Just p  -> p <> "(" <> newThing <> ")"
             t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents)
-            return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing})
+            return (nfp, WorkspaceEdit {_changes=Just (GHC.Exts.fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing})
   | otherwise =
     mzero
 
@@ -385,7 +396,7 @@ suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range}
     Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)",
     mods <- [(modName, s) | [_, modName, s] <- matched],
     result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier),
-    hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) =
+    hideAll <- ("Hide " <> identifier <> " from all occurence imports", concatMap snd result) =
     result <> [hideAll]
   | otherwise = []
   where
@@ -881,34 +892,111 @@ 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}
---     * Variable not in scope:
---         suggestAcion :: Maybe T.Text -> Range -> Range
-    | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"
-    = newDefinitionAction ideOptions parsedModule _range name typ
-    | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"
-    , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ
-    = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]
-    | otherwise = []
-    where
-      message = unifySpaces _message
+suggestNewDefinition ideOptions parsedModule contents Diagnostic {_message, _range}
+  | Just (name, typ) <- matchVariableNotInScope message =
+      newDefinitionAction ideOptions parsedModule _range name typ
+  | Just (name, typ) <- matchFoundHole message,
+    [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name (Just typ) =
+      [(label, mkRenameEdit contents _range name : newDefinitionEdits)]
+  | otherwise = []
+  where
+    message = unifySpaces _message
 
-newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]
-newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
-    | Range _ lastLineP : _ <-
+newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> Maybe T.Text -> [(T.Text, [TextEdit])]
+newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ
+  | Range _ lastLineP : _ <-
       [ realSrcSpanToRange sp
-      | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls
-      , _start `isInsideSrcSpan` l]
-    , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}
-    = [ ("Define " <> sig
-        , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]
-        )]
-    | otherwise = []
+        | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls,
+          _start `isInsideSrcSpan` l
+      ],
+    nextLineP <- Position {_line = _line lastLineP + 1, _character = 0} =
+      [ ( "Define " <> sig,
+          [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]
+        )
+      ]
+  | otherwise = []
   where
     colon = if optNewColonConvention then " : " else " :: "
-    sig = name <> colon <> T.dropWhileEnd isSpace typ
-    ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule
+    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).
+--
+-- TODO Include logic to also update the type signature of a binding
+--
+-- 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
+
+-- TODO use typ to modify type signature
+addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])]
+addArgumentAction (ParsedModule _ parsedSource _ _) range name _typ =
+  do
+    let addArgToMatch (L locMatch (Match xMatch ctxMatch pats rhs)) = do
+          let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name
+          let newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName)
+          pure $ L locMatch (Match xMatch ctxMatch (pats <> [newPat]) rhs)
+        insertArg = \case
+          (L locDecl (ValD xVal (FunBind xFunBind idFunBind mg coreFunBind))) -> do
+            mg' <- modifyMgMatchesT mg addArgToMatch
+            let decl' = L locDecl (ValD xVal (FunBind xFunBind idFunBind mg' coreFunBind))
+            pure [decl']
+          decl -> pure [decl]
+    case runTransformT $ modifySmallestDeclWithM spanContainsRangeOrErr insertArg (makeDeltaAst parsedSource) of
+      Left err -> Left err
+      Right (newSource, _, _) ->
+        let diff = makeDiffTextEdit (T.pack $ exactPrint parsedSource) (T.pack $ exactPrint newSource)
+         in pure [("Add argument ‘" <> name <> "’ to function", fromLspList diff)]
+      where
+        spanContainsRangeOrErr = maybeToEither (responseError "SrcSpan was not valid range") . (`spanContainsRange` range)
+#endif
+
+fromLspList :: List a -> [a]
+fromLspList (List a) = a
 
 suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]
 suggestFillTypeWildcard Diagnostic{_range=_range,..}