{-# 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.Int (Int32)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text.IO qualified as Text
import Language.LSP.Diagnostics
import Language.LSP.Protocol.Lens qualified as LSP
import Language.LSP.Protocol.Message qualified as LSP
import Language.LSP.Protocol.Types qualified as LSP
import Language.LSP.Server
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.Parser (readTerm')
import Swarm.Language.Parser.Core (defaultParserConfig)
import Swarm.Language.Parser.Util (getLocRange, showErrorPos)
import Swarm.Language.Pipeline (processParsedTerm')
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 =
  IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$
    ServerDefinition () -> IO Int
forall config. ServerDefinition config -> IO Int
runServer (ServerDefinition () -> IO Int) -> ServerDefinition () -> IO Int
forall a b. (a -> b) -> a -> b
$
      ServerDefinition
        { defaultConfig :: ()
defaultConfig = ()
        , configSection :: Text
configSection = Text
"swarm"
        , parseConfig :: () -> Value -> Either Text ()
parseConfig = (Value -> Either Text ()) -> () -> Value -> Either Text ()
forall a b. a -> b -> a
const ((Value -> Either Text ()) -> () -> Value -> Either Text ())
-> (Value -> Either Text ()) -> () -> Value -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Either Text () -> Value -> Either Text ()
forall a b. a -> b -> a
const (Either Text () -> Value -> Either Text ())
-> Either Text () -> Value -> Either Text ()
forall a b. (a -> b) -> a -> b
$ () -> Either Text ()
forall a b. b -> Either a b
Right ()
        , onConfigChange :: () -> LspM () ()
onConfigChange = LspM () () -> () -> LspM () ()
forall a b. a -> b -> a
const (LspM () () -> () -> LspM () ()) -> LspM () () -> () -> LspM () ()
forall a b. (a -> b) -> a -> b
$ () -> LspM () ()
forall a. a -> LspM () a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , doInitialize :: LanguageContextEnv ()
-> TMessage 'Method_Initialize
-> IO (Either ResponseError (LanguageContextEnv ()))
doInitialize = \LanguageContextEnv ()
env TMessage 'Method_Initialize
_req -> Either ResponseError (LanguageContextEnv ())
-> IO (Either ResponseError (LanguageContextEnv ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (LanguageContextEnv ())
 -> IO (Either ResponseError (LanguageContextEnv ())))
-> Either ResponseError (LanguageContextEnv ())
-> IO (Either ResponseError (LanguageContextEnv ()))
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv ()
-> Either ResponseError (LanguageContextEnv ())
forall a b. b -> Either a b
Right LanguageContextEnv ()
env
        , staticHandlers :: ClientCapabilities -> Handlers (LspT () IO)
staticHandlers = Handlers (LspT () IO)
-> ClientCapabilities -> Handlers (LspT () IO)
forall a b. a -> b -> a
const Handlers (LspT () IO)
handlers
        , interpretHandler :: LanguageContextEnv () -> LspT () IO <~> IO
interpretHandler = \LanguageContextEnv ()
env -> (forall a. LspM () a -> IO a)
-> (forall a. IO a -> LspM () a) -> LspT () IO <~> IO
forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
Iso (LanguageContextEnv () -> LspT () IO a -> IO a
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv ()
env) IO a -> LspM () a
forall a. IO a -> LspM () a
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.
                optTextDocumentSync =
                  Just
                    ( LSP.TextDocumentSyncOptions
                        (Just True)
                        (Just syncKind)
                        (Just False)
                        (Just False)
                        (Just . LSP.InR . LSP.SaveOptions $ Just True)
                    )
              }
        }
 where
  -- Using SyncFull seems to handle the debounce for us.
  -- The alternative is to use SyncIncremental, but then the
  -- handler is called for each keystroke.
  syncKind :: TextDocumentSyncKind
syncKind = TextDocumentSyncKind
LSP.TextDocumentSyncKind_Full

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

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

type TextDocumentVersion = Int32

validateSwarmCode :: LSP.NormalizedUri -> Maybe TextDocumentVersion -> Text -> LspM () ()
validateSwarmCode :: NormalizedUri -> Maybe TextDocumentVersion -> Text -> LspM () ()
validateSwarmCode NormalizedUri
doc Maybe 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.
  Int -> Maybe Text -> LspM () ()
forall config (m :: * -> *).
MonadLsp config m =>
Int -> Maybe Text -> m ()
flushDiagnosticsBySource Int
0 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
diagnosticSourcePrefix)

  let ([((Int, Int), (Int, Int), Text)]
parsingErrs, [(Range, Text)]
unusedVarWarnings) = case ParserConfig -> Text -> Either ParserError (Maybe Syntax)
readTerm' ParserConfig
defaultParserConfig 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 BindingSites
forall a. Monoid a => a
mempty Syntax
term
          unusedWarnings :: [(Range, Text)]
unusedWarnings = (VarUsage -> Maybe (Range, Text)) -> [VarUsage] -> [(Range, Text)]
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 Env -> Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm' Env
forall a. Monoid a => a
mempty Syntax
term of
            Right TSyntax
_ -> []
            Left ContextualTypeErr
e -> ((Int, Int), (Int, Int), Text) -> [((Int, Int), (Int, Int), Text)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Int, Int), (Int, Int), Text)
 -> [((Int, Int), (Int, Int), Text)])
