{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
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.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 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 (m :: * -> *) a. Monad m => a -> m a
return ()
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
{ onConfigurationChange :: () -> Value -> Either Text ()
onConfigurationChange = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (),
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 = ()
}