diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index a8a7acce27..54f003349a 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -44,7 +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) +import Language.LSP.Types (isSubrangeOf) diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic @@ -121,7 +121,7 @@ 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 +-- | Returns Nothing if the SrcSpan does not represent a valid range spanContainsRange :: SrcSpan -> Range -> Maybe Bool spanContainsRange srcSpan range = (range `isSubrangeOf`) <$> srcSpanToRange srcSpan 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 62d39bfd6f..d9a2c73b54 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 @@ -21,7 +21,6 @@ import qualified Data.Map.Strict as Map 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), @@ -75,6 +74,7 @@ import Language.LSP.Types (CodeAction (CodeAction, _com WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), type (|?) (InR), uriToNormalizedFilePath) +import Development.IDE (spanContainsRange) thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} diff --git a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal index 80979f2f6e..3733a9ff20 100644 --- a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal +++ b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal @@ -29,6 +29,7 @@ library exposed-modules: Development.IDE.GHC.ExactPrint Development.IDE.GHC.Compat.ExactPrint Development.IDE.Plugin.CodeAction + Development.IDE.Plugin.CodeAction.Extract Development.IDE.Plugin.CodeAction.Util Development.IDE.GHC.Dump other-modules: Development.IDE.Plugin.CodeAction.Args @@ -97,6 +98,7 @@ test-suite tests default-language: Haskell2010 hs-source-dirs: test main-is: Main.hs + other-modules: Extract ghc-options: -O0 -threaded -rtsopts -with-rtsopts=-N -Wunused-imports build-depends: , base 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 4704afd9eb..a9a6924771 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -50,6 +50,10 @@ module Development.IDE.GHC.ExactPrint ExceptStringT (..), TransformT, Log(..), + mapAnchor, + generatedAnchor, + modifySmallestDeclWithM_, + querySmallestDeclWithM, ) where @@ -479,14 +483,46 @@ modifySmallestDeclWithM validSpan f a = do False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a +-- | Just like modifySmallestDeclWithM but just find some information about the declaration +querySmallestDeclWithM :: + forall a m r. + (HasDecls a, Monad m) => + (SrcSpan -> m Bool) -> + (LHsDecl GhcPs -> TransformT m r) -> + a -> + TransformT m (Maybe r) +querySmallestDeclWithM validSpan f a = do + (_, r) <- modifySmallestDeclWithM + validSpan + (\ decl -> do + r <- f decl + pure ([decl], r)) + a + pure r + +-- | Just like modifySmallestDeclWithM but with no extra result +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 = fst <$> modifySmallestDeclWithM validSpan (fmap (, ()) . f) a + generatedAnchor :: AnchorOperation -> Anchor generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp -setAnchor :: Anchor -> SrcSpanAnnN -> SrcSpanAnnN +setAnchor :: Anchor -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann) setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) = SrcSpanAnn (EpAnn anc nameAnn comments) span setAnchor _ spanAnnN = spanAnnN +mapAnchor :: (Maybe Anchor -> Anchor) -> SrcSpanAnnA -> SrcSpanAnnA +mapAnchor f (SrcSpanAnn (EpAnn anc nameAnn comments) span) = + SrcSpanAnn (EpAnn (f $ Just anc) nameAnn comments) span +mapAnchor f (SrcSpanAnn EpAnnNotUsed span) = SrcSpanAnn (EpAnn (f Nothing) mempty emptyComments) span + removeTrailingAnns :: SrcSpanAnnN -> SrcSpanAnnN removeTrailingAnns (SrcSpanAnn (EpAnn anc nameAnn comments) span) = let nameAnnSansTrailings = nameAnn {nann_trailing = []} 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..e743f559e0 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -11,7 +11,8 @@ module Development.IDE.Plugin.CodeAction fillHolePluginDescriptor, extendImportPluginDescriptor, -- * For testing - matchRegExMultipleImports + matchRegExMultipleImports, + extractCodePluginDescriptor ) where import Control.Applicative ((<|>)) @@ -54,6 +55,7 @@ import Development.IDE.GHC.Util (printOutputa printRdrName) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint +import Development.IDE.Plugin.CodeAction.Extract import Development.IDE.Plugin.CodeAction.PositionIndexed import Development.IDE.Plugin.CodeAction.Util import Development.IDE.Plugin.Completions.Types @@ -116,7 +118,8 @@ import GHC (AddEpAnn (Ad TrailingAnn (..), addTrailingAnnToA, emptyComments, - noAnn) + noAnn, + spans) import GHC.Hs (IsUnicodeSyntax (..)) import Language.Haskell.GHC.ExactPrint.Transform (d1) @@ -203,6 +206,12 @@ extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> Plu extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId) { pluginCommands = [extendImportCommand] } +extractCodePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +extractCodePluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ + mkGhcideCAsPlugin [ + wrap suggestExtractFunction + ] + plId -- | Add the ability for a plugin to call GetAnnotatedParsedSource mkExactprintPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginDescriptor a -> PluginDescriptor a @@ -1073,11 +1082,9 @@ addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) = 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,..} -- Foo.hs:3:8: error: @@ -2097,24 +2104,6 @@ splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) | otherwise = (x, T.empty) --- | Returns [start .. end[ -textInRange :: Range -> T.Text -> T.Text -textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text = - case compare startRow endRow of - LT -> - let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine - (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of - [] -> ("", []) - firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween) - maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines - in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine) - EQ -> - let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine) - in T.take (endCol - startCol) (T.drop startCol line) - GT -> "" - where - linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) - -- | Returns the ranges for a binding in an import declaration rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = 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 82e0134fcb..a06d46c17a 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 @@ -55,7 +55,7 @@ type GhcideCodeAction = ExceptT ResponseError (ReaderT CodeActionArgs IO) Ghcide {-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-} runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult -runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do +runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = List diags}) codeAction = do let mbFile = toNormalizedFilePath' <$> uriToFilePath uri runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key caaGhcSession <- onceIO $ runRule GhcSession @@ -82,13 +82,15 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra caaHar <- onceIO $ runRule GetHieAst caaBindings <- onceIO $ runRule GetBindings caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs + let caaRange = Just range results <- liftIO $ sequence - [ runReaderT (runExceptT codeAction) caa - | caaDiagnostic <- diags, + ([ runReaderT (runExceptT codeAction) caa + | diagnostic <- diags, + let caaDiagnostic = Just diagnostic, let caa = CodeActionArgs {..} - ] + ] <> [let caaDiagnostic = Nothing in runReaderT (runExceptT codeAction) CodeActionArgs{..}]) let (errs, successes) = partitionEithers results pure $ concat successes @@ -163,7 +165,8 @@ data CodeActionArgs = CodeActionArgs caaHar :: IO (Maybe HieAstResult), caaBindings :: IO (Maybe Bindings), caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult), - caaDiagnostic :: Diagnostic + caaDiagnostic :: Maybe Diagnostic, + caaRange :: Maybe Range } -- | There's no concurrency in each provider, @@ -251,7 +254,10 @@ instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where toCodeAction = toCodeAction3 caaIdeOptions instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where - toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f x + toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f <$> x + +instance ToCodeAction r => ToCodeAction (Range -> r) where + toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaRange = 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/src/Development/IDE/Plugin/CodeAction/Extract.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs new file mode 100644 index 0000000000..21efd32c19 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE GADTs #-} + +module Development.IDE.Plugin.CodeAction.Extract (textInRange, suggestExtractFunction, fromLspList) where + +import Control.Applicative ((<|>)) +import Data.Foldable (foldl') +import Data.Generics (everywhere, mkT) +import Data.Maybe +import Data.Monoid (Sum (..)) +import qualified Data.Set as Set +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.ExactPrint +import Development.IDE.Types.Location +import Generics.SYB (GenericQ, + everything, + everythingBut, extQ) +import Generics.SYB.Aliases (mkQ) +import GHC (AddEpAnn (AddEpAnn), + Anchor (..), + AnchorOperation (..), + DeltaPos (..), + EpAnn (..), + NoEpAnns (..), + SrcSpanAnn' (SrcSpanAnn), + emptyComments, + realSrcSpan) +import GHC.Types.SrcLoc (generatedSrcSpan) +import Ide.PluginUtils (makeDiffTextEdit) +import Language.Haskell.GHC.ExactPrint (noAnnSrcSpanDP, + runTransform, + uniqueSrcSpanT) +import Language.Haskell.GHC.ExactPrint.Transform (d1) +import Language.LSP.Types (List (..), UInt) +import Language.LSP.Types.Capabilities + +-- | Suggest a code action for extracting the expression indicated by the user's current Range selection. +-- +-- The expression is extracted to the top level of the module, with a new function called `newDefinition`, and with +-- a best-guess at the newly-free-scoped variables. +-- +-- Before: +-- foo = x + y + z +-- After +-- newDefinition y z = y + z +-- foo = x + newDefinition y z +-- +-- Does not work with record wild cards, and subtle bugs relating to shadowed variables, which is documented throughout +-- this module. +suggestExtractFunction :: T.Text -> Annotated ParsedSource -> Range -> [(T.Text, [TextEdit])] +suggestExtractFunction srcText (Annotated parsedSource _) range = + case tryFindLargestExprInRange minimalRange parsedSource of + Nothing -> [] + Just (extractSpan, extractExpr) -> execTransform $ do + argsList <- findFreeVarsPostExtract extractSpan extractExpr parsedSource + newDef <- generateNewDecl newDefName argsList extractExpr + let addNewDef = modifySmallestDeclWithM_ + (pure . (extractSpan `isSubspanOf`)) + (\case + ldecl@(L (SrcSpanAnn (EpAnn anchor _ _) _) _) -> do + let lNewDef = L (SrcSpanAnn (EpAnn anchor mempty emptyComments) generatedSrcSpan) newDef + pure [lNewDef, setAtLeastNewlineDp ldecl] + _ -> error "todo") + replaceExtractExprWithVarQ = everywhere $ mkT $ \case + L (SrcSpanAnn epAnn span) _e :: LHsExpr GhcPs + | extractSpan == span -> + let go fExpr argExpr = HsApp + (EpAnn (Anchor (realSrcSpan generatedSrcSpan) $ MovedAnchor $ SameLine 0) NoEpAnns emptyComments) + (noLocA fExpr) + (L (noAnnSrcSpanDP generatedSrcSpan $ SameLine 1) $ HsVar noExtField (noLocA argExpr)) + in L (SrcSpanAnn epAnn generatedSrcSpan) $ foldl' go (HsVar noExtField newDefName) argsList + lexpr -> lexpr + let source' = replaceExtractExprWithVarQ parsedSource + source'' <- addNewDef $ makeDeltaAst source' + let diff = makeDiffTextEdit (T.pack $ exactPrint parsedSource) (T.pack $ exactPrint $ makeDeltaAst source'') + pure [("Extract function", fromLspList diff)] + where + minimalRange = removeWhitespacePadding range srcText + newDefName = noLocA $ mkRdrUnqual $ mkVarOcc $ T.unpack "newDefinition" + execTransform = (\(a,_,_) -> a) . runTransform +suggestExtractFunction _ _ _ = [] -- Could not find Annotated ParsedSource + +-- | This function represents a simple guess of which variables are going to be out of scope after the expression +-- is extracted. This strategy will probably work for >90% cases. +-- +-- The strategy is that we assume that all variables bound in the extracted expr scope over any occurrence of said +-- variable in the same extracted expr. Assuming this, we can take the variables bound in the surrounding context minus +-- the variables bound in the expression. This gives us variables that were in scope that will no longer be in scope +-- post-extraction. Then we find the utilized variables by finding the intersection of in-scope variable and utilized +-- variables. +-- +-- A simple counter-example to this strategy would occur by extracting the rhs of `foo`, "let tmp = ... in bar": + +-- foo bar = let tmp = bar in let bar = 1 in bar + +-- `bar` is used in the rhs of, but is also bound in the same expression, and so this strategy will detect the variable +-- not being out of scope post-extraction (even though it will be). +-- +-- Thankfully this would just cause an unbound variable error post-extraction. +-- +-- In order to have a more robust strategy without excessive maintenance burden, we would require output from +-- GHC's renamer phase, preferably in-tree. +-- +-- Some known weaknesses: +-- TODO Some subtle name shadowing issues in the extracted expression. Hard to fix without more GHC help. +-- You can see this in the above example, where `bar` is actually a free variable, but the implementation will +-- not realize that the variable will be free post-extraction. +-- TODO Record `{..}` pattern matching syntax; we can find the fields in the matching record to fix this. See +-- hls-explicit-record-fields-plugin. +-- TODO When finding bound variables in the whole declaration, we find bound variables in the _whole_ declaration, +-- not just the surrounding Match. Therefore, as far as this implementation is concerned, variables in other +-- Match's scoped over the Match that contains the extracted expression. +findFreeVarsPostExtract :: (Monad m) => SrcSpan -> LHsExpr GhcPs -> ParsedSource -> TransformT m [RdrName] +findFreeVarsPostExtract extractSpan extractExpr parsedSource = do + -- Find the variables that are bound in this declaration. Not finding the surrounding decl is a bug + -- (since an expression) must necessarily occur in a top-level declaration. + -- + -- TODO log error when we cannot find the containing decl + boundVarsInWholeDeclMay <- querySmallestDeclWithM (pure . (extractSpan `isSubspanOf`)) (pure . boundVarsQ) parsedSource + -- Variables bound in the entire declaration that contains the extracted expression + let boundVarsInWholeDecl = fromMaybe [] boundVarsInWholeDeclMay + -- Variables bound in the extracted expression + let boundVarsInExtractedExpr = boundVarsQ extractExpr + -- Variables used in the extracted expression. Note this does not detect record wildcards for record construction, + -- such as `foo x y = Rec {..}`, in the case that Rec has a field x and/or y. + let usedVarsInExtractedExpr = usedVarsQ extractExpr + -- The bound variables that scope over the extracted expression is, in most cases, all bindings in the + -- declarations minus the bindings in the extracted expression. This is a simplifying assumption. + let boundVarsThatScopeOverExtractedExpr = + Set.fromList boundVarsInWholeDecl `Set.difference` Set.fromList boundVarsInExtractedExpr + -- The newly freed variables of the extracted expression are, most of the time, those variables scoping over + -- the extracted expression that also exist in the extracted expression. + -- + -- Anything else is assumed to be an import, which could be wrong in a case such as: + -- + -- data Rec = Rec {x :: Int} + -- foo Rec {..} y = x + y + -- + -- This implementation erroneously produces: + -- + -- data Rec = Rec {x :: Int} + -- newDefinition y = x + y + -- foo Rec {..} y = newDefinition y + let postExtractFreeVars = + boundVarsThatScopeOverExtractedExpr `Set.intersection` Set.fromList usedVarsInExtractedExpr + pure $ Set.toList postExtractFreeVars + +-- | A type-safety-helpful newtype that represents that a Range has had its whitespace padding removed from both sides: +-- +-- Original range: +-- 1 + 1 +-- ^ ^ +-- +-- UnpaddedRange: +-- 1 + 1 +-- ^ ^ +-- See `removeWhitespacePadding` for more info +newtype UnpaddedRange = UnpaddedRange {unUnpaddedRange :: Range} + deriving stock (Show, Eq) + +-- | This function removes whitespace padding from the Range provided by the user. +-- +-- When the user selects their range that they would like to extract, we would like to ignore whitespace in their +-- selection, so that we can find expressions that are contained fully by said range, but without accepting false +-- positives. Therefore, we remove whitespace padding, and then during matching of ranges, we only match expression +-- that have exactly the range selected by the user (whitespace agnostic) by performing a range _equality_ check. +-- +-- If we were to check whether we can extract an expression with a subspan check (instead of equality), then we would +-- accept selections that are not valid extractions. For example: +-- +-- foo = 1 + 2 +-- ^ ^ +-- In this case, while the range fully wraps `2`, it is not a valid extract function query, since it also wraps `+ 2`, +-- which is not an expression. +-- +-- Therefore, in order to ensure that we do not suggest an extraction in this case, we narrow the selection to: +-- +-- foo = 1 + 2 +-- ^ ^ +-- and look for LHsExprs that match the given Range using _equality_, which ensures that we only accept a range if: +-- 1. the range wraps an entire LHsExpr +-- 2. the range wraps an LHsExpr exactly (so as to not suggest false positives) +removeWhitespacePadding :: Range -> T.Text -> UnpaddedRange +removeWhitespacePadding range@(Range (Position sl sc) (Position el ec)) source = + let selectedTxt = textInRange range source + -- TODO We do not yet handle tabs gracefully + isWhiteSpace c = elem c [' ', '\n'] + (paddingLeft, minimalOnLeft) = T.span isWhiteSpace selectedTxt + (paddingRight, _) = T.span isWhiteSpace $ T.reverse minimalOnLeft + whitespaceToDelta = \case + ' ' -> (0 :: Sum UInt, -1 :: Sum UInt) + '\n' -> (-1, 0) + _ -> error "impossible" + paddingToDelta = foldMap whitespaceToDelta . T.unpack + (getSum -> rowsL, getSum -> colsL) = paddingToDelta paddingLeft + (getSum -> rowsR, getSum -> colsR) = paddingToDelta paddingRight + in UnpaddedRange $ Range (Position (sl - rowsL) (sc - colsL)) (Position (el - rowsR) (ec - colsR)) + +-- | Convert a GHC SrcSpan to an UnpaddedRange +-- +-- TODO consolidate with Range as found in the rest of HLS. For some reason, the Range provided to code actions has +-- a character value of one less than the same Range used in the rest of HLS. Therefore, the typical Range <-> SrcSpan +-- conversions don't work because of an off-by-one. +srcSpanToUnpaddedRange :: SrcSpan -> Maybe UnpaddedRange +srcSpanToUnpaddedRange (UnhelpfulSpan _) = Nothing +srcSpanToUnpaddedRange (Compat.RealSrcSpan real _) = Just $ realSrcSpanToUnpaddedRange real + where + realSrcSpanToUnpaddedRange :: RealSrcSpan -> UnpaddedRange + realSrcSpanToUnpaddedRange real = + UnpaddedRange $ Range (realSrcLocToPositionForUnpaddedRange $ Compat.realSrcSpanStart real) + (realSrcLocToPositionForUnpaddedRange $ Compat.realSrcSpanEnd real) + realSrcLocToPositionForUnpaddedRange :: RealSrcLoc -> Position + realSrcLocToPositionForUnpaddedRange real = + Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real) + + +-- | Queries an AST for the topmost LHsExpr that exactly matches the given UnpaddedRange. +tryFindLargestExprInRange :: UnpaddedRange -> GenericQ (Maybe (SrcSpan, LHsExpr GhcPs)) +tryFindLargestExprInRange range = everythingBut (<|>) $ mkQ (Nothing, False) firstContainedExprQ + where + -- When we find an LHsExpr that is fully contained by this range, we return the LHsExpr and early-exit the + -- syb traversal (by returning True) + firstContainedExprQ = \case + lexpr@(L (SrcSpanAnn _ span) _) :: LHsExpr GhcPs + | Just spanRange <- srcSpanToUnpaddedRange span, + range == spanRange + -> (Just (span, lexpr), True) + _ -> (Nothing, False) + +-- | Ensures that there is at least one newline's difference between this LHsDecl and the previous decl. If the +-- original decl was on the next line after the anchor, with no padding, we simply return with no modifications +setAtLeastNewlineDp :: LHsDecl GhcPs -> LHsDecl GhcPs +setAtLeastNewlineDp (L srcSpanAnn decl) = L (mapAnchor (maybe nextLineAnchor setAtLeastNewline) srcSpanAnn) decl + where + setAtLeastNewline (Anchor realSrcSpan ancOp) = + let ancOp' = case ancOp of + UnchangedAnchor -> nextLine2Dp + MovedAnchor (SameLine _) -> nextLine2Dp + MovedAnchor (DifferentLine 0 _) -> nextLine2Dp + ancOp_ -> ancOp_ + in Anchor realSrcSpan ancOp' + + nextLine2Dp = MovedAnchor (DifferentLine 2 0) + nextLineAnchor = generatedAnchor nextLine2Dp + +-- | Find all variable bindings in an AST. +-- +-- NOTE As with the rest of the extract plugin, shadowing is considered out of scope, and we do a best guess. +-- TODO improve shadowing here if we decide to do it ourselves. Be careful, as there is certainly more to do than +-- just the TODOs that have already been added... +boundVarsQ :: GenericQ [RdrName] +boundVarsQ = everything (<>) $ mkQ [] + (\case + (VarPat _ var :: Pat GhcPs) -> [unLocA var] + _ -> [] + ) + `extQ` + (\case + (FunBind {fun_id} :: HsBindLR GhcPs GhcPs) -> [unLocA fun_id] + PatBind {pat_lhs} -> rdrNameQ pat_lhs -- TODO shadowing + VarBind {var_id} -> [var_id] -- TODO shadowing + PatSynBind {} -> [] -- TODO shadowing + AbsBinds {} -> [] -- TODO shadowing + ) + `extQ` + (\case + (HsValBinds _ binds :: HsLocalBindsLR GhcPs GhcPs) -> boundVarsQ binds + HsIPBinds {} -> [] -- TODO shadowing + EmptyLocalBinds {} -> [] + ) + where + rdrNameQ :: GenericQ [RdrName] + rdrNameQ =everything (<>) $ mkQ [] $ \name -> [name] + +-- | Find variable usages bindings in an AST. +usedVarsQ :: GenericQ [RdrName] +usedVarsQ = everything (<>) $ mkQ [] $ + \case + (HsVar _ var :: HsExpr GhcPs) -> [unLocA var] + _ -> [] + +-- | From a function name and list of arguments, generate a new function with the given LHsExpr as the rhs. +generateNewDecl :: Monad m => LIdP GhcPs -> [RdrName] -> LHsExpr GhcPs -> TransformT m (HsDecl GhcPs) +generateNewDecl name args expr = do + sp1 <- uniqueSrcSpanT + let rhs = L generatedSrcSpan $ GRHS (epAnn generatedSrcSpan $ GrhsAnn (Just d1) (AddEpAnn AnnEqual d1)) [] expr + grhss = GRHSs emptyComments [rhs] (EmptyLocalBinds noExtField) + match = Match mempty (FunRhs name Prefix NoSrcStrict) ((\ arg -> L (noAnnSrcSpanDP generatedSrcSpan $ SameLine 1) (VarPat noExtField (noLocA arg))) <$> args) grhss + lmatch = L (noAnnSrcSpanDP generatedSrcSpan $ SameLine 0) match + mg = MG noExtField (L (noAnnSrcSpanDP sp1 $ SameLine 0) [lmatch]) FromSource + funbind = FunBind noExtField name mg [] + pure $ ValD noExtField funbind + +fromLspList :: List a -> [a] +fromLspList (List a) = a + +-- | Find the text delineated by a given Range from a source Text. +textInRange :: Range -> T.Text -> T.Text +textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text = + case compare startRow endRow of + LT -> + let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine + (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of + [] -> ("", []) + firstLine:linesInBetween -> (T.drop (startCol - 1) firstLine, linesInBetween) + maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines + in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine) + EQ -> + let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine) + in T.take (endCol - startCol) (T.drop (startCol - 1) line) + GT -> "" + where + linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) diff --git a/plugins/hls-refactor-plugin/test/Extract.hs b/plugins/hls-refactor-plugin/test/Extract.hs new file mode 100644 index 0000000000..e10259b2ec --- /dev/null +++ b/plugins/hls-refactor-plugin/test/Extract.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} + +module Extract (extractTests) where + +import Data.List.Extra +import qualified Data.Text as T +import qualified Development.IDE.Plugin.CodeAction as Refactor +import Development.IDE.Types.Location +import Language.LSP.Test +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), + mkRange) +import Test.Hls + + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +extractTests :: TestTree +extractTests = + testGroup + "extract code" + [ mkGoldenExtractTest "ExtractSimple" (R 0 6 0 28) + , mkGoldenExtractTest "ExtractSimple" (R 0 7 0 28) + , mkGoldenExtractTest "ExtractSimple" (R 0 23 0 28) + , mkGoldenExtractTest "ExtractFreeVars" (R 3 7 3 19) + , mkGoldenExtractTest "ExtractFreeVars" (R 1 5 3 19) + -- TODO this case uses record wild cards, and the current implementation handles it sub-optimally. Notice how + -- the field selectors bound in the wildcard pattern are not found to be free variables. + , mkGoldenExtractTest "ExtractBad" (R 4 16 4 21) + -- TODO current implementation considers "bar" to be in scope post extraction because the variable was + -- bound in both the surrounding context and the extracted expression. + , mkGoldenExtractTest "ExtractBad" (R 6 12 6 47) + -- TODO this case also has the record wildcard problem. + , mkGoldenExtractTest "ExtractFreeVarsComplex" (R 6 5 8 39) + , mkGoldenExtractTest "ExtractFromDeclWithSig" (R 1 7 1 28) + , mkGoldenExtractTest "ExtractFromWhere" (R 2 11 2 16) + ] + +mkGoldenExtractTest :: FilePath -> Range -> TestTree +mkGoldenExtractTest testFileName range@(Range (Position sl sc) (Position el ec)) = do + let action docB = do + _ <- waitForAllProgressDone + actions <- getCodeActions docB range + InR action@CodeAction {_title = actionTitle} : _ <- + filter (\(InR CodeAction {_title = x}) -> "Extract" `isPrefixOf` T.unpack x) + <$> getCodeActions docB range + executeCodeAction action + rangeName = show sl <> "_" <> show sc <> "_" <> show el <> "_" <> show ec + goldenWithHaskellDoc + (Refactor.extractCodePluginDescriptor mempty "ghcide-code-actions-extract") + (testFileName <> " " <> rangeName <> " (golden)") + "test/data/golden/extract" + testFileName + (rangeName <> ".expected") + "hs" + action + diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 46fb1fb616..1ea18ad7a6 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -56,11 +56,13 @@ import Text.Regex.TDFA ((=~)) import Development.IDE.Plugin.CodeAction (bindingsPluginDescriptor, matchRegExMultipleImports) +import Extract 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 Debug.Trace (traceM, traceShowM) main :: IO () main = defaultTestRunner tests @@ -313,6 +315,8 @@ codeActionTests = testGroup "code actions" , fillTypedHoleTests , addSigActionTests , insertNewDefinitionTests + , addFunctionArgumentTests + , extractTests , deleteUnusedDefinitionTests , addInstanceConstraintTests , addFunctionConstraintTests diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.4_16_4_21.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.4_16_4_21.expected.hs new file mode 100644 index 0000000000..b520872809 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.4_16_4_21.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RecordWildCards #-} + +data Rec = Rec { x :: Int } + +newDefinition = x + 1 + +foo Rec {..} = newDefinition + +quux bar = let tmp = bar in let bar = 1 in bar \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.6_12_6_47.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.6_12_6_47.expected.hs new file mode 100644 index 0000000000..987489524c --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.6_12_6_47.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RecordWildCards #-} + +data Rec = Rec { x :: Int } + +foo Rec {..} = x + 1 + +newDefinition = let tmp = bar in let bar = 1 in bar + +quux bar = newDefinition \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.hs new file mode 100644 index 0000000000..9d5970ea2e --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} + +data Rec = Rec { x :: Int } + +foo Rec {..} = x + 1 + +quux bar = let tmp = bar in let bar = 1 in bar \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.1_5_3_19.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.1_5_3_19.expected.hs new file mode 100644 index 0000000000..c42d19388a --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.1_5_3_19.expected.hs @@ -0,0 +1,9 @@ +newDefinition v1 v2 = + let v3 = 3 + in + v1 + v2 + v3 + +f1 v1 = + newDefinition v1 v2 + where + v2 = 2 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.3_7_3_19.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.3_7_3_19.expected.hs new file mode 100644 index 0000000000..6bf93c0573 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.3_7_3_19.expected.hs @@ -0,0 +1,9 @@ +newDefinition v1 v2 v3 = + v1 + v2 + v3 + +f1 v1 = + let v3 = 3 + in + newDefinition v1 v2 v3 + where + v2 = 2 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.hs new file mode 100644 index 0000000000..9fee6592f7 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.hs @@ -0,0 +1,6 @@ +f1 v1 = + let v3 = 3 + in + v1 + v2 + v3 + where + v2 = 2 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.6_5_8_39.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.6_5_8_39.expected.hs new file mode 100644 index 0000000000..f03064a425 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.6_5_8_39.expected.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +data Foo = Foo {f1 :: Int, f2 :: Int} + +newDefinition f3 f5 v1 v2 v4 = + let v3 = 3 + in + f1 + f3 + f5 + v1 + v2 + v3 + v4 + +g Foo{..} Foo{f1=f3,f2=f4} (Foo f5 f6) (id -> v1) = \ v4 -> + newDefinition f3 f5 v1 v2 v4 + where + v2 = 2 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.hs new file mode 100644 index 0000000000..332f296fe6 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +data Foo = Foo {f1 :: Int, f2 :: Int} + +g Foo{..} Foo{f1=f3,f2=f4} (Foo f5 f6) (id -> v1) = \ v4 -> + let v3 = 3 + in + f1 + f3 + f5 + v1 + v2 + v3 + v4 + where + v2 = 2 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromDeclWithSig.1_7_1_28.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromDeclWithSig.1_7_1_28.expected.hs new file mode 100644 index 0000000000..c77f186499 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromDeclWithSig.1_7_1_28.expected.hs @@ -0,0 +1,3 @@ +def :: Int +newDefinition = let quux = _ in 1 + 1 +def = newDefinition \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromDeclWithSig.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromDeclWithSig.hs new file mode 100644 index 0000000000..4371460325 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromDeclWithSig.hs @@ -0,0 +1,2 @@ +def :: Int +def = let quux = _ in 1 + 1 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromWhere.2_11_2_16.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromWhere.2_11_2_16.expected.hs new file mode 100644 index 0000000000..771ad913ba --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromWhere.2_11_2_16.expected.hs @@ -0,0 +1,5 @@ +newDefinition = 1 + 1 + +baz = foo + where + foo = newDefinition \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromWhere.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromWhere.hs new file mode 100644 index 0000000000..be06090673 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromWhere.hs @@ -0,0 +1,3 @@ +baz = foo + where + foo = 1 + 1 \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_23_0_28.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_23_0_28.expected.hs new file mode 100644 index 0000000000..2320a53e3a --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_23_0_28.expected.hs @@ -0,0 +1,3 @@ +newDefinition = 1 + 1 + +def = let quux = _ in newDefinition \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_6_0_28.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_6_0_28.expected.hs new file mode 100644 index 0000000000..7f6e2ad2bc --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_6_0_28.expected.hs @@ -0,0 +1,3 @@ +newDefinition = let quux = _ in 1 + 1 + +def = newDefinition \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_7_0_28.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_7_0_28.expected.hs new file mode 100644 index 0000000000..7f6e2ad2bc --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_7_0_28.expected.hs @@ -0,0 +1,3 @@ +newDefinition = let quux = _ in 1 + 1 + +def = newDefinition \ No newline at end of file diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.hs new file mode 100644 index 0000000000..0c63c457d4 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.hs @@ -0,0 +1 @@ +def = let quux = _ in 1 + 1 \ No newline at end of file diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index b471fa65cb..8657ec6249 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -227,6 +227,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "ghcide-code-actions-bindings" in Refactor.bindingsPluginDescriptor (pluginRecorder pId) pId : let pId = "ghcide-code-actions-fill-holes" in Refactor.fillHolePluginDescriptor (pluginRecorder pId) pId : let pId = "ghcide-extend-import-action" in Refactor.extendImportPluginDescriptor (pluginRecorder pId) pId : + let pId = "ghcide-code-actions-extract" in Refactor.extractCodePluginDescriptor (pluginRecorder pId) pId : #endif GhcIde.descriptors (pluginRecorder "ghcide") #if explicitFixity