-> ((Int, Int), (Int, Int), Text)
-> [((Int, Int), (Int, Int), Text)]
forall a b. (a -> b) -> a -> b
$ Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text)
showTypeErrorPos Text
content ContextualTypeErr
e
        Left ParserError
e -> (((Int, Int), (Int, Int), Text) -> [((Int, Int), (Int, Int), Text)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Int, Int), (Int, Int), Text)
 -> [((Int, Int), (Int, Int), Text)])
-> ((Int, Int), (Int, Int), Text)
-> [((Int, Int), (Int, Int), Text)]
forall a b. (a -> b) -> a -> b
$ ParserError -> ((Int, Int), (Int, Int), Text)
showErrorPos ParserError
e, [])
  -- debug $ "-> " <> from (show err)

  [Diagnostic] -> LspM () ()
publishDiags ([Diagnostic] -> LspM () ()) -> [Diagnostic] -> LspM () ()
forall a b. (a -> b) -> a -> b
$
    ((Range, Text) -> Diagnostic) -> [(Range, Text)] -> [Diagnostic]
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 ([Diagnostic] -> LspM () ()) -> [Diagnostic] -> LspM () ()
forall a b. (a -> b) -> a -> b
$
    (((Int, Int), (Int, Int), Text) -> Diagnostic)
-> [((Int, Int), (Int, Int), Text)] -> [Diagnostic]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), (Int, Int), Text) -> Diagnostic
makeParseErrorDiagnostic [((Int, Int), (Int, Int), Text)]
parsingErrs
 where
  publishDiags :: [LSP.Diagnostic] -> LspM () ()
  publishDiags :: [Diagnostic] -> LspM () ()
publishDiags = Int
-> NormalizedUri
-> Maybe TextDocumentVersion
-> DiagnosticsBySource
-> LspM () ()
forall config (m :: * -> *).
MonadLsp config m =>
Int
-> NormalizedUri
-> Maybe TextDocumentVersion
-> DiagnosticsBySource
-> m ()
publishDiagnostics Int
1 NormalizedUri
doc Maybe TextDocumentVersion
version (DiagnosticsBySource -> LspM () ())
-> ([Diagnostic] -> DiagnosticsBySource)
-> [Diagnostic]
-> LspM () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Diagnostic] -> DiagnosticsBySource
partitionBySource

  makeUnusedVarDiagnostic :: (LSP.Range, Text) -> LSP.Diagnostic
  makeUnusedVarDiagnostic :: (Range, Text) -> Diagnostic
makeUnusedVarDiagnostic (Range
range, Text
msg) =
    Range
