-- 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 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 IO Symbol Ann
codebase :: Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase} <- ExceptT Text Lsp Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  NameSearch Transaction
nameSearch <- ExceptT Text Lsp (NameSearch Transaction)
forall (m :: * -> *). Lspish m => m (NameSearch Transaction)
getNameSearch
  TVar (Maybe Uri)
lastTouchedFileV <- (Env -> TVar (Maybe Uri)) -> ExceptT Text Lsp (TVar (Maybe Uri))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar (Maybe Uri)
lastTouchedFileVar
  Maybe Uri
mayLastTouchedFile <- IO (Maybe Uri) -> ExceptT Text Lsp (Maybe Uri)
forall a. IO a -> ExceptT Text Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Uri) -> ExceptT Text Lsp (Maybe Uri))
-> IO (Maybe Uri) -> ExceptT Text Lsp (Maybe Uri)
forall a b. (a -> b) -> a -> b
$ STM (Maybe Uri) -> IO (Maybe Uri)
forall a. STM a -> IO a
atomically (STM (Maybe Uri) -> IO (Maybe Uri))
-> STM (Maybe Uri) -> IO (Maybe Uri)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Uri) -> STM (Maybe Uri)
forall a. TVar a -> STM a
readTVar TVar (Maybe Uri)
lastTouchedFileV
  (Maybe
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
mayUnisonFile, Uri
fileUri, FilePath
fp) <- case Maybe Uri
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
      Maybe
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
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 {Maybe (UnisonFile Symbol Ann)
parsedFile :: Maybe (UnisonFile Symbol Ann)
$sel:parsedFile:FileAnalysis :: FileAnalysis -> Maybe (UnisonFile Symbol Ann)
parsedFile, Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile :: Maybe (TypecheckedUnisonFile Symbol Ann)
$sel:typecheckedFile:FileAnalysis :: FileAnalysis -> Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile} <- Uri -> MaybeT (ExceptT Text Lsp) FileAnalysis
forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileAnalysis
FA.getFileAnalysis Uri
uri
        Maybe
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
-> MaybeT
     (ExceptT Text Lsp)
     (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (TypecheckedUnisonFile Symbol Ann
-> Either
     (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann)
forall a b. b -> Either a b
Right (TypecheckedUnisonFile Symbol Ann
 -> Either
      (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
-> Maybe (TypecheckedUnisonFile Symbol Ann)
-> Maybe
     (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TypecheckedUnisonFile Symbol Ann)
typecheckedFile Maybe
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
-> Maybe
     (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
-> Maybe
     (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UnisonFile Symbol Ann
-> Either
     (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann)
forall a b. a -> Either a b
Left (UnisonFile Symbol Ann
 -> Either
      (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
-> Maybe (UnisonFile Symbol Ann)
-> Maybe
     (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (UnisonFile Symbol Ann)
parsedFile)
      (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))
mayTypecheckedFile, Uri
uri, 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
uri)
  Name
parsedFQN <- case Text -> Either Text Name
Names.parseTextEither Text
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 {Map Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
termResults :: Map Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
$sel:termResults:DefinitionResults :: DefinitionResults
-> Map
     Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
termResults, Map Reference (DisplayObject () (Decl Symbol Ann))
typeResults :: Map Reference (DisplayObject () (Decl Symbol Ann))
$sel:typeResults:DefinitionResults :: DefinitionResults
-> Map Reference (DisplayObject () (Decl Symbol Ann))
typeResults} <- IO DefinitionResults -> ExceptT Text Lsp DefinitionResults
forall a. IO a -> ExceptT Text Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DefinitionResults -> ExceptT Text Lsp DefinitionResults)
-> IO DefinitionResults -> ExceptT Text Lsp DefinitionResults
forall a b. (a -> b) -> a -> b
$ do
    Codebase IO Symbol Ann
-> Transaction DefinitionResults -> IO DefinitionResults
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase (Transaction DefinitionResults -> IO DefinitionResults)
-> Transaction DefinitionResults -> IO DefinitionResults
forall a b. (a -> b) -> a -> b
$ Codebase IO Symbol Ann
-> NameSearch Transaction
-> IncludeCycles
-> SearchType
-> [HashQualified Name]
-> Transaction DefinitionResults
forall (m :: * -> *).
Codebase m Symbol Ann
-> NameSearch Transaction
-> IncludeCycles
-> SearchType
-> [HashQualified Name]
-> Transaction DefinitionResults
Backend.definitionsByName Codebase IO Symbol Ann
codebase NameSearch Transaction
nameSearch IncludeCycles
Backend.IncludeCycles SearchType
Names.ExactName [Name -> HashQualified Name
forall n. n -> HashQualified n
HQ.NameOnly Name
parsedFQN]
  PrettyPrintEnvDecl
pped <- ExceptT Text Lsp PrettyPrintEnvDecl
forall (m :: * -> *). Lspish m => m PrettyPrintEnvDecl
currentPPED
  Lsp () -> IO ()
toIO <- Lsp (Lsp () -> IO ()) -> ExceptT Text Lsp (Lsp () -> IO ())
forall (m :: * -> *) a. Monad m => m a -> ExceptT Text m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Lsp (Lsp () -> IO ()) -> ExceptT Text Lsp (Lsp () -> IO ()))
-> Lsp (Lsp () -> IO ()) -> ExceptT Text Lsp (Lsp () -> IO ())
forall a b. (a -> b) -> a -> b
$ Lsp (Lsp () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  let appendText :: Text -> Text -> Bool -> IO ()
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 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 -> FilePath -> ResponseError -> Lsp ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> FilePath -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP FilePath
"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 ()
  Int
numRendered <- Codebase IO Symbol Ann
-> (Text -> Text -> Bool -> IO ())
-> Maybe
     (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
-> FilePath
-> RelativeToFold
-> PrettyPrintEnvDecl
-> Map
     Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
-> Map Reference (DisplayObject () (Decl Symbol Ann))
-> ExceptT Text Lsp Int
forall (m :: * -> *) a.
(MonadIO m, Monoid a) =>
Codebase IO Symbol a
-> (Text -> Text -> Bool -> IO ())
-> Maybe
     (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol a))
-> FilePath
-> RelativeToFold
-> PrettyPrintEnvDecl
-> Map
     Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
-> Map Reference (DisplayObject () (Decl Symbol Ann))
-> m Int
renderToFile Codebase IO Symbol Ann
codebase Text -> Text -> Bool -> IO ()
appendText Maybe
  (Either (UnisonFile Symbol Ann) (TypecheckedUnisonFile Symbol Ann))
mayUnisonFile FilePath
fp RelativeToFold
WithinFold PrettyPrintEnvDecl
pped Map Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
termResults Map Reference (DisplayObject () (Decl Symbol Ann))
typeResults
  Bool -> ExceptT Text Lsp Bool
forall a. a -> ExceptT Text Lsp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
numRendered Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)