module Unison.LSP.Commands where

import Control.Lens hiding (List)
import Control.Monad.Except
import Control.Monad.Reader
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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Range
range,
        Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
description,
        Key
"replacementText" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
replacementText,
        Key
"fileUri" Key -> Uri -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
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.TResponseError m) (Aeson.Value |? Null) -> Lsp ()) -> Lsp ()
executeCommandHandler :: forall {f :: MessageDirection} (m :: Method f 'Request).
TRequestMessage 'Method_WorkspaceExecuteCommand
-> (Either (TResponseError m) (Value |? Null) -> Lsp ()) -> Lsp ()
executeCommandHandler TRequestMessage 'Method_WorkspaceExecuteCommand
m Either (TResponseError m) (Value |? Null) -> Lsp ()
respond = do
  Either (TResponseError m) (Value |? Null) -> Lsp ()
respond (Either (TResponseError m) (Value |? Null) -> Lsp ())
-> Lsp (Either (TResponseError m) (Value |? Null)) -> Lsp ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT (TResponseError m) Lsp (Value |? Null)
-> Lsp (Either (TResponseError m) (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 (TResponseError m) Lsp a
invalidCmdErr = TResponseError m -> ExceptT (TResponseError m) Lsp a
forall a. TResponseError m -> ExceptT (TResponseError m) Lsp a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TResponseError m -> ExceptT (TResponseError m) Lsp a)
-> TResponseError m -> ExceptT (TResponseError m) Lsp a
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
Msg.TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams) Text
"Invalid command" Maybe (ErrorData m)
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)
          ExceptT (TResponseError m) Lsp (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT (TResponseError m) Lsp ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT (TResponseError m) Lsp (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT (TResponseError m) Lsp ())
-> ExceptT
     (TResponseError m) Lsp (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT (TResponseError m) Lsp ()
forall a b. (a -> b) -> a -> b
$
            Lsp (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     (TResponseError m) Lsp (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (TResponseError m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
              ( SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either
      (TResponseError 'Method_WorkspaceApplyEdit)
      (MessageResult 'Method_WorkspaceApplyEdit)
    -> Lsp ())
-> Lsp (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'Method_WorkspaceApplyEdit
Msg.SMethod_WorkspaceApplyEdit ApplyWorkspaceEditParams
MessageParams 'Method_WorkspaceApplyEdit
params ((Either
    (TResponseError 'Method_WorkspaceApplyEdit)
    (MessageResult 'Method_WorkspaceApplyEdit)
  -> Lsp ())
 -> Lsp (LspId 'Method_WorkspaceApplyEdit))
-> (Either
      (TResponseError 'Method_WorkspaceApplyEdit)
      (MessageResult 'Method_WorkspaceApplyEdit)
    -> Lsp ())
-> Lsp (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ \case
                  Left TResponseError 'Method_WorkspaceApplyEdit
err -> DebugFlag
-> String -> TResponseError 'Method_WorkspaceApplyEdit -> Lsp ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> String -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP String
"Error applying workspace edit" TResponseError 'Method_WorkspaceApplyEdit
err
                  Right MessageResult 'Method_WorkspaceApplyEdit
_ -> () -> Lsp ()
forall a. a -> Lsp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              )
        Maybe [Value]
_ -> ExceptT (TResponseError m) Lsp ()
forall {a}. ExceptT (TResponseError m) Lsp a
invalidCmdErr
      Text
_ -> ExceptT (TResponseError m) Lsp ()
forall {a}. ExceptT (TResponseError m) Lsp a
invalidCmdErr
    (Value |? Null) -> ExceptT (TResponseError m) Lsp (Value |? Null)
forall a. a -> ExceptT (TResponseError m) Lsp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value |? Null) -> ExceptT (TResponseError m) Lsp (Value |? Null))
-> (Value |? Null)
-> ExceptT (TResponseError m) Lsp (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Value -> Value |? Null
forall a b. a -> a |? b
InL Value
Aeson.Null