Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Extract code action #3337

Open
wants to merge 6 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
4 changes: 2 additions & 2 deletions ghcide/src/Development/IDE/GHC/Error.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -121,7 +121,7 @@ p `isInsideSrcSpan` r = case srcSpanToRange r of
Just (Range sp ep) -> sp <= p && p <= ep
_ -> False

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

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Expand Down Expand Up @@ -75,6 +74,7 @@ import Language.LSP.Types (CodeAction (CodeAction, _com
WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),
type (|?) (InR),
uriToNormalizedFilePath)
import Development.IDE (spanContainsRange)
santiweight marked this conversation as resolved.
Show resolved Hide resolved

thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
Expand Down
2 changes: 2 additions & 0 deletions plugins/hls-refactor-plugin/hls-refactor-plugin.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -50,6 +50,10 @@ module Development.IDE.GHC.ExactPrint
ExceptStringT (..),
TransformT,
Log(..),
mapAnchor,
generatedAnchor,
modifySmallestDeclWithM_,
querySmallestDeclWithM,
)
where

Expand Down Expand Up @@ -479,14 +483,46 @@ modifySmallestDeclWithM validSpan f a = do
False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest
modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a

-- | Just like modifySmallestDeclWithM but just find some information about the declaration
querySmallestDeclWithM ::
forall a m r.
(HasDecls a, Monad m) =>
(SrcSpan -> m Bool) ->
(LHsDecl GhcPs -> TransformT m r) ->
a ->
TransformT m (Maybe r)
querySmallestDeclWithM validSpan f a = do
(_, r) <- modifySmallestDeclWithM
validSpan
(\ decl -> do
r <- f decl
pure ([decl], r))
a
pure r

-- | Just like modifySmallestDeclWithM but with no extra result
modifySmallestDeclWithM_ ::
forall a m.
(HasDecls a, Monad m) =>
(SrcSpan -> m Bool) ->
(LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]) ->
a ->
TransformT m a
modifySmallestDeclWithM_ validSpan f a = fst <$> modifySmallestDeclWithM validSpan (fmap (, ()) . f) a

generatedAnchor :: AnchorOperation -> Anchor
generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp

setAnchor :: Anchor -> SrcSpanAnnN -> SrcSpanAnnN
setAnchor :: Anchor -> SrcSpanAnn' (EpAnn ann) -> SrcSpanAnn' (EpAnn ann)
setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) =
SrcSpanAnn (EpAnn anc nameAnn comments) span
setAnchor _ spanAnnN = spanAnnN

mapAnchor :: (Maybe Anchor -> Anchor) -> SrcSpanAnnA -> SrcSpanAnnA
mapAnchor f (SrcSpanAnn (EpAnn anc nameAnn comments) span) =
SrcSpanAnn (EpAnn (f $ Just anc) nameAnn comments) span
mapAnchor f (SrcSpanAnn EpAnnNotUsed span) = SrcSpanAnn (EpAnn (f Nothing) mempty emptyComments) span

removeTrailingAnns :: SrcSpanAnnN -> SrcSpanAnnN
removeTrailingAnns (SrcSpanAnn (EpAnn anc nameAnn comments) span) =
let nameAnnSansTrailings = nameAnn {nann_trailing = []}
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,8 @@ module Development.IDE.Plugin.CodeAction
fillHolePluginDescriptor,
extendImportPluginDescriptor,
-- * For testing
matchRegExMultipleImports
matchRegExMultipleImports,
extractCodePluginDescriptor
) where

import Control.Applicative ((<|>))
Expand Down Expand Up @@ -54,6 +55,7 @@ import Development.IDE.GHC.Util (printOutputa
printRdrName)
import Development.IDE.Plugin.CodeAction.Args
import Development.IDE.Plugin.CodeAction.ExactPrint
import Development.IDE.Plugin.CodeAction.Extract
import Development.IDE.Plugin.CodeAction.PositionIndexed
import Development.IDE.Plugin.CodeAction.Util
import Development.IDE.Plugin.Completions.Types
Expand Down Expand Up @@ -116,7 +118,8 @@ import GHC (AddEpAnn (Ad
TrailingAnn (..),
addTrailingAnnToA,
emptyComments,
noAnn)
noAnn,
spans)
import GHC.Hs (IsUnicodeSyntax (..))
import Language.Haskell.GHC.ExactPrint.Transform (d1)

Expand Down Expand Up @@ -203,6 +206,12 @@ extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> Plu
extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId)
{ pluginCommands = [extendImportCommand] }

extractCodePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState
extractCodePluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
mkGhcideCAsPlugin [
wrap suggestExtractFunction
]
plId

-- | Add the ability for a plugin to call GetAnnotatedParsedSource
mkExactprintPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginDescriptor a -> PluginDescriptor a
Expand Down Expand Up @@ -1073,11 +1082,9 @@ addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) =
insertArg n (a:as) = a : insertArg (n - 1) as
lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res)
in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy')

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


suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]
suggestFillTypeWildcard Diagnostic{_range=_range,..}
-- Foo.hs:3:8: error:
Expand Down Expand Up @@ -2097,24 +2104,6 @@ splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x
= (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
| otherwise = (x, T.empty)

-- | Returns [start .. end[
textInRange :: Range -> T.Text -> T.Text
textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text =
case compare startRow endRow of
LT ->
let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
(textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
[] -> ("", [])
firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
EQ ->
let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
in T.take (endCol - startCol) (T.drop startCol line)
GT -> ""
where
linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)

-- | Returns the ranges for a binding in an import declaration
rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]
rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b =
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@ type GhcideCodeAction = ExceptT ResponseError (ReaderT CodeActionArgs IO) Ghcide

{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-}
runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult
runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do
runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = List diags}) codeAction = do
let mbFile = toNormalizedFilePath' <$> uriToFilePath uri
runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key
caaGhcSession <- onceIO $ runRule GhcSession
Expand All @@ -82,13 +82,15 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra
caaHar <- onceIO $ runRule GetHieAst
caaBindings <- onceIO $ runRule GetBindings
caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs
let caaRange = Just range
results <- liftIO $

sequence
[ runReaderT (runExceptT codeAction) caa
| caaDiagnostic <- diags,
([ runReaderT (runExceptT codeAction) caa
| diagnostic <- diags,
let caaDiagnostic = Just diagnostic,
let caa = CodeActionArgs {..}
]
] <> [let caaDiagnostic = Nothing in runReaderT (runExceptT codeAction) CodeActionArgs{..}])
let (errs, successes) = partitionEithers results
pure $ concat successes

Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -251,7 +254,10 @@ instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where
toCodeAction = toCodeAction3 caaIdeOptions

instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where
Copy link
Collaborator

Choose a reason for hiding this comment

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

every time I see this I am surprised again by this stuff lol

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
Expand Down