{-# LANGUAGE OverloadedStrings #-}

-- |
-- 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, mapMaybe)
import Data.Text (Text)
import Data.Text.IO qualified as Text
import Language.LSP.Diagnostics
import Language.LSP.Server
import Language.LSP.Types (Hover (Hover))
import Language.LSP.Types qualified as J
import Language.LSP.Types.Lens qualified as J
import Language.LSP.VFS (VirtualFile (..), virtualFileText)
import Swarm.Language.LSP.Hover qualified as H
import Swarm.Language.LSP.VarUsage qualified as VU
import Swarm.Language.Parse
import Swarm.Language.Pipeline
import Swarm.Language.Pretty (prettyText)
import Swarm.Language.Syntax (SrcLoc (..))
import Swarm.Language.Typecheck (ContextualTypeErr (..))
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 Text ()
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, as well as Open and Close events.
                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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> a |? b
J.InR forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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

diagnosticSourcePrefix :: Text
diagnosticSourcePrefix :: Text
diagnosticSourcePrefix = Text
"swarm-lsp"

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

validateSwarmCode :: J.NormalizedUri -> J.TextDocumentVersion -> Text -> LspM () ()
validateSwarmCode :: NormalizedUri -> TextDocumentVersion -> Text -> LspM () ()
validateSwarmCode NormalizedUri
doc TextDocumentVersion
version Text
content = do
  -- debug $ "Validating: " <> from (show doc) <> " ( " <> content <> ")"

  -- FIXME: #1040 With this call to flushDiagnosticsBySource in place, the warnings
  -- in other buffers (editor tabs) end up getting cleared when switching between
  -- (focusing on) other buffers in VS Code.
  -- However, getting rid of this seems to break error highlighting.
  forall config (m :: * -> *).
MonadLsp config m =>
Int -> Maybe Text -> m ()
flushDiagnosticsBySource Int
0 (forall a. a -> Maybe a
Just Text
diagnosticSourcePrefix)

  let ([((Int, Int), (Int, Int), Text)]
parsingErrs, [(Range, Text)]
unusedVarWarnings) = case Text -> Either ParserError (Maybe Syntax)
readTerm' Text
content of
        Right Maybe Syntax
Nothing -> ([], [])
        Right (Just Syntax
term) -> ([((Int, Int), (Int, Int), Text)]
parsingErrors, [(Range, Text)]
unusedWarnings)
         where
          VU.Usage Set LocVar
_ [VarUsage]
problems = BindingSites -> Syntax -> Usage
VU.getUsage forall a. Monoid a => a
mempty Syntax
term
          unusedWarnings :: [(Range, Text)]
unusedWarnings = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> VarUsage -> Maybe (Range, Text)
VU.toErrPos Text
content) [VarUsage]
problems

          parsingErrors :: [((Int, Int), (Int, Int), Text)]
parsingErrors = case TCtx -> ReqCtx -> Syntax -> Either ContextualTypeErr ProcessedTerm
processParsedTerm' forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Syntax
term of
            Right ProcessedTerm
_ -> []
            Left ContextualTypeErr
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text)
showTypeErrorPos Text
content ContextualTypeErr
e
        Left ParserError
e -> (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ParserError -> ((Int, Int), (Int, Int), Text)
showErrorPos ParserError
e, [])
  -- debug $ "-> " <> from (show err)

  [Diagnostic] -> LspM () ()
publishDiags forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (Range, Text) -> Diagnostic
makeUnusedVarDiagnostic [(Range, Text)]
unusedVarWarnings

  -- NOTE: "publishDiags" keeps only one diagnostic at a
  -- time (the most recent) so we make sure the errors are
  -- issued last (after any warnings).
  -- Note that it does not achieve the desired effect to simply
  -- concatenate the two diagnostic lists into a single
  -- publishDiagnostics function call (regardless of the order
  -- of the lists).
  [Diagnostic] -> LspM () ()
publishDiags forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), (Int, Int), Text) -> Diagnostic
makeParseErrorDiagnostic [((Int, Int), (Int, Int), Text)]
parsingErrs
 where
  publishDiags :: [J.Diagnostic] -> LspM () ()
  publishDiags :: [Diagnostic] -> LspM () ()
publishDiags = forall config (m :: * -> *).
MonadLsp config m =>
Int
-> NormalizedUri
-> TextDocumentVersion
-> DiagnosticsBySource
-> m ()
publishDiagnostics Int
1 NormalizedUri
doc TextDocumentVersion
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Diagnostic] -> DiagnosticsBySource
partitionBySource

  makeUnusedVarDiagnostic :: (J.Range, Text) -> J.Diagnostic
  makeUnusedVarDiagnostic :: (Range, Text) -> Diagnostic
