Command.hs

module LSP.Handlers.Command where

import Control.Concurrent.MVar
import Control.Lens ((^.))
import Control.Monad (void)
import Control.Monad.IO.Class
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as J
import qualified Data.Map as Map
import qualified Data.Text as T
import LSP.Diagnostic
import LSP.Handlers.InlayHint
import LSP.Util
import qualified Language.LSP.Protocol.Lens as LSP
import qualified Language.LSP.Protocol.Message as LSP
import Language.LSP.Protocol.Types ()
import qualified Language.LSP.Protocol.Types as LSP
import Language.LSP.Server (Handlers, getVirtualFile, requestHandler, sendRequest)
import Language.LSP.VFS
import Zwirn.Language.Compiler
import Zwirn.Language.LSP.Diagnostics
import Zwirn.Language.LSP.Eval
import Zwirn.Language.Macro (CodeEdit (..))

-- TODO: make this more efficient?
-- currently the document is parsed three times, once for executing code, once for validating it after and once for generating new inlay hints ...
execCommandHandler :: MVar Environment -> Handlers LSP
execCommandHandler envmv = requestHandler LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do
  debug "Processing a workspace/executeCommand request"
  let params = req ^. LSP.params
      -- name = params ^. LSP.command
      margs = params ^. LSP.arguments

  -- debug ("The arguments are: " <> show margs)
  responder (Right $ LSP.InR LSP.Null) -- respond to the request
  env <- liftIO $ takeMVar envmv
  case getEvalArgs margs of
    Nothing -> liftIO $ putMVar envmv env
    Just (docid, LSP.Range begin _) -> do
      let uri = docid ^. LSP.uri
          doc = LSP.toNormalizedUri uri
      mdoc <- getVirtualFile doc
      case mdoc of
        Just vf@(VirtualFile _ version _) -> do
          mci <- liftIO $ runCI env (evalBlockAt (virtualFileText vf) ((\(LSP.Position l _) -> fromIntegral l) begin))
          case mci of
            Right ((edits, msgs), newEnv) -> do
              liftIO $ putMVar envmv newEnv
              if null msgs then sendInfo "OK" else mapM_ sendInfo msgs
              makeEdits edits uri
              errs <- liftIO $ validateCode newEnv (virtualFileText vf)
              case errs of
                Just err -> publishDiags doc (Just (fromIntegral version)) (makeErrorDiagnostic err)
                Nothing -> refreshDiagnostics
              refreshHints
            Left err -> do
              liftIO $ putMVar envmv env
              sendError (T.pack $ show err)
        Nothing -> return ()
      return ()

getEvalArgs :: Maybe [J.Value] -> Maybe (LSP.TextDocumentIdentifier, LSP.Range)
getEvalArgs (Just [t, x]) = do
  doc <- J.parseMaybe J.parseJSON t
  pos <- J.parseMaybe J.parseJSON x
  return (doc, pos)
getEvalArgs _ = Nothing

makeEdits :: [CodeEdit] -> LSP.Uri -> LSP ()
makeEdits edits uri = do
  let lspedits = map toLSPEdit edits
      par =
        LSP.ApplyWorkspaceEditParams (Just "Howdy edit") $
          LSP.WorkspaceEdit (Just (Map.singleton uri lspedits)) Nothing Nothing

  void $ sendRequest LSP.SMethod_WorkspaceApplyEdit par (const (pure ()))

toLSPEdit :: CodeEdit -> LSP.TextEdit
toLSPEdit (CodeEdit pos x) = LSP.TextEdit (toLSP pos) x