diff --git a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal index 80979f2f6e..3f888cc946 100644 --- a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal +++ b/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 @@ -97,6 +99,7 @@ test-suite tests default-language: Haskell2010 hs-source-dirs: test main-is: Main.hs + other-modules: Test.AddArgument ghc-options: -O0 -threaded -rtsopts -with-rtsopts=-N -Wunused-imports build-depends: , base diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 69047c0aac..a28af0fa18 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/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,8 @@ 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.Plugins.Diagnostic import Development.IDE.Plugin.TypeLenses (suggestSignature) import Development.IDE.Types.Exports import Development.IDE.Types.Location @@ -65,8 +66,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 +92,7 @@ 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 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, @@ -189,9 +171,7 @@ bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ , wrap suggestImplicitParameter #endif , wrap suggestNewDefinition -#if MIN_VERSION_ghc(9,2,1) - , wrap suggestAddArgument -#endif + , wrap Development.IDE.Plugin.Plugins.AddArgument.plugin , wrap suggestDeleteUnusedBinding ] plId @@ -905,34 +885,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 +914,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 +2006,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 diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs new file mode 100644 index 0000000000..d7e59c1db2 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.Plugin.Plugins.AddArgument (plugin) where + +#if !MIN_VERSION_ghc(9,2,1) +import qualified Data.Text as T +import Language.LSP.Types +#else +import Control.Monad (join) +import Control.Monad.Except (lift) +import Data.Bifunctor (Bifunctor (..)) +import Data.Either.Extra (maybeToEither) +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint (exactPrint, + makeDeltaAst) +import Development.IDE.GHC.Error (spanContainsRange) +import Development.IDE.GHC.ExactPrint (genAnchor1, + modifyMgMatchesT', + modifySigWithM, + modifySmallestDeclWithM) +import Development.IDE.Plugin.Plugins.Diagnostic +import GHC (EpAnn (..), + SrcSpanAnn' (SrcSpanAnn), + SrcSpanAnnA, + SrcSpanAnnN, + TrailingAnn (..), + emptyComments, + noAnn) +import GHC.Hs (IsUnicodeSyntax (..)) +import GHC.Types.SrcLoc (generatedSrcSpan) +import Ide.PluginUtils (makeDiffTextEdit, + responseError) +import Language.Haskell.GHC.ExactPrint (TransformT, + noAnnSrcSpanDP1, + runTransformT) +import Language.Haskell.GHC.ExactPrint.Transform (d1) +import Language.LSP.Types +#endif + +#if !MIN_VERSION_ghc(9,2,1) +plugin :: [(T.Text, [TextEdit])] +plugin = [] +#else +-- 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. +plugin :: ParsedModule -> Diagnostic -> Either ResponseError [(T.Text, [TextEdit])] +plugin 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), Prelude.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 diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs new file mode 100644 index 0000000000..e99c23de98 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/Diagnostic.hs @@ -0,0 +1,53 @@ +module Development.IDE.Plugin.Plugins.Diagnostic ( + matchVariableNotInScope, + matchRegexUnifySpaces, + unifySpaces, + matchFoundHole, + matchFoundHoleIncludeUnderscore, + ) + where + +import Data.Bifunctor (Bifunctor (..)) +import qualified Data.Text as T +import Text.Regex.TDFA ((=~~)) + +unifySpaces :: T.Text -> T.Text +unifySpaces = T.unwords . T.words + +-- | 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 + +-- | 'matchRegex' combined with 'unifySpaces' +matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] +matchRegexUnifySpaces message = matchRegex (unifySpaces message) + +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 + +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 diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 46fb1fb616..e1b9fe9de7 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -39,7 +39,6 @@ import Language.LSP.Types hiding SemanticTokenRelative (length), SemanticTokensEdit (_start), mkRange) -import qualified Language.LSP.Types as LSP import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as L import System.Directory @@ -54,13 +53,13 @@ import Test.Tasty.HUnit import Text.Regex.TDFA ((=~)) -import Development.IDE.Plugin.CodeAction (bindingsPluginDescriptor, - matchRegExMultipleImports) +import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) import Test.Hls import Control.Applicative (liftA2) import qualified Development.IDE.Plugin.CodeAction as Refactor import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import qualified Test.AddArgument main :: IO () main = defaultTestRunner tests @@ -322,7 +321,7 @@ codeActionTests = testGroup "code actions" , addImplicitParamsConstraintTests , removeExportTests #if MIN_VERSION_ghc(9,2,1) - , addFunctionArgumentTests + , Test.AddArgument.tests #endif ] @@ -2166,244 +2165,8 @@ insertNewDefinitionTests = testGroup "insert new definition actions" ] #if MIN_VERSION_ghc(9,2,1) -addFunctionArgumentTests :: TestTree -addFunctionArgumentTests = - testGroup - "add function argument" - [ testSession "simple" $ do - let foo = - [ "foo True = select [True]", - "", - "foo False = False" - ] - foo' = - [ "foo True select = select [True]", - "", - "foo False select = False" - ] - someOtherCode = - [ "", - "someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ foo ++ someOtherCode) - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB (R 0 0 0 50) - liftIO $ actionTitle @?= "Add argument ‘select’ to function" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (foo' ++ someOtherCode), - testSession "comments" $ do - let foo = - [ "foo -- c1", - " True -- c2", - " = -- c3", - " select [True]", - "", - "foo False = False" - ] - -- TODO improve behavior slightly? - foo' = - [ "foo -- c1", - " True select -- c2", - " = -- c3", - " select [True]", - "", - "foo False select = False" - ] - someOtherCode = - [ "", - "someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ foo ++ someOtherCode) - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB (R 3 0 3 50) - liftIO $ actionTitle @?= "Add argument ‘select’ to function" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (foo' ++ someOtherCode), - testSession "leading decls" $ do - let foo = - [ "module Foo where", - "", - "bar = 1", - "", - "foo True = select [True]", - "", - "foo False = False" - ] - foo' = - [ "module Foo where", - "", - "bar = 1", - "", - "foo True select = select [True]", - "", - "foo False select = False" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ foo) - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB (R 4 0 4 50) - liftIO $ actionTitle @?= "Add argument ‘select’ to function" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines foo', - testSession "hole" $ do - let foo = - [ "module Foo where", - "", - "bar = 1", - "", - "foo True = _select [True]", - "", - "foo False = False" - ] - foo' = - [ "module Foo where", - "", - "bar = 1", - "", - "foo True _select = _select [True]", - "", - "foo False _select = False" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ foo) - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB (R 4 0 4 50) - liftIO $ actionTitle @?= "Add argument ‘_select’ to function" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines foo', - testSession "untyped error" $ do - let foo = - [ "foo = select" - ] - foo' = - [ "foo select = select" - ] - someOtherCode = - [ "", - "someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ foo ++ someOtherCode) - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB (R 0 0 0 50) - liftIO $ actionTitle @?= "Add argument ‘select’ to function" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (foo' ++ someOtherCode), - testSession "untyped error" $ do - let foo = - [ "foo = select" - ] - foo' = - [ "foo select = select" - ] - someOtherCode = - [ "", - "someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ foo ++ someOtherCode) - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB (R 0 0 0 50) - liftIO $ actionTitle @?= "Add argument ‘select’ to function" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (foo' ++ someOtherCode), - testSession "where clause" $ do - let foo = - [ "foo True = False ", - " where", - " bar = select", - "", - "foo False = False" - ] - -- TODO improve this behaviour (should add select to bar, not foo) - foo' = - [ "foo True select = False ", - " where", - " bar = select", - "", - "foo False select = False" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ foo) - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB (R 2 0 2 50) - liftIO $ actionTitle @?= "Add argument ‘select’ to function" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines foo', - testSession "where clause" $ do - let foo = - [ "foo -- c1", - " -- | c2", - " {- c3 -} True -- c4", - " = select", - "", - "foo False = False" - ] - -- TODO could use improvement here... - foo' = - [ "foo -- c1", - " -- | c2", - " {- c3 -} True select -- c4", - " = select", - "", - "foo False select = False" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ foo) - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB (R 3 0 3 50) - liftIO $ actionTitle @?= "Add argument ‘select’ to function" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines foo', - mkGoldenAddArgTest "AddArgWithSig" (R 1 0 1 50), - mkGoldenAddArgTest "AddArgWithSigAndDocs" (R 8 0 8 50), - mkGoldenAddArgTest "AddArgFromLet" (R 2 0 2 50), - mkGoldenAddArgTest "AddArgFromWhere" (R 3 0 3 50), - mkGoldenAddArgTest "AddArgWithTypeSynSig" (R 2 0 2 50), - mkGoldenAddArgTest "AddArgWithTypeSynSigContravariant" (R 2 0 2 50), - mkGoldenAddArgTest "AddArgWithLambda" (R 1 0 1 50), - mkGoldenAddArgTest "MultiSigFirst" (R 2 0 2 50), - mkGoldenAddArgTest "MultiSigLast" (R 2 0 2 50), - mkGoldenAddArgTest "MultiSigMiddle" (R 2 0 2 50) - ] #endif -mkGoldenAddArgTest :: FilePath -> Range -> TestTree -mkGoldenAddArgTest testFileName range = do - let action docB = do - _ <- waitForDiagnostics - InR action@CodeAction {_title = actionTitle} : _ <- - filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) - <$> getCodeActions docB range - liftIO $ actionTitle @?= "Add argument ‘new_def’ to function" - executeCodeAction action - goldenWithHaskellDoc - (Refactor.bindingsPluginDescriptor mempty "ghcide-code-actions-bindings") - (testFileName <> " (golden)") - "test/data/golden/add-arg" - testFileName - "expected" - "hs" - action - deleteUnusedDefinitionTests :: TestTree deleteUnusedDefinitionTests = testGroup "delete unused definition action" [ testSession "delete unused top level binding" $ diff --git a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs new file mode 100644 index 0000000000..b52e39d511 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} + +module Test.AddArgument (tests) where + +import Data.List.Extra +import qualified Data.Text as T +import Development.IDE.Types.Location +import Language.LSP.Test +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), + mkRange) +import Test.Tasty +import Test.Tasty.HUnit + + +import Test.Hls + +import qualified Development.IDE.Plugin.CodeAction as Refactor + +tests :: TestTree +tests = + testGroup + "add argument" +#if !MIN_VERSION_ghc(9,2,1) + [] +#else + [ mkGoldenAddArgTest' "Hole" (r 0 0 0 50) "_new_def", + mkGoldenAddArgTest "NoTypeSuggestion" (r 0 0 0 50), + mkGoldenAddArgTest "MultipleDeclAlts" (r 0 0 0 50), + mkGoldenAddArgTest "AddArgWithSig" (r 1 0 1 50), + mkGoldenAddArgTest "AddArgWithSigAndDocs" (r 8 0 8 50), + mkGoldenAddArgTest "AddArgFromLet" (r 2 0 2 50), + mkGoldenAddArgTest "AddArgFromWhere" (r 3 0 3 50), + mkGoldenAddArgTest "AddArgFromWhereComments" (r 3 0 3 50), + mkGoldenAddArgTest "AddArgWithTypeSynSig" (r 2 0 2 50), + mkGoldenAddArgTest "AddArgWithTypeSynSigContravariant" (r 2 0 2 50), + mkGoldenAddArgTest "AddArgWithLambda" (r 1 0 1 50), + mkGoldenAddArgTest "MultiSigFirst" (r 2 0 2 50), + mkGoldenAddArgTest "MultiSigLast" (r 2 0 2 50), + mkGoldenAddArgTest "MultiSigMiddle" (r 2 0 2 50) + ] + where + r x y x' y' = Range (Position x y) (Position x' y') + +mkGoldenAddArgTest :: FilePath -> Range -> TestTree +mkGoldenAddArgTest testFileName range = mkGoldenAddArgTest' testFileName range "new_def" + +-- Make a golden test for the add argument action. Given varName is the name of the variable not yet defined. +mkGoldenAddArgTest' :: FilePath -> Range -> T.Text -> TestTree +mkGoldenAddArgTest' testFileName range varName = do + let action docB = do + _ <- waitForDiagnostics + InR action@CodeAction {_title = actionTitle} : _ <- + filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x) + <$> getCodeActions docB range + liftIO $ actionTitle @?= ("Add argument ‘" <> varName <> "’ to function") + executeCodeAction action + goldenWithHaskellDoc + (Refactor.bindingsPluginDescriptor mempty "ghcide-code-actions-bindings") + (testFileName <> " (golden)") + "test/data/golden/add-arg" + testFileName + "expected" + "hs" + action +#endif diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.expected.hs new file mode 100644 index 0000000000..30c418cc7e --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.expected.hs @@ -0,0 +1,6 @@ +foo -- c1 + -- | c2 + {- c3 -} True new_def -- c4 + = new_def + +foo False new_def = False diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.hs new file mode 100644 index 0000000000..ece25370a5 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/AddArgFromWhereComments.hs @@ -0,0 +1,6 @@ +foo -- c1 + -- | c2 + {- c3 -} True -- c4 + = new_def + +foo False = False diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.expected.hs new file mode 100644 index 0000000000..1f440e9650 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.expected.hs @@ -0,0 +1 @@ +foo _new_def = _new_def \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.hs new file mode 100644 index 0000000000..31761e6934 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/Hole.hs @@ -0,0 +1 @@ +foo = _new_def \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.expected.hs new file mode 100644 index 0000000000..fce633e2b9 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.expected.hs @@ -0,0 +1,2 @@ +foo True new_def = new_def +foo False new_def = 1 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.hs new file mode 100644 index 0000000000..919ce56546 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/MultipleDeclAlts.hs @@ -0,0 +1,2 @@ +foo True = new_def +foo False = 1 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.expected.hs new file mode 100644 index 0000000000..e982cdf35e --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.expected.hs @@ -0,0 +1 @@ +foo new_def = new_def \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.hs b/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.hs new file mode 100644 index 0000000000..cf9ade10dc --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/add-arg/NoTypeSuggestion.hs @@ -0,0 +1 @@ +foo = new_def \ No newline at end of file