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

module Language.Rzk.VSCode.Lsp where

import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Data.Default.Class            (Default (def))
import qualified Data.Text                     as T
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Server

import           Data.Aeson                    (Result (Error, Success),
                                                fromJSON)
import           Language.Rzk.VSCode.Config    (ServerConfig (..))
import           Language.Rzk.VSCode.Env
import           Language.Rzk.VSCode.Handlers

-- | 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 =
  [Handlers LSP] -> Handlers LSP
forall a. Monoid a => [a] -> a
mconcat
    [ SMethod 'Method_Initialized
-> Handler LSP 'Method_Initialized -> Handlers LSP
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_Initialized
SMethod_Initialized (Handler LSP 'Method_Initialized -> Handlers LSP)
-> Handler LSP 'Method_Initialized -> Handlers LSP
forall a b. (a -> b) -> a -> b
$ LSP () -> TNotificationMessage 'Method_Initialized -> LSP ()
forall a b. a -> b -> a
const LSP ()
typecheckFromConfigFile
    -- TODO: add logging
    -- Empty handlers to silence the errors
    , SMethod 'Method_TextDocumentDidOpen
-> Handler LSP 'Method_TextDocumentDidOpen -> Handlers LSP
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidOpen
SMethod_TextDocumentDidOpen (Handler LSP 'Method_TextDocumentDidOpen -> Handlers LSP)
-> Handler LSP 'Method_TextDocumentDidOpen -> Handlers LSP
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidOpen
_msg -> () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , SMethod 'Method_TextDocumentDidChange
-> Handler LSP 'Method_TextDocumentDidChange -> Handlers LSP
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidChange
SMethod_TextDocumentDidChange (Handler LSP 'Method_TextDocumentDidChange -> Handlers LSP)
-> Handler LSP 'Method_TextDocumentDidChange -> Handlers LSP
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidChange
_msg -> () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , SMethod 'Method_TextDocumentDidClose
-> Handler LSP 'Method_TextDocumentDidClose -> Handlers LSP
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidClose
SMethod_TextDocumentDidClose (Handler LSP 'Method_TextDocumentDidClose -> Handlers LSP)
-> Handler LSP 'Method_TextDocumentDidClose -> Handlers LSP
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidClose
_msg -> () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , SMethod 'Method_WorkspaceDidChangeWatchedFiles
-> Handler LSP 'Method_WorkspaceDidChangeWatchedFiles
-> Handlers LSP
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_WorkspaceDidChangeWatchedFiles
SMethod_WorkspaceDidChangeWatchedFiles Handler LSP 'Method_WorkspaceDidChangeWatchedFiles
handleFilesChanged
    , SMethod 'Method_TextDocumentDidSave
-> Handler LSP 'Method_TextDocumentDidSave -> Handlers LSP
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidSave
SMethod_TextDocumentDidSave (Handler LSP 'Method_TextDocumentDidSave -> Handlers LSP)
-> Handler LSP 'Method_TextDocumentDidSave -> Handlers LSP
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.
        () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- FIXME: typecheck standalone files (if they are not a part of the project)
    -- An empty hadler is needed to silence the error since it is already handled by the LSP package
    , SMethod 'Method_WorkspaceDidChangeConfiguration
-> Handler LSP 'Method_WorkspaceDidChangeConfiguration
-> Handlers LSP
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_WorkspaceDidChangeConfiguration
SMethod_WorkspaceDidChangeConfiguration (Handler LSP 'Method_WorkspaceDidChangeConfiguration
 -> Handlers LSP)
-> Handler LSP 'Method_WorkspaceDidChangeConfiguration
-> Handlers LSP
forall a b. (a -> b) -> a -> b
$ LSP ()
-> TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
-> LSP ()
forall a b. a -> b -> a
const (LSP ()
 -> TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
 -> LSP ())
-> LSP ()
-> TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
-> LSP ()
forall a b. (a -> b) -> a -> b
$ () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- , 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)
    , SMethod 'Method_TextDocumentCompletion
-> Handler LSP 'Method_TextDocumentCompletion -> Handlers LSP
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'Method_TextDocumentCompletion
SMethod_TextDocumentCompletion Handler LSP 'Method_TextDocumentCompletion
provideCompletions
    , SMethod 'Method_TextDocumentSemanticTokensFull
-> Handler LSP 'Method_TextDocumentSemanticTokensFull
-> Handlers LSP
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'Method_TextDocumentSemanticTokensFull
SMethod_TextDocumentSemanticTokensFull Handler LSP 'Method_TextDocumentSemanticTokensFull
provideSemanticTokens
    , SMethod 'Method_TextDocumentFormatting
-> Handler LSP 'Method_TextDocumentFormatting -> Handlers LSP
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'Method_TextDocumentFormatting
SMethod_TextDocumentFormatting Handler LSP 'Method_TextDocumentFormatting
formatDocument
    ]


syncOptions :: TextDocumentSyncOptions
syncOptions :: TextDocumentSyncOptions
syncOptions = TextDocumentSyncOptions
  { _openClose :: Maybe Bool
_openClose         = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  , _change :: Maybe TextDocumentSyncKind
_change            = TextDocumentSyncKind -> Maybe TextDocumentSyncKind
forall a. a -> Maybe a
Just TextDocumentSyncKind
TextDocumentSyncKind_Full
  , _willSave :: Maybe Bool
_willSave          = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
  , _willSaveWaitUntil :: Maybe Bool
_willSaveWaitUntil = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
  , _save :: Maybe (Bool |? SaveOptions)
_save              = (Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions)
forall a. a -> Maybe a
Just ((Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions))
-> (Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions)
forall a b. (a -> b) -> a -> b
$ SaveOptions -> Bool |? SaveOptions
forall a b. b -> a |? b
InR (SaveOptions -> Bool |? SaveOptions)
-> SaveOptions -> Bool |? SaveOptions
forall a b. (a -> b) -> a -> b
$ SaveOptions { _includeText :: Maybe Bool
_includeText = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True }
  }

runLsp :: IO Int
runLsp :: IO Int
runLsp = do
  RzkEnv
rzkEnv <- IO RzkEnv
defaultRzkEnv
  ServerDefinition ServerConfig -> IO Int
forall config. ServerDefinition config -> IO Int
runServer (ServerDefinition ServerConfig -> IO Int)
-> ServerDefinition ServerConfig -> IO Int
forall a b. (a -> b) -> a -> b
$
    ServerDefinition
      { configSection :: Text
configSection = Text
"rzk"
      , parseConfig :: ServerConfig -> Value -> Either Text ServerConfig
parseConfig = \ServerConfig
_oldConfig Value
newObject -> case Value -> Result ServerConfig
forall a. FromJSON a => Value -> Result a
fromJSON Value
newObject of
          -- TODO: handle partial config updates from VS Code by updating oldConfig rather than parsing from scratch
          Error String
err         -> Text -> Either Text ServerConfig
forall a b. a -> Either a b
Left (Text -> Either Text ServerConfig)
-> Text -> Either Text ServerConfig
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err
          Success ServerConfig
rzkConfig -> ServerConfig -> Either Text ServerConfig
forall a b. b -> Either a b
Right ServerConfig
rzkConfig
      , onConfigChange :: ServerConfig -> LSP ()
onConfigChange = LSP () -> ServerConfig -> LSP ()
forall a b. a -> b -> a
const (LSP () -> ServerConfig -> LSP ())
-> LSP () -> ServerConfig -> LSP ()
forall a b. (a -> b) -> a -> b
$ () -> LSP ()
forall a. a -> LspT ServerConfig (ReaderT RzkEnv IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      , doInitialize :: LanguageContextEnv ServerConfig
-> TMessage 'Method_Initialize
-> IO
     (Either
        (TResponseError 'Method_Initialize)
        (LanguageContextEnv ServerConfig))
doInitialize = IO
  (Either
     (TResponseError 'Method_Initialize)
     (LanguageContextEnv ServerConfig))
-> TRequestMessage 'Method_Initialize
-> IO
     (Either
        (TResponseError 'Method_Initialize)
        (LanguageContextEnv ServerConfig))
forall a b. a -> b -> a
const (IO
   (Either
      (TResponseError 'Method_Initialize)
      (LanguageContextEnv ServerConfig))
 -> TRequestMessage 'Method_Initialize
 -> IO
      (Either
         (TResponseError 'Method_Initialize)
         (LanguageContextEnv ServerConfig)))
-> (LanguageContextEnv ServerConfig
    -> IO
         (Either
            (TResponseError 'Method_Initialize)
            (LanguageContextEnv ServerConfig)))
-> LanguageContextEnv ServerConfig
-> TRequestMessage 'Method_Initialize
-> IO
     (Either
        (TResponseError 'Method_Initialize)
        (LanguageContextEnv ServerConfig))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
  (TResponseError 'Method_Initialize)
  (LanguageContextEnv ServerConfig)
-> IO
     (Either
        (TResponseError 'Method_Initialize)
        (LanguageContextEnv ServerConfig))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (TResponseError 'Method_Initialize)
   (LanguageContextEnv ServerConfig)
 -> IO
      (Either
         (TResponseError 'Method_Initialize)
         (LanguageContextEnv ServerConfig)))
-> (LanguageContextEnv ServerConfig
    -> Either
         (TResponseError 'Method_Initialize)
         (LanguageContextEnv ServerConfig))
-> LanguageContextEnv ServerConfig
-> IO
     (Either
        (TResponseError 'Method_Initialize)
        (LanguageContextEnv ServerConfig))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv ServerConfig
-> Either
     (TResponseError 'Method_Initialize)
     (LanguageContextEnv ServerConfig)
forall a b. b -> Either a b
Right
      , staticHandlers :: ClientCapabilities -> Handlers LSP
staticHandlers = Handlers LSP -> ClientCapabilities -> Handlers LSP
forall a b. a -> b -> a
const Handlers LSP
handlers
      , interpretHandler :: LanguageContextEnv ServerConfig -> LSP <~> IO
interpretHandler = \LanguageContextEnv ServerConfig
env -> (forall a. LSP a -> IO a)
-> (forall a. IO a -> LSP a) -> LSP <~> IO
forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
Iso ((ReaderT RzkEnv IO a -> RzkEnv -> IO a)
-> RzkEnv -> ReaderT RzkEnv IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT RzkEnv IO a -> RzkEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RzkEnv
rzkEnv (ReaderT RzkEnv IO a -> IO a)
-> (LSP a -> ReaderT RzkEnv IO a) -> LSP a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv ServerConfig -> LSP a -> ReaderT RzkEnv IO a
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv ServerConfig
env) IO a -> LSP a
forall a. IO a -> LSP a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      , options :: Options
options = Options
defaultOptions { optTextDocumentSync = Just syncOptions }
      , defaultConfig :: ServerConfig
defaultConfig = ServerConfig
forall a. Default a => a
def :: ServerConfig
      }