Skip to content
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

support add-argument action #3149

Merged
merged 20 commits into from
Nov 6, 2022
Merged

support add-argument action #3149

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
20 commits
Select commit Hold shift + click to select a range
51e0d1c
support add-argument action
Sep 10, 2022
5206ce2
Merge branch 'master' into add-argument
pepeiborra Sep 18, 2022
cae508a
respond to review comments
Oct 2, 2022
be159c6
review: add ability to report errors in CodeAction api
Oct 8, 2022
3c6fba3
review: use already-defined function
Oct 8, 2022
4be40b7
attempts at cpp
Oct 8, 2022
2627118
fix format error
Oct 8, 2022
9388c54
fix broken test
Oct 10, 2022
3a0a8f9
doc: add self to codeowners; add doc to features.md
Oct 16, 2022
6bc2454
Merge remote-tracking branch 'haskell/master' into add-argument
Oct 16, 2022
57b4edb
formatting
Oct 16, 2022
123a4f0
formatting
Oct 16, 2022
9a232d2
fix an import
Oct 16, 2022
01cc14e
Merge branch 'master' into add-argument
michaelpj Oct 24, 2022
f2659a7
review
Nov 5, 2022
136c232
formatting
Nov 5, 2022
c39b6f3
add testcase with comments
Nov 5, 2022
34e7277
Merge branch 'master' into add-argument
santiweight Nov 5, 2022
fceae39
Merge branch 'master' into add-argument
michaelpj Nov 5, 2022
0fce830
fix build error
Nov 6, 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
46 changes: 42 additions & 4 deletions plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,10 @@ module Development.IDE.GHC.ExactPrint
addParensToCtxt,
modifyAnns,
removeComma,
modifySmallestDeclWithM,
modifyMgMatchesT,
-- * Helper function
spanContainsRange,
eqSrcSpan,
epl,
epAnn,
Expand All @@ -42,7 +45,7 @@ module Development.IDE.GHC.ExactPrint
ExceptStringT (..),
TransformT,
Log(..),
)
)
where

import Control.Applicative (Alternative)
Expand Down Expand Up @@ -98,10 +101,11 @@ import GHC (EpAnn (..),
SrcSpanAnnA,
TrailingAnn (AddCommaAnn),
emptyComments,
spanAsAnchor)
spanAsAnchor, spans)
import GHC.Parser.Annotation (AnnContext (..),
DeltaPos (SameLine),
EpaLocation (EpaDelta))
import Data.Maybe (fromMaybe)
#endif

------------------------------------------------------------------------------
Expand All @@ -114,10 +118,10 @@ instance Pretty Log where

instance Show (Annotated ParsedSource) where
show _ = "<Annotated ParsedSource>"

instance NFData (Annotated ParsedSource) where
rnf = rwhnf

data GetAnnotatedParsedSource = GetAnnotatedParsedSource
deriving (Eq, Show, Typeable, GHC.Generic)

Expand Down Expand Up @@ -430,6 +434,32 @@ graftDecls dst decs0 = Graft $ \dflags a -> do
| otherwise = DL.singleton (L src e) <> go rest
modifyDeclsT (pure . DL.toList . go) a

modifySmallestDeclWithM ::
forall a.
(HasDecls a) =>
(SrcSpan -> Bool) ->
(LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) ->
a ->
TransformT (Either String) a
modifySmallestDeclWithM validSpan f a = do
pepeiborra marked this conversation as resolved.
Show resolved Hide resolved
let modifyMatchingDecl [] = pure DL.empty
modifyMatchingDecl (e@(L src _) : rest)
| validSpan $ locA src = do
decs' <- fromMaybe [e] <$> f e
pepeiborra marked this conversation as resolved.
Show resolved Hide resolved
pure $ DL.fromList decs' <> DL.fromList rest
| otherwise = (DL.singleton e <>) <$> modifyMatchingDecl rest
modifyDeclsT (fmap DL.toList . modifyMatchingDecl) a

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' <- forM matches f
let decl' = (MG xMg (L locMatches matches') originMg)
pure decl'

graftSmallestDeclsWithM ::
forall a.
(HasDecls a) =>
Expand Down Expand Up @@ -623,6 +653,14 @@ eqSrcSpanA l r = leftmost_smallest l r == EQ
#endif

#if MIN_VERSION_ghc(9,2,0)

spanContainsRange :: SrcSpan -> Range -> Bool
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Maybe you can use realSrcSpanToRange and isSubrangeOf ?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I forgot to respond. This worked perfectly thanks :)

spanContainsRange srcSpan Range {..} =
srcSpan `spans` positionToTuple _start && srcSpan `spans` positionToTuple _end
where
positionToTuple :: Position -> (Int, Int)
positionToTuple (Position l c) = (fromIntegral l + 1, fromIntegral c)

