Skip to content

Extract AddArgument modules #3339

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 6 commits into from
Nov 20, 2022
Merged

Extract AddArgument modules #3339

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
f797887
refact: clean up add-arg tests
Nov 15, 2022
e770424
refact: extract Test.AddArgument
Nov 15, 2022
1041a25
refact: extract AddArgument logic
Nov 15, 2022
fae8f37
refact: remove unnecessary cpp
Nov 15, 2022
0ed1e43
Merge branch 'master' into fixup-add-arg
santiweight Nov 20, 2022
964ce2f
wip
Nov 20, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions plugins/hls-refactor-plugin/hls-refactor-plugin.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
186 changes: 5 additions & 181 deletions plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 (..),
Expand All @@ -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 (..),
Expand All @@ -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,
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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,..}
Expand Down Expand Up @@ -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
Expand Down
Loading