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

-- | 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 LSP ()
resetCacheForAllFiles
          else [[Char]] -> LSP ()
resetCacheForFiles [[Char]]
modifiedPaths
        -- TODO: see what files changed and typecheck them again
        --  Need to handle 3 events: added, changed, and deleted

        -- Currently, this is only sent for changes in `rzk.yaml`, so it makes sense to typecheck again (unconditionally)
        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 (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
                -- 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
      { 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 = ()
      }