{-# LANGUAGE OverloadedStrings #-}
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
{
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
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
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, [])
[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
[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)
forall a. Maybe a
Nothing
(forall a. a -> Maybe a
Just Text
diagnosticSourcePrefix)
Text
msg
(forall a. a -> Maybe a
Just (forall a. [a] -> List a
J.List [DiagnosticTag
J.DtUnnecessary]))
forall a. Maybe a
Nothing
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)
forall a. Maybe a
Nothing
(forall a. a -> Maybe a
Just Text
diagnosticSourcePrefix)
Text
msg
forall a. Maybe a
Nothing
(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))
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
]