{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Swarm.Language.LSP
-- Copyright   :  Brent Yorgey
-- Maintainer  :  byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Language Server Protocol (LSP) server for the Swarm language.
-- See the docs/EDITORS.md to learn how to use it.
module Swarm.Language.LSP where

import Control.Lens (to, (^.))
import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text.IO qualified as Text
import Language.LSP.Diagnostics
import Language.LSP.Server
import Language.LSP.Types qualified as J
import Language.LSP.Types.Lens qualified as J
import Language.LSP.VFS
import Swarm.Language.Parse
import Swarm.Language.Pipeline
import System.IO (stderr)
import Witch

lspMain :: IO ()
lspMain :: IO ()
lspMain =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall config. ServerDefinition config -> IO Int
runServer forall a b. (a -> b) -> a -> b
$
      ServerDefinition
        { onConfigurationChange :: () -> Value -> Either DiagnosticSource ()
onConfigurationChange = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
        , defaultConfig :: ()
defaultConfig = ()
        , doInitialize :: LanguageContextEnv ()
-> Message 'Initialize
-> IO (Either ResponseError (LanguageContextEnv ()))
doInitialize = \LanguageContextEnv ()
env Message 'Initialize
_req -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right LanguageContextEnv ()
env
        , staticHandlers :: Handlers (LspT () IO)
staticHandlers = Handlers (LspT () IO)
handlers
        , interpretHandler :: LanguageContextEnv () -> LspT () IO <~> 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 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
              { -- set sync options to get DidSave event
                textDocumentSync :: Maybe TextDocumentSyncOptions
textDocumentSync =
                  forall a. a -> Maybe a
Just
                    ( Maybe Bool
-> Maybe TextDocumentSyncKind
-> Maybe Bool
-> Maybe Bool
-> Maybe (Bool |? SaveOptions)
-> TextDocumentSyncOptions
J.TextDocumentSyncOptions
                        (forall a. a -> Maybe a
Just Bool
True)
                        (forall a. a -> Maybe a
Just TextDocumentSyncKind
syncKind)
                        (forall a. a -> Maybe a
Just Bool
False)
                        (forall a. a -> Maybe a
Just Bool
False)
                        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
J.InR forall a b. (a -> b) -> a -> b
$ Maybe Bool -> SaveOptions
J.SaveOptions forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True)
                    )
              }
        }
 where
  -- Using SyncFull seems to handle the debounce for us.
  -- The alternative is to use SyncIncremental, but then then
  -- handler is called for each key-stroke.
  syncKind :: TextDocumentSyncKind
syncKind = TextDocumentSyncKind
J.TdSyncFull

debug :: MonadIO m => Text -> m ()
debug :: forall (m :: * -> *). MonadIO m => DiagnosticSource -> m ()
debug DiagnosticSource
msg = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> DiagnosticSource -> IO ()
Text.hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ DiagnosticSource
"[swarm-lsp] " forall a. Semigroup a => a -> a -> a
<> DiagnosticSource
msg

validateSwarmCode :: J.NormalizedUri -> J.TextDocumentVersion -> Text -> LspM () ()
validateSwarmCode :: NormalizedUri
-> TextDocumentVersion -> DiagnosticSource -> LspM () ()
validateSwarmCode NormalizedUri
doc TextDocumentVersion
version DiagnosticSource
content = do
  -- debug $ "Validating: " <> from (show doc) <> " ( " <> content <> ")"
  forall config (m :: * -> *).
MonadLsp config m =>
Int -> Maybe DiagnosticSource -> m ()
flushDiagnosticsBySource Int
0 (forall a. a -> Maybe a
Just DiagnosticSource
"swarm-lsp")
  let err :: Maybe ((Int, Int), (Int, Int), DiagnosticSource)
err = case DiagnosticSource -> Either ParserError (Maybe Syntax)
readTerm' DiagnosticSource
content of
        Right Maybe Syntax
Nothing -> forall a. Maybe a
Nothing
        Right (Just Syntax
term) -> case TCtx -> ReqCtx -> Syntax -> Either TypeErr ProcessedTerm
processParsedTerm' forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Syntax
term of
          Right ProcessedTerm
_ -> forall a. Maybe a
Nothing
          Left TypeErr
e -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DiagnosticSource
-> TypeErr -> ((Int, Int), (Int, Int), DiagnosticSource)
showTypeErrorPos DiagnosticSource
content TypeErr
e
        Left ParserError
e -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ParserError -> ((Int, Int), (Int, Int), DiagnosticSource)
showErrorPos ParserError
e
  -- debug $ "-> " <> from (show err)
  case Maybe ((Int, Int), (Int, Int), DiagnosticSource)
