From aab644f69e8db56f721adc1e00d52eb59858b9da Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sun, 11 Oct 2026 19:22:22 -0700 Subject: [PATCH] Take the Transform modules from notebook-language-server-core --- app/Main.hs | 12 +- package.yaml | 5 - rust-notebook-language-server.cabal | 15 -- src/Transform/ClientNot.hs | 8 +- src/Transform/ClientNot/DidSave.hs | 31 ----- src/Transform/ClientReq.hs | 108 -------------- src/Transform/ClientRsp.hs | 30 ---- src/Transform/Common.hs | 73 ---------- src/Transform/ServerNot.hs | 38 ----- src/Transform/ServerReq.hs | 9 -- src/Transform/ServerRsp.hs | 127 ----------------- src/Transform/ServerRsp/Formatting.hs | 57 -------- src/Transform/ServerRsp/Hover.hs | 82 ----------- src/Transform/Util.hs | 193 -------------------------- stack.yaml | 2 +- test/Test/Formatting.hs | 6 +- test/Test/Hover.hs | 2 +- 17 files changed, 15 insertions(+), 783 deletions(-) delete mode 100644 src/Transform/ClientNot/DidSave.hs delete mode 100644 src/Transform/ClientReq.hs delete mode 100644 src/Transform/ClientRsp.hs delete mode 100644 src/Transform/Common.hs delete mode 100644 src/Transform/ServerNot.hs delete mode 100644 src/Transform/ServerReq.hs delete mode 100644 src/Transform/ServerRsp.hs delete mode 100644 src/Transform/ServerRsp/Formatting.hs delete mode 100644 src/Transform/ServerRsp/Hover.hs delete mode 100644 src/Transform/Util.hs diff --git a/app/Main.hs b/app/Main.hs index 8849121..44353c0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -35,12 +35,12 @@ import UnliftIO.Process import UnliftIO.Temporary (withSystemTempDirectory) import Transform.ClientNot -import Transform.ClientReq -import Transform.ClientRsp -import Transform.ServerNot -import Transform.ServerReq -import Transform.ServerRsp -import Transform.Util +import Language.LSP.NotebookLanguageServer.Transform.ClientReq +import Language.LSP.NotebookLanguageServer.Transform.ClientRsp +import Language.LSP.NotebookLanguageServer.Transform.ServerNot +import Language.LSP.NotebookLanguageServer.Transform.ServerReq +import Language.LSP.NotebookLanguageServer.Transform.ServerRsp +import Language.LSP.NotebookLanguageServer.Transform.Util import Language.LSP.NotebookLanguageServer.Parsing import Language.LSP.NotebookLanguageServer.Process diff --git a/package.yaml b/package.yaml index 01e6698..2c10f27 100644 --- a/package.yaml +++ b/package.yaml @@ -43,13 +43,8 @@ library: - containers - filepath - lens - - lens-regex-pcre - mtl - - network-uri - notebook-language-server-core - - pcre-light - - random - - safe - text-rope - time - unliftio-core diff --git a/rust-notebook-language-server.cabal b/rust-notebook-language-server.cabal index 8943708..2978645 100644 --- a/rust-notebook-language-server.cabal +++ b/rust-notebook-language-server.cabal @@ -17,16 +17,6 @@ library Language.LSP.Notebook.HeadTailTransformer Language.LSP.Notebook.StripDirective Transform.ClientNot - Transform.ClientNot.DidSave - Transform.ClientReq - Transform.ClientRsp - Transform.Common - Transform.ServerNot - Transform.ServerReq - Transform.ServerRsp - Transform.ServerRsp.Formatting - Transform.ServerRsp.Hover - Transform.Util other-modules: Paths_rust_notebook_language_server hs-source-dirs: @@ -54,15 +44,10 @@ library , containers , filepath , lens - , lens-regex-pcre , lsp-types >=2.0.0.1 , monad-logger , mtl - , network-uri , notebook-language-server-core - , pcre-light - , random - , safe , string-interpolate , text , text-rope diff --git a/src/Transform/ClientNot.hs b/src/Transform/ClientNot.hs index 83421e7..c5bcb00 100644 --- a/src/Transform/ClientNot.hs +++ b/src/Transform/ClientNot.hs @@ -26,10 +26,10 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Transformer import System.FilePath -import Transform.ClientNot.DidSave -import Transform.Common -import Transform.ServerRsp.Hover (mkDocRegex) -import Transform.Util +import Language.LSP.NotebookLanguageServer.Transform.ClientNot.DidSave +import Language.LSP.NotebookLanguageServer.Transform.Common +import Language.LSP.NotebookLanguageServer.Transform.ServerRsp.Hover (mkDocRegex) +import Language.LSP.NotebookLanguageServer.Transform.Util import UnliftIO.Concurrent import UnliftIO.Directory diff --git a/src/Transform/ClientNot/DidSave.hs b/src/Transform/ClientNot/DidSave.hs deleted file mode 100644 index 252592b..0000000 --- a/src/Transform/ClientNot/DidSave.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MonoLocalBinds #-} - -module Transform.ClientNot.DidSave where - -import Control.Monad.IO.Class -import qualified Data.Text.IO as T -import qualified Data.Text.Rope as Rope -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types -import Transform.Util -import Language.LSP.Transformer - - -doDidSave :: (TransformerMonad tx m, Transformer tx) => DocumentState tx -> SendExtraNotificationFn m -> m () -doDidSave (DocumentState {..}) sendExtraNotification = do - whenServerCapabilitiesSatisfy supportsWillSave $ \_ -> - sendExtraNotification $ TNotificationMessage "2.0" SMethod_TextDocumentWillSave $ WillSaveTextDocumentParams { - _textDocument = TextDocumentIdentifier newUri - , _reason = TextDocumentSaveReason_AfterDelay - } - - liftIO $ T.writeFile newPath (Rope.toText curLines') - - whenServerCapabilitiesSatisfy supportsSave $ \maybeSaveOptions -> - sendExtraNotification $ TNotificationMessage "2.0" SMethod_TextDocumentDidSave $ DidSaveTextDocumentParams { - _textDocument = TextDocumentIdentifier newUri - , _text = case maybeSaveOptions of - Just (SaveOptions {_includeText=(Just True)}) -> Just (Rope.toText curLines') - _ -> Nothing - } diff --git a/src/Transform/ClientReq.hs b/src/Transform/ClientReq.hs deleted file mode 100644 index 3cfe50d..0000000 --- a/src/Transform/ClientReq.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - -module Transform.ClientReq where - -import Control.Lens hiding ((:>)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader -import Data.Aeson as A -import Data.Proxy -import Data.String.Interpolate -import qualified Data.Text as T -import Data.Time -import GHC.TypeLits (sameSymbol) -import Language.LSP.Protocol.Lens as Lens -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types -import Language.LSP.Transformer -import Transform.Common -import Transform.Util -import UnliftIO.Concurrent - - -type ClientReqMethod m = SMethod (m :: Method 'ClientToServer 'Request) - - -transformClientReq :: (TransformerMonad tx n, Transformer tx, HasJSON (TRequestMessage m)) => ClientReqMethod m -> TRequestMessage m -> n (TRequestMessage m) -transformClientReq meth msg = do - start <- liftIO getCurrentTime - p' <- transformClientReq' meth (msg ^. params) - stop <- liftIO getCurrentTime - let msg' = set params p' msg - when (msg' /= msg) $ logDebugN [i|Transforming client req #{meth} in #{diffUTCTime stop start}: (#{A.encode msg} --> #{A.encode msg'})|] - return msg' - -transformClientReq' :: forall m n tx. (TransformerMonad tx n, Transformer tx) => ClientReqMethod m -> MessageParams m -> n (MessageParams m) - -transformClientReq' SMethod_Initialize params = do - -- Store the non-modified params, so we can access the unmodified rootUri - asks transformerInitializeParams >>= flip modifyMVar_ (\_ -> return $ Just params) - - dir <- asks transformerShadowDir - pure $ params - & set rootPath (Just (InL (T.pack dir))) - & set rootUri (InL (filePathToUri dir)) - & set (capabilities . textDocument . _Just . synchronization) (Just $ TextDocumentSyncClientCapabilities { - _dynamicRegistration = Just False - , _willSave = Just True - , _willSaveWaitUntil = Just False - , _didSave = Just True - }) - -transformClientReq' SMethod_TextDocumentCodeAction params = whenAnything params $ withTransformer params $ doTransformUriAndRange @m params -transformClientReq' SMethod_TextDocumentCodeLens params = whenAnything params $ withTransformer params $ doTransformUri @m params -transformClientReq' SMethod_TextDocumentCompletion params = whenAnything params $ withTransformer params $ doTransformUriAndPosition @m params -transformClientReq' SMethod_TextDocumentDefinition params = whenAnything params $ withTransformer params $ doTransformUriAndPosition @m params -transformClientReq' SMethod_TextDocumentDocumentHighlight params = whenAnything params $ withTransformer params $ doTransformUriAndPosition @m params -transformClientReq' SMethod_TextDocumentDocumentSymbol params = whenAnything params $ withTransformer params $ doTransformUri @m params -transformClientReq' SMethod_TextDocumentFormatting params = whenAnything params $ withTransformer params $ doTransformUri @m params -transformClientReq' SMethod_TextDocumentHover params = whenAnything params $ withTransformer params $ doTransformUriAndPosition @m params -transformClientReq' SMethod_TextDocumentImplementation params = whenAnything params $ withTransformer params $ doTransformUriAndPosition @m params -transformClientReq' SMethod_TextDocumentInlayHint params = whenAnything params $ withTransformer params $ doTransformUriAndRange @m params -transformClientReq' SMethod_TextDocumentOnTypeFormatting params = whenAnything params $ withTransformer params $ doTransformUriAndPosition @m params -transformClientReq' SMethod_TextDocumentTypeDefinition params = whenAnything params $ withTransformer params $ doTransformUriAndPosition @m params - --- Custom methods provided by rust-analyzer -transformClientReq' (SMethod_CustomMethod p) val = case sameSymbol p (Proxy @"rust-analyzer/analyzerStatus") of - Just Refl -> case A.fromJSON val of - A.Error err -> logErrorN [i|Failed to decode custom method "rust-analyzer/analyzerStatus": #{err}|] >> return val - A.Success (TextDocumentIdentifier uri) -> - whenAnything' uri val $ - withTransformer val $ \(DocumentState {newUri}) -> - return $ A.toJSON $ TextDocumentIdentifier newUri - Nothing -> return val - -transformClientReq' _ params = return params - - -doTransformUriAndPosition :: forall m n a tx. ( - TransformerMonad tx n, Transformer tx, HasPosition (MessageParams m) Position, HasTextDocument (MessageParams m) a, HasUri a Uri - ) => MessageParams m -> DocumentState tx -> n (MessageParams m) -doTransformUriAndPosition params' (DocumentState {transformer=tx, newUri}) = do - let params = params' & set (textDocument . uri) newUri - case transformPosition tx (params ^. position) of - Nothing -> do - logWarnN [i|Couldn't transform position #{params ^. position}|] - return params - Just pos' -> return $ set position pos' params - -doTransformUriAndRange :: forall m n a tx. ( - TransformerMonad tx n, Transformer tx, HasRange (MessageParams m) Range, HasTextDocument (MessageParams m) a, HasUri a Uri - ) => MessageParams m -> DocumentState tx -> n (MessageParams m) -doTransformUriAndRange params' (DocumentState {transformer=tx, newUri}) = do - let params = params' & set (textDocument . uri) newUri - case transformRange tx (params ^. range) of - Nothing -> do - logWarnN [i|Couldn't transform range #{params ^. range}|] - return params - Just pos' -> return $ set range pos' params - -doTransformUri :: forall m n a tx. ( - TransformerMonad tx n, Transformer tx, HasTextDocument (MessageParams m) a, HasUri a Uri - ) => MessageParams m -> DocumentState tx -> n (MessageParams m) -doTransformUri params' (DocumentState {newUri}) = return $ params' & set (textDocument . uri) newUri diff --git a/src/Transform/ClientRsp.hs b/src/Transform/ClientRsp.hs deleted file mode 100644 index 8b29819..0000000 --- a/src/Transform/ClientRsp.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} - -module Transform.ClientRsp where - -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger -import Data.Aeson as A -import Data.String.Interpolate -import Data.Time -import Language.LSP.Protocol.Message -import Transform.Util -import Language.LSP.Transformer - - -type ClientRspMethod m = SMethod (m :: Method 'ServerToClient 'Request) - -transformClientRsp :: (TransformerMonad tx n, Transformer tx, HasJSON (TResponseMessage m)) => ClientRspMethod m -> TResponseMessage m -> n (TResponseMessage m) -transformClientRsp meth msg = do - start <- liftIO getCurrentTime - msg' <- transformClientRsp' meth msg - stop <- liftIO getCurrentTime - when (msg' /= msg) $ logDebugN [i|Transforming client resp #{meth} in #{diffUTCTime stop start}: (#{A.encode msg} --> #{A.encode msg'})|] - return msg' - - -transformClientRsp' :: (TransformerMonad tx n, Transformer tx) => ClientRspMethod m -> TResponseMessage m -> n (TResponseMessage m) -transformClientRsp' _meth msg = pure msg diff --git a/src/Transform/Common.hs b/src/Transform/Common.hs deleted file mode 100644 index dc126ca..0000000 --- a/src/Transform/Common.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Transform.Common where - -import Control.Lens hiding (List) -import Control.Monad.Logger -import Control.Monad.Reader -import Data.Map as M -import qualified Data.Maybe -import Data.String.Interpolate -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Language.LSP.Notebook -import Language.LSP.Transformer -import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Lens as Lens -import System.FilePath -import Transform.Util -import UnliftIO.Directory -import UnliftIO.MVar - - --- * Transform - -transformRange :: Transformer tx => tx -> Range -> Maybe Range -transformRange = transformRanged - -transformRanged :: (Transformer tx, HasRange a Range) => tx -> a -> Maybe a -transformRanged tx x = x - & traverseOf (range . start) (transformPosition tx) - >>= traverseOf (range . end) (transformPosition tx) - --- * Untransform - -untransformRange :: Transformer tx => tx -> Range -> Maybe Range -untransformRange = untransformRanged - -untransformRanged :: (Transformer tx, HasRange a Range) => tx -> a -> Maybe a -untransformRanged tx x = x - & traverseOf (range . start) (untransformPosition tx) - >>= traverseOf (range . end) (untransformPosition tx) - -untransformRangedMaybe :: (Transformer tx, HasRange a (Maybe Range)) => tx -> a -> Maybe a -untransformRangedMaybe tx x = x - & traverseOf (range . _Just . start) (untransformPosition tx) - >>= traverseOf (range . _Just . end) (untransformPosition tx) - --- | An inlay hint sits at a position rather than over a range, and carries its own edits for --- when the user accepts it. Drop the hint if its position isn't in the cell; drop individual --- edits that aren't. -untransformInlayHint :: Transformer tx => tx -> InlayHint -> Maybe InlayHint -untransformInlayHint tx hint = - hint - & traverseOf position (untransformPosition tx) - & fmap (over (textEdits . _Just) (Data.Maybe.mapMaybe (untransformRanged tx))) - --- * Orphan (wish this was in lsp-types) - -instance HasRange Range Range where - range = Prelude.id - --- * Update the shadow lib.rs file - -updateLibRs :: (TransformerMonad tx m, Transformer tx) => m () -updateLibRs = do - TransformerState {..} <- ask - docs <- readMVar transformerDocuments - let identifiers = [dropExtension (takeFileName newPath) | DocumentState {..} <- fmap snd (M.toList docs)] - let libRsContent = T.intercalate "\n" [T.pack ("mod " <> x <> ";") | x <- identifiers] - logInfoN [i|libRsContent: #{libRsContent}|] - liftIO $ createDirectoryIfMissing True (transformerShadowDir "src") - liftIO $ T.writeFile (transformerShadowDir "src" "lib.rs") libRsContent diff --git a/src/Transform/ServerNot.hs b/src/Transform/ServerNot.hs deleted file mode 100644 index 959169a..0000000 --- a/src/Transform/ServerNot.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} - -module Transform.ServerNot where - -import Control.Lens hiding (List) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger -import Data.Aeson as A -import Data.Maybe -import Data.String.Interpolate -import Data.Time -import Language.LSP.Protocol.Lens -import Language.LSP.Protocol.Message -import Transform.Common -import Transform.Util -import Language.LSP.Transformer - - -transformServerNot :: (TransformerMonad tx n, Transformer tx, HasJSON (TNotificationMessage m)) => SMethod m -> TNotificationMessage m -> n (TNotificationMessage m) -transformServerNot meth msg = do - start <- liftIO getCurrentTime - p' <- transformServerNot' meth (msg ^. params) - stop <- liftIO getCurrentTime - let msg' = set params p' msg - when (msg' /= msg) $ logDebugN [i|Transforming server not #{meth} in #{diffUTCTime stop start}: (#{A.encode msg} --> #{A.encode msg'})|] - return msg' - - -transformServerNot' :: (TransformerMonad tx n, Transformer tx) => SMethod m -> MessageParams m -> n (MessageParams m) - -transformServerNot' SMethod_TextDocumentPublishDiagnostics params = whenReverseLookupUri params $ \(DocumentState {transformer=tx, ..}) -> do - return $ params - & set uri origUri - & over diagnostics (mapMaybe (traverseOf range (untransformRange tx))) - -transformServerNot' _meth msg = pure msg diff --git a/src/Transform/ServerReq.hs b/src/Transform/ServerReq.hs deleted file mode 100644 index 6be86c7..0000000 --- a/src/Transform/ServerReq.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PolyKinds #-} - -module Transform.ServerReq where - -import Language.LSP.Protocol.Message - - -transformServerReq :: SMethod m -> TRequestMessage m -> TRequestMessage m -transformServerReq _meth msg = msg diff --git a/src/Transform/ServerRsp.hs b/src/Transform/ServerRsp.hs deleted file mode 100644 index 8386395..0000000 --- a/src/Transform/ServerRsp.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} - -module Transform.ServerRsp where - -import Control.Lens hiding (List) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader -import Data.Aeson as A -import Data.Maybe -import Data.String.Interpolate -import Data.Time -import Language.LSP.Protocol.Lens as Lens -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types as LSP -import Transform.Common -import Transform.ServerRsp.Formatting -import Transform.ServerRsp.Hover -import Transform.Util -import UnliftIO.MVar -import Language.LSP.Transformer - - -type ServerRspMethod m = SMethod (m :: Method 'ClientToServer 'Request) - -transformServerRsp :: ( - TransformerMonad tx n, Transformer tx, HasJSON (TResponseMessage m) - ) => ServerRspMethod m -> MessageParams m -> TResponseMessage m -> n (TResponseMessage m) -transformServerRsp meth initialParams msg = case msg ^. result of - Left _err -> return msg - Right ret -> do - start <- liftIO getCurrentTime - p' <- transformServerRsp' meth initialParams ret - stop <- liftIO getCurrentTime - let msg' = set result (Right p') msg - when (msg' /= msg) $ logDebugN [i|Transforming server rsp #{meth} in #{diffUTCTime stop start}: (#{A.encode msg} --> #{A.encode msg'})|] - return $ set result (Right p') msg - -type ResponseResult m = Either ResponseError (MessageResult m) - -transformServerRsp' :: (TransformerMonad tx n, Transformer tx) => ServerRspMethod m -> MessageParams m -> MessageResult m -> n (MessageResult m) - -transformServerRsp' SMethod_Initialize _initialParams result = do - initializeResultVar <- asks transformerInitializeResult - modifyMVar_ initializeResultVar (\_ -> return $ Just result) - return result - -transformServerRsp' SMethod_TextDocumentCompletion initialParams result = - whenAnythingByInitialParams initialParams result $ withTransformer result $ \(DocumentState {transformer=tx}) -> do - let fixupCompletionEdit Nothing = Nothing - fixupCompletionEdit (Just (InL edit)) = InL <$> (untransformRanged tx edit) - fixupCompletionEdit (Just (InR (InsertReplaceEdit newText insert replace))) = - InR <$> (InsertReplaceEdit newText <$> untransformRanged tx insert <*> untransformRanged tx replace) - - let fixupItem :: CompletionItem -> CompletionItem - fixupItem item = item - & over textEdit fixupCompletionEdit - & over (additionalTextEdits . _Just) (mapMaybe (untransformRanged tx)) - - case result of - (InL items) -> return (InL (fmap fixupItem items)) - (InR (InL completionList)) -> return (InR (InL (completionList & over items (fmap fixupItem)))) - (InR (InR null)) -> return $ InR $ InR null - -transformServerRsp' SMethod_TextDocumentDocumentHighlight initialParams result = - whenAnythingByInitialParams initialParams result $ withTransformer result $ \(DocumentState {transformer=tx}) -> - case result of - InL highlights -> return $ InL $ mapMaybe (untransformRanged tx) highlights - InR null -> return $ InR null - -transformServerRsp' SMethod_TextDocumentFormatting initialParams result = - whenAnythingByInitialParams initialParams result $ withTransformer result $ \ds -> - case result of - InL edits -> return $ InL $ untransformFormattingEdits ds edits - InR null -> return $ InR null - -transformServerRsp' SMethod_TextDocumentOnTypeFormatting initialParams result = - whenAnythingByInitialParams initialParams result $ withTransformer result $ \(DocumentState {transformer=tx}) -> - case result of - InL edits -> return $ InL $ mapMaybe (untransformRanged tx) edits - InR null -> return $ InR null - -transformServerRsp' SMethod_TextDocumentInlayHint initialParams result = - whenAnythingByInitialParams initialParams result $ withTransformer result $ \(DocumentState {transformer=tx}) -> - case result of - InL hints -> return $ InL $ mapMaybe (untransformInlayHint tx) hints - InR null -> return $ InR null - -transformServerRsp' SMethod_TextDocumentHover initialParams result = - whenAnythingByInitialParams initialParams result $ withTransformer result $ \(DocumentState {transformer=tx}) -> - case result of - InR null -> return $ InR null - InL hov -> do - hov' <- fixupHoverText hov - return $ case untransformRangedMaybe tx hov' of - Just ret -> InL ret - Nothing -> InR LSP.Null - -transformServerRsp' SMethod_TextDocumentDocumentSymbol initialParams result = - whenAnythingByInitialParams initialParams result $ withTransformer result $ \(DocumentState {transformer=tx}) -> - case result of - InL symbolInformations -> return $ InL (symbolInformations & filter (not . ignoreSymbol) - & mapMaybe (traverseOf (location . range) (untransformRange tx))) - InR (InL documentSymbols) -> return $ InR $ InL $ (documentSymbols & filter (not . ignoreSymbol) - & mapMaybe (traverseOf range (untransformRange tx)) - & mapMaybe (traverseOf selectionRange (untransformRange tx))) - InR (InR LSP.Null) -> return $ InR $ InR LSP.Null - where - ignoreSymbol _ = False - -transformServerRsp' SMethod_TextDocumentCodeAction _initialParams (InR null) = return $ InR null -transformServerRsp' SMethod_TextDocumentCodeAction initialParams (InL result) = (InL <$>) $ - whenAnythingByInitialParams initialParams result $ withTransformer result $ \(DocumentState {}) -> do - filterM (fmap not . isInternalReferringCodeAction) result - where - isInternalReferringCodeAction (InL _command) = pure False - isInternalReferringCodeAction (InR _codeAction) = pure False - -transformServerRsp' SMethod_TextDocumentCodeLens _initialParams (InR null) = return $ InR null -transformServerRsp' SMethod_TextDocumentCodeLens initialParams (InL result) = (InL <$>) $ - whenAnythingByInitialParams initialParams result $ withTransformer result $ \(DocumentState {transformer=tx}) -> do - return $ mapMaybe (untransformRanged tx) result - -transformServerRsp' _ _ result = return result diff --git a/src/Transform/ServerRsp/Formatting.hs b/src/Transform/ServerRsp/Formatting.hs deleted file mode 100644 index 3c21e89..0000000 --- a/src/Transform/ServerRsp/Formatting.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Transform.ServerRsp.Formatting ( - untransformFormattingEdits - - -- For testing - , applyTextEdits - ) where - -import Control.Lens hiding (List) -import qualified Data.List as L -import Data.Ord -import qualified Data.Text as T -import qualified Data.Text.Rope as Rope -import Language.LSP.Protocol.Lens as Lens -import Language.LSP.Protocol.Types -import Language.LSP.Transformer -import Transform.Util - - --- | Map a @textDocument/formatting@ response back onto the original document. --- --- Unlike the other responses we rewrite, these edits can't be taken one at a time: a formatter --- reflows the whole document, and the edits only mean anything applied together. So we apply --- them to our copy of the shadow document, hand that to 'unproject' to get back to the --- original's coordinates, and return a single edit replacing the document. --- --- 'unproject' answers 'Nothing' when the projection can't be undone for this document, which --- today means a cell with directive lines in it. Returning no edits leaves the cell alone, --- which beats handing back one with the user's @:dep@ lines dropped. -untransformFormattingEdits :: Transformer tx => DocumentState tx -> [TextEdit] -> [TextEdit] -untransformFormattingEdits _ [] = [] -untransformFormattingEdits (DocumentState {transformer=tx, curLines, curLines'}) edits = - case unproject tx formatted of - Nothing -> [] - Just unprojected - -- Nothing was undone, so this isn't a notebook and the shadow document is a copy of the - -- original. The server's own edits already line up, and they're smaller than replacing - -- the whole document. - | unprojected == formatted -> edits - | otherwise -> [TextEdit wholeDocument (Rope.toText unprojected <> trailingNewline)] - where - formatted = applyTextEdits edits curLines' - - -- unproject drops the newline the formatter added along with the wrapper, so put one back - -- only if the document we're replacing had one. - trailingNewline = if "\n" `T.isSuffixOf` Rope.toText curLines then "\n" else "" - - wholeDocument = Range (Position 0 0) (Position (fromIntegral endLine) (fromIntegral endColumn)) - where Rope.Position endLine endColumn = Rope.lengthAsPosition curLines - --- | Apply LSP text edits to a document. They're non-overlapping and expressed against the --- document as it stands, so applying them last-first keeps the earlier positions valid. -applyTextEdits :: [TextEdit] -> Doc -> Doc -applyTextEdits edits doc = applyChanges (fmap toChangeEvent sorted) doc - where - sorted = L.sortOn (Down . (^. (range . start))) edits - toChangeEvent (TextEdit r t) = - TextDocumentContentChangeEvent $ InL $ TextDocumentContentChangePartial r Nothing t diff --git a/src/Transform/ServerRsp/Hover.hs b/src/Transform/ServerRsp/Hover.hs deleted file mode 100644 index bbaa239..0000000 --- a/src/Transform/ServerRsp/Hover.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -module Transform.ServerRsp.Hover ( - fixupHoverText - - , mkDocRegex - - -- For testing - , fixupDocumentReferences' - ) where - -import Control.Lens hiding (List) -import Control.Lens.Regex.Text -import Control.Monad.Logger -import Control.Monad.Reader -import Data.Function -import qualified Data.List as L -import qualified Data.Map as M -import Data.String.Interpolate -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Rope (Rope) -import Language.LSP.Notebook -import Language.LSP.Protocol.Lens hiding (id, trace) -import Language.LSP.Protocol.Types -import Language.LSP.Transformer -import Safe -import Text.Regex.PCRE.Light -import Transform.Util -import UnliftIO.MVar - - -fixupHoverText :: (TransformerMonad tx n, Transformer tx) => Hover -> n Hover -fixupHoverText initialHover = do - documentsMap <- ask >>= (readMVar . transformerDocuments) - flip fix (initialHover, M.toList documentsMap) $ \loop args -> case args of - (paramsInProgress, []) -> return paramsInProgress - (paramsInProgress, (_, DocumentState {..}):xs) -> do - newParams <- traverseOf contents (fixupDocumentReferences referenceRegex transformer curLines) paramsInProgress - loop (newParams, xs) - -type HoverContents = MarkupContent |? (MarkedString |? [MarkedString]) - -fixupDocumentReferences :: forall n tx. (MonadLogger n, Transformer tx) => Regex -> tx -> Rope -> HoverContents -> n HoverContents -fixupDocumentReferences docRegex transformer _curLines (InL (MarkupContent k t)) = (InL . MarkupContent k) <$> (fixupDocumentReferences' docRegex transformer t) -fixupDocumentReferences docRegex transformer _curLines (InR markedStrings) = (InR <$>) $ case markedStrings of - InL ms -> InL <$> transformMarkedString ms - InR mss -> InR <$> (mapM transformMarkedString mss) - where - transformMarkedString :: MarkedString -> n MarkedString - transformMarkedString (MarkedString (InL t)) = (MarkedString . InL) <$> (fixupDocumentReferences' docRegex transformer t) - transformMarkedString (MarkedString (InR thing)) = do - t' <- fixupDocumentReferences' docRegex transformer (thing ^. value) - return $ MarkedString $ InR (thing & set value t') - -fixupDocumentReferences' :: forall n tx. (MonadLogger n, Transformer tx) => Regex -> tx -> Text -> n Text -fixupDocumentReferences' docRegex transformer t = - traverseOf ((regexing docRegex) . groups) (transformGroup transformer) t - - where - transformGroup :: tx -> [Text] -> n [Text] - transformGroup transformer orig@[(readMay . T.unpack) -> Just line, (readMay . T.unpack) -> Just ch] = do - case untransformPosition transformer (Position (line - 1) (ch - 1)) of - Nothing -> return orig - Just (Position line' ch') -> return [T.pack $ show (line' + 1), T.pack $ show (ch' + 1)] - - transformGroup _ matches = return matches - -mkDocRegex :: Text -> Regex -mkDocRegex docName = compile [i|#{escapedName}:(\\d+):(\\d+)|] [utf8] - where - escapedName = docName - & (\x -> if filePrefix `T.isPrefixOf` x then T.drop (T.length filePrefix) x else x) - & L.foldl' (.) id [T.replace c ("\\" <> c) | c <- pcreChars] - - filePrefix = "file://" - - pcreChars = [".", "^", "$", "*", "+", "?", "(", ")", "[", "{", "\\", "|"] diff --git a/src/Transform/Util.hs b/src/Transform/Util.hs deleted file mode 100644 index a1f0c52..0000000 --- a/src/Transform/Util.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} - -module Transform.Util where - -import Control.Lens hiding ((:>), (<.>)) -import Control.Lens.Regex.Text -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.IO.Unlift -import Control.Monad.Logger -import Control.Monad.Reader -import Data.Aeson as A -import qualified Data.Char as C -import Data.Function -import qualified Data.List as L -import qualified Data.Map as M -import Data.String.Interpolate -import Data.Text (Text) -import qualified Data.Text as T -import Data.UUID -import Language.LSP.Notebook -import Language.LSP.Protocol.Lens as Lens -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types as LSP -import Language.LSP.Transformer -import Network.URI -import System.FilePath -import qualified System.Random as R -import UnliftIO.MVar - - -type SendExtraNotificationFn n = forall (o :: Method 'ClientToServer 'Notification). ToJSON (TNotificationMessage o) => TNotificationMessage o -> n () - --- * whenAnything - -whenAnything :: (MonadLoggerIO n, HasTextDocument a b, HasUri b Uri) => a -> (Uri -> n a) -> n a -whenAnything params = whenAnything' (params ^. (textDocument . uri)) params - -whenAnythingByInitialParams :: (MonadLoggerIO n, HasTextDocument a b, HasUri b Uri) => a -> c -> (Uri -> n c) -> n c -whenAnythingByInitialParams params = whenAnything' (params ^. (textDocument . uri)) - -whenAnything' :: (MonadLoggerIO n) => Uri -> a -> (Uri -> n a) -> n a -whenAnything' uri _params action = action uri - --- * whenNotebook - -whenNotebook :: (MonadLoggerIO n, HasTextDocument a b, HasUri b Uri) => a -> (Uri -> n a) -> n a -whenNotebook params = whenNotebook' (params ^. (textDocument . uri)) params - -whenNotebookUri :: (MonadLoggerIO n, HasUri a Uri) => a -> (Uri -> n a) -> n a -whenNotebookUri params = whenNotebook' (params ^. uri) params - -whenNotebookByInitialParams :: (MonadLoggerIO n, HasTextDocument a b, HasUri b Uri) => a -> c -> (Uri -> n c) -> n c -whenNotebookByInitialParams params = whenNotebook' (params ^. (textDocument . uri)) - -whenNotebook' :: (MonadLoggerIO n) => Uri -> a -> (Uri -> n a) -> n a -whenNotebook' uri params notebookParams = if - | isNotebook uri -> notebookParams uri - | otherwise -> pure params - -isNotebook :: Uri -> Bool -isNotebook uri = case parseURIReference (T.unpack (getUri uri)) of - Nothing -> False - Just (URI {..}) -> ".ipynb" `L.isSuffixOf` fmap C.toLower uriPath - --- * whenNotebookResult - -whenReverseLookupUri :: (TransformerMonad tx n, Transformer tx, MonadLoggerIO n, HasUri a Uri) => a -> (DocumentState tx -> n a) -> n a -whenReverseLookupUri params = whenReverseLookupUri' (params ^. uri) params - --- | Note that this takes in server URIs and calls the callback with original URIs --- TODO: make this more efficient -whenReverseLookupUri' :: (TransformerMonad tx n, Transformer tx) => Uri -> a -> (DocumentState tx -> n a) -> n a -whenReverseLookupUri' uri params cb = do - txDocumentsVar <- asks transformerDocuments - txDocuments <- readMVar txDocumentsVar - flip fix (M.toList txDocuments) $ \loop items -> case items of - [] -> return params - ((_, ds@(DocumentState {..})):rest) -> - if | newUri == uri -> cb ds - | otherwise -> loop rest - --- * TransformerMonad - -type TransformerMonad tx n = ( - MonadLoggerIO n - , MonadReader (TransformerState tx) n - , MonadUnliftIO n - , MonadFail n - ) - --- * TransformerState - -data DocumentState tx = DocumentState { - transformer :: tx - , curLines :: Doc - , curLines' :: Doc - , origUri :: Uri - , newUri :: Uri - , newPath :: FilePath - , referenceRegex :: Regex - , documentUuid :: UUID - , debouncedDidChange :: IO () - } - -data TransformerState tx = TransformerState { - transformerDocuments :: MVar (M.Map Text (DocumentState tx)) - , transformerInitializeParams :: MVar (Maybe InitializeParams) - , transformerInitializeResult :: MVar (Maybe InitializeResult) - , transformerShadowDir :: FilePath - , transformerDidSaveDebouncePeriodMs :: Int - } - --- * Transformers - -newTransformerState :: (MonadIO m) => FilePath -> Int -> m (TransformerState tx) -newTransformerState shadowDir didSaveDebouncePeriodMs = TransformerState - <$> newMVar mempty - <*> newMVar Nothing - <*> newMVar Nothing - <*> pure shadowDir - <*> pure didSaveDebouncePeriodMs - -lookupTransformer :: (TransformerMonad tx m, Transformer tx) => Uri -> m (Maybe (DocumentState tx)) -lookupTransformer uri = do - TransformerState {..} <- ask - M.lookup (getUri uri) <$> readMVar transformerDocuments - -withTransformer :: (TransformerMonad tx n, Transformer tx) => a -> (DocumentState tx -> n a) -> Uri -> n a -withTransformer def cb uri = do - lookupTransformer uri >>= \case - Nothing -> do - logWarnN [i|Couldn't find expected transformer for uri #{uri}|] - return def - Just tx -> cb tx - -modifyTransformer :: (TransformerMonad tx n, Transformer tx) => a -> (DocumentState tx -> n (DocumentState tx, a)) -> Uri -> n a -modifyTransformer def cb uri = do - TransformerState {..} <- ask - modifyMVar transformerDocuments $ \m -> case M.lookup (getUri uri) m of - Nothing -> return (m, def) - Just tx -> do - (tx', ret) <- cb tx - return (M.insert (getUri uri) tx' m, ret) - --- * Checking server capabilities - -whenServerCapabilitiesSatisfy :: (TransformerMonad tx n, Transformer tx) => (ServerCapabilities -> (Bool, a)) -> (a -> n ()) -> n () -whenServerCapabilitiesSatisfy cb action = do - initializeResultVar <- asks transformerInitializeResult - readMVar initializeResultVar >>= \case - Just ((cb . (^. capabilities)) -> (True, sideValue)) -> action sideValue - _ -> return () - -supportsWillSave :: ServerCapabilities -> (Bool, ()) -supportsWillSave (ServerCapabilities { _textDocumentSync=(Just (InL (TextDocumentSyncOptions {_willSave=(Just True)}))) }) = (True, ()) -supportsWillSave _ = (False, ()) - -supportsSave :: ServerCapabilities -> (Bool, Maybe SaveOptions) -supportsSave (ServerCapabilities { _textDocumentSync=(Just (InL (TextDocumentSyncOptions {_save}))) }) = case _save of - Nothing -> (False, Nothing) - Just (InL x) -> (x, Nothing) - Just (InR saveOptions) -> (True, Just saveOptions) -supportsSave _ = (False, Nothing) - --- * Random identifiers - --- Note: for a UUID to appear in a Kubernetes name, it needs to match this regex --- [a-z0-9]([-a-z0-9]*[a-z0-9])?(\.[a-z0-9]([-a-z0-9]*[a-z0-9])?)*' -uuidLetters :: [Char] -uuidLetters = ['a'..'z'] ++ ['A'..'Z'] - -numUUIDLetters :: Int -numUUIDLetters = L.length uuidLetters - -makeUUID' :: MonadIO m => Int -> m String -makeUUID' n = replicateM n ((uuidLetters L.!!) <$> R.randomRIO (0, numUUIDLetters - 1)) - --- * Misc - -addExtensionToUri :: (MonadLogger m) => String -> Uri -> m Uri -addExtensionToUri ext u@(Uri t) = case parseURIReference (T.unpack t) of - Nothing -> do - logErrorN [i|Couldn't parse URI: #{t}|] - return u - Just uri -> return $ Uri $ T.pack $ show $ uri { uriPath = uriPath uri <.> ext } - -flipTuple :: (b, a) -> (a, b) -flipTuple (x, y) = (y, x) diff --git a/stack.yaml b/stack.yaml index 88f45f5..91662d3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,7 +13,7 @@ system-ghc: true extra-deps: - git: https://github.com/codedownio/notebook-language-server-core.git - commit: 917c642da2a162b9da5a82e9fcc856d00fec1f0a + commit: 6bcfcb6f9deabc8a0a37636a9dcb6ff835495dce # - language-rust-0.2.0.27 diff --git a/test/Test/Formatting.hs b/test/Test/Formatting.hs index 3a5b8e0..44b7b67 100644 --- a/test/Test/Formatting.hs +++ b/test/Test/Formatting.hs @@ -12,9 +12,9 @@ import Language.LSP.Protocol.Types import Language.LSP.Transformer import Test.Sandwich import Language.LSP.Notebook.HeadTailTransformer (dedent) -import Transform.ServerRsp.Formatting -import Transform.ServerRsp.Hover (mkDocRegex) -import Transform.Util +import Language.LSP.NotebookLanguageServer.Transform.ServerRsp.Formatting +import Language.LSP.NotebookLanguageServer.Transform.ServerRsp.Hover (mkDocRegex) +import Language.LSP.NotebookLanguageServer.Transform.Util spec :: TopSpec diff --git a/test/Test/Hover.hs b/test/Test/Hover.hs index 3554295..9b0d809 100644 --- a/test/Test/Hover.hs +++ b/test/Test/Hover.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import Language.LSP.Notebook import Language.LSP.Transformer import Test.Sandwich -import Transform.ServerRsp.Hover +import Language.LSP.NotebookLanguageServer.Transform.ServerRsp.Hover spec :: TopSpec