diff --git a/hls-retrie-plugin.cabal b/hls-retrie-plugin.cabal --- a/hls-retrie-plugin.cabal +++ b/hls-retrie-plugin.cabal @@ -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 @@ -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 diff --git a/src/Ide/Plugin/Retrie.hs b/src/Ide/Plugin/Retrie.hs --- a/src/Ide/Plugin/Retrie.hs +++ b/src/Ide/Plugin/Retrie.hs @@ -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 = []