hls-retrie-plugin 2.0.0.1 → 2.1.0.0
raw patch · 2 files changed
+70/−72 lines, 2 filesdep +lensdep +mtldep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependencies added: lens, mtl
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
Files
- hls-retrie-plugin.cabal +6/−4
- src/Ide/Plugin/Retrie.hs +64/−68
hls-retrie-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hls-retrie-plugin-version: 2.0.0.1+version: 2.1.0.0 synopsis: Retrie integration plugin for Haskell Language Server description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -28,12 +28,14 @@ , directory , extra , ghc- , ghcide == 2.0.0.1+ , ghcide == 2.1.0.0 , hashable- , hls-plugin-api == 2.0.0.1+ , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin+ , lens , lsp , lsp-types+ , mtl , retrie >=0.1.1.0 , safe-exceptions , stm@@ -63,5 +65,5 @@ , hls-plugin-api , hls-refactor-plugin , hls-retrie-plugin- , hls-test-utils == 2.0.0.1+ , hls-test-utils == 2.1.0.0 , text
src/Ide/Plugin/Retrie.hs view
@@ -24,16 +24,17 @@ import Control.Exception.Safe (Exception (..), SomeException, assert, catch, throwIO, try)+import Control.Lens.Operators import Control.Monad (forM, unless, when)+import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift))-import Control.Monad.Trans.Except (ExceptT (ExceptT),- runExceptT, throwE)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.Strict import Data.Aeson (FromJSON (..),- ToJSON (..),- Value (Null))+ ToJSON (..), Value) import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.Coerce@@ -46,6 +47,7 @@ import Data.IORef.Extra (atomicModifyIORef'_, newIORef, readIORef) import Data.List.Extra (find, nubOrdOn)+import qualified Data.Map as Map import Data.Maybe (catMaybes, fromJust, listToMaybe) import Data.String (IsString)@@ -112,17 +114,17 @@ import qualified GHC as GHCGHC import GHC.Generics (Generic) import GHC.Hs.Dump+import Ide.Plugin.Error import Ide.PluginUtils import Ide.Types+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message as LSP+import Language.LSP.Protocol.Types as LSP import Language.LSP.Server (LspM, ProgressCancellable (Cancellable), sendNotification, sendRequest, withIndefiniteProgress)-import Language.LSP.Types as J hiding- (SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length),- SemanticTokensEdit (_start)) import Retrie (Annotated (astA), AnnotatedModule, Fixity (Fixity),@@ -170,6 +172,7 @@ #endif import Control.Arrow ((&&&)) import Development.IDE.Core.Actions (lookupMod)+import Development.IDE.Core.PluginUtils import Development.IDE.Spans.AtPoint (LookupModule, getNamesAtPoint, nameToLocation)@@ -178,7 +181,7 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)- { pluginHandlers = mkPluginHandler STextDocumentCodeAction provider,+ { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction provider, pluginCommands = [retrieCommand, retrieInlineThisCommand] } @@ -205,20 +208,16 @@ restrictToOriginatingFile :: Bool } deriving (Eq, Show, Generic, FromJSON, ToJSON)-runRetrieCmd ::- IdeState ->- RunRetrieParams ->- LspM c (Either ResponseError Value)-runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} =+runRetrieCmd :: CommandFunction IdeState RunRetrieParams+runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = ExceptT $ withIndefiniteProgress description Cancellable $ do- runMaybeT $ do- nfp <- MaybeT $ return $ uriToNormalizedFilePath $ toNormalizedUri uri- (session, _) <- MaybeT $ liftIO $- runAction "Retrie.GhcSessionDeps" state $- useWithStale GhcSessionDeps+ runExceptT $ do+ nfp <- getNormalizedFilePathE uri+ (session, _) <-+ runActionE "Retrie.GhcSessionDeps" state $+ useWithStaleE GhcSessionDeps nfp- (ms, binds, _, _, _) <- MaybeT $ liftIO $- runAction "Retrie.getBinds" state $ getBinds nfp+ (ms, binds, _, _, _) <- runActionE "Retrie.getBinds" state $ getBinds nfp let importRewrites = concatMap (extractImports ms binds) rewrites (errors, edits) <- liftIO $ callRetrie@@ -228,14 +227,14 @@ nfp restrictToOriginatingFile unless (null errors) $- lift $ sendNotification SWindowShowMessage $- ShowMessageParams MtWarning $+ lift $ sendNotification SMethod_WindowShowMessage $+ ShowMessageParams MessageType_Warning $ T.unlines $ "## Found errors during rewrite:" : ["-" <> T.pack (show e) | e <- errors]- lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ())+ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) return ()- return $ Right Null+ return $ Right $ InR Null data RunRetrieInlineThisParams = RunRetrieInlineThisParams { inlineIntoThisLocation :: !Location,@@ -244,49 +243,47 @@ } deriving (Eq, Show, Generic, FromJSON, ToJSON) -runRetrieInlineThisCmd :: IdeState- -> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value)-runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do- nfp <- handleMaybe "uri" $ uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineIntoThisLocation- nfpSource <- handleMaybe "sourceUri" $- uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineFromThisLocation+runRetrieInlineThisCmd :: CommandFunction IdeState RunRetrieInlineThisParams+runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = do+ nfp <- getNormalizedFilePathE $ getLocationUri inlineIntoThisLocation+ nfpSource <- getNormalizedFilePathE $ getLocationUri inlineFromThisLocation -- What we do here: -- Find the identifier in the given position -- Construct an inline rewrite for it -- Run retrie to get a list of changes -- Select the change that inlines the identifier in the given position -- Apply the edit- ast <- handleMaybeM "ast" $ liftIO $ runAction "retrie" state $- use GetAnnotatedParsedSource nfp- astSrc <- handleMaybeM "ast" $ liftIO $ runAction "retrie" state $- use GetAnnotatedParsedSource nfpSource- msr <- handleMaybeM "modSummary" $ liftIO $ runAction "retrie" state $- use GetModSummaryWithoutTimestamps nfp- hiFileRes <- handleMaybeM "modIface" $ liftIO $ runAction "retrie" state $- use GetModIface nfpSource+ ast <- runActionE "retrie" state $+ useE GetAnnotatedParsedSource nfp+ astSrc <- runActionE "retrie" state $+ useE GetAnnotatedParsedSource nfpSource+ msr <- runActionE "retrie" state $+ useE GetModSummaryWithoutTimestamps nfp+ hiFileRes <- runActionE "retrie" state $+ useE GetModIface nfpSource let fixityEnv = fixityEnvFromModIface (hirModIface hiFileRes) fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange- when (null inlineRewrite) $ throwE "Empty rewrite"- let ShakeExtras{..}= shakeExtras state- (session, _) <- handleMaybeM "GHCSession" $ liftIO $ runAction "retrie" state $- useWithStale GhcSessionDeps nfp+ when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite"+ let ShakeExtras{..} = shakeExtras state+ (session, _) <- runActionE "retrie" state $+ useWithStaleE GhcSessionDeps nfp (fixityEnv, cpp) <- liftIO $ getCPPmodule state (hscEnv session) $ fromNormalizedFilePath nfp result <- liftIO $ try @_ @SomeException $ runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp case result of- Left err -> throwE $ "Retrie - crashed with: " <> show err- Right (_,_,NoChange) -> throwE "Retrie - inline produced no changes"+ Left err -> throwError $ PluginInternalError $ "Retrie - crashed with: " <> T.pack (show err)+ Right (_,_,NoChange) -> throwError $ PluginInternalError "Retrie - inline produced no changes" Right (_,_,Change replacements imports) -> do let edits = asEditMap $ asTextEdits $ Change ourReplacement imports wedit = WorkspaceEdit (Just edits) Nothing Nothing ourReplacement = [ r | r@Replacement{..} <- replacements , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation]- lift $ sendRequest SWorkspaceApplyEdit+ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())- return Null+ return $ InR Null -- Override to skip adding binders to the context, which prevents inlining -- nested defined functions@@ -337,20 +334,19 @@ ------------------------------------------------------------------------------- -provider :: PluginMethodHandler IdeState TextDocumentCodeAction-provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = pluginResponse $ do- let (J.CodeActionContext _diags _monly) = ca- nuri = toNormalizedUri uri- nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri+provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction+provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = do+ let (LSP.CodeActionContext _diags _monly _) = ca+ nfp <- getNormalizedFilePathE uri (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds)- <- handleMaybeM "typecheck" $ liftIO $ runAction "retrie" state $+ <- runActionE "retrie" state $ getBinds nfp extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras - range <- handleMaybe "range" $ fromCurrentRange posMapping range- let pos = _start range+ range <- fromCurrentRangeE posMapping range+ let pos = range ^. L.start let rewrites = concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds ++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds@@ -370,19 +366,19 @@ suggestBindInlines plId uri topLevelBinds range withHieDb (lookupMod hiedbWriter) let inlineCommands = [ Just $- CodeAction _title (Just CodeActionRefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing+ CodeAction _title (Just CodeActionKind_RefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing | c@Command{..} <- inlineSuggestions ]- return $ J.List [InR c | c <- retrieCommands ++ catMaybes inlineCommands]+ return $ InL [InR c | c <- retrieCommands ++ catMaybes inlineCommands] getLocationUri :: Location -> Uri getLocationUri Location{_uri} = _uri getLocationRange Location{_range} = _range -getBinds :: NormalizedFilePath -> Action (Maybe (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn]))-getBinds nfp = runMaybeT $ do- (tm, posMapping) <- MaybeT $ useWithStale TypeCheck nfp+getBinds :: NormalizedFilePath -> ExceptT PluginError Action (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn])+getBinds nfp = do+ (tm, posMapping) <- useWithStaleE TypeCheck nfp -- we use the typechecked source instead of the parsed source -- to be able to extract module names from the Ids, -- so that we can include adding the required imports in the retrie command@@ -419,11 +415,11 @@ unfoldRewrite restrictToOriginatingFile = let rewrites = [Unfold (qualify ms_mod pprName)] description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile- in (description, CodeActionRefactorInline, RunRetrieParams {..})+ in (description, CodeActionKind_RefactorInline, RunRetrieParams {..}) foldRewrite restrictToOriginatingFile = let rewrites = [Fold (qualify ms_mod pprName)] description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile- in (description, CodeActionRefactorExtract, RunRetrieParams {..})+ in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..}) in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] suggestBindRewrites _ _ _ _ = [] @@ -480,11 +476,11 @@ unfoldRewrite restrictToOriginatingFile = let rewrites = [TypeForward (qualify ms_mod pprName)] description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile- in (description, CodeActionRefactorInline, RunRetrieParams {..})+ in (description, CodeActionKind_RefactorInline, RunRetrieParams {..}) foldRewrite restrictToOriginatingFile = let rewrites = [TypeBackward (qualify ms_mod pprName)] description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile- in (description, CodeActionRefactorExtract, RunRetrieParams {..})+ in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..}) in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] suggestTypeRewrites _ _ _ = [] @@ -517,7 +513,7 @@ describeRestriction restrictToOriginatingFile in ( description,- CodeActionRefactor,+ CodeActionKind_Refactor, RunRetrieParams {..} ) backwardsRewrite ruleName restrictToOriginatingFile =@@ -525,7 +521,7 @@ description = "Apply rule " <> T.pack ruleName <> " backwards" <> describeRestriction restrictToOriginatingFile in ( description,- CodeActionRefactor,+ CodeActionKind_Refactor, RunRetrieParams {..} ) @@ -703,8 +699,8 @@ constructfromFunMatches imports fun_id fun_matches _ -> return $ error "cound not find source code to inline" -asEditMap :: [(Uri, TextEdit)] -> WorkspaceEditMap-asEditMap = coerce . HM.fromListWith (++) . map (second pure)+asEditMap :: [(Uri, TextEdit)] -> Map.Map Uri [TextEdit]+asEditMap = Map.fromListWith (++) . map (second pure) asTextEdits :: Change -> [(Uri, TextEdit)] asTextEdits NoChange = []