{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}

module Unison.LSP.Commands where

import Control.Lens hiding (List)
import Control.Monad.Except
import Data.Aeson qualified as Aeson
import Data.Map qualified as Map
import Language.LSP.Protocol.Lens
import Language.LSP.Protocol.Message qualified as Msg
import Language.LSP.Protocol.Types
import Language.LSP.Server (sendRequest)
import Unison.Debug qualified as Debug
import Unison.LSP.Types
import Unison.Prelude

supportedCommands :: [Text]
supportedCommands :: [Text]
supportedCommands = [Text
"replaceText"]

replaceText ::
  --  | The text displayed to the user for this command if used in a CodeLens
  Text ->
  TextReplacement ->
  Command
replaceText :: Text -> TextReplacement -> Command
replaceText Text
title TextReplacement
tr = Text -> Text -> Maybe [Value] -> Command
Command Text
title Text
"replaceText" ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [TextReplacement -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON TextReplacement
tr])

data TextReplacement = TextReplacement
  { TextReplacement -> Range
range :: Range,
    -- Used in things like the editor's undo buffer
    TextReplacement -> Text
description :: Text,
    TextReplacement -> Text
replacementText :: Text,
    TextReplacement -> Uri
fileUri :: Uri
  }

instance Aeson.ToJSON TextReplacement where
  toJSON :: TextReplacement -> Value
toJSON (TextReplacement Range
range Text
description Text
replacementText Uri
fileUri) =
    [Pair] -> Value
Aeson.object
      [ Key
"range" Key -> Range -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= Range
range,
        Key
"description" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= Text
description,
        Key
"replacementText" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= Text
replacementText,
        Key
"fileUri" Key -> Uri -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= Uri
fileUri
      ]

instance Aeson.FromJSON TextReplacement where
  parseJSON :: Value -> Parser TextReplacement
parseJSON = String
-> (Object -> Parser TextReplacement)
-> Value
-> Parser TextReplacement
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"TextReplacement" ((Object -> Parser TextReplacement)
 -> Value -> Parser TextReplacement)
-> (Object -> Parser TextReplacement)
-> Value
-> Parser TextReplacement
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Range -> Text -> Text -> Uri -> TextReplacement
TextReplacement
      (Range -> Text -> Text -> Uri -> TextReplacement)