-> Maybe DiagnosticSeverity
-> Maybe (TextDocumentVersion |? Text)
-> Maybe CodeDescription
-> Maybe Text
-> Text
-> Maybe [DiagnosticTag]
-> Maybe [DiagnosticRelatedInformation]
-> Maybe Value
-> Diagnostic
LSP.Diagnostic
      Range
range
      (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DiagnosticSeverity_Warning) -- severity
      Maybe (TextDocumentVersion |? Text)
forall a. Maybe a
Nothing -- code
      Maybe CodeDescription
forall a. Maybe a
Nothing -- code description
      (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
diagnosticSourcePrefix) -- source
      Text
msg
      ([DiagnosticTag] -> Maybe [DiagnosticTag]
forall a. a -> Maybe a
Just [DiagnosticTag
LSP.DiagnosticTag_Unnecessary]) -- tags
      Maybe [DiagnosticRelatedInformation]
forall a. Maybe a
Nothing -- related source code info
      Maybe Value
forall a. Maybe a
Nothing -- data
  makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> LSP.Diagnostic
  makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> Diagnostic
makeParseErrorDiagnostic ((Int
startLine, Int
startCol), (Int
endLine, Int
endCol), Text
msg) =
    Range
-> Maybe DiagnosticSeverity
-> Maybe (TextDocumentVersion |? Text)
-> Maybe CodeDescription
-> Maybe Text
-> Text
-> Maybe [DiagnosticTag]
-> Maybe [DiagnosticRelatedInformation]
-> Maybe Value
-> Diagnostic
LSP.Diagnostic
      ( Position -> Position -> Range
LSP.Range
          (UInt -> UInt -> Position
LSP.Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
startLine) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
startCol))
          (UInt -> UInt -> Position
LSP.Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
endLine) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
endCol))
      )
      (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
LSP.DiagnosticSeverity_Error) -- severity
      Maybe (TextDocumentVersion |? Text)
forall a. Maybe a
Nothing -- code
      Maybe CodeDescription
forall a. Maybe a
Nothing -- code description
      (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
diagnosticSourcePrefix) -- source
      Text
msg
      Maybe [DiagnosticTag]
forall a. Maybe a
Nothing -- tags
      ([DiagnosticRelatedInformation]
-> Maybe [DiagnosticRelatedInformation]
forall a. a -> Maybe a
Just []) -- related info
      Maybe Value
