{-# 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)

-- | The maximum number of diagnostic messages to send to the client
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
    -- TODO: add logging
    -- Empty handlers to silence the errors
    , 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 ()
    -- , requestHandler SMethod_TextDocumentFormatting $ \_req _res -> 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
        -- TODO: check if the file is included in the config's `include` list.
        --       If not (and not in `exclude`) either, issue a warning.
        forall (m :: * -> *) a. Monad m => a -> m a
return () -- FIXME: typecheck standalone files (if they are not a part of the project)
    -- , requestHandler SMethod_TextDocumentHover $ \req responder -> do
    --    TODO: Read from the list of symbols that is supposed to be cached by the typechecker
    --     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)
    , 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
            -- Exception occurred when parsing the module
            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
                -- Failed to encode the tokens
                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 = ()
      }