-> Parser Range -> Parser (Text -> Text -> Uri -> TextReplacement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o
        Object -> Key -> Parser Range
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"range"
      Parser (Text -> Text -> Uri -> TextReplacement)
-> Parser Text -> Parser (Text -> Uri -> TextReplacement)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o
        Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"description"
      Parser (Text -> Uri -> TextReplacement)
-> Parser Text -> Parser (Uri -> TextReplacement)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o
        Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"replacementText"
      Parser (Uri -> TextReplacement)
-> Parser Uri -> Parser TextReplacement
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o
        Object -> Key -> Parser Uri
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"fileUri"

-- | Computes code actions for a document.
executeCommandHandler :: Msg.TRequestMessage 'Msg.Method_WorkspaceExecuteCommand -> (Either Msg.ResponseError (Aeson.Value |? Null) -> Lsp ()) -> Lsp ()
executeCommandHandler :: TRequestMessage 'Method_WorkspaceExecuteCommand
-> (Either ResponseError (Value |? Null) -> Lsp ()) -> Lsp ()
executeCommandHandler TRequestMessage 'Method_WorkspaceExecuteCommand
m Either ResponseError (Value |? Null) -> Lsp ()
respond =
  Either ResponseError (Value |? Null) -> Lsp ()
respond (Either ResponseError (Value |? Null) -> Lsp ())
-> Lsp (Either ResponseError (Value |? Null)) -> Lsp ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT ResponseError Lsp (Value |? Null)
-> Lsp (Either ResponseError (Value |? Null))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
    let cmd :: Text
cmd = TRequestMessage 'Method_WorkspaceExecuteCommand
m TRequestMessage 'Method_WorkspaceExecuteCommand
-> Getting
     Text (TRequestMessage 'Method_WorkspaceExecuteCommand) Text
-> Text
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> TRequestMessage 'Method_WorkspaceExecuteCommand
-> Const Text (TRequestMessage 'Method_WorkspaceExecuteCommand)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WorkspaceExecuteCommand)
  ExecuteCommandParams
params ((ExecuteCommandParams -> Const Text ExecuteCommandParams)
 -> TRequestMessage 'Method_WorkspaceExecuteCommand
 -> Const Text (TRequestMessage 'Method_WorkspaceExecuteCommand))
-> ((Text -> Const Text Text)
    -> ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> Getting
     Text (TRequestMessage 'Method_WorkspaceExecuteCommand) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> ExecuteCommandParams -> Const Text ExecuteCommandParams
forall s a. HasCommand s a => Lens' s a
Lens' ExecuteCommandParams Text
command
    let args :: Maybe [Value]
args = TRequestMessage 'Method_WorkspaceExecuteCommand
m TRequestMessage 'Method_WorkspaceExecuteCommand
-> Getting
     (Maybe [Value])
     (TRequestMessage 'Method_WorkspaceExecuteCommand)
     (Maybe [Value])
-> Maybe [Value]
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams
 -> Const (Maybe [Value]) ExecuteCommandParams)
-> TRequestMessage 'Method_WorkspaceExecuteCommand
-> Const
     (Maybe [Value]) (TRequestMessage 'Method_WorkspaceExecuteCommand)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WorkspaceExecuteCommand)
  ExecuteCommandParams
params ((ExecuteCommandParams
  -> Const (Maybe [Value]) ExecuteCommandParams)
 -> TRequestMessage 'Method_WorkspaceExecuteCommand
 -> Const
      (Maybe [Value]) (TRequestMessage 'Method_WorkspaceExecuteCommand))
-> ((Maybe [Value] -> Const (Maybe [Value]) (Maybe [Value]))
    -> ExecuteCommandParams
    -> Const (Maybe [Value]) ExecuteCommandParams)
-> Getting
     (Maybe [Value])
     (TRequestMessage 'Method_WorkspaceExecuteCommand)
     (Maybe [Value])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [Value] -> Const (Maybe [Value]) (Maybe [Value]))
-> ExecuteCommandParams
-> Const (Maybe [Value]) ExecuteCommandParams
forall s a. HasArguments s a => Lens' s a
Lens' ExecuteCommandParams (Maybe [Value])
arguments
    let invalidCmdErr :: ExceptT ResponseError Lsp a
invalidCmdErr = ResponseError -> ExceptT ResponseError Lsp a
forall a. ResponseError -> ExceptT ResponseError Lsp a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ResponseError -> ExceptT ResponseError Lsp a)
-> ResponseError -> ExceptT ResponseError Lsp a
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
Msg.ResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams) Text
"Invalid command" Maybe Value
forall a. Maybe a
Nothing
    case Text
cmd of
      Text
"replaceText" -> case Maybe [Value]
args of
        Just [Value -> Result TextReplacement
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON -> Aeson.Success (TextReplacement Range
range Text
description Text
replacementText Uri
fileUri)] -> do
          let params :: ApplyWorkspaceEditParams
params =
                Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams
                  (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
description)
                  (Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just ((Uri -> [TextEdit] -> Map Uri [TextEdit]
forall k a. k -> a -> Map k a
Map.singleton Uri
fileUri [Range -> Text -> TextEdit
TextEdit Range
range Text
replacementText]))) Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing)
          Lsp (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT ResponseError Lsp (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a. Monad m => m a -> ExceptT ResponseError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
            ( SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
    -> Lsp ())
-> Lsp (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'Method_WorkspaceApplyEdit
Msg.SMethod_WorkspaceApplyEdit ApplyWorkspaceEditParams
MessageParams 'Method_WorkspaceApplyEdit
params ((Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
  -> Lsp ())
 -> Lsp (LspId 'Method_WorkspaceApplyEdit))
-> (Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
    -> Lsp ())
-> Lsp (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ \case
                Left ResponseError
err -> DebugFlag -> String -> ResponseError -> Lsp ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> String -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP String
"Error applying workspace edit" ResponseError
err
                Right MessageResult 'Method_WorkspaceApplyEdit
_ -> () -> Lsp ()
forall a. a -> Lsp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            )
        Maybe [Value]
_ -> ExceptT ResponseError Lsp (LspId 'Method_WorkspaceApplyEdit)
forall {a}. ExceptT ResponseError Lsp a
invalidCmdErr
      Text
_ -> ExceptT ResponseError Lsp (LspId 'Method_WorkspaceApplyEdit)
forall {a}. ExceptT ResponseError Lsp a
invalidCmdErr
    pure $ Value -> Value |? Null
forall a b. a -> a |? b
InL Value
Aeson.Null