support extract function action

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
 

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 #-}

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

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 = []}

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 =

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