From 41a696a78792ef8af61d672d42383f75b0f0c9e6 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sat, 10 Feb 2024 15:09:55 -0600 Subject: [PATCH] finally get everything to typecheck No idea if it actually works, probably not --- src/swarm-lang/Swarm/Language/LSP.hs | 86 +++++++++++++++------------- 1 file changed, 46 insertions(+), 40 deletions(-) diff --git a/src/swarm-lang/Swarm/Language/LSP.hs b/src/swarm-lang/Swarm/Language/LSP.hs index b1c85f5f0..54b131a7d 100644 --- a/src/swarm-lang/Swarm/Language/LSP.hs +++ b/src/swarm-lang/Swarm/Language/LSP.hs @@ -16,9 +16,9 @@ import Data.Text (Text) import Data.Text.IO qualified as Text import Language.LSP.Diagnostics import Language.LSP.Server -import Language.LSP.Protocol.Types (Hover (Hover)) -import Language.LSP.Protocol.Types qualified as J -import Language.LSP.Protocol.Lens qualified as J +import Language.LSP.Protocol.Types qualified as LSP +import Language.LSP.Protocol.Message qualified as LSP +import Language.LSP.Protocol.Lens qualified as LSP import Language.LSP.VFS (VirtualFile (..), virtualFileText) import Swarm.Language.LSP.Hover qualified as H import Swarm.Language.LSP.VarUsage qualified as VU @@ -35,22 +35,24 @@ lspMain = void $ runServer $ ServerDefinition - { onConfigChange = const $ const $ Right () - , defaultConfig = () + { defaultConfig = () + , configSection = undefined + , parseConfig = undefined + , onConfigChange = const $ return () , doInitialize = \env _req -> pure $ Right env - , staticHandlers = handlers + , staticHandlers = const handlers , interpretHandler = \env -> Iso (runLspT env) liftIO , options = defaultOptions { -- set sync options to get DidSave event, as well as Open and Close events. optTextDocumentSync = Just - ( J.TextDocumentSyncOptions + ( LSP.TextDocumentSyncOptions (Just True) (Just syncKind) (Just False) (Just False) - (Just . J.InR . J.SaveOptions $ Just True) + (Just . LSP.InR . LSP.SaveOptions $ Just True) ) } } @@ -58,7 +60,7 @@ lspMain = -- Using SyncFull seems to handle the debounce for us. -- The alternative is to use SyncIncremental, but then then -- handler is called for each key-stroke. - syncKind = J.TextDocumentSyncKind_Full + syncKind = LSP.TextDocumentSyncKind_Full diagnosticSourcePrefix :: Text diagnosticSourcePrefix = "swarm-lsp" @@ -68,7 +70,7 @@ debug msg = liftIO $ Text.hPutStrLn stderr $ "[swarm-lsp] " <> msg type TextDocumentVersion = Int32 -validateSwarmCode :: J.NormalizedUri -> TextDocumentVersion -> Text -> LspM () () +validateSwarmCode :: LSP.NormalizedUri -> Maybe TextDocumentVersion -> Text -> LspM () () validateSwarmCode doc version content = do -- debug $ "Validating: " <> from (show doc) <> " ( " <> content <> ")" @@ -104,32 +106,36 @@ validateSwarmCode doc version content = do publishDiags $ map makeParseErrorDiagnostic parsingErrs where - publishDiags :: [J.Diagnostic] -> LspM () () + publishDiags :: [LSP.Diagnostic] -> LspM () () publishDiags = publishDiagnostics 1 doc version . partitionBySource - makeUnusedVarDiagnostic :: (J.Range, Text) -> J.Diagnostic + makeUnusedVarDiagnostic :: (LSP.Range, Text) -> LSP.Diagnostic makeUnusedVarDiagnostic (range, msg) = - J.Diagnostic + LSP.Diagnostic range - (Just J.DsWarning) -- severity + (Just undefined {- LSP.DsWarning -}) -- severity Nothing -- code + Nothing -- code description (Just diagnosticSourcePrefix) -- source msg - (Just (J.List [J.DtUnnecessary])) -- tags + (Just (undefined {- LSP.List -} [undefined {- LSP.DtUnnecessary -}])) -- tags Nothing -- related source code info - makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> J.Diagnostic + Nothing -- data + makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> LSP.Diagnostic makeParseErrorDiagnostic ((startLine, startCol), (endLine, endCol), msg) = - J.Diagnostic - ( J.Range - (J.Position (fromIntegral startLine) (fromIntegral startCol)) - (J.Position (fromIntegral endLine) (fromIntegral endCol)) + LSP.Diagnostic + ( LSP.Range + (LSP.Position (fromIntegral startLine) (fromIntegral startCol)) + (LSP.Position (fromIntegral endLine) (fromIntegral endCol)) ) - (Just J.DsError) -- severity + (Just undefined {- LSP.DsError -}) -- severity Nothing -- code + Nothing -- code description (Just diagnosticSourcePrefix) -- source msg Nothing -- tags - (Just (J.List [])) + (Just (undefined {- LSP.List -} [])) -- related info + Nothing -- data showTypeErrorPos :: Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text) showTypeErrorPos code (CTE l _ te) = (minusOne start, minusOne end, msg) @@ -144,30 +150,30 @@ showTypeErrorPos code (CTE l _ te) = (minusOne start, minusOne end, msg) handlers :: Handlers (LspM ()) handlers = mconcat - [ notificationHandler J.SInitialized $ \_not -> do + [ notificationHandler LSP.SMethod_Initialized $ \_not -> do debug "Initialized" - , notificationHandler J.STextDocumentDidSave $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - content = fromMaybe "?" $ msg ^. J.params . J.text - validateSwarmCode (J.toNormalizedUri doc) Nothing content - , notificationHandler J.STextDocumentDidOpen $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - content = msg ^. J.params . J.textDocument . J.text - validateSwarmCode (J.toNormalizedUri doc) Nothing content - , notificationHandler J.STextDocumentDidChange $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri + , notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri + content = fromMaybe "?" $ msg ^. LSP.params . LSP.text + validateSwarmCode (LSP.toNormalizedUri doc) Nothing content + , notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri + content = msg ^. LSP.params . LSP.textDocument . LSP.text + validateSwarmCode (LSP.toNormalizedUri doc) Nothing content + , notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri mdoc <- getVirtualFile doc case mdoc of Just vf@(VirtualFile _ version _rope) -> do - validateSwarmCode doc (Just $ fromIntegral version) (virtualFileText vf) + validateSwarmCode doc (Just (fromIntegral version)) (virtualFileText vf) _ -> debug $ "No virtual file found for: " <> from (show msg) - , requestHandler J.STextDocumentHover $ \req responder -> do - let doc = req ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri - pos = req ^. J.params . J.position + , requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do + let doc = req ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri + pos = req ^. LSP.params . LSP.position mdoc <- getVirtualFile doc let maybeHover = do vf <- mdoc - (markdownText, maybeRange) <- H.showHoverInfo doc Nothing pos vf - return $ Hover (J.HoverContents $ J.MarkupContent J.MkMarkdown markdownText) maybeRange - responder $ Right maybeHover + (markdownText, maybeRange) <- H.showHoverInfo doc pos vf + return $ LSP.Hover (LSP.InL $ LSP.MarkupContent LSP.MarkupKind_Markdown markdownText) maybeRange + responder . Right . LSP.maybeToNull $ maybeHover ]