-- LSP wrappers for common Unison functionality
module Unison.LSP.Util.Wrappers (editDefinitionByFQN) where

import Control.Concurrent.STM
import Control.Monad.Except
import Control.Monad.Reader
import Data.Map qualified as Map
import Data.Set qualified as Set
import Language.LSP.Protocol.Message qualified as Msg
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Types qualified as LSP
import Language.LSP.Server (sendRequest)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.HandleInput.ShowDefinition (renderToFile)
import Unison.Codebase.Editor.Input (RelativeToFold (..))
import Unison.Debug qualified as Debug
import Unison.HashQualified qualified as HQ
import Unison.LSP.FileAnalysis qualified as FA
import Unison.LSP.Types
import Unison.NamesWithHistory qualified as Names
import Unison.Prelude
import Unison.Server.Backend qualified as Backend
import Unison.Syntax.Name qualified as Names

editDefinitionByFQN ::
  LSP.Uri ->
  -- | Fully qualified name of the definition to edit
  Text ->
  -- Returns 'True' if the definition was added to the file, False if it was already present
  ExceptT Text Lsp Bool
editDefinitionByFQN :: Uri -> Text -> ExceptT Text Lsp Bool
editDefinitionByFQN Uri
fileURI Text
fqn = do
  Env {codebase} <- ExceptT Text Lsp Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  nameSearch <- getNameSearch
  lastTouchedFileV <- asks lastTouchedFileVar
  mayLastTouchedFile <- liftIO $ atomically $ readTVar lastTouchedFileV
  (mayUnisonFile, fileUri, fp) <- case mayLastTouchedFile of
    Maybe Uri
Nothing -> (Maybe
   (Either
      (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann)),
 Uri, FilePath)
-> ExceptT
     Text
     Lsp
     (Maybe
        (Either
           (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann)),
      Uri, FilePath)
forall a. a -> ExceptT Text Lsp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
forall a. Maybe a
Nothing, Uri
fileURI, FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"scratch.u" (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe FilePath
uriToFilePath Uri
fileURI)
    Just Uri
uri -> do
      mayTypecheckedFile <- MaybeT
  (ExceptT Text Lsp)
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
-> ExceptT
     Text
     Lsp
     (Maybe
        (Either
           (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann)))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
        FileAnalysis {parsedFile, typecheckedFile} <- Uri -> MaybeT (ExceptT Text Lsp) FileAnalysis
forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileAnalysis
FA.getFileAnalysis Uri
uri
        hoistMaybe (Right <$> typecheckedFile <|> Left <$> parsedFile)
      pure (mayTypecheckedFile, uri, fromMaybe "scratch.u" $ uriToFilePath uri)
  parsedFQN <- case Names.parseTextEither fqn of
    Left Text
err -> Text -> ExceptT Text Lsp Name
forall a. Text -> ExceptT Text Lsp a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
err
    Right Name
parsedFQN -> do
      Name -> ExceptT Text Lsp Name
forall a. a -> ExceptT Text Lsp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
parsedFQN
  Backend.DefinitionResults {termResults, typeResults} <- liftIO $ do
    Codebase.runTransaction codebase $ Backend.definitionsByName codebase nameSearch Backend.IncludeCycles Names.ExactName (Set.singleton (HQ.NameOnly parsedFQN))
  pped <- currentPPED
  toIO <- lift $ askRunInIO
  let appendText Text
_fp Text
rendered Bool
_aboveFold = Lsp () -> IO ()
toIO (Lsp () -> IO ()) -> Lsp () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let range :: Range
range = Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
0 UInt
0)
        let description :: Text
description = Text
"Edit definition: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fqn
        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
rendered Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n")]))) Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing)
        DebugFlag -> FilePath -> ApplyWorkspaceEditParams -> Lsp ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> FilePath -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP FilePath
"Applying workspace edit for editDefinitionByFQN" ApplyWorkspaceEditParams
params
        Lsp (LspId 'Method_WorkspaceApplyEdit) -> Lsp ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Lsp (LspId 'Method_WorkspaceApplyEdit) -> Lsp ())
-> Lsp (LspId 'Method_WorkspaceApplyEdit) -> Lsp ()
forall a b. (a -> b) -> a -> b
$ 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
-> FilePath -> TResponseError 'Method_WorkspaceApplyEdit -> Lsp ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> FilePath -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP FilePath
"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 ()
  numRendered <- renderToFile codebase (const True) appendText mayUnisonFile fp WithinFold pped termResults typeResults
  pure (numRendered > 0)