diff --git a/hls-splice-plugin.cabal b/hls-splice-plugin.cabal --- a/hls-splice-plugin.cabal +++ b/hls-splice-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-splice-plugin -version: 2.0.0.1 +version: 2.1.0.0 synopsis: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes @@ -42,11 +42,12 @@ , foldl , ghc , ghc-exactprint - , ghcide == 2.0.0.1 - , hls-plugin-api == 2.0.0.1 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin , lens , lsp + , mtl , retrie , syb , text @@ -69,5 +70,6 @@ , base , filepath , hls-splice-plugin - , hls-test-utils == 2.0.0.1 + , hls-test-utils == 2.1.0.0 , text + , row-types diff --git a/src/Ide/Plugin/Splice.hs b/src/Ide/Plugin/Splice.hs --- a/src/Ide/Plugin/Splice.hs +++ b/src/Ide/Plugin/Splice.hs @@ -25,19 +25,21 @@ where import Control.Applicative (Alternative ((<|>))) -import Control.Arrow -import Control.Exception +import Control.Arrow ( Arrow(first) ) +import Control.Exception ( SomeException ) import qualified Control.Foldl as L import Control.Lens (Identity (..), ix, view, (%~), (<&>), (^.)) -import Control.Monad +import Control.Monad ( guard, unless, forM ) +import Control.Monad.Error.Class ( MonadError(throwError) ) import Control.Monad.Extra (eitherM) import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Unlift -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except +import Control.Monad.IO.Unlift ( MonadIO(..), askRunInIO ) +import Control.Monad.Trans.Class ( MonadTrans(lift) ) +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT ) import Control.Monad.Trans.Maybe -import Data.Aeson +import Data.Aeson hiding (Null) +import qualified Data.Bifunctor as B (first) import Data.Foldable (Foldable (foldl')) import Data.Function import Data.Generics @@ -47,32 +49,42 @@ mapMaybe) import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat as Compat hiding (getLoc) import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Transform (TransformT(TransformT)) + #if MIN_VERSION_ghc(9,4,1) + import GHC.Data.Bag (Bag) + #endif + import GHC.Exts + #if MIN_VERSION_ghc(9,2,0) + import GHC.Parser.Annotation (SrcSpanAnn'(..)) import qualified GHC.Types.Error as Error + #endif + import Ide.Plugin.Splice.Types import Ide.Types import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) import Language.LSP.Server -import Language.LSP.Types -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as J +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Lens as J +import Ide.Plugin.Error (PluginError(PluginInternalError)) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = commands - , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeAction } commands :: [PluginCommand IdeState] @@ -93,28 +105,27 @@ -- | Inplace? ExpandStyle -> CommandFunction IdeState ExpandSpliceParams -expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do +expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = ExceptT $ do clientCapabilities <- getClientCapabilities rio <- askRunInIO let reportEditor :: ReportEditor - reportEditor msgTy msgs = liftIO $ rio $ sendNotification SWindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) + reportEditor msgTy msgs = liftIO $ rio $ sendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) + expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit expandManually fp = do mresl <- liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp (TcModuleResult {..}, _) <- maybe - (throwE "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." + (throwError $ PluginInternalError "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." ) pure mresl reportEditor - MtWarning + MessageType_Warning [ "Expansion in type-checking phase failed;" , "trying to expand manually, but note that it is less rigorous." ] - pm <- - liftIO $ - runAction "expandTHSplice.fallback.GetParsedModule" ideState $ - use_ GetParsedModule fp + pm <- runActionE "expandTHSplice.fallback.GetParsedModule" ideState $ + useE GetParsedModule fp (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm manualCalcEdit @@ -150,10 +161,10 @@ transform dflags clientCapabilities - uri + verTxtDocId (graft (RealSrcSpan spliceSpan Nothing) expanded) ps - maybe (throwE "No splice information found") (either throwE pure) $ + maybe (throwError $ PluginInternalError "No splice information found") (either (throwError . PluginInternalError . T.pack) pure) $ case spliceContext of Expr -> graftSpliceWith exprSuperSpans Pat -> @@ -166,16 +177,16 @@ transform dflags clientCapabilities - uri + verTxtDocId (graftDecls (RealSrcSpan spliceSpan Nothing) expanded) ps <&> -- FIXME: Why ghc-exactprint sweeps preceding comments? - adjustToRange uri range + adjustToRange (verTxtDocId ^. J.uri) range res <- liftIO $ runMaybeT $ do - fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri (verTxtDocId ^. J.uri) eedits <- ( lift . runExceptT . withTypeChecked fp =<< MaybeT @@ -186,17 +197,17 @@ case eedits of Left err -> do reportEditor - MtError - ["Error during expanding splice: " <> T.pack err] - pure (Left $ responseError $ T.pack err) + MessageType_Error + [T.pack $ "Error during expanding splice: " <> show (pretty err)] + pure (Left err) Right edits -> pure (Right edits) case res of - Nothing -> pure $ Right Null - Just (Left err) -> pure $ Left err + Nothing -> pure $ Right $ InR Null + Just (Left err) -> pure $ Left $ err Just (Right edit) -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - pure $ Right Null + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + pure $ Right $ InR Null where range = realSrcSpanToRange spliceSpan @@ -207,12 +218,10 @@ :: IdeState -> NormalizedFilePath -> ParsedModule - -> ExceptT String IO (Annotated ParsedSource, HscEnv, DynFlags) + -> ExceptT PluginError IO (Annotated ParsedSource, HscEnv, DynFlags) setupHscEnv ideState fp pm = do - hscEnvEq <- - liftIO $ - runAction "expandTHSplice.fallback.ghcSessionDeps" ideState $ - use_ GhcSessionDeps fp + hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $ + useE GhcSessionDeps fp let ps = annotateParsedSource pm hscEnv0 = hscEnvWithImportPaths hscEnvEq modSum = pm_mod_summary pm @@ -369,15 +378,15 @@ RealSrcSpan -> ExpandStyle -> ExpandSpliceParams -> - ExceptT String IO WorkspaceEdit + ExceptT PluginError IO WorkspaceEdit manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do (warns, resl) <- ExceptT $ do (msgs, eresl) <- initTcWithGbl hscEnv typechkd srcSpan $ case classifyAST spliceContext of - IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ - flip (transformM dflags clientCapabilities uri) ps $ + IsHsDecl -> fmap (fmap $ adjustToRange (verTxtDocId ^. J.uri) ran) $ + flip (transformM dflags clientCapabilities verTxtDocId) ps $ graftDeclsWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do eExpr <- @@ -390,7 +399,7 @@ pure $ Just eExpr _ -> pure Nothing OneToOneAST astP -> - flip (transformM dflags clientCapabilities uri) ps $ + flip (transformM dflags clientCapabilities verTxtDocId) ps $ graftWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (matchSplice astP -> Just spl)) -> do eExpr <- @@ -410,12 +419,13 @@ #else msgs #endif - pure $ (warns,) <$> fromMaybe (Left $ showErrors errs) eresl + pure $ (warns,) <$> maybe (throwError $ PluginInternalError $ T.pack $ showErrors errs) + (B.first (PluginInternalError . T.pack)) eresl unless (null warns) $ reportEditor - MtWarning + MessageType_Warning [ "Warning during expanding: " , "" , T.pack (showErrors warns) @@ -483,9 +493,10 @@ -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? -codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction -codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ - fmap (maybe (Right $ List []) Right) $ +codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeAction state plId (CodeActionParams _ _ docId ran _) = do + verTxtDocId <- lift $ getVersionedTextDoc docId + liftIO $ fmap (fromMaybe ( InL [])) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri ParsedModule {..} <- @@ -496,13 +507,13 @@ mcmds <- forM mouterSplice $ \(spliceSpan, spliceContext) -> forM expandStyles $ \(_, (title, cmdId)) -> do - let params = ExpandSpliceParams {uri = theUri, ..} + let params = ExpandSpliceParams {verTxtDocId, ..} act = mkLspCommand plId cmdId title (Just [toJSON params]) pure $ InR $ - CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing + CodeAction title (Just CodeActionKind_RefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing - pure $ maybe mempty List mcmds + pure $ InL $ fromMaybe mempty mcmds where theUri = docId ^. J.uri detectSplice :: diff --git a/src/Ide/Plugin/Splice/Types.hs b/src/Ide/Plugin/Splice/Types.hs --- a/src/Ide/Plugin/Splice/Types.hs +++ b/src/Ide/Plugin/Splice/Types.hs @@ -5,16 +5,18 @@ module Ide.Plugin.Splice.Types where -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Text as T -import Development.IDE (Uri) -import Development.IDE.GHC.Compat (RealSrcSpan) -import GHC.Generics (Generic) -import Ide.Types (CommandId) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Text as T + -- This import is needed for the ToJSON/FromJSON instances of RealSrcSpan +import Development.IDE () +import Development.IDE.GHC.Compat (RealSrcSpan) +import GHC.Generics (Generic) +import Ide.Types (CommandId) +import Language.LSP.Protocol.Types (VersionedTextDocumentIdentifier) -- | Parameter for the addMethods PluginCommand. data ExpandSpliceParams = ExpandSpliceParams - { uri :: Uri + { verTxtDocId :: VersionedTextDocumentIdentifier , spliceSpan :: RealSrcSpan , spliceContext :: SpliceContext } diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,15 +1,16 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} - module Main ( main ) where import Control.Monad (void) import Data.List (find) +import Data.Row import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -76,7 +77,7 @@ case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) _ -> liftIO $ assertFailure "No CodeAction detected" goldenTestWithEdit :: FilePath -> FilePath -> ExpandStyle -> Int -> Int -> TestTree @@ -94,7 +95,9 @@ waitForAllProgressDone alt <- liftIO $ T.readFile (fp <.> "error.hs") void $ applyEdit doc $ TextEdit theRange alt - changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] + changeDoc doc [TextDocumentContentChangeEvent $ InL $ #range .== theRange + .+ #rangeLength .== Nothing + .+ #text .== alt] void waitForDiagnostics -- wait for the entire build to finish void waitForBuildQueue @@ -102,7 +105,7 @@ case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) _ -> liftIO $ assertFailure "No CodeAction detected" testDataDir :: FilePath