content: {-# 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.Syntax (SrcLoc (..))
  import Swarm.Language.Typecheck (ContextualTypeErr (..))
  import Swarm.Language.Value (emptyEnv)
  import Swarm.Pretty (prettyText)
  import System.IO (stderr)
  import Witch
  
  lspMain :: IO ()
  lspMain =
    void $
      runServer $
        ServerDefinition
          { defaultConfig = ()
          , configSection = "swarm"
          , parseConfig = const $ const $ Right ()
          , onConfigChange = const $ return ()
          , doInitialize = \env _req -> pure $ Right env
          , staticHandlers = const handlers
          , interpretHandler = \env -> Iso (runLspT env) liftIO
          , 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 = LSP.TextDocumentSyncKind_Full
  
  diagnosticSourcePrefix :: Text
  diagnosticSourcePrefix = "swarm-lsp"
  
  debug :: (MonadIO m) => Text -> m ()
  debug msg = liftIO $ Text.hPutStrLn stderr $ "[swarm-lsp] " <> msg
  
  type TextDocumentVersion = Int32
  
  validateSwarmCode :: LSP.NormalizedUri -> Maybe TextDocumentVersion -> Text -> LspM () ()
  validateSwarmCode doc version 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.
    flushDiagnosticsBySource 0 (Just diagnosticSourcePrefix)
  
    let (parsingErrs, unusedVarWarnings) = case readTerm' defaultParserConfig content of
          Right Nothing -> ([], [])
          Right (Just term) -> (parsingErrors, unusedWarnings)
           where
            VU.Usage _ problems = VU.getUsage mempty term
            unusedWarnings = mapMaybe (VU.toErrPos content) problems
  
            parsingErrors = case processParsedTerm' emptyEnv term of
              Right _ -> []
              Left e -> pure $ showTypeErrorPos content e
          Left e -> (pure $ showErrorPos e, [])
    -- debug $ "-> " <> from (show err)
  
    publishDiags $
      map makeUnusedVarDiagnostic 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).
    publishDiags $
      map makeParseErrorDiagnostic parsingErrs
   where
    publishDiags :: [LSP.Diagnostic] -> LspM () ()
    publishDiags = publishDiagnostics 1 doc version . partitionBySource
  
    makeUnusedVarDiagnostic :: (LSP.Range, Text) -> LSP.Diagnostic
    makeUnusedVarDiagnostic (range, msg) =
      LSP.Diagnostic
        range
        (Just LSP.DiagnosticSeverity_Warning) -- severity
        Nothing -- code
        Nothing -- code description
        (Just diagnosticSourcePrefix) -- source
        msg
        (Just [LSP.DiagnosticTag_Unnecessary]) -- tags
        Nothing -- related source code info
        Nothing -- data
    makeParseErrorDiagnostic :: ((Int, Int), (Int, Int), Text) -> LSP.Diagnostic
    makeParseErrorDiagnostic ((startLine, startCol), (endLine, endCol), msg) =
      LSP.Diagnostic
        ( LSP.Range
            (LSP.Position (fromIntegral startLine) (fromIntegral startCol))
            (LSP.Position (fromIntegral endLine) (fromIntegral endCol))
        )
        (Just LSP.DiagnosticSeverity_Error) -- severity
        Nothing -- code
        Nothing -- code description
        (Just diagnosticSourcePrefix) -- source
        msg
        Nothing -- tags
        (Just []) -- related info
        Nothing -- data
  
  showTypeErrorPos :: Text -> ContextualTypeErr -> ((Int, Int), (Int, Int), Text)
  showTypeErrorPos code (CTE l _ te) = (minusOne start, minusOne end, msg)
   where
    minusOne (x, y) = (x - 1, y - 1)
  
    (start, end) = case l of
      SrcLoc s e -> getLocRange code (s, e)
      NoLoc -> ((1, 1), (65535, 65535)) -- unknown loc spans the whole document
    msg = prettyText te
  
  handlers :: Handlers (LspM ())
  handlers =
    mconcat
      [ notificationHandler LSP.SMethod_Initialized $ \_not -> do
          debug "Initialized"
      , notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do
          let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri
              content = fromMaybe "?" $ msg ^. LSP.params . LSP.text
          validateSwarmCode (LSP.toNormalizedUri doc) Nothing content
      , notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do
          let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri
              content = msg ^. LSP.params . LSP.textDocument . LSP.text
          validateSwarmCode (LSP.toNormalizedUri doc) Nothing content
      , notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do
          let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri
          mdoc <- getVirtualFile doc
          case mdoc of
            Just vf@(VirtualFile _ version _rope) -> do
              validateSwarmCode doc (Just (fromIntegral version)) (virtualFileText vf)
            _ -> debug $ "No virtual file found for: " <> from (show msg)
      , requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do
          let doc = req ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri
              pos = req ^. LSP.params . LSP.position
          mdoc <- getVirtualFile doc
          let maybeHover = do
                vf <- mdoc
                (markdownText, maybeRange) <- H.showHoverInfo doc pos vf
                return $ LSP.Hover (LSP.InL $ LSP.MarkupContent LSP.MarkupKind_Markdown markdownText) maybeRange
          responder . Right . LSP.maybeToNull $ maybeHover
      ]
  