{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Rzk.VSCode.Lsp where
import Control.Lens (_Just, to, (^.), (^..))
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.List (isSuffixOf)
import qualified Data.Text as T
import Language.LSP.Protocol.Lens (HasParams (params),
HasTextDocument (textDocument),
HasUri (uri), changes, uri)
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Language.LSP.VFS (virtualFileText)
import Language.Rzk.Syntax (parseModuleSafe)
import Language.Rzk.VSCode.Env
import Language.Rzk.VSCode.Handlers
import Language.Rzk.VSCode.Logging
import Language.Rzk.VSCode.Tokenize (tokenizeModule)
maxDiagnosticCount :: Int
maxDiagnosticCount :: Int
maxDiagnosticCount = Int
100
handlers :: Handlers LSP
handlers :: Handlers LSP
handlers =
forall a. Monoid a => [a] -> a
mconcat
[ forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_Initialized
SMethod_Initialized forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const LSP ()
typecheckFromConfigFile
, forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidOpen
SMethod_TextDocumentDidOpen forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidOpen
_msg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidChange
SMethod_TextDocumentDidChange forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidChange
_msg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidClose
SMethod_TextDocumentDidClose forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidClose
_msg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_WorkspaceDidChangeWatchedFiles
SMethod_WorkspaceDidChangeWatchedFiles forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles
msg -> do
let modifiedPaths :: [[Char]]
modifiedPaths = TNotificationMessage 'Method_WorkspaceDidChangeWatchedFiles
msg forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasChanges s a => Lens' s a
changes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
uri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Uri -> Maybe [Char]
uriToFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char]
"rzk.yaml" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [[Char]]
modifiedPaths
then do
forall c (m :: * -> *). MonadLsp c m => [Char] -> m ()
logDebug [Char]
"rzk.yaml modified. Clearing module cache"
LSP ()
resetCacheForAllFiles
else [[Char]] -> LSP ()
resetCacheForFiles [[Char]]
modifiedPaths
LSP ()
typecheckFromConfigFile
, forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidSave
SMethod_TextDocumentDidSave forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidSave
_msg -> do
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'Method_TextDocumentCompletion
SMethod_TextDocumentCompletion Handler LSP 'Method_TextDocumentCompletion
provideCompletions
, forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'Method_TextDocumentSemanticTokensFull
SMethod_TextDocumentSemanticTokensFull forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_TextDocumentSemanticTokensFull
req Either ResponseError (SemanticTokens |? Null) -> LSP ()
responder -> do
let doc :: NormalizedUri
doc = TRequestMessage 'Method_TextDocumentSemanticTokensFull
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
uri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Uri -> NormalizedUri
toNormalizedUri
Maybe VirtualFile
mdoc <- forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile NormalizedUri
doc
Either [Char] [SemanticTokenAbsolute]
possibleTokens <- case VirtualFile -> Text
virtualFileText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VirtualFile
mdoc of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left [Char]
"Failed to get file content")
Just Text
sourceCode -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> [SemanticTokenAbsolute]
tokenizeModule) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
[Char] -> IO (Either [Char] Module)
parseModuleSafe (Text -> [Char]
T.unpack Text
sourceCode)
case Either [Char] [SemanticTokenAbsolute]
possibleTokens of
Left [Char]
err -> do
forall c (m :: * -> *). MonadLsp c m => [Char] -> m ()
logWarning ([Char]
"Failed to tokenize file: " forall a. [a] -> [a] -> [a]
++ [Char]
err)
Right [SemanticTokenAbsolute]
tokens -> do
let encoded :: Either Text [UInt]
encoded = SemanticTokensLegend
-> [SemanticTokenRelative] -> Either Text [UInt]
encodeTokens SemanticTokensLegend
defaultSemanticTokensLegend forall a b. (a -> b) -> a -> b
$ [SemanticTokenAbsolute] -> [SemanticTokenRelative]
relativizeTokens [SemanticTokenAbsolute]
tokens
case Either Text [UInt]
encoded of
Left Text
_err -> do
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Right [UInt]
list ->
Either ResponseError (SemanticTokens |? Null) -> LSP ()
responder (forall a b. b -> Either a b
Right (forall a b. a -> a |? b
InL SemanticTokens { $sel:_resultId:SemanticTokens :: Maybe Text
_resultId = forall a. Maybe a
Nothing, $sel:_data_:SemanticTokens :: [UInt]
_data_ = [UInt]
list }))
]
syncOptions :: TextDocumentSyncOptions
syncOptions :: TextDocumentSyncOptions
syncOptions = TextDocumentSyncOptions
{ $sel:_openClose:TextDocumentSyncOptions :: Maybe Bool
_openClose = forall a. a -> Maybe a
Just Bool
True
, $sel:_change:TextDocumentSyncOptions :: Maybe TextDocumentSyncKind
_change = forall a. a -> Maybe a
Just TextDocumentSyncKind
TextDocumentSyncKind_Full
, $sel:_willSave:TextDocumentSyncOptions :: Maybe Bool
_willSave = forall a. a -> Maybe a
Just Bool
False
, $sel:_willSaveWaitUntil:TextDocumentSyncOptions :: Maybe Bool
_willSaveWaitUntil = forall a. a -> Maybe a
Just Bool
False
, $sel:_save:TextDocumentSyncOptions :: Maybe (Bool |? SaveOptions)
_save = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ SaveOptions { $sel:_includeText:SaveOptions :: Maybe Bool
_includeText = forall a. a -> Maybe a
Just Bool
True }
}
runLsp :: IO Int
runLsp :: IO Int
runLsp = do
RzkEnv
rzkEnv <- IO RzkEnv
defaultRzkEnv
forall config. ServerDefinition config -> IO Int
runServer forall a b. (a -> b) -> a -> b
$
ServerDefinition
{ configSection :: Text
configSection = Text
"rzk"
, parseConfig :: () -> Value -> Either Text ()
parseConfig = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
, onConfigChange :: () -> LSP ()
onConfigChange = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, doInitialize :: LanguageContextEnv ()
-> TMessage 'Method_Initialize
-> IO (Either ResponseError (LanguageContextEnv ()))
doInitialize = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
, staticHandlers :: ClientCapabilities -> Handlers LSP
staticHandlers = forall a b. a -> b -> a
const Handlers LSP
handlers
, interpretHandler :: LanguageContextEnv () -> LSP <~> IO
interpretHandler = \LanguageContextEnv ()
env -> forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
Iso (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RzkEnv
rzkEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv ()
env) forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
, options :: Options
options = Options
defaultOptions { optTextDocumentSync :: Maybe TextDocumentSyncOptions
optTextDocumentSync = forall a. a -> Maybe a
Just TextDocumentSyncOptions
syncOptions }
, defaultConfig :: ()
defaultConfig = ()
}