hls-splice-plugin 2.0.0.1 → 2.1.0.0

raw patch · 4 files changed

+81/−63 lines, 4 filesdep +mtldep +row-typesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, row-types

Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils

API changes (from Hackage documentation)

Files

• hls-splice-plugin.cabal +6/−4
• src/Ide/Plugin/Splice.hs +59/−48
• src/Ide/Plugin/Splice/Types.hs +9/−7
• test/Main.hs +7/−4

@@ -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

@@ -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 ::

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

@@ -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