diff --git a/CODEOWNERS b/CODEOWNERS index 627b4f1361..1867d280ba 100644 --- 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 index 54c03d1b86..ef4ae8a88e 100644 --- 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 index b16d908c58..a8a7acce27 100644 --- 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 index 6d78cee625..62d39bfd6f 100644 --- 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 index 7dfa8a020c..80979f2f6e 100644 --- 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 index ead2e04186..67c1f89f32 100644 --- 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 index 4901ccab05..442ffcb253 100644 --- 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,..} diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index ef5c7b623a..82e0134fcb 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -15,7 +15,8 @@ where import Control.Concurrent.STM.Stats (readTVarIO) import Control.Monad.Reader import Control.Monad.Trans.Maybe -import Data.Either (fromRight) +import Data.Either (fromRight, + partitionEithers) import qualified Data.HashMap.Strict as Map import Data.IORef.Extra import Data.Maybe (fromMaybe) @@ -30,6 +31,8 @@ import Development.IDE.GHC.ExactPrint import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, rewriteToEdit) #endif +import Control.Monad.Except (ExceptT (..), + runExceptT) import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), GlobalBindingTypeSigsResult) import Development.IDE.Spans.LocalBindings (Bindings) @@ -46,7 +49,7 @@ type CodeActionPreferred = Bool type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] -type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult +type GhcideCodeAction = ExceptT ResponseError (ReaderT CodeActionArgs IO) GhcideCodeActionResult ------------------------------------------------------------------------------------------------- @@ -79,13 +82,15 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra caaHar <- onceIO $ runRule GetHieAst caaBindings <- onceIO $ runRule GetBindings caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs - liftIO $ - concat - <$> sequence - [ runReaderT codeAction caa + results <- liftIO $ + + sequence + [ runReaderT (runExceptT codeAction) caa | caaDiagnostic <- diags, let caa = CodeActionArgs {..} ] + let (errs, successes) = partitionEithers results + pure $ concat successes mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title kind isPreferred diags edit = @@ -194,39 +199,44 @@ instance ToCodeAction a => ToCodeAction [a] where instance ToCodeAction a => ToCodeAction (Maybe a) where toCodeAction = maybe (pure []) toCodeAction +instance ToCodeAction a => ToCodeAction (Either ResponseError a) where + toCodeAction = either (\err -> ExceptT $ ReaderT $ \_ -> pure $ Left err) toCodeAction + instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where - toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te + toCodeAction (title, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where - toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te + toCodeAction (title, kind, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Nothing,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where - toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te + toCodeAction (title, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where - toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te + toCodeAction (title, kind, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te ------------------------------------------------------------------------------------------------- toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction -toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f +toCodeAction1 get f = ExceptT . ReaderT $ \caa -> do + caaMay <- get caa + flip runReaderT caa . runExceptT . toCodeAction . f $ caaMay toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction -toCodeAction2 get f = ReaderT $ \caa -> +toCodeAction2 get f = ExceptT . ReaderT $ \caa -> get caa >>= \case - Just x -> flip runReaderT caa . toCodeAction . f $ x - _ -> pure [] + Just x -> flip runReaderT caa . runExceptT . toCodeAction . f $ x + _ -> pure $ Right [] toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction -toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f +toCodeAction3 get f = ExceptT . ReaderT $ \caa -> get caa >>= flip runReaderT caa . runExceptT . toCodeAction . f -- | this instance returns a delta AST, useful for exactprint transforms instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where #if !MIN_VERSION_ghc(9,3,0) - toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> + toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> x >>= \case - Just s -> flip runReaderT caa . toCodeAction . f . astA $ s - _ -> pure [] + Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . astA $ s + _ -> pure $ Right [] #else toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} -> x >>= \case @@ -241,7 +251,7 @@ instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where toCodeAction = toCodeAction3 caaIdeOptions instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where - toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x + toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f x instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where toCodeAction = toCodeAction1 caaParsedModule diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 599d4bde29..124f28acf1 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -57,6 +57,7 @@ import Text.Regex.TDFA ((=~)) 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 @@ -319,6 +320,9 @@ codeActionTests = testGroup "code actions" , exportUnusedTests , addImplicitParamsConstraintTests , removeExportTests +#if MIN_VERSION_ghc(9,2,1) + , addFunctionArgumentTests +#endif ] insertImportTests :: TestTree @@ -1507,7 +1511,7 @@ extendImportTests = testGroup "extend import actions" actionsOrCommands <- getCodeActions docB range let codeActions = filter - (T.isPrefixOf "Add" . codeActionTitle) + (liftA2 (&&) (T.isPrefixOf "Add") (not . T.isPrefixOf "Add argument") . codeActionTitle) [ca | InR ca <- actionsOrCommands] actualTitles = codeActionTitle <$> codeActions -- Note that we are not testing the order of the actions, as the @@ -2047,7 +2051,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions" docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> getCodeActions docB (R 0 0 0 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action @@ -2071,7 +2075,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions" docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> getCodeActions docB (R 0 0 0 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action @@ -2105,7 +2109,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions" docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> getCodeActions docB (R 1 0 0 50) liftIO $ actionTitle @?= "Define select :: Int -> Bool" executeCodeAction action @@ -2131,14 +2135,246 @@ insertNewDefinitionTests = testGroup "insert new definition actions" docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> getCodeActions docB (R 1 0 0 50) liftIO $ actionTitle @?= "Define select :: Int -> Bool" executeCodeAction action contentAfterAction <- documentContents docB liftIO $ contentAfterAction @?= T.unlines expected + , testSession "insert new function definition - untyped error" $ do + let txtB = + ["foo = select" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> + getCodeActions docB (R 0 0 0 50) + liftIO $ actionTitle @?= "Define select :: _" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines (txtB ++ + [ "" + , "select :: _" + , "select = _" + ] + ++ txtB') ] +#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' + ] +#endif deleteUnusedDefinitionTests :: TestTree deleteUnusedDefinitionTests = testGroup "delete unused definition action"