From 0d91dd17b5464a8a97b25719f4a3f22ab0a2ee0b Mon Sep 17 00:00:00 2001 From: Santiago Weight Date: Sun, 2 Oct 2022 19:22:47 -0700 Subject: [PATCH 1/6] support extract function action --- ghcide/src/Development/IDE/GHC/Error.hs | 10 +- .../src/Ide/Plugin/QualifyImportedNames.hs | 1 + .../hls-refactor-plugin.cabal | 2 + .../src/Development/IDE/GHC/ExactPrint.hs | 24 +- .../src/Development/IDE/Plugin/CodeAction.hs | 37 +-- .../Development/IDE/Plugin/CodeAction/Args.hs | 18 +- .../IDE/Plugin/CodeAction/Extract.hs | 250 ++++++++++++++++++ plugins/hls-refactor-plugin/test/Extract.hs | 98 +++++++ plugins/hls-refactor-plugin/test/Main.hs | 4 + .../ExtractFreeVars.1_5_3_19.expected.hs | 9 + .../ExtractFreeVars.3_7_3_19.expected.hs | 9 + .../data/golden/extract/ExtractFreeVars.hs | 6 + ...xtractFreeVarsComplex.5_5_7_34.expected.hs | 13 + .../golden/extract/ExtractFreeVarsComplex.hs | 10 + ...xtractFromDeclWithSig.1_7_1_28.expected.hs | 3 + .../golden/extract/ExtractFromDeclWithSig.hs | 2 + .../ExtractFromWhere.2_11_2_16.expected.hs | 5 + .../data/golden/extract/ExtractFromWhere.hs | 3 + .../ExtractSimple.0_23_0_28.expected.hs | 3 + .../ExtractSimple.0_6_0_28.expected.hs | 3 + .../ExtractSimple.0_7_0_28.expected.hs | 3 + .../test/data/golden/extract/ExtractSimple.hs | 1 + src/HlsPlugins.hs | 1 + 23 files changed, 483 insertions(+), 32 deletions(-) create mode 100644 plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs create mode 100644 plugins/hls-refactor-plugin/test/Extract.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.1_5_3_19.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.3_7_3_19.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVars.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromDeclWithSig.1_7_1_28.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromDeclWithSig.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromWhere.2_11_2_16.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFromWhere.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_23_0_28.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_6_0_28.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.0_7_0_28.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractSimple.hs diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index a8a7acce27..d0a82c83e2 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 @@ -112,16 +112,22 @@ rangeToRealSrcSpan nfp = <$> positionToRealSrcLoc nfp . _start <*> positionToRealSrcLoc nfp . _end +#if !MIN_VERSION_ghc(9,2,1) positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc positionToRealSrcLoc nfp (Position l c)= Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (fromIntegral $ l + 1) (fromIntegral $ c + 1) +#else +positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc +positionToRealSrcLoc nfp (Position l c)= + Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (fromIntegral $ l + 1) (fromIntegral c) +#endif isInsideSrcSpan :: Position -> SrcSpan -> Bool 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..44ca2e73ab 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 @@ -75,6 +75,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..71b6669802 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,9 @@ module Development.IDE.GHC.ExactPrint ExceptStringT (..), TransformT, Log(..), + mapAnchor, + generatedAnchor, + modifySmallestDeclWithM_, ) where @@ -479,14 +482,33 @@ modifySmallestDeclWithM validSpan f a = do False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a +-- | 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 r. + (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 :: Monoid ann => (Maybe Anchor -> Anchor) -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann) +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..b4377e08ef 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,8 @@ import Development.IDE.GHC.Util (printOutputa printRdrName) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint +import Development.IDE.Plugin.CodeAction.Util +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 +119,8 @@ import GHC (AddEpAnn (Ad TrailingAnn (..), addTrailingAnnToA, emptyComments, - noAnn) + noAnn, + LocatedA, spans) import GHC.Hs (IsUnicodeSyntax (..)) import Language.Haskell.GHC.ExactPrint.Transform (d1) @@ -203,6 +207,13 @@ extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> Plu extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId) { pluginCommands = [extendImportCommand] } +-- | Add the ability for a plugin to call GetAnnotatedParsedSource +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 +1084,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 +2106,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..ddeef3d4ce 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) (Just -> caaRange) 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 @@ -85,10 +85,10 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra results <- liftIO $ sequence - [ runReaderT (runExceptT codeAction) caa - | caaDiagnostic <- diags, + ([ runReaderT (runExceptT codeAction) caa + | (Just -> caaDiagnostic) <- diags, let caa = CodeActionArgs {..} - ] + ] <> [let caaDiagnostic = Nothing in runReaderT (runExceptT codeAction) CodeActionArgs{..}]) let (errs, successes) = partitionEithers results pure $ concat successes @@ -101,7 +101,9 @@ mkGhcideCAPlugin codeAction plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction $ \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do + -- traceM "pre-runAction" results <- runGhcideCodeAction state params codeAction + -- traceM "post-runAction" pure $ Right $ List @@ -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..e3905de7b9 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GADTs #-} + +module Development.IDE.Plugin.CodeAction.Extract (textInRange, suggestExtractFunction, fromLspList) where + +import Control.Applicative ((<|>)) +import Data.Data (Data) +import Data.Foldable (foldl') +import Data.Function +import Data.Generics (Typeable, + everywhere, mkT) +import Data.Maybe +import Data.Monoid (Sum (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (fromString) +import qualified Data.Text as T +import Debug.Trace +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Core as Compat +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Error (positionToRealSrcLoc, + rangeToSrcSpan) +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 (..), + LocatedN, + NoEpAnns (..), + SrcSpanAnn' (SrcSpanAnn), + emptyComments, + realSrcSpan) +import GHC.Types.SrcLoc (generatedSrcSpan) +import Ide.PluginUtils (makeDiffTextEdit) +import Language.Haskell.GHC.ExactPrint (noAnnSrcSpanDP, + runTransform, + runTransformT, + uniqueSrcSpanT) +import Language.Haskell.GHC.ExactPrint.ExactPrint (showAst) +import Language.Haskell.GHC.ExactPrint.Transform (d1) +import Language.LSP.Types (List (..), UInt) +import Language.LSP.Types.Capabilities +import Control.Monad.Identity (Identity(..)) + +-- | Returns True if two SrcSpan occupy the same text region (even if they have different file information) +isSameSrcSpanModuloFile :: SrcSpan -> SrcSpan -> Bool +isSameSrcSpanModuloFile span1 span2 = span1 `isSubspanOf` span2 && span2 `isSubspanOf` span1 + +-- | 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} + +-- | 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. Consider the following selection: +-- +-- 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 catch this case, we narrow the selection to: +-- +-- foo = 1 + 2 +-- ^ ^ +-- and look for LHsExprs that precisely match the given Range, which ensures that we only accept a range if: +-- 1. the range wraps an entire LHsExpr +-- 2. the range wraps an LHsExpr exactly +-- +-- More explanation of (2)... If a range does exactly match any LHsExpr, then we know it is an invalid range for +-- extract, since there is no whitespace padding in the range. +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)) + +-- | 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@(RealSrcSpan realSrcSpan _)) _) :: LHsExpr GhcPs + | rangeSrcSpan <- rangeToSrcSpan (fromString $ unpackFS $ srcSpanFile realSrcSpan) (unUnpaddedRange range) + , isSameSrcSpanModuloFile rangeSrcSpan span + -> (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 + +rdrNameQ :: GenericQ [RdrName] +rdrNameQ =everything (<>) $ mkQ [] $ \case name -> [name] + +boundVarsQ :: forall a. Data a => a -> [RdrName] +boundVarsQ = everything (<>) $ mkQ [] + (\case + -- pat@(VarPat _ var :: Pat GhcPs) -> trace (showAst pat) [unLocA var] + pat@(VarPat _ var :: Pat GhcPs) -> [unLocA var] + -- e -> trace (showAst e) [] + e -> [] + ) + `extQ` + (\case + -- (FunBind {fun_id, fun_matches} :: HsBindLR GhcPs GhcPs) -> trace (showAst (fun_matches, boundVarsQ fun_matches)) [unLocA fun_id] + (FunBind {fun_id, fun_matches} :: HsBindLR GhcPs GhcPs) -> [unLocA fun_id] + PatBind {pat_lhs, pat_rhs} -> rdrNameQ pat_lhs -- TODO shadowing + VarBind {var_id, var_rhs} -> [var_id] -- TODO shadowing + PatSynBind {} -> [] -- TODO + AbsBinds {} -> [] -- TODO + ) + `extQ` + (\case + (HsValBinds _ binds :: HsLocalBindsLR GhcPs GhcPs) -> boundVarsQ binds + HsIPBinds {} -> [] -- TODO + EmptyLocalBinds {} -> [] + ) + -- Can't get this to match? + -- `extQ` + -- (\case + -- (Match {m_pats} :: Match GhcPs (LHsExpr GhcPs)) -> trace (showAst m_pats) rdrNameQ m_pats + -- ) + +usedVarsQ :: forall a. Data a => a -> [RdrName] +usedVarsQ = everything (<>) $ mkQ [] $ + \case + (HsVar _ var :: HsExpr GhcPs) -> [unLocA var] + _ -> [] + +suggestExtractFunction :: T.Text -> Annotated ParsedSource -> Range -> [(T.Text, [TextEdit])] +suggestExtractFunction srcText (Annotated parsedSource _) range = + let minimalRange = removeWhitespacePadding range srcText + edits = case tryFindLargestExprInRange minimalRange parsedSource of + Nothing -> [] + Just (extractSpan, extractExpr) -> (\(a,_,_) -> a) $ runTransform $ do + let newDefName = noLocA $ mkRdrUnqual $ mkVarOcc $ T.unpack "newDefinition" + -- We do not actually modify anything, just find the bound variables + (_, boundVars) <- modifySmallestDeclWithM (Identity . (extractSpan `isSubspanOf`)) + (\ decl -> pure ([decl], boundVarsQ decl)) + -- traceM $ "decl" <> showAst decl + parsedSource + -- TODO + let allVarsInExtracted = usedVarsQ extractExpr + let boundVarsInExtracted = boundVarsQ extractExpr + let args = (Set.fromList (fromMaybe [] boundVars) `Set.difference` Set.fromList boundVarsInExtracted) + `Set.intersection` Set.fromList allVarsInExtracted + let argsList = Set.toList args + -- traceM $ "allVarsInExtracted" <> showAst allVarsInExtracted + -- traceM $ "boundVars" <> showAst boundVars + -- traceM $ "args" <> showAst args + -- traceM $ "extracted" <> showAst extractExpr + newDef <- generateNewDecl newDefName argsList extractExpr + let addNewDef = modifySmallestDeclWithM_ + (Identity . (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") + removeExpr = 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' = removeExpr parsedSource + source'' <- addNewDef $ makeDeltaAst source' + let diff = makeDiffTextEdit (T.pack $ exactPrint parsedSource) (T.pack $ exactPrint $ makeDeltaAst source'') + pure [("Extract function", fromLspList diff)] + in edits +suggestExtractFunction _ _ _ = [] -- Could not find Annotated ParsedSource + +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) + +-- | 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 diff --git a/plugins/hls-refactor-plugin/test/Extract.hs b/plugins/hls-refactor-plugin/test/Extract.hs new file mode 100644 index 0000000000..5a3b1492b4 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/Extract.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} + +module Extract (extractTests) where + +import Control.Applicative.Combinators +import Control.Lens ((^.)) +import Control.Monad +import Data.Default +import Data.Foldable +import Data.List.Extra +import Data.Maybe +import qualified Data.Text as T +import Data.Tuple.Extra +import Development.IDE.GHC.Util +import Development.IDE.Plugin.Completions.Types (extendImportCommandId) +import Development.IDE.Test +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Ide.Types +import Language.LSP.Test +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), + mkRange) +import qualified Language.LSP.Types as LSP +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as L +import System.Directory +import System.FilePath +import System.Info.Extra (isMac, isWindows) +import qualified System.IO.Extra +import System.IO.Extra hiding (withTempDir) +import System.Time.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Text.Regex.TDFA ((=~)) + + +import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports, bindingsPluginDescriptor) +import Test.Hls + +import qualified Development.IDE.Plugin.CodeAction as Refactor +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import Debug.Trace (traceM, traceShowM) + + +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) + , mkGoldenExtractTest "ExtractFreeVarsComplex" (R 5 5 7 34) + , 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/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.5_5_7_34.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs new file mode 100644 index 0000000000..6b5c2c6eda --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ViewPatterns #-} + +data Foo = Foo {f1 :: Int, f2 :: Int} + +newDefinition f1 f3 v1 v2 v4 = + let v3 = 3 + in + f1 + f3 + v1 + v2 + v3 + v4 + +g Foo{f1=f1,f2=f2} (Foo f3 f4) (id -> v1) = \ v4 -> + newDefinition f1 f3 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..cd20f5f7ae --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ViewPatterns #-} + +data Foo = Foo {f1 :: Int, f2 :: Int} + +g Foo{f1=f1,f2=f2} (Foo f3 f4) (id -> v1) = \ v4 -> + let v3 = 3 + in + f1 + f3 + 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 From 99d5753903ce814380ed13cb1b1a4ff38866d0ae Mon Sep 17 00:00:00 2001 From: Santiago Weight Date: Sat, 19 Nov 2022 19:14:51 -0800 Subject: [PATCH 2/6] wip --- .../src/Development/IDE/GHC/ExactPrint.hs | 26 ++- .../IDE/Plugin/CodeAction/Extract.hs | 158 +++++++++++------- plugins/hls-refactor-plugin/test/Extract.hs | 3 +- ...xtractFreeVarsComplex.5_5_7_34.expected.hs | 4 +- ...xtractFreeVarsComplex.6_5_8_39.expected.hs | 14 ++ .../golden/extract/ExtractFreeVarsComplex.hs | 5 +- 6 files changed, 138 insertions(+), 72 deletions(-) create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.6_5_8_39.expected.hs 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 71b6669802..a42bce4b78 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -53,6 +53,7 @@ module Development.IDE.GHC.ExactPrint mapAnchor, generatedAnchor, modifySmallestDeclWithM_, + querySmallestDeclWithM, ) where @@ -482,15 +483,28 @@ modifySmallestDeclWithM validSpan f a = do False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a --- | 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_ :: +-- | 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 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 index e3905de7b9..8e85514967 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs @@ -51,9 +51,51 @@ import Language.LSP.Types (List (..), UInt) import Language.LSP.Types.Capabilities import Control.Monad.Identity (Identity(..)) --- | Returns True if two SrcSpan occupy the same text region (even if they have different file information) -isSameSrcSpanModuloFile :: SrcSpan -> SrcSpan -> Bool -isSameSrcSpanModuloFile span1 span2 = span1 `isSubspanOf` span2 && span2 `isSubspanOf` span1 +-- | 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 +-- +-- 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 -- | A type-safety-helpful newtype that represents that a Range has had its whitespace padding removed from both sides: -- @@ -135,7 +177,7 @@ setAtLeastNewlineDp (L srcSpanAnn decl) = L (mapAnchor (maybe nextLineAnchor set rdrNameQ :: GenericQ [RdrName] rdrNameQ =everything (<>) $ mkQ [] $ \case name -> [name] -boundVarsQ :: forall a. Data a => a -> [RdrName] +boundVarsQ :: GenericQ [RdrName] boundVarsQ = everything (<>) $ mkQ [] (\case -- pat@(VarPat _ var :: Pat GhcPs) -> trace (showAst pat) [unLocA var] @@ -170,51 +212,57 @@ usedVarsQ = everything (<>) $ mkQ [] $ (HsVar _ var :: HsExpr GhcPs) -> [unLocA var] _ -> [] -suggestExtractFunction :: T.Text -> Annotated ParsedSource -> Range -> [(T.Text, [TextEdit])] -suggestExtractFunction srcText (Annotated parsedSource _) range = - let minimalRange = removeWhitespacePadding range srcText - edits = case tryFindLargestExprInRange minimalRange parsedSource of - Nothing -> [] - Just (extractSpan, extractExpr) -> (\(a,_,_) -> a) $ runTransform $ do - let newDefName = noLocA $ mkRdrUnqual $ mkVarOcc $ T.unpack "newDefinition" - -- We do not actually modify anything, just find the bound variables - (_, boundVars) <- modifySmallestDeclWithM (Identity . (extractSpan `isSubspanOf`)) - (\ decl -> pure ([decl], boundVarsQ decl)) - -- traceM $ "decl" <> showAst decl - parsedSource - -- TODO - let allVarsInExtracted = usedVarsQ extractExpr - let boundVarsInExtracted = boundVarsQ extractExpr - let args = (Set.fromList (fromMaybe [] boundVars) `Set.difference` Set.fromList boundVarsInExtracted) - `Set.intersection` Set.fromList allVarsInExtracted - let argsList = Set.toList args - -- traceM $ "allVarsInExtracted" <> showAst allVarsInExtracted - -- traceM $ "boundVars" <> showAst boundVars - -- traceM $ "args" <> showAst args - -- traceM $ "extracted" <> showAst extractExpr - newDef <- generateNewDecl newDefName argsList extractExpr - let addNewDef = modifySmallestDeclWithM_ - (Identity . (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") - removeExpr = 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' = removeExpr parsedSource - source'' <- addNewDef $ makeDeltaAst source' - let diff = makeDiffTextEdit (T.pack $ exactPrint parsedSource) (T.pack $ exactPrint $ makeDeltaAst source'') - pure [("Extract function", fromLspList diff)] - in edits -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 intersection of the variables bound in the +-- expression's scope, and those bound in the surrounding context, and thereby find the newly-free variables +-- post-extraction. +-- +-- A simple counter-example to this strategy would occur by extracting the rhs of `foo`: +-- foo bar = let tmp = bar; bar = 1 in bar +-- Where bar is used in the rhs of, but is also bound in the same expression. 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. +-- In this case, bar is actually a free variable, but this function will find it not to be free. +-- TODO Record `{..}` pattern matching syntax; we can find the fields in the matching record to fix this. See +-- hls-explicit-refcord-fields-plugin +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. + -- TODO return error when we cannot find the containing decl + (fromMaybe [] -> boundVarsInWholeDecl) <- querySmallestDeclWithM (pure . (extractSpan `isSubspanOf`)) (pure . boundVarsQ) parsedSource + let boundVarsInExtractedExpr = boundVarsQ extractExpr + let usedVarsInExtractedExpr = usedVarsQ extractExpr + let varsThatScopeOverExtractedExpr = + Set.fromList boundVarsInWholeDecl `Set.difference` Set.fromList boundVarsInExtractedExpr + -- We use intersection, which implicitly assumes that all non-bound variables in the surrounding scope are + -- imports. This is where problems with record field wildcards arise. + let postExtractFreeVars = varsThatScopeOverExtractedExpr `Set.intersection` Set.fromList usedVarsInExtractedExpr + let argsList = Set.toList postExtractFreeVars + pure argsList + +-- | 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 + +-- | Returns True if two SrcSpan occupy the same text region (even if they have different file information) +isSameSrcSpanModuloFile :: SrcSpan -> SrcSpan -> Bool +isSameSrcSpanModuloFile span1 span2 = span1 `isSubspanOf` span2 && span2 `isSubspanOf` span1 fromLspList :: List a -> [a] fromLspList (List a) = a @@ -236,15 +284,3 @@ textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCo GT -> "" where linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) - --- | 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 diff --git a/plugins/hls-refactor-plugin/test/Extract.hs b/plugins/hls-refactor-plugin/test/Extract.hs index 5a3b1492b4..3c0d381844 100644 --- a/plugins/hls-refactor-plugin/test/Extract.hs +++ b/plugins/hls-refactor-plugin/test/Extract.hs @@ -72,7 +72,8 @@ extractTests = , mkGoldenExtractTest "ExtractSimple" (R 0 23 0 28) , mkGoldenExtractTest "ExtractFreeVars" (R 3 7 3 19) , mkGoldenExtractTest "ExtractFreeVars" (R 1 5 3 19) - , mkGoldenExtractTest "ExtractFreeVarsComplex" (R 5 5 7 34) + -- TODO this case uses record wild cards, and the current implementation handles it sub-optimally. + , mkGoldenExtractTest "ExtractFreeVarsComplex" (R 6 5 8 39) , mkGoldenExtractTest "ExtractFromDeclWithSig" (R 1 7 1 28) , mkGoldenExtractTest "ExtractFromWhere" (R 2 11 2 16) ] diff --git a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs index 6b5c2c6eda..93489e5ccc 100644 --- a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs @@ -7,7 +7,7 @@ newDefinition f1 f3 v1 v2 v4 = in f1 + f3 + v1 + v2 + v3 + v4 -g Foo{f1=f1,f2=f2} (Foo f3 f4) (id -> v1) = \ v4 -> - newDefinition f1 f3 v1 v2 v4 +g Foo{f1=f3,f2=f4} (Foo f5 f6) (id -> v1) = \ v4 -> + newDefinition f1 f3 fv1 v2 v4 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 index cd20f5f7ae..332f296fe6 100644 --- a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.hs +++ b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.hs @@ -1,10 +1,11 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} data Foo = Foo {f1 :: Int, f2 :: Int} -g Foo{f1=f1,f2=f2} (Foo f3 f4) (id -> v1) = \ v4 -> +g Foo{..} Foo{f1=f3,f2=f4} (Foo f5 f6) (id -> v1) = \ v4 -> let v3 = 3 in - f1 + f3 + v1 + v2 + v3 + v4 + f1 + f3 + f5 + v1 + v2 + v3 + v4 where v2 = 2 \ No newline at end of file From 07c7030770fd287a56ea1f0fb55f98b1c90da98d Mon Sep 17 00:00:00 2001 From: Santiago Weight Date: Sat, 19 Nov 2022 19:19:34 -0800 Subject: [PATCH 3/6] wip --- .../IDE/Plugin/CodeAction/Extract.hs | 174 ++++++++---------- 1 file changed, 78 insertions(+), 96 deletions(-) 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 index 8e85514967..8addd6bc55 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs @@ -1,55 +1,43 @@ -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} module Development.IDE.Plugin.CodeAction.Extract (textInRange, suggestExtractFunction, fromLspList) where -import Control.Applicative ((<|>)) -import Data.Data (Data) -import Data.Foldable (foldl') -import Data.Function -import Data.Generics (Typeable, - everywhere, mkT) +import Control.Applicative ((<|>)) +import Data.Data (Data) +import Data.Foldable (foldl') +import Data.Generics (everywhere, mkT) import Data.Maybe -import Data.Monoid (Sum (..)) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.String (fromString) -import qualified Data.Text as T -import Debug.Trace +import Data.Monoid (Sum (..)) +import qualified Data.Set as Set +import Data.String (fromString) +import qualified Data.Text as T import Development.IDE.GHC.Compat -import qualified Development.IDE.GHC.Compat.Core as Compat import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.Compat.Util -import Development.IDE.GHC.Error (positionToRealSrcLoc, - rangeToSrcSpan) +import Development.IDE.GHC.Error (rangeToSrcSpan) 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 (..), - LocatedN, - NoEpAnns (..), - SrcSpanAnn' (SrcSpanAnn), - emptyComments, - realSrcSpan) -import GHC.Types.SrcLoc (generatedSrcSpan) -import Ide.PluginUtils (makeDiffTextEdit) -import Language.Haskell.GHC.ExactPrint (noAnnSrcSpanDP, - runTransform, - runTransformT, - uniqueSrcSpanT) -import Language.Haskell.GHC.ExactPrint.ExactPrint (showAst) -import Language.Haskell.GHC.ExactPrint.Transform (d1) -import Language.LSP.Types (List (..), UInt) +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 -import Control.Monad.Identity (Identity(..)) -- | Suggest a code action for extracting the expression indicated by the user's current Range selection. -- @@ -97,6 +85,42 @@ suggestExtractFunction srcText (Annotated parsedSource _) range = 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 intersection of the variables bound in the +-- expression's scope, and those bound in the surrounding context, and thereby find the newly-free variables +-- post-extraction. +-- +-- A simple counter-example to this strategy would occur by extracting the rhs of `foo`: +-- foo bar = let tmp = bar; bar = 1 in bar +-- Where bar is used in the rhs of, but is also bound in the same expression. 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. +-- In this case, bar is actually a free variable, but this function will find it not to be free. +-- TODO Record `{..}` pattern matching syntax; we can find the fields in the matching record to fix this. See +-- hls-explicit-refcord-fields-plugin +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. + -- TODO return error when we cannot find the containing decl + (fromMaybe [] -> boundVarsInWholeDecl) <- querySmallestDeclWithM (pure . (extractSpan `isSubspanOf`)) (pure . boundVarsQ) parsedSource + let boundVarsInExtractedExpr = boundVarsQ extractExpr + let usedVarsInExtractedExpr = usedVarsQ extractExpr + let varsThatScopeOverExtractedExpr = + Set.fromList boundVarsInWholeDecl `Set.difference` Set.fromList boundVarsInExtractedExpr + -- We use intersection, which implicitly assumes that all non-bound variables in the surrounding scope are + -- imports. This is where problems with record field wildcards arise. + let postExtractFreeVars = varsThatScopeOverExtractedExpr `Set.intersection` Set.fromList usedVarsInExtractedExpr + let argsList = Set.toList postExtractFreeVars + pure argsList + -- | A type-safety-helpful newtype that represents that a Range has had its whitespace padding removed from both sides: -- -- Original range: @@ -174,25 +198,20 @@ setAtLeastNewlineDp (L srcSpanAnn decl) = L (mapAnchor (maybe nextLineAnchor set nextLine2Dp = MovedAnchor (DifferentLine 2 0) nextLineAnchor = generatedAnchor nextLine2Dp -rdrNameQ :: GenericQ [RdrName] -rdrNameQ =everything (<>) $ mkQ [] $ \case name -> [name] - +-- | Find all variable bindings in an AST. boundVarsQ :: GenericQ [RdrName] boundVarsQ = everything (<>) $ mkQ [] (\case - -- pat@(VarPat _ var :: Pat GhcPs) -> trace (showAst pat) [unLocA var] - pat@(VarPat _ var :: Pat GhcPs) -> [unLocA var] - -- e -> trace (showAst e) [] - e -> [] + (VarPat _ var :: Pat GhcPs) -> [unLocA var] + _ -> [] ) `extQ` (\case - -- (FunBind {fun_id, fun_matches} :: HsBindLR GhcPs GhcPs) -> trace (showAst (fun_matches, boundVarsQ fun_matches)) [unLocA fun_id] - (FunBind {fun_id, fun_matches} :: HsBindLR GhcPs GhcPs) -> [unLocA fun_id] - PatBind {pat_lhs, pat_rhs} -> rdrNameQ pat_lhs -- TODO shadowing - VarBind {var_id, var_rhs} -> [var_id] -- TODO shadowing - PatSynBind {} -> [] -- TODO - AbsBinds {} -> [] -- TODO + (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 + AbsBinds {} -> [] -- TODO ) `extQ` (\case @@ -200,54 +219,17 @@ boundVarsQ = everything (<>) $ mkQ [] HsIPBinds {} -> [] -- TODO EmptyLocalBinds {} -> [] ) - -- Can't get this to match? - -- `extQ` - -- (\case - -- (Match {m_pats} :: Match GhcPs (LHsExpr GhcPs)) -> trace (showAst m_pats) rdrNameQ m_pats - -- ) + where + rdrNameQ :: GenericQ [RdrName] + rdrNameQ =everything (<>) $ mkQ [] $ \case name -> [name] -usedVarsQ :: forall a. Data a => a -> [RdrName] +-- | Find variable usages bindings in an AST. +usedVarsQ :: GenericQ [RdrName] usedVarsQ = everything (<>) $ mkQ [] $ \case (HsVar _ var :: HsExpr GhcPs) -> [unLocA var] _ -> [] --- | 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 intersection of the variables bound in the --- expression's scope, and those bound in the surrounding context, and thereby find the newly-free variables --- post-extraction. --- --- A simple counter-example to this strategy would occur by extracting the rhs of `foo`: --- foo bar = let tmp = bar; bar = 1 in bar --- Where bar is used in the rhs of, but is also bound in the same expression. 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. --- In this case, bar is actually a free variable, but this function will find it not to be free. --- TODO Record `{..}` pattern matching syntax; we can find the fields in the matching record to fix this. See --- hls-explicit-refcord-fields-plugin -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. - -- TODO return error when we cannot find the containing decl - (fromMaybe [] -> boundVarsInWholeDecl) <- querySmallestDeclWithM (pure . (extractSpan `isSubspanOf`)) (pure . boundVarsQ) parsedSource - let boundVarsInExtractedExpr = boundVarsQ extractExpr - let usedVarsInExtractedExpr = usedVarsQ extractExpr - let varsThatScopeOverExtractedExpr = - Set.fromList boundVarsInWholeDecl `Set.difference` Set.fromList boundVarsInExtractedExpr - -- We use intersection, which implicitly assumes that all non-bound variables in the surrounding scope are - -- imports. This is where problems with record field wildcards arise. - let postExtractFreeVars = varsThatScopeOverExtractedExpr `Set.intersection` Set.fromList usedVarsInExtractedExpr - let argsList = Set.toList postExtractFreeVars - pure argsList - -- | 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 From 8ee9915b985ed31a19bf4e43dbcfc735e168bce7 Mon Sep 17 00:00:00 2001 From: Santiago Weight Date: Thu, 15 Dec 2022 18:05:51 -0800 Subject: [PATCH 4/6] wip --- ghcide/src/Development/IDE/GHC/Error.hs | 6 -- .../src/Ide/Plugin/QualifyImportedNames.hs | 1 - .../src/Development/IDE/GHC/ExactPrint.hs | 2 +- .../src/Development/IDE/Plugin/CodeAction.hs | 4 +- .../Development/IDE/Plugin/CodeAction/Args.hs | 8 +-- .../IDE/Plugin/CodeAction/Extract.hs | 60 +++++++++++++------ plugins/hls-refactor-plugin/test/Extract.hs | 52 +++------------- 7 files changed, 54 insertions(+), 79 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index d0a82c83e2..54f003349a 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -112,15 +112,9 @@ rangeToRealSrcSpan nfp = <$> positionToRealSrcLoc nfp . _start <*> positionToRealSrcLoc nfp . _end -#if !MIN_VERSION_ghc(9,2,1) positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc positionToRealSrcLoc nfp (Position l c)= Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (fromIntegral $ l + 1) (fromIntegral $ c + 1) -#else -positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc -positionToRealSrcLoc nfp (Position l c)= - Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (fromIntegral $ l + 1) (fromIntegral c) -#endif isInsideSrcSpan :: Position -> SrcSpan -> Bool p `isInsideSrcSpan` r = case srcSpanToRange r of 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 44ca2e73ab..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), 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 a42bce4b78..a9a6924771 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -518,7 +518,7 @@ setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) = SrcSpanAnn (EpAnn anc nameAnn comments) span setAnchor _ spanAnnN = spanAnnN -mapAnchor :: Monoid ann => (Maybe Anchor -> Anchor) -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann) +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 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 b4377e08ef..e743f559e0 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -55,7 +55,6 @@ import Development.IDE.GHC.Util (printOutputa printRdrName) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint -import Development.IDE.Plugin.CodeAction.Util import Development.IDE.Plugin.CodeAction.Extract import Development.IDE.Plugin.CodeAction.PositionIndexed import Development.IDE.Plugin.CodeAction.Util @@ -120,7 +119,7 @@ import GHC (AddEpAnn (Ad addTrailingAnnToA, emptyComments, noAnn, - LocatedA, spans) + spans) import GHC.Hs (IsUnicodeSyntax (..)) import Language.Haskell.GHC.ExactPrint.Transform (d1) @@ -207,7 +206,6 @@ extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> Plu extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId) { pluginCommands = [extendImportCommand] } --- | Add the ability for a plugin to call GetAnnotatedParsedSource extractCodePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState extractCodePluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ mkGhcideCAsPlugin [ 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 ddeef3d4ce..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) (Just -> caaRange) 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,11 +82,13 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) (Ju caaHar <- onceIO $ runRule GetHieAst caaBindings <- onceIO $ runRule GetBindings caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs + let caaRange = Just range results <- liftIO $ sequence ([ runReaderT (runExceptT codeAction) caa - | (Just -> caaDiagnostic) <- diags, + | diagnostic <- diags, + let caaDiagnostic = Just diagnostic, let caa = CodeActionArgs {..} ] <> [let caaDiagnostic = Nothing in runReaderT (runExceptT codeAction) CodeActionArgs{..}]) let (errs, successes) = partitionEithers results @@ -101,9 +103,7 @@ mkGhcideCAPlugin codeAction plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction $ \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do - -- traceM "pre-runAction" results <- runGhcideCodeAction state params codeAction - -- traceM "post-runAction" pure $ Right $ List 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 index 8addd6bc55..cbcf18eafe 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs @@ -1,20 +1,17 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} module Development.IDE.Plugin.CodeAction.Extract (textInRange, suggestExtractFunction, fromLspList) where import Control.Applicative ((<|>)) -import Data.Data (Data) import Data.Foldable (foldl') import Data.Generics (everywhere, mkT) import Data.Maybe import Data.Monoid (Sum (..)) import qualified Data.Set as Set -import Data.String (fromString) 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.Compat.Util -import Development.IDE.GHC.Error (rangeToSrcSpan) import Development.IDE.GHC.ExactPrint import Development.IDE.Types.Location import Generics.SYB (GenericQ, @@ -105,12 +102,13 @@ suggestExtractFunction _ _ _ = [] -- Could not find Annotated ParsedSource -- TODO Some subtle name shadowing issues in the extracted expression. Hard to fix without more GHC help. -- In this case, bar is actually a free variable, but this function will find it not to be free. -- TODO Record `{..}` pattern matching syntax; we can find the fields in the matching record to fix this. See --- hls-explicit-refcord-fields-plugin +-- hls-explicit-record-fields-plugin 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. -- TODO return error when we cannot find the containing decl - (fromMaybe [] -> boundVarsInWholeDecl) <- querySmallestDeclWithM (pure . (extractSpan `isSubspanOf`)) (pure . boundVarsQ) parsedSource + boundVarsInWholeDeclMay <- querySmallestDeclWithM (pure . (extractSpan `isSubspanOf`)) (pure . boundVarsQ) parsedSource + let boundVarsInWholeDecl = fromMaybe [] boundVarsInWholeDeclMay let boundVarsInExtractedExpr = boundVarsQ extractExpr let usedVarsInExtractedExpr = usedVarsQ extractExpr let varsThatScopeOverExtractedExpr = @@ -132,6 +130,7 @@ findFreeVarsPostExtract extractSpan extractExpr parsedSource = do -- ^ ^ -- 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. -- @@ -169,6 +168,24 @@ removeWhitespacePadding range@(Range (Position sl sc) (Position el ec)) source = (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 @@ -176,10 +193,15 @@ tryFindLargestExprInRange range = everythingBut (<|>) $ mkQ (Nothing, False) fir -- 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@(RealSrcSpan realSrcSpan _)) _) :: LHsExpr GhcPs - | rangeSrcSpan <- rangeToSrcSpan (fromString $ unpackFS $ srcSpanFile realSrcSpan) (unUnpaddedRange range) - , isSameSrcSpanModuloFile rangeSrcSpan span - -> (Just (span, lexpr), True) + -- lexpr@(L (SrcSpanAnn _ span@(RealSrcSpan realSrcSpan _)) _) :: LHsExpr GhcPs + -- | rangeSrcSpan <- rangeToSrcSpan (fromString $ unpackFS $ srcSpanFile realSrcSpan) (unUnpaddedRange range) + -- , isSameSrcSpanModuloFile rangeSrcSpan span + -- -> (Just (span, lexpr), True) + lexpr@(L (SrcSpanAnn _ span) _) :: LHsExpr GhcPs + | Just spanRange <- srcSpanToUnpaddedRange span, + range == spanRange + -- traceShow (range, spanRange) True + -> (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 @@ -199,6 +221,10 @@ setAtLeastNewlineDp (L srcSpanAnn decl) = L (mapAnchor (maybe nextLineAnchor set 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 @@ -210,18 +236,18 @@ boundVarsQ = everything (<>) $ mkQ [] (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 - AbsBinds {} -> [] -- TODO + PatSynBind {} -> [] -- TODO shadowing + AbsBinds {} -> [] -- TODO shadowing ) `extQ` (\case (HsValBinds _ binds :: HsLocalBindsLR GhcPs GhcPs) -> boundVarsQ binds - HsIPBinds {} -> [] -- TODO + HsIPBinds {} -> [] -- TODO shadowing EmptyLocalBinds {} -> [] ) where rdrNameQ :: GenericQ [RdrName] - rdrNameQ =everything (<>) $ mkQ [] $ \case name -> [name] + rdrNameQ =everything (<>) $ mkQ [] $ \name -> [name] -- | Find variable usages bindings in an AST. usedVarsQ :: GenericQ [RdrName] @@ -242,10 +268,6 @@ generateNewDecl name args expr = do funbind = FunBind noExtField name mg [] pure $ ValD noExtField funbind --- | Returns True if two SrcSpan occupy the same text region (even if they have different file information) -isSameSrcSpanModuloFile :: SrcSpan -> SrcSpan -> Bool -isSameSrcSpanModuloFile span1 span2 = span1 `isSubspanOf` span2 && span2 `isSubspanOf` span1 - fromLspList :: List a -> [a] fromLspList (List a) = a diff --git a/plugins/hls-refactor-plugin/test/Extract.hs b/plugins/hls-refactor-plugin/test/Extract.hs index 3c0d381844..d7867b53be 100644 --- a/plugins/hls-refactor-plugin/test/Extract.hs +++ b/plugins/hls-refactor-plugin/test/Extract.hs @@ -3,62 +3,24 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} module Extract (extractTests) where -import Control.Applicative.Combinators -import Control.Lens ((^.)) -import Control.Monad -import Data.Default -import Data.Foldable import Data.List.Extra -import Data.Maybe -import qualified Data.Text as T -import Data.Tuple.Extra -import Development.IDE.GHC.Util -import Development.IDE.Plugin.Completions.Types (extendImportCommandId) -import Development.IDE.Test +import qualified Data.Text as T +import qualified Development.IDE.Plugin.CodeAction as Refactor import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import Ide.Types import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start), - mkRange) -import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as L -import System.Directory -import System.FilePath -import System.Info.Extra (isMac, isWindows) -import qualified System.IO.Extra -import System.IO.Extra hiding (withTempDir) -import System.Time.Extra -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Text.Regex.TDFA ((=~)) - - -import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports, bindingsPluginDescriptor) +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), + mkRange) import Test.Hls -import qualified Development.IDE.Plugin.CodeAction as Refactor -import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Debug.Trace (traceM, traceShowM) - pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') From 37296cd90c20c9abccf7157f01a102de5ff29f68 Mon Sep 17 00:00:00 2001 From: Santiago Weight Date: Thu, 15 Dec 2022 18:45:57 -0800 Subject: [PATCH 5/6] wip --- .../IDE/Plugin/CodeAction/Extract.hs | 84 ++++++++++++------- plugins/hls-refactor-plugin/test/Extract.hs | 9 +- .../extract/ExtractBad.4_16_4_21.expected.hs | 9 ++ .../extract/ExtractBad.6_12_6_47.expected.hs | 9 ++ .../test/data/golden/extract/ExtractBad.hs | 7 ++ ...xtractFreeVarsComplex.5_5_7_34.expected.hs | 13 --- 6 files changed, 87 insertions(+), 44 deletions(-) create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.4_16_4_21.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.6_12_6_47.expected.hs create mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractBad.hs delete mode 100644 plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs 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 index cbcf18eafe..78904bd45d 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs @@ -44,8 +44,8 @@ import Language.LSP.Types.Capabilities -- Before: -- foo = x + y + z -- After --- newDefinition y + z = y + z --- foo = x + newDefinition +-- 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. @@ -86,14 +86,19 @@ suggestExtractFunction _ _ _ = [] -- Could not find Annotated ParsedSource -- 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 intersection of the variables bound in the --- expression's scope, and those bound in the surrounding context, and thereby find the newly-free variables --- post-extraction. +-- 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`: --- foo bar = let tmp = bar; bar = 1 in bar --- Where bar is used in the rhs of, but is also bound in the same expression. Thankfully this would just cause an --- unbound variable error post-extraction. +-- 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. @@ -102,22 +107,44 @@ suggestExtractFunction _ _ _ = [] -- Could not find Annotated ParsedSource -- TODO Some subtle name shadowing issues in the extracted expression. Hard to fix without more GHC help. -- In this case, bar is actually a free variable, but this function will find it not to be free. -- TODO Record `{..}` pattern matching syntax; we can find the fields in the matching record to fix this. See --- hls-explicit-record-fields-plugin +-- 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. - -- TODO return error when we cannot find the containing decl + -- 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 - let varsThatScopeOverExtractedExpr = + -- 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 - -- We use intersection, which implicitly assumes that all non-bound variables in the surrounding scope are - -- imports. This is where problems with record field wildcards arise. - let postExtractFreeVars = varsThatScopeOverExtractedExpr `Set.intersection` Set.fromList usedVarsInExtractedExpr - let argsList = Set.toList postExtractFreeVars - pure argsList + -- 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: -- @@ -135,23 +162,25 @@ newtype UnpaddedRange = UnpaddedRange {unUnpaddedRange :: Range} -- | 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. Consider the following selection: +-- 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 catch this case, we narrow the selection to: +-- 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 precisely match the given Range, which ensures that we only accept a range if: +-- 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 --- --- More explanation of (2)... If a range does exactly match any LHsExpr, then we know it is an invalid range for --- extract, since there is no whitespace padding in the range. +-- 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 @@ -193,14 +222,9 @@ tryFindLargestExprInRange range = everythingBut (<|>) $ mkQ (Nothing, False) fir -- 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@(RealSrcSpan realSrcSpan _)) _) :: LHsExpr GhcPs - -- | rangeSrcSpan <- rangeToSrcSpan (fromString $ unpackFS $ srcSpanFile realSrcSpan) (unUnpaddedRange range) - -- , isSameSrcSpanModuloFile rangeSrcSpan span - -- -> (Just (span, lexpr), True) lexpr@(L (SrcSpanAnn _ span) _) :: LHsExpr GhcPs | Just spanRange <- srcSpanToUnpaddedRange span, range == spanRange - -- traceShow (range, spanRange) True -> (Just (span, lexpr), True) _ -> (Nothing, False) diff --git a/plugins/hls-refactor-plugin/test/Extract.hs b/plugins/hls-refactor-plugin/test/Extract.hs index d7867b53be..e10259b2ec 100644 --- a/plugins/hls-refactor-plugin/test/Extract.hs +++ b/plugins/hls-refactor-plugin/test/Extract.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} @@ -34,7 +35,13 @@ extractTests = , 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. + -- 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) 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/ExtractFreeVarsComplex.5_5_7_34.expected.hs b/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs deleted file mode 100644 index 93489e5ccc..0000000000 --- a/plugins/hls-refactor-plugin/test/data/golden/extract/ExtractFreeVarsComplex.5_5_7_34.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -data Foo = Foo {f1 :: Int, f2 :: Int} - -newDefinition f1 f3 v1 v2 v4 = - let v3 = 3 - in - f1 + f3 + v1 + v2 + v3 + v4 - -g Foo{f1=f3,f2=f4} (Foo f5 f6) (id -> v1) = \ v4 -> - newDefinition f1 f3 fv1 v2 v4 - where - v2 = 2 \ No newline at end of file From bdb52ffc90f4573aabc50b64c4b3c30206f1c1b7 Mon Sep 17 00:00:00 2001 From: Santiago Weight Date: Sat, 17 Dec 2022 10:55:15 -0800 Subject: [PATCH 6/6] wip --- .../src/Development/IDE/Plugin/CodeAction/Extract.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) 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 index 78904bd45d..21efd32c19 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Extract.hs @@ -105,7 +105,8 @@ suggestExtractFunction _ _ _ = [] -- Could not find Annotated ParsedSource -- -- Some known weaknesses: -- TODO Some subtle name shadowing issues in the extracted expression. Hard to fix without more GHC help. --- In this case, bar is actually a free variable, but this function will find it not to be free. +-- 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,