Skip to content

Commit a45c5ee

Browse files
author
Santiago Weight
committed
support extract function action
1 parent fe139af commit a45c5ee

23 files changed

+483
-32
lines changed

‎ghcide/src/Development/IDE/GHC/Error.hs

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ import Development.IDE.GHC.Orphans ()
4444
import Development.IDE.Types.Diagnostics as D
4545
import Development.IDE.Types.Location
4646
import GHC
47-
import Language.LSP.Types (isSubrangeOf)
47+
import Language.LSP.Types (isSubrangeOf)
4848

4949

5050
diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
@@ -112,16 +112,22 @@ rangeToRealSrcSpan nfp =
112112
<$> positionToRealSrcLoc nfp . _start
113113
<*> positionToRealSrcLoc nfp . _end
114114

115+
#if !MIN_VERSION_ghc(9,2,1)
115116
positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc
116117
positionToRealSrcLoc nfp (Position l c)=
117118
Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (fromIntegral $ l + 1) (fromIntegral $ c + 1)
119+
#else
120+
positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc
121+
positionToRealSrcLoc nfp (Position l c)=
122+
Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (fromIntegral $ l + 1) (fromIntegral c)
123+
#endif
118124

119125
isInsideSrcSpan :: Position -> SrcSpan -> Bool
120126
p `isInsideSrcSpan` r = case srcSpanToRange r of
121127
Just (Range sp ep) -> sp <= p && p <= ep
122128
_ -> False
123129

124-
-- Returns Nothing if the SrcSpan does not represent a valid range
130+
-- | Returns Nothing if the SrcSpan does not represent a valid range
125131
spanContainsRange :: SrcSpan -> Range -> Maybe Bool
126132
spanContainsRange srcSpan range = (range `isSubrangeOf`) <$> srcSpanToRange srcSpan
127133

‎plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,7 @@ import Language.LSP.Types (CodeAction (CodeAction, _com
7575
WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),
7676
type (|?) (InR),
7777
uriToNormalizedFilePath)
78+
import Development.IDE (spanContainsRange)
7879

7980
thenCmp :: Ordering -> Ordering -> Ordering
8081
{-# INLINE thenCmp #-}

‎plugins/hls-refactor-plugin/hls-refactor-plugin.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ library
2929
exposed-modules: Development.IDE.GHC.ExactPrint
3030
Development.IDE.GHC.Compat.ExactPrint
3131
Development.IDE.Plugin.CodeAction
32+
Development.IDE.Plugin.CodeAction.Extract
3233
Development.IDE.Plugin.CodeAction.Util
3334
Development.IDE.GHC.Dump
3435
other-modules: Development.IDE.Plugin.CodeAction.Args
@@ -97,6 +98,7 @@ test-suite tests
9798
default-language: Haskell2010
9899
hs-source-dirs: test
99100
main-is: Main.hs
101+
other-modules: Extract
100102
ghc-options: -O0 -threaded -rtsopts -with-rtsopts=-N -Wunused-imports
101103
build-depends:
102104
, base

‎plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs

Lines changed: 23 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,9 @@ module Development.IDE.GHC.ExactPrint
5050
ExceptStringT (..),
5151
TransformT,
5252
Log(..),
53+
mapAnchor,
54+
generatedAnchor,
55+
modifySmallestDeclWithM_,
5356
)
5457
where
5558

@@ -479,14 +482,33 @@ modifySmallestDeclWithM validSpan f a = do
479482
False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest
480483
modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a
481484

485+
-- | Replace the smallest declaration whose SrcSpan satisfies the given condition with a new
486+
-- list of declarations.
487+
--
488+
-- For example, if you would like to move a where-clause-defined variable to the same
489+
-- level as its parent HsDecl, you could use this function.
490+
modifySmallestDeclWithM_ ::
491+
forall a m r.
492+
(HasDecls a, Monad m) =>
493+
(SrcSpan -> m Bool) ->
494+
(LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]) ->
495+
a ->
496+
TransformT m a
497+
modifySmallestDeclWithM_ validSpan f a = fst <$> modifySmallestDeclWithM validSpan (fmap (, ()) . f) a
498+
482499
generatedAnchor :: AnchorOperation -> Anchor
483500
generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp
484501

485-
setAnchor :: Anchor -> SrcSpanAnnN -> SrcSpanAnnN
502+
setAnchor :: Anchor -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
486503
setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) =
487504
SrcSpanAnn (EpAnn anc nameAnn comments) span
488505
setAnchor _ spanAnnN = spanAnnN
489506

507+
mapAnchor :: Monoid ann => (Maybe Anchor -> Anchor) -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
508+
mapAnchor f (SrcSpanAnn (EpAnn anc nameAnn comments) span) =
509+
SrcSpanAnn (EpAnn (f $ Just anc) nameAnn comments) span
510+
mapAnchor f (SrcSpanAnn EpAnnNotUsed span) = SrcSpanAnn (EpAnn (f Nothing) mempty emptyComments) span
511+
490512
removeTrailingAnns :: SrcSpanAnnN -> SrcSpanAnnN
491513
removeTrailingAnns (SrcSpanAnn (EpAnn anc nameAnn comments) span) =
492514
let nameAnnSansTrailings = nameAnn {nann_trailing = []}

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