forall a. Maybe a
Nothing -- data

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) = ((Int, Int) -> (Int, Int)
forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
minusOne (Int, Int)
start, (Int, Int) -> (Int, Int)
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 a -> a -> a
forall a. Num a => a -> a -> a
- a
1, b
y b -> b -> b
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 = TypeErr -> Text
forall a. PrettyPrec a => a -> Text
prettyText TypeErr
te

handlers :: Handlers (LspM ())
handlers :: Handlers (LspT () IO)
handlers =
  [Handlers (LspT () IO)] -> Handlers (LspT () IO)
forall a. Monoid a => [a] -> a
mconcat
    [ SMethod 'Method_Initialized
-> Handler (LspT () IO) 'Method_Initialized
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_Initialized
LSP.SMethod_Initialized (Handler (LspT () IO) 'Method_Initialized -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_Initialized
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_Initialized
_not -> do
        Text -> LspM () ()
forall (m :: * -> *). MonadIO m => Text -> m ()
debug Text
"Initialized"
    , SMethod 'Method_TextDocumentDidSave
-> Handler (LspT () IO) 'Method_TextDocumentDidSave
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidSave
LSP.SMethod_TextDocumentDidSave (Handler (LspT () IO) 'Method_TextDocumentDidSave
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentDidSave
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidSave
msg -> do
        let doc :: Uri
doc = TNotificationMessage 'Method_TextDocumentDidSave
msg TNotificationMessage 'Method_TextDocumentDidSave
-> Getting
     Uri (TNotificationMessage 'Method_TextDocumentDidSave) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams)
-> TNotificationMessage 'Method_TextDocumentDidSave
-> Const Uri (TNotificationMessage 'Method_TextDocumentDidSave)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentDidSave)
  DidSaveTextDocumentParams
LSP.params ((DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams)
 -> TNotificationMessage 'Method_TextDocumentDidSave
 -> Const Uri (TNotificationMessage 'Method_TextDocumentDidSave))
-> ((Uri -> Const Uri Uri)
    -> DidSaveTextDocumentParams
    -> Const Uri DidSaveTextDocumentParams)
-> Getting
     Uri (TNotificationMessage 'Method_TextDocumentDidSave) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DidSaveTextDocumentParams -> Const Uri DidSaveTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DidSaveTextDocumentParams TextDocumentIdentifier
LSP.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DidSaveTextDocumentParams
 -> Const Uri DidSaveTextDocumentParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> DidSaveTextDocumentParams
-> Const Uri DidSaveTextDocumentParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
LSP.uri
            content :: Text
content = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"?" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ TNotificationMessage 'Method_TextDocumentDidSave
msg TNotificationMessage 'Method_TextDocumentDidSave
-> Getting
     (Maybe Text)
     (TNotificationMessage 'Method_TextDocumentDidSave)
     (Maybe Text)
-> Maybe Text
forall s a. s -> Getting a s a -> a
^. (DidSaveTextDocumentParams
 -> Const (Maybe Text) DidSaveTextDocumentParams)
-> TNotificationMessage 'Method_TextDocumentDidSave
-> Const
     (Maybe Text) (TNotificationMessage 'Method_TextDocumentDidSave)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentDidSave)
  DidSaveTextDocumentParams
LSP.params ((DidSaveTextDocumentParams
  -> Const (Maybe Text) DidSaveTextDocumentParams)
 -> TNotificationMessage 'Method_TextDocumentDidSave
 -> Const
      (Maybe Text) (TNotificationMessage 'Method_TextDocumentDidSave))
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
    -> DidSaveTextDocumentParams
    -> Const (Maybe Text) DidSaveTextDocumentParams)
-> Getting
     (Maybe Text)
     (TNotificationMessage 'Method_TextDocumentDidSave)
     (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> Const (Maybe Text) (Maybe Text))
-> DidSaveTextDocumentParams
-> Const (Maybe Text) DidSaveTextDocumentParams
forall s a. HasText s a => Lens' s a
Lens' DidSaveTextDocumentParams (Maybe Text)
LSP.text
        NormalizedUri -> Maybe TextDocumentVersion -> Text -> LspM () ()
validateSwarmCode (Uri -> NormalizedUri
LSP.toNormalizedUri Uri
doc) Maybe TextDocumentVersion
forall a. Maybe a
Nothing Text
content
    , SMethod 'Method_TextDocumentDidOpen
-> Handler (LspT () IO) 'Method_TextDocumentDidOpen
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidOpen
LSP.SMethod_TextDocumentDidOpen (Handler (LspT () IO) 'Method_TextDocumentDidOpen
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentDidOpen
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidOpen
msg -> do
        let doc :: Uri
doc = TNotificationMessage 'Method_TextDocumentDidOpen
msg TNotificationMessage 'Method_TextDocumentDidOpen
-> Getting
     Uri (TNotificationMessage 'Method_TextDocumentDidOpen) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams)
-> TNotificationMessage 'Method_TextDocumentDidOpen
-> Const Uri (TNotificationMessage 'Method_TextDocumentDidOpen)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentDidOpen)
  DidOpenTextDocumentParams
LSP.params ((DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams)
 -> TNotificationMessage 'Method_TextDocumentDidOpen
 -> Const Uri (TNotificationMessage 'Method_TextDocumentDidOpen))
-> ((Uri -> Const Uri Uri)
    -> DidOpenTextDocumentParams
    -> Const Uri DidOpenTextDocumentParams)
-> Getting
     Uri (TNotificationMessage 'Method_TextDocumentDidOpen) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentItem -> Const Uri TextDocumentItem)
-> DidOpenTextDocumentParams -> Const Uri DidOpenTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DidOpenTextDocumentParams TextDocumentItem
LSP.textDocument ((TextDocumentItem -> Const Uri TextDocumentItem)
 -> DidOpenTextDocumentParams
 -> Const Uri DidOpenTextDocumentParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentItem -> Const Uri TextDocumentItem)
-> (Uri -> Const Uri Uri)
-> DidOpenTextDocumentParams
-> Const Uri DidOpenTextDocumentParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentItem -> Const Uri TextDocumentItem
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentItem Uri
LSP.uri
            content :: Text
content = TNotificationMessage 'Method_TextDocumentDidOpen
msg TNotificationMessage 'Method_TextDocumentDidOpen
-> Getting
     Text (TNotificationMessage 'Method_TextDocumentDidOpen) Text
-> Text
forall s a. s -> Getting a s a -> a
^. (DidOpenTextDocumentParams -> Const Text DidOpenTextDocumentParams)
-> TNotificationMessage 'Method_TextDocumentDidOpen
-> Const Text (TNotificationMessage 'Method_TextDocumentDidOpen)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentDidOpen)
  DidOpenTextDocumentParams
LSP.params ((DidOpenTextDocumentParams
  -> Const Text DidOpenTextDocumentParams)
 -> TNotificationMessage 'Method_TextDocumentDidOpen
 -> Const Text (TNotificationMessage 'Method_TextDocumentDidOpen))
-> ((Text -> Const Text Text)
    -> DidOpenTextDocumentParams
    -> Const Text DidOpenTextDocumentParams)
-> Getting
     Text (TNotificationMessage 'Method_TextDocumentDidOpen) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentItem -> Const Text TextDocumentItem)
-> DidOpenTextDocumentParams
-> Const Text DidOpenTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DidOpenTextDocumentParams TextDocumentItem
LSP.textDocument ((TextDocumentItem -> Const Text TextDocumentItem)
 -> DidOpenTextDocumentParams
 -> Const Text DidOpenTextDocumentParams)
-> ((Text -> Const Text Text)
    -> TextDocumentItem -> Const Text TextDocumentItem)
-> (Text -> Const Text Text)
-> DidOpenTextDocumentParams
-> Const Text DidOpenTextDocumentParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> TextDocumentItem -> Const Text TextDocumentItem
forall s a. HasText s a => Lens' s a
Lens' TextDocumentItem Text
LSP.text
        NormalizedUri -> Maybe TextDocumentVersion -> Text -> LspM () ()
validateSwarmCode (Uri -> NormalizedUri
LSP.toNormalizedUri Uri
doc) Maybe TextDocumentVersion
forall a. Maybe a
Nothing Text
content
    , SMethod 'Method_TextDocumentDidChange
-> Handler (LspT () IO) 'Method_TextDocumentDidChange
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidChange
LSP.SMethod_TextDocumentDidChange (Handler (LspT () IO) 'Method_TextDocumentDidChange
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentDidChange
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidChange
msg -> do
        let doc :: NormalizedUri
doc = TNotificationMessage 'Method_TextDocumentDidChange
msg TNotificationMessage 'Method_TextDocumentDidChange
-> Getting
     NormalizedUri
     (TNotificationMessage 'Method_TextDocumentDidChange)
     NormalizedUri
-> NormalizedUri
forall s a. s -> Getting a s a -> a
^. (DidChangeTextDocumentParams
 -> Const NormalizedUri DidChangeTextDocumentParams)
-> TNotificationMessage 'Method_TextDocumentDidChange
-> Const
     NormalizedUri (TNotificationMessage 'Method_TextDocumentDidChange)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentDidChange)
  DidChangeTextDocumentParams
LSP.params ((DidChangeTextDocumentParams
  -> Const NormalizedUri DidChangeTextDocumentParams)
 -> TNotificationMessage 'Method_TextDocumentDidChange
 -> Const
      NormalizedUri (TNotificationMessage 'Method_TextDocumentDidChange))
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> DidChangeTextDocumentParams
    -> Const NormalizedUri DidChangeTextDocumentParams)
-> Getting
     NormalizedUri
     (TNotificationMessage 'Method_TextDocumentDidChange)
     NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionedTextDocumentIdentifier
 -> Const NormalizedUri VersionedTextDocumentIdentifier)
-> DidChangeTextDocumentParams
-> Const NormalizedUri DidChangeTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DidChangeTextDocumentParams VersionedTextDocumentIdentifier
LSP.textDocument ((VersionedTextDocumentIdentifier
  -> Const NormalizedUri VersionedTextDocumentIdentifier)
 -> DidChangeTextDocumentParams
 -> Const NormalizedUri DidChangeTextDocumentParams)
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> VersionedTextDocumentIdentifier
    -> Const NormalizedUri VersionedTextDocumentIdentifier)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> DidChangeTextDocumentParams
-> Const NormalizedUri DidChangeTextDocumentParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const NormalizedUri Uri)
-> VersionedTextDocumentIdentifier
-> Const NormalizedUri VersionedTextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' VersionedTextDocumentIdentifier Uri
LSP.uri ((Uri -> Const NormalizedUri Uri)
 -> VersionedTextDocumentIdentifier
 -> Const NormalizedUri VersionedTextDocumentIdentifier)
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> Uri -> Const NormalizedUri Uri)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> VersionedTextDocumentIdentifier
-> Const NormalizedUri VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> NormalizedUri)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> Uri
-> Const NormalizedUri Uri
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Uri -> NormalizedUri
LSP.toNormalizedUri
        Maybe VirtualFile
mdoc <- NormalizedUri -> LspT () IO (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile NormalizedUri
doc
        case Maybe VirtualFile
mdoc of
          Just vf :: VirtualFile
vf@(VirtualFile TextDocumentVersion
_ Int
version Rope
_rope) -> do
            NormalizedUri -> Maybe TextDocumentVersion -> Text -> LspM () ()
validateSwarmCode NormalizedUri
doc (TextDocumentVersion -> Maybe TextDocumentVersion
forall a. a -> Maybe a
Just (Int -> TextDocumentVersion
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
version)) (VirtualFile -> Text
virtualFileText VirtualFile
vf)
          Maybe VirtualFile
_ -> Text -> LspM () ()
forall (m :: * -> *). MonadIO m => Text -> m ()
debug (Text -> LspM () ()) -> Text -> LspM () ()
forall a b. (a -> b) -> a -> b
$ Text
"No virtual file found for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall source target. From source target => source -> target
from (TNotificationMessage 'Method_TextDocumentDidChange -> String
forall a. Show a => a -> String
show TNotificationMessage 'Method_TextDocumentDidChange
msg)
    , SMethod 'Method_TextDocumentHover
-> Handler (LspT () IO) 'Method_TextDocumentHover
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'Method_TextDocumentHover
LSP.SMethod_TextDocumentHover (Handler (LspT () IO) 'Method_TextDocumentHover
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentHover
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_TextDocumentHover
req Either ResponseError (Hover |? Null) -> LspM () ()
responder -> do
        let doc :: NormalizedUri
doc = TRequestMessage 'Method_TextDocumentHover
req TRequestMessage 'Method_TextDocumentHover
-> Getting
     NormalizedUri
     (TRequestMessage 'Method_TextDocumentHover)
     NormalizedUri
-> NormalizedUri
forall s a. s -> Getting a s a -> a
^. (HoverParams -> Const NormalizedUri HoverParams)
-> TRequestMessage 'Method_TextDocumentHover
-> Const NormalizedUri (TRequestMessage 'Method_TextDocumentHover)
forall s a. HasParams s a => Lens' s a
Lens' (TRequestMessage 'Method_TextDocumentHover) HoverParams
LSP.params ((HoverParams -> Const NormalizedUri HoverParams)
 -> TRequestMessage 'Method_TextDocumentHover
 -> Const NormalizedUri (TRequestMessage 'Method_TextDocumentHover))
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> HoverParams -> Const NormalizedUri HoverParams)
-> Getting
     NormalizedUri
     (TRequestMessage 'Method_TextDocumentHover)
     NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier
 -> Const NormalizedUri TextDocumentIdentifier)
-> HoverParams -> Const NormalizedUri HoverParams
forall s a. HasTextDocument s a => Lens' s a
Lens' HoverParams TextDocumentIdentifier
LSP.textDocument ((TextDocumentIdentifier
  -> Const NormalizedUri TextDocumentIdentifier)
 -> HoverParams -> Const NormalizedUri HoverParams)
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> TextDocumentIdentifier
    -> Const NormalizedUri TextDocumentIdentifier)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> HoverParams
-> Const NormalizedUri HoverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const NormalizedUri Uri)
-> TextDocumentIdentifier
-> Const NormalizedUri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
LSP.uri ((Uri -> Const NormalizedUri Uri)
 -> TextDocumentIdentifier
 -> Const NormalizedUri TextDocumentIdentifier)
-> ((NormalizedUri -> Const NormalizedUri NormalizedUri)
    -> Uri -> Const NormalizedUri Uri)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> TextDocumentIdentifier
-> Const NormalizedUri TextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> NormalizedUri)
-> (NormalizedUri -> Const NormalizedUri NormalizedUri)
-> Uri
-> Const NormalizedUri Uri
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Uri -> NormalizedUri
LSP.toNormalizedUri
            pos :: Position
pos = TRequestMessage 'Method_TextDocumentHover
req TRequestMessage 'Method_TextDocumentHover
-> Getting
     Position (TRequestMessage 'Method_TextDocumentHover) Position
-> Position
forall s a. s -> Getting a s a -> a
^. (HoverParams -> Const Position HoverParams)
-> TRequestMessage 'Method_TextDocumentHover
-> Const Position (TRequestMessage 'Method_TextDocumentHover)
forall s a. HasParams s a => Lens' s a
Lens' (TRequestMessage 'Method_TextDocumentHover) HoverParams
LSP.params ((HoverParams -> Const Position HoverParams)
 -> TRequestMessage 'Method_TextDocumentHover
 -> Const Position (TRequestMessage 'Method_TextDocumentHover))
-> ((Position -> Const Position Position)
    -> HoverParams -> Const Position HoverParams)
-> Getting
     Position (TRequestMessage 'Method_TextDocumentHover) Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> HoverParams -> Const Position HoverParams
forall s a. HasPosition s a => Lens' s a
Lens' HoverParams Position
LSP.position
        Maybe VirtualFile
mdoc <- NormalizedUri -> LspT () IO (Maybe VirtualFile)
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
-> Position -> VirtualFile -> Maybe (Text, Maybe Range)
H.showHoverInfo NormalizedUri
doc Position
pos VirtualFile
vf
              Hover -> Maybe Hover
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Hover -> Maybe Hover) -> Hover -> Maybe Hover
forall a b. (a -> b) -> a -> b
$ (MarkupContent |? (MarkedString |? [MarkedString]))
-> Maybe Range -> Hover
LSP.Hover (MarkupContent -> MarkupContent |? (MarkedString |? [MarkedString])
forall a b. a -> a |? b
LSP.InL (MarkupContent
 -> MarkupContent |? (MarkedString |? [MarkedString]))
-> MarkupContent
-> MarkupContent |? (MarkedString |? [MarkedString])
forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
LSP.MarkupContent MarkupKind
LSP.MarkupKind_Markdown Text
markdownText) Maybe Range
maybeRange
        Either ResponseError (Hover |? Null) -> LspM () ()
responder (Either ResponseError (Hover |? Null) -> LspM () ())
-> (Maybe Hover -> Either ResponseError (Hover |? Null))
-> Maybe Hover
-> LspM () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Hover |? Null) -> Either ResponseError (Hover |? Null)
forall a b. b -> Either a b
Right ((Hover |? Null) -> Either ResponseError (Hover |? Null))
-> (Maybe Hover -> Hover |? Null)
-> Maybe Hover
-> Either ResponseError (Hover |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Hover -> Hover |? Null
forall a. Maybe a -> a |? Null
LSP.maybeToNull (Maybe Hover -> LspM () ()) -> Maybe Hover -> LspM () ()
forall a b. (a -> b) -> a -> b
$ Maybe Hover
maybeHover
    ]