err of
    Maybe ((Int, Int), (Int, Int), DiagnosticSource)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ((Int, Int), (Int, Int), DiagnosticSource)
e -> ((Int, Int), (Int, Int), DiagnosticSource) -> LspM () ()
sendDiagnostic ((Int, Int), (Int, Int), DiagnosticSource)
e
 where
  sendDiagnostic :: ((Int, Int), (Int, Int), Text) -> LspM () ()
  sendDiagnostic :: ((Int, Int), (Int, Int), DiagnosticSource) -> LspM () ()
sendDiagnostic ((Int
startLine, Int
startCol), (Int
endLine, Int
endCol), DiagnosticSource
msg) = do
    let diags :: [Diagnostic]
diags =
          [ Range
-> Maybe DiagnosticSeverity
-> Maybe (Int32 |? DiagnosticSource)
-> Maybe DiagnosticSource
-> DiagnosticSource
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
J.Diagnostic
              ( Position -> Position -> Range
J.Range
                  (UInt -> UInt -> Position
J.Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
startLine) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
startCol))
                  (UInt -> UInt -> Position
J.Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
endLine) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
endCol))
              )
              (forall a. a -> Maybe a
Just DiagnosticSeverity
J.DsWarning) -- severity
              forall a. Maybe a
Nothing -- code
              (forall a. a -> Maybe a
Just DiagnosticSource
"swarm-lsp") -- source
              DiagnosticSource
msg
              forall a. Maybe a
Nothing -- tags
              (forall a. a -> Maybe a
Just (forall a. [a] -> List a
J.List []))
          ]
    forall config (m :: * -> *).
MonadLsp config m =>
Int
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> m ()
publishDiagnostics Int
1 NormalizedUri
doc TextDocumentVersion
version ([Diagnostic] -> DiagnosticsBySource
partitionBySource [Diagnostic]
diags)

handlers :: Handlers (LspM ())
handlers :: Handlers (LspT () IO)
handlers =
  forall a. Monoid a => [a] -> a
mconcat
    [ forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Initialized
J.SInitialized forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'Initialized
_not -> do
        forall (m :: * -> *). MonadIO m => DiagnosticSource -> m ()
debug DiagnosticSource
"Initialized"
    , forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'TextDocumentDidSave
J.STextDocumentDidSave forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'TextDocumentDidSave
msg -> do
        let doc :: Uri
doc = NotificationMessage 'TextDocumentDidSave
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
J.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
J.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
J.uri
            content :: DiagnosticSource
content = forall a. a -> Maybe a -> a
fromMaybe DiagnosticSource
"?" forall a b. (a -> b) -> a -> b
$ NotificationMessage 'TextDocumentDidSave
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
J.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasText s a => Lens' s a
J.text
        NormalizedUri
-> TextDocumentVersion -> DiagnosticSource -> LspM () ()
validateSwarmCode (Uri -> NormalizedUri
J.toNormalizedUri Uri
doc) forall a. Maybe a
Nothing DiagnosticSource
content
    , forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'TextDocumentDidOpen
J.STextDocumentDidOpen forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'TextDocumentDidOpen
msg -> do
        let doc :: Uri
doc = NotificationMessage 'TextDocumentDidOpen
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
J.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
J.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
J.uri
            content :: DiagnosticSource
content = NotificationMessage 'TextDocumentDidOpen
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
J.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
J.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasText s a => Lens' s a
J.text
        NormalizedUri
-> TextDocumentVersion -> DiagnosticSource -> LspM () ()
validateSwarmCode (Uri -> NormalizedUri
J.toNormalizedUri Uri
doc) forall a. Maybe a
Nothing DiagnosticSource
content
    , forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'TextDocumentDidChange
J.STextDocumentDidChange forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'TextDocumentDidChange
msg -> do
        let doc :: NormalizedUri
doc = NotificationMessage 'TextDocumentDidChange
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
J.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
J.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
J.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
J.toNormalizedUri
        Maybe VirtualFile
mdoc <- forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile NormalizedUri
doc
        case Maybe VirtualFile
mdoc of
          Just vf :: VirtualFile
vf@(VirtualFile Int32
_ Int
version Rope
_rope) -> do
            NormalizedUri
-> TextDocumentVersion -> DiagnosticSource -> LspM () ()
validateSwarmCode NormalizedUri
doc (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
version) (VirtualFile -> DiagnosticSource
virtualFileText VirtualFile
vf)
          Maybe VirtualFile
_ -> forall (m :: * -> *). MonadIO m => DiagnosticSource -> m ()
debug forall a b. (a -> b) -> a -> b
$ DiagnosticSource
"No virtual file found for: " forall a. Semigroup a => a -> a -> a
<> forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show NotificationMessage 'TextDocumentDidChange
msg)
    ]