Lines changed: 14 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,8 @@ module Development.IDE.Plugin.CodeAction
1111
fillHolePluginDescriptor,
1212
extendImportPluginDescriptor,
1313
-- * For testing
14-
matchRegExMultipleImports
14+
matchRegExMultipleImports,
15+
extractCodePluginDescriptor
1516
) where
1617

1718
import Control.Applicative ((<|>))
@@ -54,6 +55,8 @@ import Development.IDE.GHC.Util (printOutputa
5455
printRdrName)
5556
import Development.IDE.Plugin.CodeAction.Args
5657
import Development.IDE.Plugin.CodeAction.ExactPrint
58+
import Development.IDE.Plugin.CodeAction.Util
59+
import Development.IDE.Plugin.CodeAction.Extract
5760
import Development.IDE.Plugin.CodeAction.PositionIndexed
5861
import Development.IDE.Plugin.CodeAction.Util
5962
import Development.IDE.Plugin.Completions.Types
@@ -116,7 +119,8 @@ import GHC (AddEpAnn (Ad
116119
TrailingAnn (..),
117120
addTrailingAnnToA,
118121
emptyComments,
119-
noAnn)
122+
noAnn,
123+
LocatedA, spans)
120124
import GHC.Hs (IsUnicodeSyntax (..))
121125
import Language.Haskell.GHC.ExactPrint.Transform (d1)
122126

@@ -203,6 +207,13 @@ extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> Plu
203207
extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId)
204208
{ pluginCommands = [extendImportCommand] }
205209

210+
-- | Add the ability for a plugin to call GetAnnotatedParsedSource
211+
extractCodePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState
212+
extractCodePluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
213+
mkGhcideCAsPlugin [
214+
wrap suggestExtractFunction
215+
]
216+
plId
206217

207218
-- | Add the ability for a plugin to call GetAnnotatedParsedSource
208219
mkExactprintPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginDescriptor a -> PluginDescriptor a
@@ -1073,11 +1084,9 @@ addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) =
10731084
insertArg n (a:as) = a : insertArg (n - 1) as
10741085
lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res)
10751086
in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy')
1076-
1077-
fromLspList :: List a -> [a]
1078-
fromLspList (List a) = a
10791087
#endif
10801088

1089+
10811090
suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]
10821091
suggestFillTypeWildcard Diagnostic{_range=_range,..}
10831092
-- Foo.hs:3:8: error:
@@ -2097,24 +2106,6 @@ splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x
20972106
= (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
20982107
| otherwise = (x, T.empty)
20992108

2100-
-- | Returns [start .. end[
2101-
textInRange :: Range -> T.Text -> T.Text
2102-
textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text =
2103-
case compare startRow endRow of
2104-
LT ->
2105-
let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
2106-
(textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
2107-
[] -> ("", [])
2108-
firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
2109-
maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
2110-
in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
2111-
EQ ->
2112-
let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
2113-
in T.take (endCol - startCol) (T.drop startCol line)
2114-
GT -> ""
2115-
where
2116-
linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
2117-
21182109
-- | Returns the ranges for a binding in an import declaration
21192110
rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]
21202111
rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b =

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs

Lines changed: 12 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,7 @@ type GhcideCodeAction = ExceptT ResponseError (ReaderT CodeActionArgs IO) Ghcide
5555

5656
{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-}
5757
runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult
58-
runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do
58+
runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) (Just -> caaRange) CodeActionContext {_diagnostics = List diags}) codeAction = do
5959
let mbFile = toNormalizedFilePath' <$> uriToFilePath uri
6060
runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key
6161
caaGhcSession <- onceIO $ runRule GhcSession
@@ -85,10 +85,10 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra
8585
results <- liftIO $
8686

8787
sequence
88-
[ runReaderT (runExceptT codeAction) caa
89-
| caaDiagnostic <- diags,
88+
([ runReaderT (runExceptT codeAction) caa
89+
| (Just -> caaDiagnostic) <- diags,
9090
let caa = CodeActionArgs {..}
91-
]
91+
] <> [let caaDiagnostic = Nothing in runReaderT (runExceptT codeAction) CodeActionArgs{..}])
9292
let (errs, successes) = partitionEithers results
9393
pure $ concat successes
9494

@@ -101,7 +101,9 @@ mkGhcideCAPlugin codeAction plId =
101101
(defaultPluginDescriptor plId)
102102
{ pluginHandlers = mkPluginHandler STextDocumentCodeAction $
103103
\state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do
104+
-- traceM "pre-runAction"
104105
results <- runGhcideCodeAction state params codeAction
106+
-- traceM "post-runAction"
105107
pure $
106108
Right $
107109
List
@@ -163,7 +165,8 @@ data CodeActionArgs = CodeActionArgs
163165
caaHar :: IO (Maybe HieAstResult),
164166
caaBindings :: IO (Maybe Bindings),
165167
caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult),
166-
caaDiagnostic :: Diagnostic
168+
caaDiagnostic :: Maybe Diagnostic,
169+
caaRange :: Maybe Range
167170
}
168171

169172
-- | There's no concurrency in each provider,
@@ -251,7 +254,10 @@ instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where
251254
toCodeAction = toCodeAction3 caaIdeOptions
252255

253256
instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where
254-
toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f x
257+
toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f <$> x
258+
259+
instance ToCodeAction r => ToCodeAction (Range -> r) where
260+
toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaRange = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f <$> x
255261

256262
instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where
257263
toCodeAction = toCodeAction1 caaParsedModule

0 commit comments

Comments
 (0)