makeUnusedVarDiagnostic (Range
range, Text
msg) =
    Range
-> Maybe DiagnosticSeverity
-> Maybe (Int32 |? Text)
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
J.Diagnostic
      Range
range
      (forall a. a -> Maybe a
Just DiagnosticSeverity
J.DsWarning) -- severity
      forall a. Maybe a
Nothing -- code
      (forall a. a -> Maybe a
Just Text
diagnosticSourcePrefix) -- source
      Text
msg
      (forall a. a -> Maybe a
Just (forall a. [a] -> List a
J.List [DiagnosticTag
J.DtUnnecessary])) -- tags
      forall a. Maybe a
Nothing -- related source code info
  makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> J.Diagnostic
  makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> Diagnostic
makeParseErrorDiagnostic ((Int
startLine, Int
startCol), (Int
endLine, Int
endCol), Text
msg) =
    Range
-> Maybe DiagnosticSeverity
-> Maybe (Int32 |? Text)
-> Maybe Text
-> Text
-> 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.DsError) -- severity
      forall a. Maybe a
Nothing -- code
      (forall a. a -> Maybe a
Just Text
diagnosticSourcePrefix) -- source
      Text
msg
      forall a. Maybe a
Nothing -- tags
      (forall a. a -> Maybe a
Just (forall a. [a] -> List a
J.List []))

showTypeErrorPos :: Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text)
showTypeErrorPos :: Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text)
showTypeErrorPos Text
code (CTE SrcLoc
l TCStack
_ TypeErr
te) = (forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
minusOne (Int, Int)
start, forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
minusOne (Int, Int)
end, Text
msg)
 where
  minusOne :: (a, b) -> (a, b)
minusOne (a
x, b
y) = (a
x forall a. Num a => a -> a -> a
- a
1, b
y forall a. Num a => a -> a -> a
- b
1)

  ((Int, Int)
start, (Int, Int)
end) = case SrcLoc
l of
    SrcLoc Int
s Int
e -> Text -> (Int, Int) -> ((Int, Int), (Int, Int))
getLocRange Text
code (Int
s, Int
e)
    SrcLoc
NoLoc -> ((Int
1, Int
1), (Int
65535, Int
65535)) -- unknown loc spans the whole document
  msg :: Text
msg = forall a. PrettyPrec a => a -> Text
prettyText TypeErr
te

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 => Text -> m ()
debug Text
"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 :: Text
content = forall a. a -> Maybe a -> a
fromMaybe Text
"?" 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 -> Text -> LspM () ()
validateSwarmCode (Uri -> NormalizedUri
J.toNormalizedUri Uri
doc) forall a. Maybe a
Nothing Text
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 :: Text
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 -> Text -> LspM () ()
validateSwarmCode (Uri -> NormalizedUri
J.toNormalizedUri Uri
doc) forall a. Maybe a
Nothing Text
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 -> Text -> 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 -> Text
virtualFileText VirtualFile
vf)
          Maybe VirtualFile
_ -> forall (m :: * -> *). MonadIO m => Text -> m ()
debug forall a b. (a -> b) -> a -> b
$ Text
"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)
    , forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'TextDocumentHover
J.STextDocumentHover forall a b. (a -> b) -> a -> b
$ \RequestMessage 'TextDocumentHover
req Either ResponseError (Maybe Hover) -> LspM () ()
responder -> do
        let doc :: NormalizedUri
doc = RequestMessage 'TextDocumentHover
req 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
            pos :: Position
pos = RequestMessage 'TextDocumentHover
req 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. HasPosition s a => Lens' s a
J.position
        Maybe VirtualFile
mdoc <- forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile NormalizedUri
doc
        let maybeHover :: Maybe Hover
maybeHover = do
              VirtualFile
vf <- Maybe VirtualFile
mdoc
              (Text
markdownText, Maybe Range
maybeRange) <- NormalizedUri
-> TextDocumentVersion
-> Position
-> VirtualFile
-> Maybe (Text, Maybe Range)
H.showHoverInfo NormalizedUri
doc forall a. Maybe a
Nothing Position
pos VirtualFile
vf
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HoverContents -> Maybe Range -> Hover
Hover (MarkupContent -> HoverContents
J.HoverContents forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
J.MarkupContent MarkupKind
J.MkMarkdown Text
markdownText) Maybe Range
maybeRange
        Either ResponseError (Maybe Hover) -> LspM () ()
responder forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Maybe Hover
maybeHover
    ]