pepeiborra marked this conversation as resolved.
Show resolved Hide resolved
addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext
addParensToCtxt close_dp = addOpen . addClose
where
Expand Down
120 changes: 91 additions & 29 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,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 (fst3)
import Data.Tuple.Extra (fst3, first)
import Development.IDE.Types.Logger hiding (group)
import Development.IDE.Core.Rules
import Development.IDE.Core.RuleTypes
Expand All @@ -62,7 +62,7 @@ import Development.IDE.Types.Exports
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import qualified GHC.LanguageExtensions as Lang
import Ide.PluginUtils (subRange)
import Ide.PluginUtils (subRange, makeDiffTextEdit)
import Ide.Types
import qualified Language.LSP.Server as LSP
import Language.LSP.Types (ApplyWorkspaceEditParams(..), CodeAction (..),
Expand All @@ -82,7 +82,7 @@ import Language.LSP.Types (ApplyWorkspa
WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),
type (|?) (InR),
uriToFilePath)
import GHC.Exts (fromList)
import GHC.Exts (IsList (fromList))
import Language.LSP.VFS (VirtualFile,
_file_text)
import Text.Regex.TDFA (mrAfter,
Expand All @@ -96,7 +96,9 @@ import GHC (AddEpAnn (Ad
EpAnn (..),
EpaLocation (..),
LEpaComment,
LocatedA)
LocatedA, spans)
import Language.Haskell.GHC.ExactPrint (runTransformFromT, noAnnSrcSpanDP1, runTransform, runTransformT)
import GHC.Types.SrcLoc (generatedSrcSpan)
pepeiborra marked this conversation as resolved.
Show resolved Hide resolved

#else
import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP),
Expand Down Expand Up @@ -167,6 +169,7 @@ bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
, wrap suggestImplicitParameter
#endif
, wrap suggestNewDefinition
, wrap suggestAddArgument
, wrap suggestDeleteUnusedBinding
]
plId
Expand Down Expand Up @@ -242,7 +245,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

Expand Down Expand Up @@ -389,7 +392,7 @@ suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range}
| otherwise = []
where
L _ HsModule {hsmodImports} = astA ps

suggests identifier modName s
| Just tcM <- mTcM,
Just har <- mHar,
Expand Down Expand Up @@ -845,34 +848,93 @@ suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
= [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
| otherwise = []

matchVariableNotInScope :: T.Text -> Maybe (T.Text, Maybe T.Text)
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Perhaps an annoying suggestion, but these matching functions are all nice pure functions that could benefit from some direct tests checking that they do definitely match all the cases you care about.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Also, this module is also quite large, perhaps the add-action stuff could go in a separate module also?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I actually already did this in a followup MR. Would you be okay with following up with this change (to avoid unnecessary conflicts)?

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,
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think you have a Plan. Something like:

  • Look for errors of a particular kind
  • Based on the kind of error, make certain kinds of suggestion

But the Plan is not written down anywhere, and as a reader it's hard to figure out what it is. Maybe worth writing it down somewhere and referring to it?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Revised

[(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

suggestAddArgument :: ParsedModule -> Diagnostic -> [(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 = []
where
message = unifySpaces _message

-- TODO use typ to modify type signature
santiweight marked this conversation as resolved.
Show resolved Hide resolved
addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> [(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 $ Just [decl']
_ -> pure Nothing
case runTransformT $ modifySmallestDeclWithM (`spanContainsRange` range) insertArg (makeDeltaAst parsedSource) of
pepeiborra marked this conversation as resolved.
Show resolved Hide resolved
Left err -> error $ "Error when inserting argument: " <> err
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Avoid throwing an error here, as it will at best kill all other code actions and at worst kill all other plugins. Ideally you should return a ResponseError but that probably requires too much refactoring.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm unclear on what to do here. For the time being I used a trace call and returned no diffs. Is ResponseError part of the MonadLSP interface?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes it is :)

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I summoned up the courage to reveal ResponseErrors in the CodeAction API. The only hold up is I don't know how to throw/report ResponseErrors with MonadLSP after some hoogling.

Anyone have any pointers? 😅 Note that I am returning a list of errors and successes (since there are many potential code actions), so it should just be logResponseError :: MonadLSP m => ResponseError -> m (), not throw

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think it's fine to just use logError or logWarn and return nothing

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

After some investigation, it appears that the only Recorder available to CodeActions is Recorder (WithPriority E.Log), which is the logging from Development.IDE.Core.Shake.

Which logger should I be using for code actions? I can't find a Logger or nonShake recorder in the parent functions...

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is because this plugin was only recently extracted from ghcide core. The plugin needs to define its own Logger I guess.

Right (newSource, _, _) ->
let diff = makeDiffTextEdit (T.pack $ exactPrint parsedSource) (T.pack $ exactPrint newSource)
in [("Add argument ‘" <> name <> "’ to function", fromLspList $ diff)]

fromLspList :: List a -> [a]
fromLspList (List a) = a

suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]
suggestFillTypeWildcard Diagnostic{_range=_range,..}
Expand Down
Loading