geolog-lsp/src/Main.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}

import Control.Monad.IO.Class
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Data.Either (fromRight)

handlers :: Handlers (LspM ())
handlers =
    mconcat
        [ notificationHandler SMethod_Initialized $ \_ -> pure ()
        , requestHandler SMethod_TextDocumentHover $ \req responder -> do
            let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
                Position _l _c' = pos
                rsp = Hover (InL ms) (Just range)
                ms = mkMarkdown "Hello world"
                range = Range pos pos
            responder (Right $ InL rsp)
        , requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
            let TRequestMessage _ _ _ (SemanticTokensParams _doc _workDone _partial) = req

            -- Each token is encoded as 5 uints:
            -- [deltaLine, deltaStartChar, length, tokenTypeIndex, tokenModifiersBitset]
            -- This example returns a single token at (0,0) of length 5.
            let  -- tokenTypeIndex=0 is "whatever the legend's 0 is"
                token = SemanticTokenAbsolute {
                    _line = 0,
                    _startChar = 0,
                    _length = 5,
                    _tokenType = SemanticTokenTypes_Keyword,
                    _tokenModifiers = []
                }
                tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token]

            responder (Right $ InL tokens)
        ]

main :: IO Int
main =
    runServer $
        ServerDefinition
            { parseConfig = const $ const $ Right ()
            , onConfigChange = const $ pure ()
            , defaultConfig = ()
            , configSection = "demo"
            , doInitialize = \env _req -> pure $ Right env
            , staticHandlers = const handlers
            , interpretHandler = \env -> Iso (runLspT env) liftIO
            , options =
                defaultOptions
                    { optTextDocumentSync =
                        Just $
                            TextDocumentSyncOptions
                                { _openClose = Just True
                                , _change = Just TextDocumentSyncKind_Full
                                , _willSave = Just False
                                , _willSaveWaitUntil = Just False
                                , _save = Just (InR (SaveOptions (Just False)))
                                }
                    }
            }